diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,13 @@ +# ChangeLog for clientsession + +## 0.9.3.0 + +* Migrate to crypton from cryptonite. + +## 0.9.2.0 + +* Migrate crypto-aes and cprng-aes to cryptonite. [#36](https://github.com/yesodweb/clientsession/pull/36) + +## 0.9.1.2 + +* Clarify that we're using MIT license diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,25 +1,20 @@ -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: +Copyright (c) 2008 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: -* 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. +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. -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 SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +## clientsession + +Securely store session data in a client-side cookie. + +Achieves security through AES-CTR encryption and Skein-MAC-512-256 +authentication. Uses Base64 encoding to avoid any issues with characters. diff --git a/bin/generate.hs b/bin/generate.hs new file mode 100644 --- /dev/null +++ b/bin/generate.hs @@ -0,0 +1,9 @@ +module Main where + +import Data.Maybe (fromMaybe, listToMaybe) +import Control.Monad (void) +import System.Environment (getArgs) +import Web.ClientSession (randomKeyEnv) + +main :: IO () +main = void $ randomKeyEnv . fromMaybe "SESSION_KEY" . listToMaybe =<< getArgs diff --git a/clientsession.cabal b/clientsession.cabal --- a/clientsession.cabal +++ b/clientsession.cabal @@ -1,6 +1,6 @@ name: clientsession -version: 0.7.5 -license: BSD3 +version: 0.9.3.0 +license: MIT license-file: LICENSE author: Michael Snoyman , Felipe Lessa maintainer: Michael Snoyman @@ -10,42 +10,54 @@ encoding to avoid any issues with characters. category: Web stability: stable -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Simple homepage: http://github.com/yesodweb/clientsession/tree/master -data-files: bench.hs -extra-source-files: tests/runtests.hs +extra-source-files: tests/runtests.hs bench.hs ChangeLog.md README.md flag test description: Build the executable to run unit tests default: False +executable clientsession-generate + default-language: Haskell2010 + main-is: generate.hs + build-depends: base + , clientsession + ghc-options: -Wall + hs-source-dirs: bin + library - build-depends: base >=4 && < 5 - , bytestring >= 0.9 && < 0.10 - , cereal >= 0.3 && < 0.4 - , directory >= 1 && < 1.2 + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + -- https://github.com/yesodweb/clientsession/commit/1221230770feff60f77ff676d52fc464cb77b2d9#r122087962 + -- Data.Bifunctor entered base in 4.8 + , bytestring >= 0.9 + , cereal >= 0.3 + , directory >= 1 , tagged >= 0.1 - , crypto-api >= 0.8 && < 0.11 - , cryptocipher >= 0.2.5 - , skein >= 0.1 && < 0.2 - , base64-bytestring >= 0.1.1.1 && < 0.2 + , crypto-api >= 0.8 + , skein == 1.0.* + , base64-bytestring >= 0.1.1.1 , entropy >= 0.2.1 - , cprng-aes >= 0.2 + , crypton >= 1.0 + , setenv exposed-modules: Web.ClientSession + other-modules: System.LookupEnv ghc-options: -Wall hs-source-dirs: src test-suite runtests + default-language: Haskell2010 type: exitcode-stdio-1.0 - build-depends: base >=4 && < 5 - , bytestring >= 0.9 && < 0.10 - , cryptocipher >= 0.2.5 - , hspec >= 0.6 && < 0.10 - , QuickCheck >= 2 && < 3 + build-depends: base + , bytestring >= 0.9 + , hspec >= 1.3 + , QuickCheck >= 2 , HUnit , transformers , containers + , cereal -- finally, our own package , clientsession ghc-options: -Wall @@ -54,4 +66,4 @@ source-repository head type: git - location: git://github.com/yesodweb/clientsession.git + location: https://github.com/yesodweb/clientsession.git diff --git a/src/System/LookupEnv.hs b/src/System/LookupEnv.hs new file mode 100644 --- /dev/null +++ b/src/System/LookupEnv.hs @@ -0,0 +1,6 @@ +module System.LookupEnv (lookupEnv) where + +import System.Environment (getEnvironment) + +lookupEnv :: String -> IO (Maybe String) +lookupEnv envVar = fmap (lookup envVar) $ getEnvironment diff --git a/src/Web/ClientSession.hs b/src/Web/ClientSession.hs --- a/src/Web/ClientSession.hs +++ b/src/Web/ClientSession.hs @@ -1,6 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} --------------------------------------------------------- -- -- | @@ -38,14 +41,17 @@ --------------------------------------------------------- module Web.ClientSession ( -- * Automatic key generation - Key(..) + Key , IV , randomIV , mkIV , getKey + , getKeyEnv , defaultKeyFile , getDefaultKey , initKey + , randomKey + , randomKeyEnv -- * Actual encryption/decryption , encrypt , encryptIO @@ -53,32 +59,47 @@ ) where -- from base +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO) import Control.Monad (guard, when) -import qualified Data.IORef as I +import Data.Bifunctor (first) +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 Control.Concurrent (forkIO) +import qualified Data.IORef as I -- from directory import System.Directory (doesFileExist) -- from bytestring import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Base64 as B -- from cereal -import Data.Serialize (encode, decode) +import Data.Serialize (encode, 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 +import Crypto.Classes (constTimeEq) --- from cryptocipher +-- from crypton import qualified Crypto.Cipher.AES as A +import Crypto.Cipher.Types(Cipher(..),BlockCipher(..),makeIV) +import Crypto.Error (eitherCryptoError) +import "crypton" Crypto.Random (ChaChaDRG,drgNew,randomBytesGenerate) -- from skein import Crypto.Skein (skeinMAC', Skein_512_256) @@ -86,43 +107,73 @@ -- 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). +-- the authencity and integrity of the cookie. The AES key must +-- have exactly 32 bytes (256 bits) while Skein-MAC-512-256 must +-- have 64 bytes (512 bits). -- -- See also 'getDefaultKey' and 'initKey'. -data Key = Key { aesKey :: A.AES256 +data Key = Key { aesKey :: + !A.AES256 -- ^ AES key with 32 bytes. - , macKey :: S.ByteString -> Skein_512_256 + , 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 +-- | The initialization vector used by AES. Must be exactly 16 -- bytes long. -type IV = Modes.IV A.AES256 +newtype IV = IV S.ByteString +unsafeMkIV :: S.ByteString -> IV +unsafeMkIV bs = (IV bs) + +unIV :: IV -> S.ByteString +unIV (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 = case (S.length bs, decode bs) of - (16, Right iv) -> Just iv - _ -> Nothing +mkIV bs | S.length bs == 16 = Just (unsafeMkIV bs) + | otherwise = Nothing -- | Randomly construct a fresh initialization vector. You --- /should not/ reuse initialization vectors. +-- /MUST NOT/ reuse initialization vectors. randomIV :: IO IV -randomIV = aesRNG +randomIV = chaChaRNG -- | The default key file. defaultKeyFile :: FilePath @@ -149,6 +200,22 @@ S.writeFile keyFile bs return key' +-- | Get the key from the named environment variable +-- +-- Assumes the value is a Base64-encoded string. If the variable is not set, a +-- random key will be generated, set in the environment, and the Base64-encoded +-- version printed on @/dev/stdout@. +getKeyEnv :: String -- ^ Name of the environment variable + -> IO Key -- ^ The actual key. +getKeyEnv envVar = do + mvalue <- lookupEnv envVar + case mvalue of + Just value -> either (const newKey) return $ initKey =<< decode value + Nothing -> newKey + where + decode = B.decode . C.pack + newKey = randomKeyEnv envVar + -- | Generate a random 'Key'. Besides the 'Key', the -- 'ByteString' passed to 'initKey' is returned so that it can be -- saved for later use. @@ -159,18 +226,42 @@ Left e -> error $ "Web.ClientSession.randomKey: never here, " ++ e Right key -> return (bs, key) +-- | Generate a random 'Key', set a Base64-encoded version of it in the given +-- environment variable, then return it. Also prints the generated string to +-- @/dev/stdout@. +randomKeyEnv :: String -> IO Key +randomKeyEnv envVar = do + (bs, key) <- randomKey + let encoded = C.unpack $ B.encode bs + setEnv envVar encoded + putStrLn $ envVar ++ "=" ++ encoded + return 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). +-- +-- Note that the input string is assumed to be uniformly chosen +-- from the set of all 96-byte strings. In other words, each +-- byte should be chosen from the set of all byte values (0-255) +-- with the same probability. +-- +-- In particular, this function does not do any kind of key +-- stretching. You should never feed it a password, for example. +-- +-- It's /highly/ recommended to feed @initKey@ only with values +-- generated by 'randomKey', unless you really know what you're +-- doing. 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 } - where - (preMacKey, preAesKey) = S.splitAt 64 bs +initKey bs = do + let (preMacKey, preAesKey) = S.splitAt 64 bs + aesKey <- first show $ eitherCryptoError (cipherInit preAesKey) + Right $ Key { aesKey + , macKey = skeinMAC' preMacKey + , keyRaw = bs + } -- | Same as 'encrypt', however randomly generates the -- initialization vector for you. @@ -187,12 +278,14 @@ -> 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 +encrypt key (IV b) x = case makeIV b of + Nothing -> error "Web.ClientSession.encrypt: Failed to makeIV" + Just iv -> B.encode final + where + encrypted = ctrCombine (aesKey key) iv x + toBeAuthed = b `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 @@ -207,59 +300,55 @@ 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 + let (iv, encrypted) = S.splitAt 16 toBeAuthed + iv' <- makeIV iv + return $! ctrCombine (aesKey key) iv' encrypted + +-- [from when the code used cprng-aes.AESRNG] -- 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. +-- 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. +-- [now with crypton.ChaChaDRG] +-- I haven't run any benchmark; this conversion is a case of “code +-- that doesn't crash trumps performance.” +data ChaChaState = + CCSt {-# UNPACK #-} !ChaChaDRG -- Our CPRNG using ChaCha + {-# UNPACK #-} !Int -- How many IVs were generated with this + -- CPRNG. Used to control reseeding. + -- | Construct initial state of the CPRNG. -aesSeed :: IO AESState -aesSeed = do - rng <- makeSystem - return $! ASt rng 0 +chaChaSeed :: IO ChaChaState +chaChaSeed = do + drg <- drgNew + return $! CCSt drg 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. +chaChaReseed :: IO () +chaChaReseed = do + drg' <- drgNew + I.writeIORef chaChaRef $ CCSt drg' 0 -- | '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 #-} +chaChaRef :: I.IORef ChaChaState +chaChaRef = unsafePerformIO $ chaChaSeed >>= I.newIORef +{-# NOINLINE chaChaRef #-} -- | 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 +chaChaRNG :: IO IV +chaChaRNG = do (bs, count) <- - I.atomicModifyIORef aesRef $ \(ASt rng count) -> - let (bs', rng') = genRandomBytes rng 16 - in (ASt rng' (succ count), (bs', count)) - when (count == threshold) $ void $ forkIO aesReseed - either (error . show) return $ decode bs + I.atomicModifyIORef chaChaRef $ \(CCSt drg count) -> + let (bs', drg') = randomBytesGenerate 16 drg + in (CCSt drg' (succ count), (bs', count)) + when (count == threshold) $ void $ forkIO chaChaReseed + return $! unsafeMkIV bs where void f = f >> return () diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -1,11 +1,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -import Test.HUnit -import Test.Hspec.Monadic -import Test.QuickCheck hiding (property) -import Test.Hspec.QuickCheck -import Test.Hspec.HUnit () +import Test.HUnit (assertBool) +import Test.Hspec +import Test.QuickCheck import Control.Monad (replicateM) import qualified Data.ByteString as S @@ -19,14 +17,18 @@ import Control.Monad.Trans.Class (lift) import Control.Monad (replicateM_) +import Data.Serialize (encode, decode) + main :: IO () -main = hspecX $ describe "client session" $ do +main = hspec $ describe "client session" $ do it "encrypt/decrypt success" $ property propEncDec + it "encrypt/decrypt success (environment key)" $ property propEncDecEnv 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 @@ -35,6 +37,13 @@ let bs' = decrypt key s return $ Just bs == bs' +propEncDecEnv :: S.ByteString -> Bool +propEncDecEnv bs = unsafePerformIO $ do + key <- getKeyEnv "SESSION_KEY" + s <- encryptIO key bs + let bs' = decrypt key s + return $ Just bs == bs' + propEncDecFailure :: S.ByteString -> Bool propEncDecFailure bs = unsafePerformIO $ do key <- getDefaultKey @@ -48,16 +57,16 @@ propAESChanges :: MyKey -> MyIV -> S.ByteString -> Bool propAESChanges (MyKey key) (MyIV iv) bs = encrypt key iv bs /= bs -caseSpecific :: Assertion +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 - Just s @=? decrypt key (encrypt key iv s) + decrypt key (encrypt key iv s) `shouldBe` Just s let s' = S.concat $ replicate 500 s - Just s' @=? decrypt key (encrypt key iv s') + decrypt key (encrypt key iv s') `shouldBe` Just s' -caseRandomIV :: Assertion +caseRandomIV :: Expectation caseRandomIV = do evalStateT (replicateM_ 10000 go) Set.empty where @@ -67,6 +76,9 @@ 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 @@ -78,7 +90,7 @@ either error (return . MyKey) $ initKey $ S.pack ws instance Show MyKey where - show _ = "" + show (MyKey key) = "MyKey:" ++ show (encode key) newtype MyIV = MyIV IV