diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. - diff --git a/lib/Wai/CryptoCookie.hs b/lib/Wai/CryptoCookie.hs --- a/lib/Wai/CryptoCookie.hs +++ b/lib/Wai/CryptoCookie.hs @@ -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 . --- --- 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 , 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) diff --git a/lib/Wai/CryptoCookie/Encoding.hs b/lib/Wai/CryptoCookie/Encoding.hs deleted file mode 100644 --- a/lib/Wai/CryptoCookie/Encoding.hs +++ /dev/null @@ -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} diff --git a/lib/Wai/CryptoCookie/Encryption.hs b/lib/Wai/CryptoCookie/Encryption.hs --- a/lib/Wai/CryptoCookie/Encryption.hs +++ b/lib/Wai/CryptoCookie/Encryption.hs @@ -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" diff --git a/lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs b/lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs --- a/lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs +++ b/lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs @@ -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 diff --git a/lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs b/lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs --- a/lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs +++ b/lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs @@ -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 diff --git a/lib/Wai/CryptoCookie/Middleware.hs b/lib/Wai/CryptoCookie/Middleware.hs deleted file mode 100644 --- a/lib/Wai/CryptoCookie/Middleware.hs +++ /dev/null @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/wai-cryptocookie.cabal b/wai-cryptocookie.cabal --- a/wai-cryptocookie.cabal +++ b/wai-cryptocookie.cabal @@ -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,