{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
module Web.ClientSession
(
Key
, IV
, randomIV
, mkIV
, getKey
, getKeyEnv
, defaultKeyFile
, getDefaultKey
, initKey
, randomKey
, randomKeyEnv
, encrypt
, encryptIO
, decrypt
) where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO)
import Control.Monad (guard, when)
import Data.Function (on)
#if MIN_VERSION_base(4,7,0)
import System.Environment (lookupEnv, setEnv)
#elif MIN_VERSION_base(4,6,0)
import System.Environment (lookupEnv)
import System.SetEnv (setEnv)
#else
import System.LookupEnv (lookupEnv)
import System.SetEnv (setEnv)
#endif
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.IORef as I
import System.Directory (doesFileExist)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Base64 as B
import Data.Serialize (encode, Serialize (put, get), getBytes, putByteString)
import Data.Tagged (Tagged, untag)
import Crypto.Classes (constTimeEq)
import "crypto-api" Crypto.Random (genSeedLength, reseed)
import Crypto.Types (ByteLength)
import qualified Crypto.Cipher.AES as A
import Crypto.Skein (skeinMAC', Skein_512_256)
import System.Entropy (getEntropy)
#if MIN_VERSION_cprng_aes(0,5,0)
import Crypto.Random.AESCtr (AESRNG, makeSystem)
import "crypto-random" Crypto.Random (cprgGenerate)
#else
import Crypto.Random.AESCtr (AESRNG, makeSystem, genRandomBytes)
#endif
data Key = Key { Key -> AES
aesKey ::
#if MIN_VERSION_cipher_aes(0, 2, 0)
!A.AES
#else
!A.Key
#endif
, Key -> ByteString -> Skein_512_256
macKey :: !(S.ByteString -> Skein_512_256)
, Key -> ByteString
keyRaw :: !S.ByteString
}
instance Eq Key where
Key AES
_ ByteString -> Skein_512_256
_ ByteString
r1 == :: Key -> Key -> Bool
== Key AES
_ ByteString -> Skein_512_256
_ ByteString
r2 = ByteString
r1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
r2
instance Serialize Key where
put :: Putter Key
put = Putter ByteString
putByteString Putter ByteString -> (Key -> ByteString) -> Putter Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> ByteString
keyRaw
get :: Get Key
get = ([Char] -> Key) -> (Key -> Key) -> Either [Char] Key -> Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Key
forall a. HasCallStack => [Char] -> a
error Key -> Key
forall a. a -> a
id (Either [Char] Key -> Key)
-> (ByteString -> Either [Char] Key) -> ByteString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] Key
initKey (ByteString -> Key) -> Get ByteString -> Get Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
96
instance Show Key where
show :: Key -> [Char]
show Key
_ = [Char]
"<Web.ClientSession.Key>"
newtype IV = IV S.ByteString
unsafeMkIV :: S.ByteString -> IV
unsafeMkIV :: ByteString -> IV
unsafeMkIV ByteString
bs = (ByteString -> IV
IV ByteString
bs)
unIV :: IV -> S.ByteString
unIV :: IV -> ByteString
unIV (IV ByteString
bs) = ByteString
bs
instance Eq IV where
== :: IV -> IV -> Bool
(==) = ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ByteString -> ByteString -> Bool)
-> (IV -> ByteString) -> IV -> IV -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
/= :: IV -> IV -> Bool
(/=) = ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (ByteString -> ByteString -> Bool)
-> (IV -> ByteString) -> IV -> IV -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
instance Ord IV where
compare :: IV -> IV -> Ordering
compare = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ByteString -> ByteString -> Ordering)
-> (IV -> ByteString) -> IV -> IV -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
<= :: IV -> IV -> Bool
(<=) = ByteString -> ByteString -> Bool
forall a. Ord a => a -> a -> Bool
(<=) (ByteString -> ByteString -> Bool)
-> (IV -> ByteString) -> IV -> IV -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
< :: IV -> IV -> Bool
(<) = ByteString -> ByteString -> Bool
forall a. Ord a => a -> a -> Bool
(<) (ByteString -> ByteString -> Bool)
-> (IV -> ByteString) -> IV -> IV -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
>= :: IV -> IV -> Bool
(>=) = ByteString -> ByteString -> Bool
forall a. Ord a => a -> a -> Bool
(>=) (ByteString -> ByteString -> Bool)
-> (IV -> ByteString) -> IV -> IV -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
> :: IV -> IV -> Bool
(>) = ByteString -> ByteString -> Bool
forall a. Ord a => a -> a -> Bool
(>) (ByteString -> ByteString -> Bool)
-> (IV -> ByteString) -> IV -> IV -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
instance Show IV where
show :: IV -> [Char]
show = ByteString -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> [Char]) -> (IV -> ByteString) -> IV -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IV -> ByteString
unIV
instance Serialize IV where
put :: Putter IV
put = Putter ByteString
forall t. Serialize t => Putter t
put Putter ByteString -> (IV -> ByteString) -> Putter IV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IV -> ByteString
unIV
get :: Get IV
get = ByteString -> IV
unsafeMkIV (ByteString -> IV) -> Get ByteString -> Get IV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall t. Serialize t => Get t
get
mkIV :: S.ByteString -> Maybe IV
mkIV :: ByteString -> Maybe IV
mkIV ByteString
bs | ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 = IV -> Maybe IV
forall a. a -> Maybe a
Just (ByteString -> IV
unsafeMkIV ByteString
bs)
| Bool
otherwise = Maybe IV
forall a. Maybe a
Nothing
randomIV :: IO IV
randomIV :: IO IV
randomIV = IO IV
aesRNG
defaultKeyFile :: FilePath
defaultKeyFile :: [Char]
defaultKeyFile = [Char]
"client_session_key.aes"
getDefaultKey :: IO Key
getDefaultKey :: IO Key
getDefaultKey = [Char] -> IO Key
getKey [Char]
defaultKeyFile
getKey :: FilePath
-> IO Key
getKey :: [Char] -> IO Key
getKey [Char]
keyFile = do
Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
keyFile
if Bool
exists
then [Char] -> IO ByteString
S.readFile [Char]
keyFile IO ByteString -> (ByteString -> IO Key) -> IO Key
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Char] -> IO Key)
-> (Key -> IO Key) -> Either [Char] Key -> IO Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO Key -> [Char] -> IO Key
forall a b. a -> b -> a
const IO Key
newKey) Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Key -> IO Key)
-> (ByteString -> Either [Char] Key) -> ByteString -> IO Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] Key
initKey
else IO Key
newKey
where
newKey :: IO Key
newKey = do
(ByteString
bs, Key
key') <- IO (ByteString, Key)
randomKey
[Char] -> ByteString -> IO ()
S.writeFile [Char]
keyFile ByteString
bs
Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key'
getKeyEnv :: String
-> IO Key
getKeyEnv :: [Char] -> IO Key
getKeyEnv [Char]
envVar = do
Maybe [Char]
mvalue <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
envVar
case Maybe [Char]
mvalue of
Just [Char]
value -> ([Char] -> IO Key)
-> (Key -> IO Key) -> Either [Char] Key -> IO Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO Key -> [Char] -> IO Key
forall a b. a -> b -> a
const IO Key
newKey) Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Key -> IO Key) -> Either [Char] Key -> IO Key
forall a b. (a -> b) -> a -> b
$ ByteString -> Either [Char] Key
initKey (ByteString -> Either [Char] Key)
-> Either [Char] ByteString -> Either [Char] Key
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Either [Char] ByteString
decode [Char]
value
Maybe [Char]
Nothing -> IO Key
newKey
where
decode :: [Char] -> Either [Char] ByteString
decode = ByteString -> Either [Char] ByteString
B.decode (ByteString -> Either [Char] ByteString)
-> ([Char] -> ByteString) -> [Char] -> Either [Char] ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
C.pack
newKey :: IO Key
newKey = [Char] -> IO Key
randomKeyEnv [Char]
envVar
randomKey :: IO (S.ByteString, Key)
randomKey :: IO (ByteString, Key)
randomKey = do
ByteString
bs <- Int -> IO ByteString
getEntropy Int
96
case ByteString -> Either [Char] Key
initKey ByteString
bs of
Left [Char]
e -> [Char] -> IO (ByteString, Key)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (ByteString, Key)) -> [Char] -> IO (ByteString, Key)
forall a b. (a -> b) -> a -> b
$ [Char]
"Web.ClientSession.randomKey: never here, " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
e
Right Key
key -> (ByteString, Key) -> IO (ByteString, Key)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, Key
key)
randomKeyEnv :: String -> IO Key
randomKeyEnv :: [Char] -> IO Key
randomKeyEnv [Char]
envVar = do
(ByteString
bs, Key
key) <- IO (ByteString, Key)
randomKey
let encoded :: [Char]
encoded = ByteString -> [Char]
C.unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.encode ByteString
bs
[Char] -> [Char] -> IO ()
setEnv [Char]
envVar [Char]
encoded
[Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
envVar [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
encoded
Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key
initKey :: S.ByteString -> Either String Key
initKey :: ByteString -> Either [Char] Key
initKey ByteString
bs | ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
96 = [Char] -> Either [Char] Key
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Key) -> [Char] -> Either [Char] Key
forall a b. (a -> b) -> a -> b
$ [Char]
"Web.ClientSession.initKey: length of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
Int -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Int
S.length ByteString
bs) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" /= 96."
initKey ByteString
bs = Key -> Either [Char] Key
forall a b. b -> Either a b
Right (Key -> Either [Char] Key) -> Key -> Either [Char] Key
forall a b. (a -> b) -> a -> b
$ Key :: AES -> (ByteString -> Skein_512_256) -> ByteString -> Key
Key { aesKey :: AES
aesKey = ByteString -> AES
forall b. Byteable b => b -> AES
A.initKey ByteString
preAesKey
, macKey :: ByteString -> Skein_512_256
macKey = ByteString -> ByteString -> Skein_512_256
forall skeinCtx digest.
(SkeinMAC skeinCtx, Hash skeinCtx digest) =>
ByteString -> ByteString -> digest
skeinMAC' ByteString
preMacKey
, keyRaw :: ByteString
keyRaw = ByteString
bs
}
where
(ByteString
preMacKey, ByteString
preAesKey) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
64 ByteString
bs
encryptIO :: Key -> S.ByteString -> IO S.ByteString
encryptIO :: Key -> ByteString -> IO ByteString
encryptIO Key
key ByteString
x = do
IV
iv <- IO IV
randomIV
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Key -> IV -> ByteString -> ByteString
encrypt Key
key IV
iv ByteString
x
encrypt :: Key
-> IV
-> S.ByteString
-> S.ByteString
encrypt :: Key -> IV -> ByteString -> ByteString
encrypt Key
key (IV ByteString
iv) ByteString
x = ByteString -> ByteString
B.encode ByteString
final
where
#if MIN_VERSION_cipher_aes(0, 2, 0)
encrypted :: ByteString
encrypted = AES -> ByteString -> ByteString -> ByteString
forall iv. Byteable iv => AES -> iv -> ByteString -> ByteString
A.encryptCTR (Key -> AES
aesKey Key
key) ByteString
iv ByteString
x
#else
encrypted = A.encryptCTR (aesKey key) (A.IV iv) x
#endif
toBeAuthed :: ByteString
toBeAuthed = ByteString
iv ByteString -> ByteString -> ByteString
`S.append` ByteString
encrypted
auth :: Skein_512_256
auth = Key -> ByteString -> Skein_512_256
macKey Key
key ByteString
toBeAuthed
final :: ByteString
final = Skein_512_256 -> ByteString
forall a. Serialize a => a -> ByteString
encode Skein_512_256
auth ByteString -> ByteString -> ByteString
`S.append` ByteString
toBeAuthed
decrypt :: Key
-> S.ByteString
-> Maybe S.ByteString
decrypt :: Key -> ByteString -> Maybe ByteString
decrypt Key
key ByteString
dataBS64 = do
ByteString
dataBS <- ([Char] -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either [Char] ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> [Char] -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Either [Char] ByteString -> Maybe ByteString)
-> Either [Char] ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either [Char] ByteString
B.decode ByteString
dataBS64
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
S.length ByteString
dataBS Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
48)
let (ByteString
auth, ByteString
toBeAuthed) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
32 ByteString
dataBS
auth' :: Skein_512_256
auth' = Key -> ByteString -> Skein_512_256
macKey Key
key ByteString
toBeAuthed
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Skein_512_256 -> ByteString
forall a. Serialize a => a -> ByteString
encode Skein_512_256
auth' ByteString -> ByteString -> Bool
`constTimeEq` ByteString
auth)
let (ByteString
iv, ByteString
encrypted) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
16 ByteString
toBeAuthed
#if MIN_VERSION_cipher_aes(0, 2, 0)
let iv' :: ByteString
iv' = ByteString
iv
#else
let iv' = A.IV iv
#endif
ByteString -> Maybe ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! AES -> ByteString -> ByteString -> ByteString
forall iv. Byteable iv => AES -> iv -> ByteString -> ByteString
A.decryptCTR (Key -> AES
aesKey Key
key) ByteString
iv' ByteString
encrypted
data AESState =
ASt {-# UNPACK #-} !AESRNG
{-# UNPACK #-} !Int
aesSeed :: IO AESState
aesSeed :: IO AESState
aesSeed = do
AESRNG
rng <- IO AESRNG
makeSystem
AESState -> IO AESState
forall (m :: * -> *) a. Monad m => a -> m a
return (AESState -> IO AESState) -> AESState -> IO AESState
forall a b. (a -> b) -> a -> b
$! AESRNG -> Int -> AESState
ASt AESRNG
rng Int
0
aesReseed :: IO ()
aesReseed :: IO ()
aesReseed = do
AESRNG
rng' <- IO AESRNG
makeSystem
IORef AESState -> AESState -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef AESState
aesRef (AESState -> IO ()) -> AESState -> IO ()
forall a b. (a -> b) -> a -> b
$ AESRNG -> Int -> AESState
ASt AESRNG
rng' Int
0
aesRef :: I.IORef AESState
aesRef :: IORef AESState
aesRef = IO (IORef AESState) -> IORef AESState
forall a. IO a -> a
unsafePerformIO (IO (IORef AESState) -> IORef AESState)
-> IO (IORef AESState) -> IORef AESState
forall a b. (a -> b) -> a -> b
$ IO AESState
aesSeed IO AESState
-> (AESState -> IO (IORef AESState)) -> IO (IORef AESState)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AESState -> IO (IORef AESState)
forall a. a -> IO (IORef a)
I.newIORef
{-# NOINLINE aesRef #-}
aesRNG :: IO IV
aesRNG :: IO IV
aesRNG = do
(ByteString
bs, Int
count) <-
IORef AESState
-> (AESState -> (AESState, (ByteString, Int)))
-> IO (ByteString, Int)
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef AESState
aesRef ((AESState -> (AESState, (ByteString, Int)))
-> IO (ByteString, Int))
-> (AESState -> (AESState, (ByteString, Int)))
-> IO (ByteString, Int)
forall a b. (a -> b) -> a -> b
$ \(ASt AESRNG
rng Int
count) ->
#if MIN_VERSION_cprng_aes(0, 5, 0)
let (ByteString
bs', AESRNG
rng') = Int -> AESRNG -> (ByteString, AESRNG)
forall gen. CPRG gen => Int -> gen -> (ByteString, gen)
cprgGenerate Int
16 AESRNG
rng
#elif MIN_VERSION_cprng_aes(0, 3, 2)
let (bs', rng') = genRandomBytes 16 rng
#else
let (bs', rng') = genRandomBytes rng 16
#endif
in (AESRNG -> Int -> AESState
ASt AESRNG
rng' (Int -> Int
forall a. Enum a => a -> a
succ Int
count), (ByteString
bs', Int
count))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
threshold) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> IO ()
forall (m :: * -> *) a. Monad m => m a -> m ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
aesReseed
IV -> IO IV
forall (m :: * -> *) a. Monad m => a -> m a
return (IV -> IO IV) -> IV -> IO IV
forall a b. (a -> b) -> a -> b
$! ByteString -> IV
unsafeMkIV ByteString
bs
where
void :: m a -> m ()
void m a
f = m a
f m a -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
threshold :: Int
threshold :: Int
threshold = Int
100000