{-# 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 forall a. Eq a => a -> a -> Bool
== ByteString
r2
instance Serialize Key where
put :: Putter Key
put = Putter ByteString
putByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> ByteString
keyRaw
get :: Get Key
get = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Key
initKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
96
instance Show Key where
show :: Key -> String
show Key
_ = String
"<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
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
/= :: IV -> IV -> Bool
(/=) = forall a. Eq a => a -> a -> 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 = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
<= :: IV -> IV -> Bool
(<=) = forall a. Ord a => a -> a -> Bool
(<=) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
< :: IV -> IV -> Bool
(<) = forall a. Ord a => a -> a -> Bool
(<) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
>= :: IV -> IV -> Bool
(>=) = forall a. Ord a => a -> a -> Bool
(>=) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
> :: IV -> IV -> Bool
(>) = forall a. Ord a => a -> a -> Bool
(>) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` IV -> ByteString
unIV
instance Show IV where
show :: IV -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. IV -> ByteString
unIV
instance Serialize IV where
put :: Putter IV
put = forall t. Serialize t => Putter t
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. IV -> ByteString
unIV
get :: Get IV
get = ByteString -> IV
unsafeMkIV forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. Eq a => a -> a -> Bool
== Int
16 = forall a. a -> Maybe a
Just (ByteString -> IV
unsafeMkIV ByteString
bs)
| Bool
otherwise = forall a. Maybe a
Nothing
randomIV :: IO IV
randomIV :: IO IV
randomIV = IO IV
aesRNG
defaultKeyFile :: FilePath
defaultKeyFile :: String
defaultKeyFile = String
"client_session_key.aes"
getDefaultKey :: IO Key
getDefaultKey :: IO Key
getDefaultKey = String -> IO Key
getKey String
defaultKeyFile
getKey :: FilePath
-> IO Key
getKey :: String -> IO Key
getKey String
keyFile = do
Bool
exists <- String -> IO Bool
doesFileExist String
keyFile
if Bool
exists
then String -> IO ByteString
S.readFile String
keyFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const IO Key
newKey) forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Key
initKey
else IO Key
newKey
where
newKey :: IO Key
newKey = do
(ByteString
bs, Key
key') <- IO (ByteString, Key)
randomKey
String -> ByteString -> IO ()
S.writeFile String
keyFile ByteString
bs
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key'
getKeyEnv :: String
-> IO Key
getKeyEnv :: String -> IO Key
getKeyEnv String
envVar = do
Maybe String
mvalue <- String -> IO (Maybe String)
lookupEnv String
envVar
case Maybe String
mvalue of
Just String
value -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const IO Key
newKey) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Key
initKey forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Either String ByteString
decode String
value
Maybe String
Nothing -> IO Key
newKey
where
decode :: String -> Either String ByteString
decode = ByteString -> Either String ByteString
B.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C.pack
newKey :: IO Key
newKey = String -> IO Key
randomKeyEnv String
envVar
randomKey :: IO (S.ByteString, Key)
randomKey :: IO (ByteString, Key)
randomKey = do
ByteString
bs <- Int -> IO ByteString
getEntropy Int
96
case ByteString -> Either String Key
initKey ByteString
bs of
Left String
e -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Web.ClientSession.randomKey: never here, " forall a. [a] -> [a] -> [a]
++ String
e
Right Key
key -> forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, Key
key)
randomKeyEnv :: String -> IO Key
randomKeyEnv :: String -> IO Key
randomKeyEnv String
envVar = do
(ByteString
bs, Key
key) <- IO (ByteString, Key)
randomKey
let encoded :: String
encoded = ByteString -> String
C.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.encode ByteString
bs
String -> String -> IO ()
setEnv String
envVar String
encoded
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
envVar forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String
encoded
forall (m :: * -> *) a. Monad m => a -> m a
return Key
key
initKey :: S.ByteString -> Either String Key
initKey :: ByteString -> Either String Key
initKey ByteString
bs | ByteString -> Int
S.length ByteString
bs forall a. Eq a => a -> a -> Bool
/= Int
96 = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Web.ClientSession.initKey: length of " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show (ByteString -> Int
S.length ByteString
bs) forall a. [a] -> [a] -> [a]
++ String
" /= 96."
initKey ByteString
bs = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Key { aesKey :: AES
aesKey = forall b. Byteable b => b -> AES
A.initKey ByteString
preAesKey
, macKey :: ByteString -> Skein_512_256
macKey = 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 = 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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B.decode ByteString
dataBS64
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
S.length ByteString
dataBS 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
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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
forall a. IORef a -> a -> IO ()
I.writeIORef IORef AESState
aesRef forall a b. (a -> b) -> a -> b
$ AESRNG -> Int -> AESState
ASt AESRNG
rng' Int
0
aesRef :: I.IORef AESState
aesRef :: IORef AESState
aesRef = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ IO AESState
aesSeed forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (IORef a)
I.newIORef
{-# NOINLINE aesRef #-}
aesRNG :: IO IV
aesRNG :: IO IV
aesRNG = do
(ByteString
bs, Int
count) <-
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef AESState
aesRef 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') = 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' (forall a. Enum a => a -> a
succ Int
count), (ByteString
bs', Int
count))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Eq a => a -> a -> Bool
== Int
threshold) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}. Monad m => m a -> m ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
aesReseed
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString -> IV
unsafeMkIV ByteString
bs
where
void :: m a -> m ()
void m a
f = m a
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
threshold :: Int
threshold :: Int
threshold = Int
100000