diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,25 +1,25 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2008, Michael Snoyman. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2008, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,7 +1,7 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/bench.hs b/bench.hs --- a/bench.hs +++ b/bench.hs @@ -1,19 +1,19 @@ -import qualified Data.ByteString as B -import Web.ClientSession -import Data.Maybe -import Data.Serialize - -import Criterion.Main -import Text.Printf - -Right key = initKey (B.replicate 96 0xFE) -Just iv = mkIV (B.replicate 16 0xB0) - -main :: IO () -main = - defaultMain - [ bgroup "encrypt then decrypt" - [ bench (printf "Message length = %d bytes" len) $ - whnf (fromJust . decrypt key . encrypt key iv) (B.replicate len 0xAA) - | len <- [0, 50, 100, 400, 2000, 80000]] - ] +import qualified Data.ByteString as B +import Web.ClientSession +import Data.Maybe +import Data.Serialize + +import Criterion.Main +import Text.Printf + +Right key = initKey (B.replicate 96 0xFE) +Just iv = mkIV (B.replicate 16 0xB0) + +main :: IO () +main = + defaultMain + [ bgroup "encrypt then decrypt" + [ bench (printf "Message length = %d bytes" len) $ + whnf (fromJust . decrypt key . encrypt key iv) (B.replicate len 0xAA) + | len <- [0, 50, 100, 400, 2000, 80000]] + ] diff --git a/clientsession.cabal b/clientsession.cabal --- a/clientsession.cabal +++ b/clientsession.cabal @@ -1,57 +1,57 @@ -name: clientsession -version: 0.8.0.3 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman , Felipe Lessa -maintainer: Michael Snoyman -synopsis: Securely store session data in a client-side cookie. -description: Achieves security through AES-CTR encryption and - Skein-MAC-512-256 authentication. Uses Base64 - encoding to avoid any issues with characters. -category: Web -stability: stable -cabal-version: >= 1.8 -build-type: Simple -homepage: http://github.com/yesodweb/clientsession/tree/master -data-files: bench.hs -extra-source-files: tests/runtests.hs - -flag test - description: Build the executable to run unit tests - default: False - -library - build-depends: base >=4 && < 5 - , bytestring >= 0.9 - , cereal >= 0.3 - , directory >= 1 - , tagged >= 0.1 - , crypto-api >= 0.8 - , skein >= 0.1 && < 0.2 - , base64-bytestring >= 0.1.1.1 - , entropy >= 0.2.1 - , cprng-aes >= 0.2 - , cipher-aes >= 0.1.7 - exposed-modules: Web.ClientSession - ghc-options: -Wall - hs-source-dirs: src - -test-suite runtests - type: exitcode-stdio-1.0 - build-depends: base - , bytestring >= 0.9 - , hspec >= 1.3 - , QuickCheck >= 2 - , HUnit - , transformers - , containers - , cereal - -- finally, our own package - , clientsession - ghc-options: -Wall - hs-source-dirs: tests - main-is: runtests.hs - -source-repository head - type: git - location: git://github.com/yesodweb/clientsession.git +name: clientsession +version: 0.8.1 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman , Felipe Lessa +maintainer: Michael Snoyman +synopsis: Securely store session data in a client-side cookie. +description: Achieves security through AES-CTR encryption and + Skein-MAC-512-256 authentication. Uses Base64 + encoding to avoid any issues with characters. +category: Web +stability: stable +cabal-version: >= 1.8 +build-type: Simple +homepage: http://github.com/yesodweb/clientsession/tree/master +data-files: bench.hs +extra-source-files: tests/runtests.hs + +flag test + description: Build the executable to run unit tests + default: False + +library + build-depends: base >=4 && < 5 + , bytestring >= 0.9 + , cereal >= 0.3 + , directory >= 1 + , tagged >= 0.1 + , crypto-api >= 0.8 + , skein >= 0.1 && < 0.2 + , base64-bytestring >= 0.1.1.1 + , entropy >= 0.2.1 + , cprng-aes >= 0.2 + , cipher-aes >= 0.1.7 + exposed-modules: Web.ClientSession + ghc-options: -Wall + hs-source-dirs: src + +test-suite runtests + type: exitcode-stdio-1.0 + build-depends: base + , bytestring >= 0.9 + , hspec >= 1.3 + , QuickCheck >= 2 + , HUnit + , transformers + , containers + , cereal + -- finally, our own package + , clientsession + ghc-options: -Wall + hs-source-dirs: tests + main-is: runtests.hs + +source-repository head + type: git + location: git://github.com/yesodweb/clientsession.git diff --git a/src/Web/ClientSession.hs b/src/Web/ClientSession.hs --- a/src/Web/ClientSession.hs +++ b/src/Web/ClientSession.hs @@ -1,307 +1,311 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- | --- --- Module : Web.ClientSession --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Stores session data in a client cookie. In order to do so, --- we: --- --- * Encrypt the cookie data using AES in CTR mode. This allows --- you to store sensitive information on the client side without --- worrying about eavesdropping. --- --- * Authenticate the encrypted cookie data using --- Skein-MAC-512-256. Besides detecting potential errors in --- storage or transmission of the cookies (integrity), the MAC --- also avoids malicious modifications of the cookie data by --- assuring you that the cookie data really was generated by this --- server (authenticity). --- --- * Encode everything using Base64. Thus we avoid problems with --- non-printable characters by giving the browser a simple --- string. --- --- Simple usage of the library involves just calling --- 'getDefaultKey' on the startup of your server, 'encryptIO' --- when serializing cookies and 'decrypt' when parsing then back. --- ---------------------------------------------------------- -module Web.ClientSession - ( -- * Automatic key generation - Key - , IV - , randomIV - , mkIV - , getKey - , defaultKeyFile - , getDefaultKey - , initKey - , randomKey - -- * Actual encryption/decryption - , encrypt - , encryptIO - , decrypt - ) where - --- from base -import Control.Monad (guard, when) -import qualified Data.IORef as I -import System.IO.Unsafe (unsafePerformIO) -import Control.Concurrent (forkIO) -import Control.Applicative ((<$>)) - --- from directory -import System.Directory (doesFileExist) - --- from bytestring -import qualified Data.ByteString as S -import qualified Data.ByteString.Base64 as B - --- from cereal -import Data.Serialize (encode, decode, Serialize (put, get), getBytes, putByteString) - --- from tagged -import Data.Tagged (Tagged, untag) - --- from crypto-api -import Crypto.Classes (buildKey, constTimeEq) -import Crypto.Random (genSeedLength, reseed) -import Crypto.Types (ByteLength) -import qualified Crypto.Modes as Modes - --- from cipher-aes -import qualified Crypto.Cipher.AES as A - --- from skein -import Crypto.Skein (skeinMAC', Skein_512_256) - --- from entropy -import System.Entropy (getEntropy) - --- from cprng-aes -import Crypto.Random.AESCtr (AESRNG, makeSystem, genRandomBytes) - -import Crypto.Classes (BlockCipher(..)) -import Data.Tagged (Tagged(..)) - -newtype AES256 = A256 { unA256 :: A.Key } - -instance BlockCipher AES256 where - blockSize = Tagged 128 - encryptBlock = A.encryptECB . unA256 - decryptBlock = A.decryptECB . unA256 - buildKey = Just . A256 . A.initKey - keyLength = Tagged 256 - -instance Serialize AES256 where - put = putByteString . A.keyOfCtx . unA256 - get = do - raw <- getBytes (256 `div` 8) - return $ A256 $ A.initKey raw - --- | The keys used to store the cookies. We have an AES key used --- to encrypt the cookie and a Skein-MAC-512-256 key used verify --- the authencity and integrity of the cookie. The AES key needs --- to have exactly 32 bytes (256 bits) while Skein-MAC-512-256 --- should have 64 bytes (512 bits). --- --- See also 'getDefaultKey' and 'initKey'. -data Key = Key { aesKey :: AES256 - -- ^ AES key with 32 bytes. - , macKey :: S.ByteString -> Skein_512_256 - -- ^ Skein-MAC key. Instead of storing the key - -- data, we store a partially applied function - -- for calculating the MAC (see 'skeinMAC''). - , keyRaw :: S.ByteString - } - -instance Eq Key where - Key a _ b == Key x _ y = encode a == encode x && b == y - -instance Serialize Key where - put = putByteString . keyRaw - get = either error id . initKey <$> getBytes 96 - --- | Dummy 'Show' instance. -instance Show Key where - show _ = "" - --- | The initialization vector used by AES. Should be exactly 16 --- bytes long. -type IV = Modes.IV AES256 - --- | Construct an initialization vector from a 'S.ByteString'. --- Fails if there isn't exactly 16 bytes. -mkIV :: S.ByteString -> Maybe IV -mkIV bs = case (S.length bs, decode bs) of - (16, Right iv) -> Just iv - _ -> Nothing - --- | Randomly construct a fresh initialization vector. You --- /should not/ reuse initialization vectors. -randomIV :: IO IV -randomIV = aesRNG - --- | The default key file. -defaultKeyFile :: FilePath -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 or is corrupted 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' - --- | Generate a random 'Key'. Besides the 'Key', the --- 'ByteString' passed to 'initKey' is returned so that it can be --- saved for later use. -randomKey :: IO (S.ByteString, Key) -randomKey = do - bs <- getEntropy 96 - case initKey bs of - Left e -> error $ "Web.ClientSession.randomKey: never here, " ++ e - Right key -> return (bs, key) - --- | Initializes a 'Key' from a random 'S.ByteString'. Fails if --- there isn't exactly 96 bytes (256 bits for AES and 512 bits --- for Skein-MAC-512-512). -initKey :: S.ByteString -> Either String Key -initKey bs | S.length bs /= 96 = Left $ "Web.ClientSession.initKey: length of " ++ - show (S.length bs) ++ " /= 96." -initKey bs = case buildKey preAesKey of - Nothing -> Left $ "Web.ClientSession.initKey: unknown error with buildKey." - Just k -> Right $ Key { aesKey = k - , macKey = skeinMAC' preMacKey - , keyRaw = bs - } - where - (preMacKey, preAesKey) = S.splitAt 64 bs - --- | Same as 'encrypt', however randomly generates the --- initialization vector for you. -encryptIO :: Key -> S.ByteString -> IO S.ByteString -encryptIO key x = do - iv <- randomIV - return $ encrypt key iv x - --- | Encrypt (AES-CTR), authenticate (Skein-MAC-512-256) and --- encode (Base64) the given cookie data. The returned byte --- string is ready to be used in a response header. -encrypt :: Key -- ^ Key of the server. - -> IV -- ^ New, random initialization vector (see 'randomIV'). - -> S.ByteString -- ^ Serialized cookie data. - -> S.ByteString -- ^ Encoded cookie data to be given to - -- the client browser. -encrypt key iv x = B.encode final - where - (encrypted, _) = Modes.ctr' Modes.incIV (aesKey key) iv x - toBeAuthed = encode iv `S.append` encrypted - auth = macKey key toBeAuthed - final = encode auth `S.append` toBeAuthed - --- | Decode (Base64), verify the integrity and authenticity --- (Skein-MAC-512-256) and decrypt (AES-CTR) the given encoded --- cookie data. Returns the original serialized cookie data. --- Fails if the data is corrupted. -decrypt :: Key -- ^ Key of the server. - -> S.ByteString -- ^ Encoded cookie data given by the browser. - -> Maybe S.ByteString -- ^ Serialized cookie data. -decrypt key dataBS64 = do - dataBS <- either (const Nothing) Just $ B.decode dataBS64 - guard (S.length dataBS >= 48) -- 16 bytes of IV + 32 bytes of Skein-MAC-512-256 - let (auth, toBeAuthed) = S.splitAt 32 dataBS - auth' = macKey key toBeAuthed - guard (encode auth' `constTimeEq` auth) - let (iv_e, encrypted) = S.splitAt 16 toBeAuthed - iv <- either (const Nothing) Just $ decode iv_e - let (x, _) = Modes.unCtr' Modes.incIV (aesKey key) iv encrypted - return x - --- Significantly more efficient random IV generation. Initial --- benchmarks placed it at 6.06 us versus 1.69 ms for Modes.getIVIO, --- since it does not require /dev/urandom I/O for every call. - -data AESState = - ASt {-# UNPACK #-} !AESRNG -- Our CPRNG using AES on CTR mode - {-# UNPACK #-} !Int -- How many IVs were generated with this - -- AESRNG. Used to control reseeding. - --- | Construct initial state of the CPRNG. -aesSeed :: IO AESState -aesSeed = do - rng <- makeSystem - return $! ASt rng 0 - --- | Reseed the CPRNG with new entropy from the system pool. -aesReseed :: IO () -aesReseed = do - let len :: Tagged AESRNG ByteLength - len = genSeedLength - ent <- getEntropy (untag len) - I.atomicModifyIORef aesRef $ - \(ASt rng _) -> - case reseed ent rng of - Right rng' -> (ASt rng' 0, ()) - Left _ -> (ASt rng 0, ()) - -- Use the old RNG, but force a reseed - -- after another 'threshold' uses of it. - -- In theory, we will never reach this - -- branch, but if we do, we're safe. - --- | 'IORef' that keeps the current state of the CPRNG. Yep, --- global state. Used in thread-safe was only, though. -aesRef :: I.IORef AESState -aesRef = unsafePerformIO $ aesSeed >>= I.newIORef -{-# NOINLINE aesRef #-} - --- | Construct a new 16-byte IV using our CPRNG. Forks another --- thread to reseed the CPRNG should its usage count reach a --- hardcoded threshold. -aesRNG :: IO IV -aesRNG = do - (bs, count) <- - I.atomicModifyIORef aesRef $ \(ASt rng count) -> -#if MIN_VERSION_cprng_aes(0, 3, 2) - let (bs', rng') = genRandomBytes 16 rng -#else - let (bs', rng') = genRandomBytes rng 16 -#endif - in (ASt rng' (succ count), (bs', count)) - when (count == threshold) $ void $ forkIO aesReseed - either (error . show) return $ decode bs - where - void f = f >> return () - --- | How many IVs should be generated before reseeding the CPRNG. --- This number depends basically on how paranoid you are. We --- think 100.000 is a good compromise: larger numbers give only a --- small performance advantage, while it still is a small number --- since we only generate 1.5 MiB of random data between reseeds. -threshold :: Int -threshold = 100000 +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +--------------------------------------------------------- +-- +-- | +-- +-- Module : Web.ClientSession +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Stores session data in a client cookie. In order to do so, +-- we: +-- +-- * Encrypt the cookie data using AES in CTR mode. This allows +-- you to store sensitive information on the client side without +-- worrying about eavesdropping. +-- +-- * Authenticate the encrypted cookie data using +-- Skein-MAC-512-256. Besides detecting potential errors in +-- storage or transmission of the cookies (integrity), the MAC +-- also avoids malicious modifications of the cookie data by +-- assuring you that the cookie data really was generated by this +-- server (authenticity). +-- +-- * Encode everything using Base64. Thus we avoid problems with +-- non-printable characters by giving the browser a simple +-- string. +-- +-- Simple usage of the library involves just calling +-- 'getDefaultKey' on the startup of your server, 'encryptIO' +-- when serializing cookies and 'decrypt' when parsing then back. +-- +--------------------------------------------------------- +module Web.ClientSession + ( -- * Automatic key generation + Key + , IV + , randomIV + , mkIV + , getKey + , defaultKeyFile + , getDefaultKey + , initKey + , randomKey + -- * Actual encryption/decryption + , encrypt + , encryptIO + , decrypt + ) where + +-- from base +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO) +import Control.Monad (guard, when) +import Data.Function (on) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.IORef as I + +-- from directory +import System.Directory (doesFileExist) + +-- from bytestring +import qualified Data.ByteString as S +import qualified Data.ByteString.Base64 as B + +-- from cereal +import Data.Serialize (encode, Serialize (put, get), getBytes, putByteString) + +-- from tagged +import Data.Tagged (Tagged, untag) + +-- from crypto-api +import Crypto.Classes (constTimeEq) +import Crypto.Random (genSeedLength, reseed) +import Crypto.Types (ByteLength) + +-- from cipher-aes +import qualified Crypto.Cipher.AES as A + +-- from skein +import Crypto.Skein (skeinMAC', Skein_512_256) + +-- from entropy +import System.Entropy (getEntropy) + +-- from cprng-aes +import Crypto.Random.AESCtr (AESRNG, makeSystem, genRandomBytes) + + +-- | The keys used to store the cookies. We have an AES key used +-- to encrypt the cookie and a Skein-MAC-512-256 key used verify +-- the authencity and integrity of the cookie. The AES key needs +-- to have exactly 32 bytes (256 bits) while Skein-MAC-512-256 +-- should have 64 bytes (512 bits). +-- +-- See also 'getDefaultKey' and 'initKey'. +data Key = Key { aesKey :: !A.Key + -- ^ AES key with 32 bytes. + , macKey :: !(S.ByteString -> Skein_512_256) + -- ^ Skein-MAC key. Instead of storing the key + -- data, we store a partially applied function + -- for calculating the MAC (see 'skeinMAC''). + , keyRaw :: !S.ByteString + } + +instance Eq Key where + Key _ _ r1 == Key _ _ r2 = r1 == r2 + +instance Serialize Key where + put = putByteString . keyRaw + get = either error id . initKey <$> getBytes 96 + +-- | Dummy 'Show' instance. +instance Show Key where + show _ = "" + +-- | The initialization vector used by AES. Should be exactly 16 +-- bytes long. +newtype IV = IV A.IV + +unsafeMkIV :: S.ByteString -> IV +unsafeMkIV bs = (IV (A.IV bs)) + +unIV :: IV -> S.ByteString +unIV (IV (A.IV bs)) = bs + +instance Eq IV where + (==) = (==) `on` unIV + (/=) = (/=) `on` unIV + +instance Ord IV where + compare = compare `on` unIV + (<=) = (<=) `on` unIV + (<) = (<) `on` unIV + (>=) = (>=) `on` unIV + (>) = (>) `on` unIV + +instance Show IV where + show = show . unIV + +instance Serialize IV where + put = put . unIV + get = unsafeMkIV <$> get + +-- | Construct an initialization vector from a 'S.ByteString'. +-- Fails if there isn't exactly 16 bytes. +mkIV :: S.ByteString -> Maybe IV +mkIV bs | S.length bs == 16 = Just (unsafeMkIV bs) + | otherwise = Nothing + +-- | Randomly construct a fresh initialization vector. You +-- /should not/ reuse initialization vectors. +randomIV :: IO IV +randomIV = aesRNG + +-- | The default key file. +defaultKeyFile :: FilePath +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 or is corrupted 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' + +-- | Generate a random 'Key'. Besides the 'Key', the +-- 'ByteString' passed to 'initKey' is returned so that it can be +-- saved for later use. +randomKey :: IO (S.ByteString, Key) +randomKey = do + bs <- getEntropy 96 + case initKey bs of + Left e -> error $ "Web.ClientSession.randomKey: never here, " ++ e + Right key -> return (bs, key) + +-- | Initializes a 'Key' from a random 'S.ByteString'. Fails if +-- there isn't exactly 96 bytes (256 bits for AES and 512 bits +-- for Skein-MAC-512-512). +initKey :: S.ByteString -> Either String Key +initKey bs | S.length bs /= 96 = Left $ "Web.ClientSession.initKey: length of " ++ + show (S.length bs) ++ " /= 96." +initKey bs = Right $ Key { aesKey = A.initKey preAesKey + , macKey = skeinMAC' preMacKey + , keyRaw = bs + } + where + (preMacKey, preAesKey) = S.splitAt 64 bs + +-- | Same as 'encrypt', however randomly generates the +-- initialization vector for you. +encryptIO :: Key -> S.ByteString -> IO S.ByteString +encryptIO key x = do + iv <- randomIV + return $ encrypt key iv x + +-- | Encrypt (AES-CTR), authenticate (Skein-MAC-512-256) and +-- encode (Base64) the given cookie data. The returned byte +-- string is ready to be used in a response header. +encrypt :: Key -- ^ Key of the server. + -> IV -- ^ New, random initialization vector (see 'randomIV'). + -> S.ByteString -- ^ Serialized cookie data. + -> S.ByteString -- ^ Encoded cookie data to be given to + -- the client browser. +encrypt key (IV (A.IV iv)) x = B.encode final + where + encrypted = A.encryptCTR (aesKey key) (A.IV iv) x + toBeAuthed = iv `S.append` encrypted + auth = macKey key toBeAuthed + final = encode auth `S.append` toBeAuthed + +-- | Decode (Base64), verify the integrity and authenticity +-- (Skein-MAC-512-256) and decrypt (AES-CTR) the given encoded +-- cookie data. Returns the original serialized cookie data. +-- Fails if the data is corrupted. +decrypt :: Key -- ^ Key of the server. + -> S.ByteString -- ^ Encoded cookie data given by the browser. + -> Maybe S.ByteString -- ^ Serialized cookie data. +decrypt key dataBS64 = do + dataBS <- either (const Nothing) Just $ B.decode dataBS64 + guard (S.length dataBS >= 48) -- 16 bytes of IV + 32 bytes of Skein-MAC-512-256 + let (auth, toBeAuthed) = S.splitAt 32 dataBS + auth' = macKey key toBeAuthed + guard (encode auth' `constTimeEq` auth) + let (iv, encrypted) = S.splitAt 16 toBeAuthed + return $! A.decryptCTR (aesKey key) (A.IV iv) encrypted + + +-- Significantly more efficient random IV generation. Initial +-- benchmarks placed it at 6.06 us versus 1.69 ms for +-- Crypto.Modes.getIVIO, since it does not require /dev/urandom +-- I/O for every call. + +data AESState = + ASt {-# UNPACK #-} !AESRNG -- Our CPRNG using AES on CTR mode + {-# UNPACK #-} !Int -- How many IVs were generated with this + -- AESRNG. Used to control reseeding. + +-- | Construct initial state of the CPRNG. +aesSeed :: IO AESState +aesSeed = do + rng <- makeSystem + return $! ASt rng 0 + +-- | Reseed the CPRNG with new entropy from the system pool. +aesReseed :: IO () +aesReseed = do + let len :: Tagged AESRNG ByteLength + len = genSeedLength + ent <- getEntropy (untag len) + I.atomicModifyIORef aesRef $ + \(ASt rng _) -> + case reseed ent rng of + Right rng' -> (ASt rng' 0, ()) + Left _ -> (ASt rng 0, ()) + -- Use the old RNG, but force a reseed + -- after another 'threshold' uses of it. + -- In theory, we will never reach this + -- branch, but if we do, we're safe. + +-- | 'IORef' that keeps the current state of the CPRNG. Yep, +-- global state. Used in thread-safe was only, though. +aesRef :: I.IORef AESState +aesRef = unsafePerformIO $ aesSeed >>= I.newIORef +{-# NOINLINE aesRef #-} + +-- | Construct a new 16-byte IV using our CPRNG. Forks another +-- thread to reseed the CPRNG should its usage count reach a +-- hardcoded threshold. +aesRNG :: IO IV +aesRNG = do + (bs, count) <- + I.atomicModifyIORef aesRef $ \(ASt rng count) -> +#if MIN_VERSION_cprng_aes(0, 3, 2) + let (bs', rng') = genRandomBytes 16 rng +#else + let (bs', rng') = genRandomBytes rng 16 +#endif + in (ASt rng' (succ count), (bs', count)) + when (count == threshold) $ void $ forkIO aesReseed + return $! unsafeMkIV bs + where + void f = f >> return () + +-- | How many IVs should be generated before reseeding the CPRNG. +-- This number depends basically on how paranoid you are. We +-- think 100.000 is a good compromise: larger numbers give only a +-- small performance advantage, while it still is a small number +-- since we only generate 1.5 MiB of random data between reseeds. +threshold :: Int +threshold = 100000 diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -1,95 +1,95 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -import Test.HUnit (assertBool) -import Test.Hspec -import Test.QuickCheck -import Control.Monad (replicateM) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 - -import Web.ClientSession -import System.IO.Unsafe - -import qualified Data.Set as Set -import Control.Monad.Trans.State.Strict (evalStateT, get, put) -import Control.Monad.Trans.Class (lift) -import Control.Monad (replicateM_) - -import Data.Serialize (encode, decode) - -main :: IO () -main = hspec $ describe "client session" $ do - it "encrypt/decrypt success" $ property propEncDec - it "encrypt/decrypt failure" $ property propEncDecFailure - it "AES encrypt/decrypt success" $ property propAES - it "AES encryption changes bs" $ property propAESChanges - it "specific values" caseSpecific - it "randomIV is really random" caseRandomIV - it "serialize instance" $ property propSerialize - -propEncDec :: S.ByteString -> Bool -propEncDec bs = unsafePerformIO $ do - key <- getDefaultKey - s <- encryptIO key bs - let bs' = decrypt key s - return $ Just bs == bs' - -propEncDecFailure :: S.ByteString -> Bool -propEncDecFailure bs = unsafePerformIO $ do - key <- getDefaultKey - s <- encryptIO key bs - let bs' = decrypt key $ (S.head s + 1) `S.cons` S.drop 1 s - return $ Just bs /= bs' - -propAES :: MyKey -> MyIV -> S.ByteString -> Bool -propAES (MyKey key) (MyIV iv) bs = decrypt key (encrypt key iv bs) == Just bs - -propAESChanges :: MyKey -> MyIV -> S.ByteString -> Bool -propAESChanges (MyKey key) (MyIV iv) bs = encrypt key iv bs /= bs - -caseSpecific :: Expectation -caseSpecific = do - let s = S8.pack $ show [("lo\ENQ\143XAq","\DC2\207\226\DC1;.z56|\203\222"),("\USnu#\139\ETXB\201 ","l"),("\RS\b,zM2U\184\191F)\EOT\220S\NUL","O\\\GSd\247\246\n\EOT\SYN\182U2G"),("\219\NAK\217\CAN\252","ym\STX\188\232?\\\145"),("\239k","\vRZP\a\DC2F>"),("\FS\180P &\RS\174zSL\\?@","p\170\237vZ|\GS>\SYNk\176n\r"),("","\199D\DC3\200m)"),("6\152tVhB\246)9","\ENQdfU\SUB"),("I\ACK\181\NUL","\129\&6s\130q\US)oR1\197\FSp\US\SYN0"),("\183\200<\250","\211 \131g4\207N\155"),("\248O6k\CANK\135\234.","`\205!+&Z&9\DLE\244\214HP\SI\161"),("\"I'\ACK\149 \CAN\197","\141N\201\SO\204\\o.\128\148")] - key <- getDefaultKey - iv <- randomIV - decrypt key (encrypt key iv s) `shouldBe` Just s - let s' = S.concat $ replicate 500 s - decrypt key (encrypt key iv s') `shouldBe` Just s' - -caseRandomIV :: Expectation -caseRandomIV = do - evalStateT (replicateM_ 10000 go) Set.empty - where - go = do - val <- lift randomIV - set <- get - lift $ assertBool "No duplicated keys" (not $ val `Set.member` set) - put $ Set.insert val set - -propSerialize :: MyKey -> Bool -propSerialize (MyKey key) = Right key == decode (encode key) - -instance Arbitrary S.ByteString where - arbitrary = S.pack `fmap` arbitrary - -newtype MyKey = MyKey Key - -instance Arbitrary MyKey where - arbitrary = do - ws <- replicateM 96 arbitrary - either error (return . MyKey) $ initKey $ S.pack ws - -instance Show MyKey where - show (MyKey key) = "MyKey:" ++ show (encode key) - -newtype MyIV = MyIV IV - -instance Arbitrary MyIV where - arbitrary = do - ws <- replicateM 16 arbitrary - maybe (error "Invalid IV") (return . MyIV) $ mkIV $ S.pack ws - -instance Show MyIV where - show _ = "" +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +import Test.HUnit (assertBool) +import Test.Hspec +import Test.QuickCheck +import Control.Monad (replicateM) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 + +import Web.ClientSession +import System.IO.Unsafe + +import qualified Data.Set as Set +import Control.Monad.Trans.State.Strict (evalStateT, get, put) +import Control.Monad.Trans.Class (lift) +import Control.Monad (replicateM_) + +import Data.Serialize (encode, decode) + +main :: IO () +main = hspec $ describe "client session" $ do + it "encrypt/decrypt success" $ property propEncDec + it "encrypt/decrypt failure" $ property propEncDecFailure + it "AES encrypt/decrypt success" $ property propAES + it "AES encryption changes bs" $ property propAESChanges + it "specific values" caseSpecific + it "randomIV is really random" caseRandomIV + it "serialize instance" $ property propSerialize + +propEncDec :: S.ByteString -> Bool +propEncDec bs = unsafePerformIO $ do + key <- getDefaultKey + s <- encryptIO key bs + let bs' = decrypt key s + return $ Just bs == bs' + +propEncDecFailure :: S.ByteString -> Bool +propEncDecFailure bs = unsafePerformIO $ do + key <- getDefaultKey + s <- encryptIO key bs + let bs' = decrypt key $ (S.head s + 1) `S.cons` S.drop 1 s + return $ Just bs /= bs' + +propAES :: MyKey -> MyIV -> S.ByteString -> Bool +propAES (MyKey key) (MyIV iv) bs = decrypt key (encrypt key iv bs) == Just bs + +propAESChanges :: MyKey -> MyIV -> S.ByteString -> Bool +propAESChanges (MyKey key) (MyIV iv) bs = encrypt key iv bs /= bs + +caseSpecific :: Expectation +caseSpecific = do + let s = S8.pack $ show [("lo\ENQ\143XAq","\DC2\207\226\DC1;.z56|\203\222"),("\USnu#\139\ETXB\201 ","l"),("\RS\b,zM2U\184\191F)\EOT\220S\NUL","O\\\GSd\247\246\n\EOT\SYN\182U2G"),("\219\NAK\217\CAN\252","ym\STX\188\232?\\\145"),("\239k","\vRZP\a\DC2F>"),("\FS\180P &\RS\174zSL\\?@","p\170\237vZ|\GS>\SYNk\176n\r"),("","\199D\DC3\200m)"),("6\152tVhB\246)9","\ENQdfU\SUB"),("I\ACK\181\NUL","\129\&6s\130q\US)oR1\197\FSp\US\SYN0"),("\183\200<\250","\211 \131g4\207N\155"),("\248O6k\CANK\135\234.","`\205!+&Z&9\DLE\244\214HP\SI\161"),("\"I'\ACK\149 \CAN\197","\141N\201\SO\204\\o.\128\148")] + key <- getDefaultKey + iv <- randomIV + decrypt key (encrypt key iv s) `shouldBe` Just s + let s' = S.concat $ replicate 500 s + decrypt key (encrypt key iv s') `shouldBe` Just s' + +caseRandomIV :: Expectation +caseRandomIV = do + evalStateT (replicateM_ 10000 go) Set.empty + where + go = do + val <- lift randomIV + set <- get + lift $ assertBool "No duplicated keys" (not $ val `Set.member` set) + put $ Set.insert val set + +propSerialize :: MyKey -> Bool +propSerialize (MyKey key) = Right key == decode (encode key) + +instance Arbitrary S.ByteString where + arbitrary = S.pack `fmap` arbitrary + +newtype MyKey = MyKey Key + +instance Arbitrary MyKey where + arbitrary = do + ws <- replicateM 96 arbitrary + either error (return . MyKey) $ initKey $ S.pack ws + +instance Show MyKey where + show (MyKey key) = "MyKey:" ++ show (encode key) + +newtype MyIV = MyIV IV + +instance Arbitrary MyIV where + arbitrary = do + ws <- replicateM 16 arbitrary + maybe (error "Invalid IV") (return . MyIV) $ mkIV $ S.pack ws + +instance Show MyIV where + show _ = ""