module Web.ClientSession
(
getKey
, defaultKeyFile
, getDefaultKey
, encrypt
, decrypt
, Word256
, AESKey
, ClientSessionException
) where
import Codec.Encryption.AES (AESKey)
import qualified Data.ByteString as BS
import Control.Failure
import Control.Monad (unless)
import Data.LargeWord (Word256)
import Codec.Utils (listFromOctets, listToOctets)
import Data.Word (Word8)
import System.Random (getStdGen, randoms, Random, randomR, random)
import qualified Codec.Encryption.AES as AES
import qualified Codec.Binary.Base64Url as Base64
import qualified Data.Digest.MD5 as MD5
import Data.Typeable (Typeable)
import Control.Exception (Exception)
defaultKeyFile :: String
defaultKeyFile = "client_session_key.aes"
getDefaultKey :: IO Word256
getDefaultKey = getKey defaultKeyFile
data ClientSessionException =
KeyTooSmall BS.ByteString
| InvalidBase64 String
| MismatchedHash { _expected :: [Word8]
, _actual :: [Word8]
}
deriving (Show, Typeable)
instance Exception ClientSessionException
getKey :: FilePath
-> IO Word256
getKey keyFile = catch loadKeyFromFile $ const generateNewKey where
loadKeyFromFile :: IO Word256
loadKeyFromFile = do
contents <- BS.readFile keyFile
if BS.length contents < 32
then failure $ KeyTooSmall contents
else return $ head $ listFromOctets $ BS.unpack contents
generateNewKey :: IO Word256
generateNewKey = do
stdGen <- getStdGen
let word8s = map unMyWord8 $ take 32 $ randoms stdGen
let newKey = head $ listFromOctets word8s
BS.writeFile keyFile $ BS.pack word8s
return newKey
newtype MyWord8 = MyWord8 { unMyWord8 :: Word8 }
deriving (Integral, Real, Enum, Num, Ord, Eq, Show)
instance Random MyWord8 where
randomR (a,b) g =
let (x, g') = randomR (toInteger a, toInteger b) g
in (fromIntegral $ mod x 256, g')
random = randomR (MyWord8 minBound, MyWord8 maxBound)
encrypt :: AES.AESKey k
=> k
-> BS.ByteString
-> String
encrypt k x =
let unpacked = BS.unpack x
in Base64.encode . listToOctets . map (AES.encrypt k) .
listFromOctets $ MD5.hash unpacked ++ unpacked
decrypt :: (AES.AESKey k, Monad m, Failure ClientSessionException m)
=> k
-> String
-> m BS.ByteString
decrypt k x = do
decoded <- case Base64.decode x of
Nothing -> failure $ InvalidBase64 x
Just y -> return y
let decrypted = listToOctets $ map (AES.decrypt k)
$ listFromOctets decoded
let (expected, rest) = splitAt 16 decrypted
let actual = MD5.hash rest
unless (expected == actual) $ failure
$ MismatchedHash expected actual
return $ BS.pack rest