wai-cryptocookie 0.2 → 0.3
raw patch · 10 files changed
+336/−441 lines, 10 filesdep +case-insensitivedep +wai-csrfdep −binarydep −randomdep −stm
Dependencies added: case-insensitive, wai-csrf
Dependencies removed: binary, random, stm
Files
- CHANGELOG.md +7/−0
- README.md +0/−10
- lib/Wai/CryptoCookie.hs +220/−93
- lib/Wai/CryptoCookie/Encoding.hs +0/−36
- lib/Wai/CryptoCookie/Encryption.hs +27/−7
- lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs +12/−9
- lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs +14/−11
- lib/Wai/CryptoCookie/Middleware.hs +0/−205
- test/Main.hs +49/−60
- wai-cryptocookie.cabal +7/−10
CHANGELOG.md view
@@ -1,3 +1,10 @@+# Version 0.3++* BREAKING CHANGE: Pretty much everything is the library was changed, in+ order for the library to become a bit lower level, and to support+ CSRF protection.++ # Version 0.2 * BREAKING CHANGE: The type of `set` changed so that `set cc Nothing` is
README.md view
@@ -6,13 +6,3 @@ * Licensing terms in `LICENSE` file (`Apache-2.0`). ---## Development--1. Clone this repo and run `nix develop` in the top-level folder.--2. Within that environment, you can use `cabal` as usual.--3. If you don't have `nix` installed, then have `nix` installed.-
lib/Wai/CryptoCookie.hs view
@@ -1,123 +1,250 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoFieldSelectors #-}+ -- | This module exports tools for safely storing encrypted data on client-side--- cookies through "Network.Wai".------ This module is designed to be imported as follows:------ @--- import qualified "Wai.CryptoCookie"--- @------ Use 'middleware' to obtain a function to allow an 'Wai.Application' to--- interact with a 'CryptoCookie' using 'get', 'set', 'delete' and 'keep'.------ == Do I store session data on the client or on the server?------ It's not so much about /where/ to store the session data, but about /how/ to--- store it and /how/ to expire it. Here are some ideas. But please, do your--- own research.------ 1. __Data on server, identifier on both__: In this approach, all the data is--- stored on the server. On the 'CryptoCookie', simply 'set' a unique session--- identifier and later 'get' it back and use it to find the associated session--- data on your server-side database. In order to expire the session, all the--- server have to do is remove this session identifier from its database.--- /Choose this option unless you know what you are doing,/--- /it doesn't require you to plan ahead too much./------ 2. __Data on the client, identifier on both__: In this approach, all the--- data and session identifier is stored on the 'CryptoCookie'. On your--- server-side database, store the session identifier and a timestamp--- representing its creation time or last session activity time.--- Before accepting the session data from the 'CryptoCookie' as valid, check--- that the session identifier exists in your database, and that the time since--- the timestamp is acceptable. This approach is simpler on your server-side--- database, but it can lead to more network traffic, and schema migrations for--- session data will be complex if you care about backwards compatibility--- with currently active sessions.------ 3. __Everything on the client__: You can store everything in the--- 'CryptoCookie'. However, you will be more suceptible to /replay attacks/--- because you won't have control over session expiration beyond comparing the--- current time against the session creation timestamp or last activity--- timestamp previously set in the session data. You can force all the--- existing sessions to “expire” by rotating your encryption 'Key'. Also, this--- approach can lead to more network traffic, and schema migrations for session--- data will be complex if you care about backwards compatibility with--- currently active sessions.+-- cookies through "Network.Wai". Consider using it in conjunction with "Wai.CSRF". module Wai.CryptoCookie- ( -- * Cookie data- CryptoCookie- , get- , set- , delete- , keep+ ( -- * Config+ defaultConfig+ , Config (..)+ , Env+ , newEnv - -- * Middleware+ -- * Request and responses , middleware- , defaultConfig- , Config (..)+ , msgFromRequestCookie+ , setCookie+ , expireCookie++ -- * Encryption+ , Encryption (..) , autoKeyFileBase16 , readKeyFileBase16- )-where+ , readKeyFile+ , writeKeyFile+ ) where +import Control.Monad.IO.Class import Data.Aeson qualified as Ae-import Web.Cookie (SetCookie (..), defaultSetCookie, sameSiteLax)--import Wai.CryptoCookie.Encoding+import Data.ByteArray.Encoding qualified as BA+import Data.ByteArray.Sized qualified as BAS+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as BL+import Data.IORef+import Data.Kind (Type)+import Data.Time.Clock.POSIX qualified as Time+import Network.Wai qualified as Wai+import Wai.CSRF qualified import Wai.CryptoCookie.Encryption import Wai.CryptoCookie.Encryption.AEAD_AES_128_GCM_SIV () import Wai.CryptoCookie.Encryption.AEAD_AES_256_GCM_SIV ()-import Wai.CryptoCookie.Middleware+import Web.Cookie qualified as WC -- | Default 'Config': ----- * 'Encoding' is 'aeson'.------ * 'Encryption' scheme is the nonce-misuse resistant @AEAD_AES_256_GCM_SIV@--- as defined in in <https://tools.ietf.org/html/rfc8452 RFC 8452>.------ As an AEAD encryption scheme, you can be confident that a successfully--- decrypted cookie could only have been encrypted by the same--- 'Key'. This makes this encryption scheme suitable for--- storing user session authentication identifiers generated by the server.--- -- * Cookie name is @SESSION@. ----- * @HttpOnly@: yes+-- * Encoding and decoding of @msg@ is done through 'Ae.ToJSON' and+-- 'Ae.FromJSON'. ----- * @Max-Age@: 16 hours+-- * The 'Encryption' scheme is the nonce-misuse resistant @AEAD_AES_256_GCM_SIV@+-- as defined in in <https://tools.ietf.org/html/rfc8452 RFC 8452>, using+-- a "Wai.CSRF".'Wai.CSRF.Token' as AEAD associated data. ----- * @Path@: @\/@+-- As an AEAD encryption scheme, you can be confident that a successfully+-- decrypted cookie could only have been encrypted by the same+-- 'Key' known only to your server, and associated with a specific+-- "Wai.CSRF".'Wai.CSRF.Token', expected to have been sent with the+-- incoming request. ----- * @SameSite@: @Lax@+-- In principle, this makes this encryption scheme suitable for storing+-- server-generated user session data in the @msg@. However, you must make+-- sure that you rotate the "Wai.CSRF".'Wai.CSRF.Token' ocassionally, at+-- least each time a new user session is established, so as to avoid CSRF+-- risks. ----- * @Secure@: yes+-- * This 'defaultConfig' suggests you should be composing 'middleware' and+-- "Wai.CSRF".'Wai.CSRF.middleware' in this way: ----- * @Domain@: not set+-- @+-- "Wai.CSRF".'Wai.CSRF.middleware' /myCsrfConfig/+-- . "Wai.CryptoCookie".'middleware' /myCryptoCookieEnv/+-- :: ('Maybe' ("Wai.CSRF".'Wai.CSRF.Token', msg) -> 'Wai.Application')+-- -> 'Wai.Application'+-- @ defaultConfig- :: (Ae.FromJSON a, Ae.ToJSON a)+ :: (Ae.ToJSON msg, Ae.FromJSON msg) => Key "AEAD_AES_256_GCM_SIV" -- ^ Consider using 'autoKeyFileBase16' or -- 'readKeyFileBase16' for safely reading a 'Key' from a -- 'FilePath'. Alternatively, if you have the base-16 representation of the- -- 'Key' in JSON configuration, you coulud use+ -- 'Key' in JSON configuration, you could use -- 'Data.Aeson.FromJSON'.- -> Config a+ -> Config Wai.CSRF.Token msg defaultConfig key = Config- { key- , encoding = aeson- , setCookie =- defaultSetCookie- { setCookieDomain = Nothing- , setCookieExpires = Nothing- , setCookieHttpOnly = True- , setCookieMaxAge = Just (16 * 60 * 60)- , setCookieName = "SESSION"- , setCookiePath = Just "/"- , setCookieSameSite = Just sameSiteLax- , setCookieSecure = True- , setCookieValue = error "setCookieValue"- }+ { cookieName = "SESSION"+ , key+ , aadEncode = \(Wai.CSRF.Token t) ->+ BL.fromStrict $ BAS.unSizedByteArray t+ , msgEncode = Ae.encode+ , msgDecode = Ae.decode }++-- | Configuration for 'Env'.+--+-- Consider using 'defaultConfig' and updating desired fields only.+data Config (aad :: Type) (msg :: Type) = forall e.+ (Encryption e) =>+ Config+ { cookieName :: B.ByteString+ -- ^ Consider using a @\"SESSION\"@.+ , key :: Key e+ -- ^ Consider using a @'Key' \"AEAD_AES_256_GCM_SIV\"@.+ , aadEncode :: aad -> BL.ByteString+ -- ^ These are the exact bytes that will be used as AEAD associated data.+ -- Consider using the raw bytes of a "Wai.CSRF".'Wai.CSRF.Token'.+ , msgEncode :: msg -> BL.ByteString+ -- ^ These are the exact bytes that will be encrypted.+ , msgDecode :: BL.ByteString -> Maybe msg+ -- ^ Undo what @msgEncode@ did, if possible.+ }++-- | Stateful encryption environment for interacting with the encrypted cookie.+--+-- It is safe to use 'Env' concurrently if necessary. Concurrency is handled+-- safely internally.+--+-- Obtain with 'newEnv'.+data Env (aad :: Type) (msg :: Type) = Env+ { cookieName :: B.ByteString+ , encodeEncrypt :: aad -> msg -> IO BL.ByteString+ , decryptDecode :: aad -> BL.ByteString -> Maybe msg+ }++--------------------------------------------------------------------------------++-- | Obtain a new 'Env'.+newEnv :: (MonadIO m) => Config aad msg -> m (Env aad msg)+newEnv c@Config{key} = liftIO do+ let dc = initDecrypt key+ ecRef <- newIORef =<< initEncrypt key+ pure+ Env+ { encodeEncrypt = \aad0 msg0 -> do+ let !aad1 :: BL.ByteString = c.aadEncode aad0+ !msg1 :: BL.ByteString = c.msgEncode msg0+ ec <- atomicModifyIORef' ecRef \ec -> (advance ec, ec)+ pure $ encrypt ec aad1 msg1+ , decryptDecode = \aad0 !cry -> do+ let !aad1 = c.aadEncode aad0+ case decrypt dc aad1 cry of+ Right msg -> c.msgDecode msg+ _ -> Nothing+ , cookieName = c.cookieName+ }++-- | Transform an 'Wai.Application' so that if there is an encrypted+-- message in the incoming 'Wai.Request' cookies, it will be automatically+-- decrypted and made available to the underlying 'Wai.Application'.+--+-- The @aad@ is the AEAD associated data that came with the 'Wai.Request'.+-- Consider using 'middleware' in conjunction with+-- "Wai.CSRF".'Wai.CSRF.middleware', using "Wai.CSRF".'Wai.CSRF.Token' as+-- @aad@.+middleware+ :: Env aad msg+ -- ^ Encryption environment. Obtain with 'newEnv'.+ -> (Maybe (aad, Maybe msg) -> Wai.Application)+ -- ^ Underlying 'Wai.Application' having access to the decrypted cookie+ -- @msg@, if any.+ --+ -- Also, seeing as @msg@ being available implies @aad@ is available too, we+ -- output both values together in a manner that represents this relationship.+ -> Maybe aad+ -- ^ AEAD associated data of the incomming 'Wai.Request', if any.+ -> Wai.Application+middleware env fapp yaad req respond = do+ let ymsg = msgFromRequestCookie env req =<< yaad+ fapp (fmap (,ymsg) yaad) req respond++-- | Obtain the @msg@ from the 'Wai.Request' cookies.+--+-- You don't need to use this if you are using 'middleware'.+msgFromRequestCookie :: Env aad msg -> Wai.Request -> aad -> Maybe msg+msgFromRequestCookie env r aad = do+ [d64] <- pure $ lookupMany env.cookieName $ requestCookies r+ case BA.convertFromBase BA.Base64URLUnpadded d64 of+ Right cry -> env.decryptDecode aad $ BL.fromStrict cry+ Left _ -> Nothing++--------------------------------------------------------------------------------++-- | Construct a 'C.SetCookie' containing the encrypted @msg@.+--+-- The associated data @aad@ will not be included in this cookie, but it will+-- be taken into account for encryption and necessary for eventual decryption.+--+-- The 'C.SetCookie' has these settings, some of which could be overriden.+--+-- * Cookie name is 'Config'\'s @cookieName@.+--+-- * @HttpOnly@: Yes, and you shouldn't change this.+--+-- * @Max-Age@ and @Expires@: This cookie never expires. We recommend+-- relying on server-side expiration instead, as the lifetime of the+-- cookie could easily be extended by a legitimate but malicious client.+-- You can store a creation or expiration timestamp inside @msg@, and+-- make a decision based on that.+--+-- * @Path@: @\/@+--+-- * @SameSite@: @Lax@.+--+-- * @Secure@: Yes.+--+-- * @Domain@: Not set.+--+-- Note: If you are using "Wai.CSRF".'Wai.CSRF.Token' as @aad@, it is+-- recommended that you generate a new "Wai.CSRF".'Wai.CSRF.Token' at least+-- each time a new user session is established, but possibly more frequently,+-- and send it alongside this one (see "Wai.CSRF".'Wai.CSRF.setCookie').+setCookie :: (MonadIO m) => Env aad msg -> aad -> msg -> m WC.SetCookie+setCookie env aad msg = liftIO do+ cry <- env.encodeEncrypt aad msg+ pure $+ (expireCookie env)+ { WC.setCookieExpires = Nothing+ , WC.setCookieMaxAge = Nothing+ , WC.setCookieValue =+ BA.convertToBase BA.Base64URLUnpadded $ BL.toStrict cry+ }++-- | Construct a 'C.SetCookie' expiring the cookie named 'Config'\'s+-- @cookieName@.+expireCookie :: Env aad msg -> WC.SetCookie+expireCookie env =+ WC.defaultSetCookie+ { WC.setCookieDomain = Nothing+ , WC.setCookieExpires = Just (Time.posixSecondsToUTCTime 0)+ , WC.setCookieHttpOnly = True+ , WC.setCookieMaxAge = Just (negate 1)+ , WC.setCookieName = env.cookieName+ , WC.setCookiePath = Just "/"+ , WC.setCookieSameSite = Just WC.sameSiteLax+ , WC.setCookieSecure = True+ , WC.setCookieValue = ""+ }++--------------------------------------------------------------------------------++requestCookies :: Wai.Request -> [(B.ByteString, B.ByteString)]+requestCookies r =+ WC.parseCookies =<< lookupMany "Cookie" (Wai.requestHeaders r)++lookupMany :: (Eq k) => k -> [(k, v)] -> [v]+lookupMany k = findMany (== k)++findMany :: (Eq k) => (k -> Bool) -> [(k, v)] -> [v]+findMany f = map snd . filter (\(a, _) -> f a)
− lib/Wai/CryptoCookie/Encoding.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE StrictData #-}-{-# LANGUAGE NoFieldSelectors #-}---- | You will need to import this module if you are planning to define--- or use a 'Encoding' other than the defaults provided by this library.-module Wai.CryptoCookie.Encoding- ( Encoding (..)- , aeson- , binary- ) where--import Data.Aeson qualified as Ae-import Data.Binary qualified as Bin-import Data.ByteString.Lazy qualified as BL-import Data.Kind (Type)---- | How to encode and decode a value of type @a@ into a 'BL.ByteString'.-data Encoding (a :: Type) = Encoding- { encode :: a -> BL.ByteString- , decode :: BL.ByteString -> Maybe a- }---- | Encode and decode use 'Bin.Binary' from the @binary@ library.-binary :: (Bin.Binary a) => Encoding a-binary =- Encoding- { encode = Bin.encode- , decode = \bl -> case Bin.decodeOrFail bl of- Right (_, _, a) -> Just a- Left _ -> Nothing- }---- | Encode and decode use 'Ae.ToJSON' and 'Ae.FromJSON' from--- the @aeson@ library.-aeson :: (Ae.FromJSON a, Ae.ToJSON a) => Encoding a-aeson = Encoding{encode = Ae.encode, decode = Ae.decode}
lib/Wai/CryptoCookie/Encryption.hs view
@@ -29,7 +29,7 @@ import System.IO qualified as IO import System.IO.Error qualified as IO --- | Encryption method.+-- | AEAD encryption method. class (KnownNat (KeyLength e), Eq (Key e)) => Encryption (e :: k) where -- | Key used for encryption. You can obtain an initial random -- 'Key' using 'genKey'. As long as you have access to@@ -48,7 +48,7 @@ data Decrypt e :: Type -- | Generate a random encryption 'Key'.- genKey :: (C.MonadRandom m) => m (Key e)+ randomKey :: (C.MonadRandom m) => m (Key e) -- | Load a 'Key' from its bytes representation, if possible. keyFromBytes :: (BA.ByteArrayAccess raw) => raw -> Either String (Key e)@@ -56,7 +56,7 @@ -- | Dump the bytes representation of a 'Key'. keyToBytes :: (BAS.ByteArrayN (KeyLength e) raw) => Key e -> raw - -- | Generate initial 'Encrypt'ion and 'Decrypt'ion context for a 'Key'.+ -- | Generate initial 'Encrypt'ion context for a 'Key'. -- -- The 'Encrypt'ion context could carry for example the next -- __randomly generated nonce__ to use for 'encrypt'ion, the 'Key'@@ -65,8 +65,14 @@ -- -- The 'Decrypt'ion context could carry for example the 'Key' itself or its -- derivative used during the 'decrypt'ion process.- initial :: (C.MonadRandom m) => Key e -> m (Encrypt e, Decrypt e)+ initEncrypt :: (C.MonadRandom m) => Key e -> m (Encrypt e) + -- | Generate initial 'Decrypt'ion context for a 'Key'.+ --+ -- The 'Decrypt'ion context could carry for example the 'Key' itself or its+ -- derivative used during the 'decrypt'ion process.+ initDecrypt :: Key e -> Decrypt e+ -- | After each 'encrypt'ion, the 'Encrypt'ion context will be automatically -- 'advance'd through this function. For example, if your 'Encrypt'ion -- context carries a nonce or a deterministic random number generator,@@ -74,12 +80,26 @@ advance :: Encrypt e -> Encrypt e -- | Encrypt a plaintext message according to the 'Encrypt'ion context.- encrypt :: Encrypt e -> BL.ByteString -> BL.ByteString+ encrypt+ :: Encrypt e+ -> BL.ByteString+ -- ^ AEAD associated data.+ -> BL.ByteString+ -- ^ Message to encrypt.+ -> BL.ByteString+ -- ^ Encrypted message including AEAD tag and nonce. -- | Decrypt a message according to the 'Decrypt'ion context. -- -- The 'String' is for internal debugging purposes only.- decrypt :: Decrypt e -> BL.ByteString -> Either String BL.ByteString+ decrypt+ :: Decrypt e+ -> BL.ByteString+ -- ^ AEAD associated data.+ -> BL.ByteString+ -- ^ Encrypted message including AEAD tag and nonce.+ -> Either String BL.ByteString+ -- ^ Decrypted message or error message. -- | If the 'FilePath' exists, then read the base-16 representation of -- a 'Key' from it. Ignores trailing newlines.@@ -98,7 +118,7 @@ (guard . IO.isDoesNotExistError) (readKeyFileBase16 path) \_ -> do- k0 <- genKey+ k0 <- randomKey writeKeyFile (BA.convertToBase BA.Base16) path k0 k1 <- readKeyFileBase16 path when (k0 /= k1) $ fail "autoKeyFile: no roundtrip"
lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs view
@@ -27,24 +27,27 @@ = Encrypt CAES.AES128 C.ChaChaDRG CAGS.Nonce newtype Decrypt "AEAD_AES_128_GCM_SIV" = Decrypt CAES.AES128- genKey = fmap (Key . BAS.unsafeSizedByteArray) (C.getRandomBytes 16)+ randomKey = fmap (Key . BAS.unsafeSizedByteArray) (C.getRandomBytes 16) keyFromBytes = maybe (Left "Bad length") (Right . Key) . BAS.fromByteArrayAccess keyToBytes (Key key) = BAS.convert key- initial (Key key0) = do+ initEncrypt (Key key0) = do drg0 <- C.drgNew let (nonce, drg1) = C.withDRG drg0 CAGS.generateNonce- aes = C.throwCryptoError $ CAES.cipherInit $ BAS.unSizedByteArray key0- pure (Encrypt aes drg1 nonce, Decrypt aes)+ !aes = C.throwCryptoError $ CAES.cipherInit $ BAS.unSizedByteArray key0+ pure $ Encrypt aes drg1 nonce+ initDecrypt (Key key0) =+ let !aes = C.throwCryptoError $ CAES.cipherInit $ BAS.unSizedByteArray key0+ in Decrypt aes advance (Encrypt aes drg0 _) = let (nonce, drg1) = C.withDRG drg0 CAGS.generateNonce in Encrypt aes drg1 nonce- encrypt (Encrypt aes _ nonce) plain =- let (tag, cry) = CAGS.encrypt aes nonce B.empty $ B.toStrict plain+ encrypt (Encrypt aes _ nonce) (BL.toStrict -> aad) (BL.toStrict -> plain) =+ let (tag, cry) = CAGS.encrypt aes nonce aad plain in BL.fromChunks [BA.convert nonce, BA.convert tag, cry]- decrypt = \(Decrypt aes) raw -> do- (nonce, tag, cry) <- fromResult $ BAP.parse p (B.toStrict raw)- case CAGS.decrypt aes nonce B.empty cry tag of+ decrypt (Decrypt aes) (BL.toStrict -> aad) (BL.toStrict -> raw) = do+ (nonce, tag, cry) <- fromResult $ BAP.parse p raw+ case CAGS.decrypt aes nonce aad cry tag of Just x -> pure $ BL.fromStrict x Nothing -> Left "Can't decrypt" where
lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs view
@@ -27,24 +27,27 @@ = Encrypt CAES.AES256 C.ChaChaDRG CAGS.Nonce newtype Decrypt "AEAD_AES_256_GCM_SIV" = Decrypt CAES.AES256- genKey = fmap (Key . BAS.unsafeSizedByteArray) (C.getRandomBytes 32)+ randomKey = fmap (Key . BAS.unsafeSizedByteArray) (C.getRandomBytes 32) keyFromBytes = maybe (Left "Bad length") (Right . Key) . BAS.fromByteArrayAccess keyToBytes (Key key) = BAS.convert key- initial (Key key0) = do+ initEncrypt (Key key0) = do drg0 <- C.drgNew let (nonce, drg1) = C.withDRG drg0 CAGS.generateNonce- aes = C.throwCryptoError $ CAES.cipherInit $ BAS.unSizedByteArray key0- pure (Encrypt aes drg1 nonce, Decrypt aes)+ !aes = C.throwCryptoError $ CAES.cipherInit $ BAS.unSizedByteArray key0+ pure $ Encrypt aes drg1 nonce+ initDecrypt (Key key0) =+ let !aes = C.throwCryptoError $ CAES.cipherInit $ BAS.unSizedByteArray key0+ in Decrypt aes advance (Encrypt aes drg0 _) = let (nonce, drg1) = C.withDRG drg0 CAGS.generateNonce in Encrypt aes drg1 nonce- encrypt (Encrypt aes _ nonce) plain =- let (tag, cry) = CAGS.encrypt aes nonce B.empty $ B.toStrict plain+ encrypt (Encrypt aes _ nonce) (BL.toStrict -> aad) (BL.toStrict -> msg) =+ let (tag, cry) = CAGS.encrypt aes nonce aad msg in BL.fromChunks [BA.convert nonce, BA.convert tag, cry]- decrypt = \(Decrypt aes) raw -> do- (nonce, tag, cry) <- fromResult $ BAP.parse p (B.toStrict raw)- case CAGS.decrypt aes nonce B.empty cry tag of+ decrypt (Decrypt aes) (BL.toStrict -> aad) (BL.toStrict -> raw) = do+ (nonce, tag, cry) <- fromResult $ BAP.parse p raw+ case CAGS.decrypt aes nonce aad cry tag of Just x -> pure $ BL.fromStrict x Nothing -> Left "Can't decrypt" where@@ -55,10 +58,10 @@ cry <- BAP.takeAll pure (nonce, tag, cry) -fromResult :: BAP.Result B.ByteString a -> Either String a+fromResult :: (BA.ByteArrayAccess bin) => BAP.Result bin a -> Either String a fromResult = \case BAP.ParseOK rest a- | B.null rest -> Right a+ | BA.null rest -> Right a | otherwise -> Left "Leftovers" BAP.ParseMore f -> fromResult (f Nothing) BAP.ParseFail e -> Left e
− lib/Wai/CryptoCookie/Middleware.hs
@@ -1,205 +0,0 @@-{-# LANGUAGE StrictData #-}-{-# LANGUAGE NoFieldSelectors #-}--module Wai.CryptoCookie.Middleware- ( Config (..)- , CryptoCookie- , get- , set- , delete- , keep- , middleware- ) where--import Control.Concurrent.STM-import Control.Monad.IO.Class-import Data.ByteArray.Encoding qualified as BA-import Data.ByteString qualified as B-import Data.ByteString.Lazy qualified as BL-import Data.IORef-import Data.Kind (Type)-import Data.List (find)-import Data.Time.Clock.POSIX qualified as Time-import Network.Wai qualified as Wai-import Web.Cookie- ( SetCookie (..)- , parseCookies- , parseSetCookie- , renderSetCookieBS- )--import Wai.CryptoCookie.Encoding (Encoding (..))-import Wai.CryptoCookie.Encryption (Encryption (..))---- | Configuration for 'middleware'.------ Consider using 'Wai.CryptoCookie.defaultConfig' and--- updating desired fields only.-data Config (a :: Type) = forall e.- (Encryption e) =>- Config- { key :: Key e- , encoding :: Encoding a- , setCookie :: SetCookie- }--data Env (a :: Type) = Env- { encrypt :: BL.ByteString -> IO BL.ByteString- , decrypt :: BL.ByteString -> Maybe BL.ByteString- , encoding :: Encoding a- , setCookie :: SetCookie- }--encodeEncrypt :: Env a -> a -> IO B.ByteString-encodeEncrypt env a = do- cryl <- env.encrypt $! env.encoding.encode a- pure $ BA.convertToBase BA.Base64URLUnpadded $ BL.toStrict cryl--decryptDecode :: Env a -> B.ByteString -> Maybe a-decryptDecode env cry64 = do- cry <- either (const Nothing) Just do- BA.convertFromBase BA.Base64URLUnpadded cry64- env.encoding.decode =<< env.decrypt (B.fromStrict cry)--newEnv :: Config a -> IO (Env a)-newEnv Config{key, encoding, setCookie} = do- (!ec0, !dc) <- initial key- ecRef <- newIORef ec0- pure- Env- { encrypt = \raw -> do- ec <- atomicModifyIORef' ecRef \ec -> (advance ec, ec)- pure $ encrypt ec raw- , decrypt = either (const Nothing) Just . decrypt dc- , encoding- , setCookie- }---- | Read-write access to the "Wai.CryptoCookie" data.------ See 'get', 'set', 'delete', 'keep'.-data CryptoCookie a = CryptoCookie ~(Maybe a) (TVar (Maybe (Maybe a)))---- | The data that came through the 'Wai.Request' cookie, if any.-get :: CryptoCookie a -> Maybe a-get (CryptoCookie x _) = x---- | Cause the eventual 'Wai.Response' corresponding to the current--- 'Wai.Request' to __set the cookie to the specified value__.------ Overrides previous uses of 'set', 'delete', and 'keep'.-set :: CryptoCookie a -> a -> STM ()-set (CryptoCookie _ x) = writeTVar x . Just . Just---- | Cause the eventual 'Wai.Response' corresponding to the current--- 'Wai.Request' to __delete the cookie__ by setting its expiration to--- a date in the past.------ Overrides previous uses of 'set', 'delete', and 'keep'.-delete :: CryptoCookie a -> STM ()-delete (CryptoCookie _ x) = writeTVar x $ Just Nothing---- | Cause the eventual 'Wai.Response' corresponding to the current--- 'Wai.Request' to __keep the cookie as it is in the client__.------ This is different than 'set'ting the cookie value to the value that came--- with the incoming 'Wai.Request', because doing that could potentially--- re-write a cookie that was deleted by the client after they sent the--- 'Wai.Request' but before we send the 'Wai.Response'.------ Doing nothing with a 'CryptoCookie' in your 'Wai.Application' is analogous--- to using 'keep' just before returning the 'Wai.Response'.------ Overrides previous uses of 'set', 'delete', and 'keep'.-keep :: CryptoCookie a -> STM ()-keep (CryptoCookie _ x) = writeTVar x Nothing---- | Obtain a new 'Wai.Application'-transforming function (more or less a--- 'Wai.Middleware') wherein the 'Wai.Application' being transformed can interact--- with a 'CryptoCookie'.------ It is safe to reuse a same 'Key', as well as 'middleware', as well as the--- function returned by 'middleware', even concurrently. The library takes care--- of randomly and atomically 'initial'izing or 'advance'ing 'Encrypt'ion--- contexts as necessary.------ If you plan to use 'middleware' more than once, which you would do if you--- want to have two independently `CryptoCookies`, just make sure each `Config`--- uses a different `setCookieName`.-middleware- :: forall a m- . (MonadIO m)- => Config a- -- ^ Consider using 'Wai.CryptoCookie.defaultConfig'.- -> m ((CryptoCookie a -> Wai.Application) -> Wai.Application)- -- ^ Remember that 'Wai.Middleware' is a type-synonym for- -- @'Wai.Application' -> 'Wai.Application'@. This type is not too different- -- from that.-middleware c = liftIO do- env <- newEnv c- pure \fapp -> \req respond -> do- tv <- newTVarIO (Nothing :: Maybe (Maybe a))- fapp (CryptoCookie (getRequestCookieData env req) tv) req \res -> do- yya1 <- readTVarIO tv- let f = case yya1 of- Nothing -> pure- Just Nothing -> expireResponseCookieData env- Just (Just a1) -> setResponseCookieData env a1- respond =<< f res---- | Find, decrypt and decode the cookie value from the 'Wai.Request'.------ 'Nothing' if the unique cookie couldn't be found--- or couldn't be decrypted. 'Left' if the 'Encoding' failed.-getRequestCookieData :: Env a -> Wai.Request -> Maybe a-getRequestCookieData env r = do- let cookieName = setCookieName env.setCookie- [cry] <- pure $ lookupMany cookieName $ requestCookies r- decryptDecode env cry---- | Adds the @Set-Cookie@ header to the 'Wai.Response'.-setResponseCookieData :: Env a -> a -> Wai.Response -> IO Wai.Response-setResponseCookieData env a = \res ->- case find predicate (responseCookies res) of- Nothing -> do- cry <- encodeEncrypt env a- let hval = renderSetCookieBS $ env.setCookie{setCookieValue = cry}- pure $ Wai.mapResponseHeaders (("Set-Cookie", hval) :) res- _ -> fail $ "Duplicate cookie name: " <> show cookieName- where- cookieName = setCookieName env.setCookie- predicate = \x -> setCookieName x == cookieName---- | Adds the @Set-Cookie@ header to the 'Wai.Response'.-expireResponseCookieData :: Env a -> Wai.Response -> IO Wai.Response-expireResponseCookieData env = \res ->- case find predicate (responseCookies res) of- Nothing -> pure $ Wai.mapResponseHeaders (("Set-Cookie", hval) :) res- _ -> fail $ "Duplicate cookie name: " <> show cookieName- where- cookieName = setCookieName env.setCookie- predicate = \x -> setCookieName x == cookieName- hval =- renderSetCookieBS $- env.setCookie- { setCookieValue = mempty- , setCookieExpires = Just (Time.posixSecondsToUTCTime 0)- , setCookieMaxAge = Just (negate 1)- }------------------------------------------------------------------------------------requestCookies :: Wai.Request -> [(B.ByteString, B.ByteString)]-requestCookies r = parseCookies =<< lookupMany "Cookie" (Wai.requestHeaders r)--responseCookies :: Wai.Response -> [SetCookie]-responseCookies =- fmap parseSetCookie . lookupMany "Set-Cookie" . Wai.responseHeaders------------------------------------------------------------------------------------lookupMany :: (Eq k) => k -> [(k, v)] -> [v]-lookupMany k = findMany (== k)--findMany :: (Eq k) => (k -> Bool) -> [(k, v)] -> [v]-findMany f = map snd . filter (\(a, _) -> f a)
test/Main.hs view
@@ -2,10 +2,11 @@ module Main (main) where -import Control.Concurrent.STM import Control.Exception qualified as Ex import Control.Monad import Control.Monad.IO.Class+import Data.ByteString qualified as B+import Data.Maybe import Data.String import Network.HTTP.Types qualified as HT import Network.Wai qualified as W@@ -13,10 +14,9 @@ import System.Directory import System.FilePath import System.IO.Error (isAlreadyExistsError)-import System.Random qualified as R+import Web.Cookie qualified as WC import Wai.CryptoCookie qualified as WCC-import Wai.CryptoCookie.Encryption qualified as WCC main :: IO () main = withTmpDir \tmp -> do@@ -27,58 +27,62 @@ k1c <- WCC.readKeyFileBase16 @"AEAD_AES_256_GCM_SIV" k1path when (k1a /= k1c) $ fail "k1a /= k1c" testEncryption @"AEAD_AES_256_GCM_SIV" k1a- testEncryption @"AEAD_AES_256_GCM_SIV" =<< WCC.genKey- testEncryption @"AEAD_AES_128_GCM_SIV" =<< WCC.genKey- testCookies @"AEAD_AES_256_GCM_SIV" =<< WCC.genKey- testCookies @"AEAD_AES_128_GCM_SIV" =<< WCC.genKey+ testEncryption @"AEAD_AES_256_GCM_SIV" =<< WCC.randomKey+ testEncryption @"AEAD_AES_128_GCM_SIV" =<< WCC.randomKey+ testCookies @"AEAD_AES_256_GCM_SIV" =<< WCC.randomKey+ testCookies @"AEAD_AES_128_GCM_SIV" =<< WCC.randomKey putStrLn "TESTS OK" testEncryption :: (WCC.Encryption e) => WCC.Key e -> IO () testEncryption key = do e0a <- do- (s0, de) <- WCC.initial key+ s0 <- WCC.initEncrypt key+ let de = WCC.initDecrypt key either fail pure do let r0 = ""- let e0 = WCC.encrypt s0 r0+ let e0 = WCC.encrypt s0 "a" r0 when (r0 == e0) $ Left "e0"- r0' <- WCC.decrypt de e0+ r0' <- WCC.decrypt de "a" e0 when (r0 /= r0') $ Left "r0'" let s1 = WCC.advance s0- let e0' = WCC.encrypt s1 r0+ let e0' = WCC.encrypt s1 "b" r0 when (e0 == e0') $ Left "e0'"- r0'' <- WCC.decrypt de e0'+ r0'' <- WCC.decrypt de "b" e0' when (r0 /= r0'') $ Left "r0''" let r1 = "hello" let s2 = WCC.advance s1- let e1 = WCC.encrypt s2 r1+ let e1 = WCC.encrypt s2 "" r1 when (r1 == e1) $ Left "e1"- r1' <- WCC.decrypt de e1+ r1' <- WCC.decrypt de "" e1 when (r1 /= r1') $ Left "r1'" let s3 = WCC.advance s2- let e1' = WCC.encrypt s3 r1+ let e1' = WCC.encrypt s3 "boo" r1 when (e1 == e1') $ Left "e1'"- r1'' <- WCC.decrypt de e1'+ r1'' <- WCC.decrypt de "boo" e1' when (r1 /= r1'') $ Left "r1''" pure e0 e0b <- do- (s0, de) <- WCC.initial key+ s0 <- WCC.initEncrypt key+ let de = WCC.initDecrypt key either fail pure do let r0 = ""- let e0 = WCC.encrypt s0 r0+ let e0 = WCC.encrypt s0 "aa" r0 pure e0 when (e0a == e0b) $ fail "e0b" testCookies :: (WCC.Encryption e) => WCC.Key e -> IO () testCookies k = do- c1 <- do- c <- fmap WCC.defaultConfig WCC.genKey- pure c{WCC.key = k}- fmw1 <- WCC.middleware c1+ env :: WCC.Env () Word <- do+ c0 <- WCC.defaultConfig <$> WCC.randomKey+ WCC.newEnv c0{WCC.key = k, WCC.aadEncode = \() -> "hello"} + let fapp1 :: (Maybe Word -> Maybe (Maybe Word)) -> W.Application+ fapp1 = \g -> WCC.middleware env (app1 env g . join . fmap snd) (Just ())+ -- keeping cookies untouched- WT.withSession (fmw1 $ app \_ -> Nothing) do+ WT.withSession (fapp1 \_ -> Nothing) do WT.assertNoClientCookieExists "t0-a" "SESSION" sres1 <- WT.request WT.defaultRequest WT.assertBody "Nothing" sres1@@ -88,7 +92,7 @@ WT.assertNoClientCookieExists "t0-c" "SESSION" -- explicitly deleting cookie- WT.withSession (fmw1 $ app \_ -> Just Nothing) do+ WT.withSession (fapp1 \_ -> Just Nothing) do WT.assertNoClientCookieExists "t1-a" "SESSION" sres1 <- WT.request WT.defaultRequest WT.assertBody "Nothing" sres1@@ -98,7 +102,7 @@ WT.assertClientCookieExists "t1-c" "SESSION" -- explicitely setting cookie- ck0 <- WT.withSession (fmw1 $ app \_ -> Just (Just 900)) do+ ck0 <- WT.withSession (fapp1 \_ -> Just (Just 900)) do WT.assertNoClientCookieExists "t2-a" "SESSION" sres1 <- WT.request WT.defaultRequest WT.assertBody "Nothing" sres1@@ -109,7 +113,7 @@ WT.getClientCookies -- modify and explicitly delete- WT.withSession (fmw1 $ app \_ -> Just Nothing) do+ WT.withSession (fapp1 \_ -> Just Nothing) do WT.assertNoClientCookieExists "t3-a" "SESSION" WT.modifyClientCookies \_ -> ck0 WT.assertClientCookieExists "t3-b" "SESSION"@@ -122,7 +126,7 @@ WT.assertClientCookieValue "t3-e" "SESSION" "" -- set/modify- WT.withSession (fmw1 $ app (Just . fmap (+ 1))) do+ WT.withSession (fapp1 (Just . fmap (+ 1))) do WT.assertNoClientCookieExists "t4-a" "SESSION" sres1 <- WT.request WT.defaultRequest WT.assertBody "Nothing" sres1@@ -136,44 +140,29 @@ WT.assertBody "Just 901" sres2 WT.assertClientCookieExists "t4-c" "SESSION" - -- We make sure that no matter how many interactions with- -- cc we have, we always keep the last. See app2.- WT.withSession (fmw1 app2) do- WT.assertNoClientCookieExists "t5-a" "SESSION"- sres1 <- WT.request WT.defaultRequest- WT.assertBody "Nothing" sres1- replicateM_ 1000 do- WT.assertClientCookieExists "t5-b" "SESSION"- sres1 <- WT.request WT.defaultRequest- WT.assertBody "Just 2" sres1--app- :: (Maybe Word -> Maybe (Maybe Word))- -> WCC.CryptoCookie Word+app1+ :: WCC.Env () Word+ -> (Maybe Word -> Maybe (Maybe Word))+ -> Maybe Word -> W.Application-app g cc = \req res -> do- let yold = WCC.get cc- case g yold of- Nothing -> pure ()- Just Nothing -> atomically $ WCC.delete cc- Just (Just new) -> atomically $ WCC.set cc new- res $ W.responseLBS HT.status200 [] $ fromString $ show yold--app2 :: WCC.CryptoCookie Word -> W.Application-app2 cc = \req res -> do- n <- R.randomRIO (0, 10)- xs <- replicateM n $ R.randomRIO ('a', 'c')- forM_ xs \case- 'a' -> atomically $ WCC.set cc 1- 'b' -> atomically $ WCC.delete cc- _ -> atomically $ WCC.keep cc- atomically $ WCC.set cc 2- res $ W.responseLBS HT.status200 [] $ fromString $ show $ WCC.get cc+app1 env g yold = \req respond -> do+ ysc :: Maybe WC.SetCookie <- case g yold of+ Nothing -> pure Nothing+ Just Nothing -> pure $ Just $ WCC.expireCookie env+ Just (Just new) -> Just <$> WCC.setCookie env () new+ respond+ $ W.responseLBS+ HT.status200+ ( fmap+ (\sc -> ("Set-Cookie", WC.renderSetCookieBS sc))+ (maybeToList ysc)+ )+ $ fromString (show yold) withTmpDir :: (FilePath -> IO a) -> IO a withTmpDir f = do tmp0 <- getTemporaryDirectory- Ex.bracket (acq tmp0 0) (\_ -> pure () {-removeDirectoryRecursive-}) f+ Ex.bracket (acq tmp0 0) (removeDirectoryRecursive) f where acq :: FilePath -> Word -> IO FilePath acq prefix !n = do
wai-cryptocookie.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: wai-cryptocookie-version: 0.2+version: 0.3 license: Apache-2.0 license-file: LICENSE extra-source-files: README.md CHANGELOG.md@@ -24,6 +24,7 @@ DerivingStrategies DuplicateRecordFields LambdaCase+ MultiWayIf OverloadedRecordDot OverloadedStrings TypeFamilies@@ -36,24 +37,22 @@ hs-source-dirs: lib exposed-modules: Wai.CryptoCookie- Wai.CryptoCookie.Encoding- Wai.CryptoCookie.Encryption other-modules:+ Wai.CryptoCookie.Encryption Wai.CryptoCookie.Encryption.AEAD_AES_128_GCM_SIV Wai.CryptoCookie.Encryption.AEAD_AES_256_GCM_SIV- Wai.CryptoCookie.Middleware build-depends: aeson,- binary, bytestring,+ case-insensitive, cookie, crypton, http-types, memory,- stm, text, time, wai,+ wai-csrf, test-suite test import: basic@@ -62,14 +61,12 @@ main-is: Main.hs ghc-options: -threaded -with-rtsopts=-N build-depends:- aeson,- binary,+ bytestring,+ cookie, directory, filepath, http-types, wai, wai-cryptocookie, wai-extra,- random,- stm,