module Web.ClientSession
(
getKey
, defaultKeyFile
, getDefaultKey
, encrypt
, decrypt
, ClientSessionException (..)
) where
import Codec.Crypto.SimpleAES
import Control.Failure
import Control.Monad (unless)
import qualified Codec.Crypto.SimpleAES as AES
import qualified Codec.Binary.Base64Url as Base64
import qualified Data.Digest.Pure.MD5 as MD5
import Data.Typeable (Typeable)
import Control.Exception
import System.Directory
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Binary
defaultKeyFile :: String
defaultKeyFile = "client_session_key.aes"
getDefaultKey :: IO AES.Key
getDefaultKey = getKey defaultKeyFile
data ClientSessionException =
KeyTooSmall S.ByteString
| InvalidBase64 String
| InvalidHash String
| MismatchedHash { expectedHash :: L.ByteString
, actualHash :: L.ByteString
}
deriving (Show, Typeable, Eq)
instance Exception ClientSessionException
getKey :: FilePath
-> IO AES.Key
getKey keyFile = do
exists <- doesFileExist keyFile
if exists
then S.readFile keyFile
else do
key <- AES.randomKey
S.writeFile keyFile key
return key
encrypt :: AES.Key
-> L.ByteString
-> IO (String)
encrypt k bs = do
let withHash = encode (MD5.md5 bs) `L.append` bs
encrypted <- AES.encryptMsg mode k withHash
return $ Base64.encode $ L.unpack encrypted
mode :: AES.Mode
mode = ECB
decrypt :: (Monad m, Failure ClientSessionException m)
=> AES.Key
-> String
-> m L.ByteString
decrypt k x = do
decoded <- case Base64.decode x of
Nothing -> failure $ InvalidBase64 x
Just y -> return y
decrypted <- case AES.decryptMsg' mode k $ L.pack decoded of
Left s -> failure $ InvalidHash s
Right z -> return z
let (expected, rest) = L.splitAt 16 decrypted
let actual = encode $ MD5.md5 rest
unless (expected == actual) $ failure
$ MismatchedHash expected actual
return rest