diff --git a/Web/ClientSession.hs b/Web/ClientSession.hs deleted file mode 100644 --- a/Web/ClientSession.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} ---------------------------------------------------------- --- --- Module : Web.ClientSession --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Stores session data in a client cookie. --- ---------------------------------------------------------- -module Web.ClientSession - ( -- * Automatic key generation - Key - , IV - , randomIV - , mkIV - , getKey - , defaultKeyFile - , getDefaultKey - -- * Actual encryption/decryption - , encrypt - , encryptIO - , decrypt - ) where - -import System.Directory (doesFileExist) -import qualified Data.ByteString as S -import qualified Crypto.Cipher.AES as A -import Crypto.Cipher.AES (Key) -import qualified Data.ByteString.Base64 as B -import Crypto.Random (newGenIO, genBytes, SystemRandom) - -newtype IV = IV S.ByteString - deriving Show - -mkIV :: S.ByteString -> Maybe IV -mkIV bs - | S.length bs == 16 = Just $ IV bs - | otherwise = Nothing - -randomIV :: IO IV -randomIV = fmap IV $ randomBytes 16 - --- | The default key file. -defaultKeyFile :: String -defaultKeyFile = "client_session_key.aes" - --- | Simply calls 'getKey' 'defaultKeyFile'. -getDefaultKey :: IO Key -getDefaultKey = getKey defaultKeyFile - --- | Get a key from the given text file. --- --- If the file does not exist a random key will be generated and stored in that --- file. -getKey :: FilePath -- ^ File name where key is stored. - -> IO Key -- ^ The actual key. -getKey keyFile = do - exists <- doesFileExist keyFile - if exists - then S.readFile keyFile >>= either (const newKey) return . A.initKey256 - else newKey - where - newKey = do - (bs, key') <- randomKey - S.writeFile keyFile bs - return key' - -randomBytes :: Int -> IO S.ByteString -randomBytes len = do - g <- newGenIO - either (error . show) (return . fst) $ genBytes len (g :: SystemRandom) - -randomKey :: IO (S.ByteString, Key) -randomKey = do - bs <- randomBytes 32 - case A.initKey256 bs of - Left e -> error e -- should never happen - Right key -> return (bs, key) - -encryptIO :: Key -> S.ByteString -> IO S.ByteString -encryptIO key x = do - iv <- randomIV - return $ encrypt key iv x - -encrypt :: Key - -> IV - -> S.ByteString -- ^ data - -> S.ByteString -encrypt key (IV iv) x = - B.encode $ iv `S.append` A.encryptCBC key iv y - where - toPad = 16 - S.length x `mod` 16 - pad = S.replicate toPad $ fromIntegral toPad - y = pad `S.append` x - -decrypt :: Key -- ^ key - -> S.ByteString -- ^ data - -> Maybe S.ByteString -decrypt key dataBS64 = do - dataBS <- either (const Nothing) Just $ B.decode dataBS64 - if S.length dataBS `mod` 16 /= 0 || S.length dataBS < 16 - then Nothing - else do - let (iv, encrypted) = S.splitAt 16 dataBS - let x = A.decryptCBC key iv encrypted - (td, _) <- S.uncons x - if td > 0 && td <= 16 - then Just $ S.drop (fromIntegral td) x - else Nothing diff --git a/clientsession.cabal b/clientsession.cabal --- a/clientsession.cabal +++ b/clientsession.cabal @@ -1,5 +1,5 @@ name: clientsession -version: 0.7.0 +version: 0.7.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -20,19 +20,28 @@ library build-depends: base >=4 && < 5 , bytestring >= 0.9 && < 0.10 + , cereal >= 0.3 && < 0.4 , directory >= 1 && < 1.2 , crypto-api >= 0.6.4 && < 0.7 , cryptocipher >= 0.2.5 && < 0.3 + , cryptohash >= 0.7.1 && < 0.8 , base64-bytestring >= 0.1.0.3 && < 0.2 exposed-modules: Web.ClientSession ghc-options: -Wall + hs-source-dirs: src test-suite runtests type: exitcode-stdio-1.0 - build-depends: hspec == 0.6.* - , QuickCheck >= 2 && < 3 - , HUnit + build-depends: base >=4 && < 5 + , bytestring >= 0.9 && < 0.10 + , cryptocipher >= 0.2.5 && < 0.3 + , hspec == 0.6.* + , QuickCheck >= 2 && < 3 + , HUnit + -- finally, our own package + , clientsession ghc-options: -Wall + hs-source-dirs: tests main-is: runtests.hs source-repository head diff --git a/src/Web/ClientSession.hs b/src/Web/ClientSession.hs new file mode 100644 --- /dev/null +++ b/src/Web/ClientSession.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +--------------------------------------------------------- +-- +-- Module : Web.ClientSession +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Stores session data in a client cookie. +-- +--------------------------------------------------------- +module Web.ClientSession + ( -- * Automatic key generation + Key(..) + , IV + , randomIV + , mkIV + , getKey + , defaultKeyFile + , getDefaultKey + , initKey + -- * Actual encryption/decryption + , encrypt + , encryptIO + , decrypt + ) where + +import Control.Arrow (second) +import Control.Monad (guard) +import Data.Bits (xor) +import System.Directory (doesFileExist) +import qualified Data.ByteString as S +import qualified Crypto.Cipher.AES as A +import Crypto.Hash.SHA256 (SHA256) +import Crypto.HMAC (MacKey(..), hmac') +import qualified Data.ByteString.Base64 as B +import Crypto.Random (newGenIO, genBytes, SystemRandom) +import Data.Serialize (encode) + +data Key = Key { aesKey :: A.Key + , hmacKey :: MacKey } + deriving (Eq, Show) + +newtype IV = IV S.ByteString + deriving Show + +mkIV :: S.ByteString -> Maybe IV +mkIV bs + | S.length bs == 16 = Just $ IV bs + | otherwise = Nothing + +randomIV :: IO IV +randomIV = fmap IV $ randomBytes 16 + +-- | The default key file. +defaultKeyFile :: String +defaultKeyFile = "client_session_key.aes" + +-- | Simply calls 'getKey' 'defaultKeyFile'. +getDefaultKey :: IO Key +getDefaultKey = getKey defaultKeyFile + +-- | Get a key from the given text file. +-- +-- If the file does not exist a random key will be generated and stored in that +-- file. +getKey :: FilePath -- ^ File name where key is stored. + -> IO Key -- ^ The actual key. +getKey keyFile = do + exists <- doesFileExist keyFile + if exists + then S.readFile keyFile >>= either (const newKey) return . initKey + else newKey + where + newKey = do + (bs, key') <- randomKey + S.writeFile keyFile bs + return key' + +randomBytes :: Int -> IO S.ByteString +randomBytes len = do + g <- newGenIO + either (error . show) (return . fst) $ genBytes len (g :: SystemRandom) + +randomKey :: IO (S.ByteString, Key) +randomKey = do + bs <- randomBytes 64 + case initKey bs of + Left e -> error e -- should never happen + Right key -> return (bs, key) + +-- | Initializes a 'Key' from a random 'S.ByteString'. It's +-- better to give a 'S.ByteString' with exactly 64 bytes, but +-- anything with at least 32 bytes will work. +initKey :: S.ByteString -> Either String Key +initKey bs | S.length bs < 32 = Left $ "Web.ClientSession.initKey: length of " ++ + show (S.length bs) ++ " too small." +initKey bs = fmap mk $ A.initKey256 preAesKey + where + preAesKey | S.length bs >= 64 = S.pack $ uncurry (S.zipWith xor) $ S.splitAt 32 bs + | otherwise = S.take 32 bs + mk k = Key { aesKey = k + , hmacKey = MacKey bs } + -- It's okay to have a MacKey where bs doesn't + -- have exactly 512 bits, the size of the block + -- used in SHA-256. hmac' already deals with it. + +encryptIO :: Key -> S.ByteString -> IO S.ByteString +encryptIO key x = do + iv <- randomIV + return $ encrypt key iv x + +encrypt :: Key + -> IV + -> S.ByteString -- ^ data + -> S.ByteString +encrypt key (IV iv) x = + B.encode $ S.concat [iv, encode auth, encrypted] + where + toPad = 16 - S.length x `mod` 16 + pad = S.replicate toPad $ fromIntegral toPad + y = pad `S.append` x + encrypted = A.encryptCBC (aesKey key) iv y + auth = hmac' (hmacKey key) encrypted :: SHA256 + +decrypt :: Key -- ^ key + -> S.ByteString -- ^ data + -> Maybe S.ByteString +decrypt key dataBS64 = do + dataBS <- either (const Nothing) Just $ B.decode dataBS64 + if S.length dataBS `mod` 16 /= 0 || S.length dataBS < 48 + then Nothing + else do + let (iv, (auth, encrypted)) = second (S.splitAt 32) $ S.splitAt 16 dataBS + auth' = hmac' (hmacKey key) encrypted :: SHA256 + guard (encode auth' == auth) + let x = A.decryptCBC (aesKey key) iv encrypted + (td, _) <- S.uncons x + guard (td > 0 && td <= 16) + return $ S.drop (fromIntegral td) x