wai-cryptocookie (empty) → 0.0.1
raw patch · 11 files changed
+1116/−0 lines, 11 filesdep +aesondep +basedep +binary
Dependencies added: aeson, base, binary, bytestring, cookie, crypton, directory, filepath, http-types, memory, stm, text, time, vault, wai, wai-cryptocookie, wai-extra
Files
- CHANGELOG.md +3/−0
- LICENSE +219/−0
- README.md +18/−0
- lib/Wai/CryptoCookie.hs +135/−0
- lib/Wai/CryptoCookie/Encoding.hs +36/−0
- lib/Wai/CryptoCookie/Encryption.hs +172/−0
- lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs +64/−0
- lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs +64/−0
- lib/Wai/CryptoCookie/Middleware.hs +175/−0
- test/Main.hs +155/−0
- wai-cryptocookie.cabal +75/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Version 0.0.1++* Initial version.
+ LICENSE view
@@ -0,0 +1,219 @@+Copyright 2024, Renzo Carbonara.++Except where otherwise explicitly mentioned, all of contents of the+"wai-cryptocookie" project are licensed under the Apache License,+Version 2.0 (the "License"); you may not use this file except in+compliance with the License. You may obtain a copy of the License at the+end of this file or at http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+++-------------------------------------------------------------------------------+++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,18 @@+# wai-cryptocookie++Encrypted cookies for Haskell WAI++* Copyright © Renzo Carbonara, 2024.++* 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
@@ -0,0 +1,135 @@+-- | 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"+-- @+--+-- One example of how to obtain a new "Network.Wai".'Network.Wai.Middleware',+--+-- @+-- do (__middleware__, __lookup__) <- do+-- key <- "Wai.CryptoCookie".'autoKeyFileBase16' \"\/run\/my-cookie-encryption-key\"+-- "Wai.CryptoCookie".'middleware' ("Wai.CryptoCookie".'defaultConfig' key)+-- @+--+-- The obtained @__middleware__@ shall be applied to your+-- "Network.Wai".'Wai.Application'.+--+-- The obtained @__lookup__@ function can be used to obtain the 'CryptoCookie'+-- associated with each 'Wai.Request'. It returns 'Nothing' if this particular+-- @__middleware__@ was not used on the given 'Wai.Request'.+--+-- Finally, interact with the 'CryptoCookie' data using 'get' or 'set'.+--+-- == 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.+module Wai.CryptoCookie+ ( -- * Cookie data+ CryptoCookie+ , get+ , set++ -- * Middleware+ , middleware+ , defaultConfig+ , Config (..)+ , autoKeyFileBase16+ , readKeyFileBase16+ )+where++import Data.Aeson qualified as Ae+import Web.Cookie (SetCookie (..), defaultSetCookie, sameSiteLax)++import Wai.CryptoCookie.Encoding+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++-- | 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+--+-- * @Max-Age@: 16 hours+--+-- * @Path@: @\/@+--+-- * @SameSite@: @Lax@+--+-- * @Secure@: yes+--+-- * @Domain@: not set+defaultConfig+ :: (Ae.FromJSON a, Ae.ToJSON a)+ => 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+ -- 'Data.Aeson.FromJSON'.+ -> Config a+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"+ }+ }
+ lib/Wai/CryptoCookie/Encoding.hs view
@@ -0,0 +1,36 @@+{-# 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
@@ -0,0 +1,172 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | You will need to import this module if you are planning to define an+-- 'Encryption' scheme other than the defaults provided by this library.+module Wai.CryptoCookie.Encryption+ ( Encryption (..)+ , autoKeyFileBase16+ , readKeyFileBase16+ , readKeyFile+ , writeKeyFile+ ) where++import Control.Exception qualified as Ex+import Control.Monad+import Control.Monad.IO.Class+import Crypto.Random qualified as C+import Data.Aeson qualified as Ae+import Data.Bits+import Data.ByteArray qualified as BA+import Data.ByteArray.Encoding qualified as BA+import Data.ByteArray.Sized qualified as BAS+import Data.ByteString.Lazy qualified as BL+import Data.Char qualified as Char+import Data.Kind (Type)+import Data.Text.Encoding qualified as T+import Data.Word+import GHC.TypeNats+import System.IO qualified as IO+import System.IO.Error qualified as IO++-- | 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+ -- said 'Key', you will be able to decrypt data previously+ -- encrypted with it. For this reason, be sure to save and load the key+ -- using 'keyToBytes' and 'keyFromBytes'.+ data Key e :: Type++ -- | Statically known 'Key' length.+ type KeyLength e :: Natural++ -- | Encryption context used by 'encrypt'.+ data Encrypt e :: Type++ -- | Decryption context used by 'decrypt'.+ data Decrypt e :: Type++ -- | Generate a random encryption 'Key'.+ genKey :: (C.MonadRandom m) => m (Key e)++ -- | Load a 'Key' from its bytes representation, if possible.+ keyFromBytes :: (BA.ByteArrayAccess raw) => raw -> Either String (Key e)++ -- | 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'.+ --+ -- The 'Encrypt'ion context could carry for example the next nonce to use+ -- for 'encrypt'ion, the 'Key' itself or its derivative used during the+ -- actual 'encrypt'ion process, or a deterministic random number generator.+ --+ -- 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)++ -- | 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,+ -- this is the place to update them.+ advance :: Encrypt e -> Encrypt e++ -- | Encrypt a plaintext message according to the 'Encrypt'ion context.+ encrypt :: Encrypt e -> BL.ByteString -> BL.ByteString++ -- | 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++-- | If the 'FilePath' exists, then read the base-16 representation of+-- a 'Key' from it. Ignores trailing newlines.+--+-- Otherwise, generate a random new 'Key' and write its base-16 representation+-- in the 'FilePath'.+--+-- Finally, return the 'Key'.+autoKeyFileBase16+ :: forall e m+ . (Encryption e, MonadIO m)+ => FilePath+ -> m (Key e)+autoKeyFileBase16 path = liftIO do+ Ex.catchJust+ (guard . IO.isDoesNotExistError)+ (readKeyFileBase16 path)+ \_ -> do+ k0 <- genKey+ writeKeyFile (BA.convertToBase BA.Base16) path k0+ k1 <- readKeyFileBase16 path+ when (k0 /= k1) $ fail "autoKeyFile: no roundtrip"+ pure k1++-- | Read a base-16 encoded 'Key' from a file. Ignores trailing newlines.+readKeyFileBase16+ :: forall e m+ . (Encryption e, MonadIO m)+ => FilePath+ -> m (Key e)+readKeyFileBase16 = readKeyFile \a ->+ case BA.span (not . rn) a of+ (pre, pos)+ | BA.all rn pos -> BA.convertFromBase BA.Base16 pre+ | otherwise -> Left "invalid format"+ where+ _r :: Word8 = fromIntegral (Char.ord '\r')+ _n :: Word8 = fromIntegral (Char.ord '\n')+ rn :: Word8 -> Bool = \w -> w == _r || w == _n++-- | Read a 'Key' from a file.+readKeyFile+ :: forall e m+ . (Encryption e, MonadIO m)+ => (BA.ScrubbedBytes -> Either String BA.ScrubbedBytes)+ -- ^ Convert the raw content of the file into input suitable+ -- for 'keyFromBytes'.+ -> FilePath+ -> m (Key e)+readKeyFile g path = liftIO do+ IO.withFile path IO.ReadMode \h -> do+ flen :: Int <- do+ a <- IO.hFileSize h+ case toIntegralSized a of+ Just b | b > 0 -> pure b+ _ -> fail "readKeyFile: invalid key file size"+ (rlen, fraw) <- BA.allocRet flen \p -> IO.hGetBuf h p flen+ when (rlen /= flen) do+ -- This shouldn't happen, but we are being extra careful.+ fail "readKeyFile: could not read key file"+ case g fraw of+ Left e -> fail $ "readKeyFile: " <> e+ Right kraw -> case keyFromBytes kraw of+ Right key -> pure key+ Left err -> fail $ "readKeyFile: " <> err++-- | Save a key to a file.+writeKeyFile+ :: forall e m+ . (Encryption e, MonadIO m)+ => (BAS.SizedByteArray (KeyLength e) BA.ScrubbedBytes -> BA.ScrubbedBytes)+ -- ^ Convert the raw 'keyToBytes' bytes to file contents.+ -> FilePath+ -> Key e+ -> m ()+writeKeyFile g path key = liftIO do+ kout <- Ex.evaluate $ g $ keyToBytes key+ IO.withFile path IO.WriteMode \h ->+ BA.withByteArray kout \p ->+ IO.hPutBuf h p $ BA.length kout++-- | Base-16 encoded.+instance (Encryption e) => Ae.FromJSON (Key e) where+ parseJSON = Ae.withText "Key" \t ->+ -- Note that un-scrubbable bytes will continue to exist in @t@.+ case BA.convertFromBase BA.Base16 (T.encodeUtf8 t) of+ Right (kraw :: BA.ScrubbedBytes) ->+ case keyFromBytes kraw of+ Right key -> pure key+ Left err -> fail err+ _ -> fail "Invalid key"
+ lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Wai.CryptoCookie.Encryption.AEAD_AES_128_GCM_SIV () where++import Crypto.Cipher.AES qualified as CAES+import Crypto.Cipher.AESGCMSIV qualified as CAGS+import Crypto.Cipher.Types qualified as CAES+import Crypto.Error qualified as C+import Crypto.Random qualified as C+import Data.ByteArray qualified as BA+import Data.ByteArray.Parse qualified as BAP+import Data.ByteArray.Sized qualified as BAS+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as BL++import Wai.CryptoCookie.Encryption++-- | @AEAD_AES_128_GCM_SIV@ is a nonce-misuse resistant AEAD encryption scheme+-- defined in <https://tools.ietf.org/html/rfc8452 RFC 8452>.+instance Encryption "AEAD_AES_128_GCM_SIV" where+ newtype Key "AEAD_AES_128_GCM_SIV"+ = Key (BAS.SizedByteArray 16 BA.ScrubbedBytes)+ deriving newtype (Eq)+ type KeyLength "AEAD_AES_128_GCM_SIV" = 16+ data Encrypt "AEAD_AES_128_GCM_SIV"+ = 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)+ keyFromBytes =+ maybe (Left "Bad length") (Right . Key) . BAS.fromByteArrayAccess+ keyToBytes (Key key) = BAS.convert key+ initial (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)+ 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+ 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+ Just x -> pure $ BL.fromStrict x+ Nothing -> Left "Can't decrypt"+ where+ p :: BAP.Parser B.ByteString (CAGS.Nonce, CAES.AuthTag, B.ByteString)+ p = do+ C.CryptoPassed nonce <- CAGS.nonce <$> BAP.take 12+ tag <- CAES.AuthTag . BA.convert <$> BAP.take 16+ cry <- BAP.takeAll+ pure (nonce, tag, cry)++fromResult :: BAP.Result B.ByteString a -> Either String a+fromResult = \case+ BAP.ParseOK rest a+ | B.null rest -> Right a+ | otherwise -> Left "Leftovers"+ BAP.ParseMore f -> fromResult (f Nothing)+ BAP.ParseFail e -> Left e
+ lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Wai.CryptoCookie.Encryption.AEAD_AES_256_GCM_SIV () where++import Crypto.Cipher.AES qualified as CAES+import Crypto.Cipher.AESGCMSIV qualified as CAGS+import Crypto.Cipher.Types qualified as CAES+import Crypto.Error qualified as C+import Crypto.Random qualified as C+import Data.ByteArray qualified as BA+import Data.ByteArray.Parse qualified as BAP+import Data.ByteArray.Sized qualified as BAS+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as BL++import Wai.CryptoCookie.Encryption++-- | @AEAD_AES_256_GCM_SIV@ is a nonce-misuse resistant AEAD encryption scheme+-- defined in <https://tools.ietf.org/html/rfc8452 RFC 8452>.+instance Encryption "AEAD_AES_256_GCM_SIV" where+ newtype Key "AEAD_AES_256_GCM_SIV"+ = Key (BAS.SizedByteArray 32 BA.ScrubbedBytes)+ deriving newtype (Eq)+ type KeyLength "AEAD_AES_256_GCM_SIV" = 32+ data Encrypt "AEAD_AES_256_GCM_SIV"+ = 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)+ keyFromBytes =+ maybe (Left "Bad length") (Right . Key) . BAS.fromByteArrayAccess+ keyToBytes (Key key) = BAS.convert key+ initial (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)+ 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+ 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+ Just x -> pure $ BL.fromStrict x+ Nothing -> Left "Can't decrypt"+ where+ p :: BAP.Parser B.ByteString (CAGS.Nonce, CAES.AuthTag, B.ByteString)+ p = do+ C.CryptoPassed nonce <- CAGS.nonce <$> BAP.take 12+ tag <- CAES.AuthTag . BA.convert <$> BAP.take 16+ cry <- BAP.takeAll+ pure (nonce, tag, cry)++fromResult :: BAP.Result B.ByteString a -> Either String a+fromResult = \case+ BAP.ParseOK rest a+ | B.null rest -> Right a+ | otherwise -> Left "Leftovers"+ BAP.ParseMore f -> fromResult (f Nothing)+ BAP.ParseFail e -> Left e
+ lib/Wai/CryptoCookie/Middleware.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoFieldSelectors #-}++module Wai.CryptoCookie.Middleware+ ( Config (..)+ , CryptoCookie+ , get+ , set+ , 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 Data.Vault.Lazy qualified as V+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' and 'set'.+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 if 'Just', or expire+-- (/delete/) the cookie if 'Nothing'.+--+-- Overrides previous uses of 'set'.+set :: CryptoCookie a -> Maybe a -> STM ()+set (CryptoCookie _ x) = writeTVar x . Just++-- | Construct a new 'Middleware', and function that can be used to look-up the+-- 'CryptoCookie' on each incoming 'Wai.Request'. Said function returns+-- 'Nothing' if the 'Middleware' was not used on the 'Wai.Request'.+middleware+ :: forall a m+ . (MonadIO m)+ => Config a+ -- ^ Consider using 'Wai.CryptoCookie.defaultConfig'.+ -> m (Wai.Middleware, Wai.Request -> Maybe (CryptoCookie a))+middleware c = liftIO do+ env <- newEnv c+ vk :: V.Key (CryptoCookie a) <- V.newKey+ pure+ ( \app req respond -> do+ tv <- newTVarIO Nothing+ let ck = CryptoCookie (getRequestCookieData env req) tv+ app (req{Wai.vault = V.insert vk ck (Wai.vault 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+ , \req -> V.lookup vk (Wai.vault req)+ )++-- | 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
@@ -0,0 +1,155 @@+{-# LANGUAGE RecordWildCards #-}++module Main (main) where++import Control.Concurrent.STM+import Control.Exception qualified as Ex+import Control.Monad+import Control.Monad.IO.Class+import Data.String+import Network.HTTP.Types qualified as HT+import Network.Wai qualified as W+import Network.Wai.Test qualified as WT+import System.Directory+import System.FilePath+import System.IO.Error (isAlreadyExistsError)++import Wai.CryptoCookie qualified as WCC+import Wai.CryptoCookie.Encryption qualified as WCC++main :: IO ()+main = withTmpDir \tmp -> do+ let k1path = tmp </> "key1"+ k1a <- WCC.autoKeyFileBase16 @"AEAD_AES_256_GCM_SIV" k1path+ k1b <- WCC.autoKeyFileBase16 @"AEAD_AES_256_GCM_SIV" k1path+ when (k1a /= k1b) $ fail "k1a /= k1b"+ 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+ putStrLn "TESTS OK"++testEncryption :: (WCC.Encryption e) => WCC.Key e -> IO ()+testEncryption key = do+ e0a <- do+ (s0, de) <- WCC.initial key+ either fail pure do+ let r0 = ""+ let e0 = WCC.encrypt s0 r0+ when (r0 == e0) $ Left "e0"+ r0' <- WCC.decrypt de e0+ when (r0 /= r0') $ Left "r0'"+ let s1 = WCC.advance s0+ let e0' = WCC.encrypt s1 r0+ when (e0 == e0') $ Left "e0'"+ r0'' <- WCC.decrypt de e0'+ when (r0 /= r0'') $ Left "r0''"+ let r1 = "hello"+ let s2 = WCC.advance s1+ let e1 = WCC.encrypt s2 r1+ when (r1 == e1) $ Left "e1"+ r1' <- WCC.decrypt de e1+ when (r1 /= r1') $ Left "r1'"+ let s3 = WCC.advance s2+ let e1' = WCC.encrypt s3 r1+ when (e1 == e1') $ Left "e1'"+ r1'' <- WCC.decrypt de e1'+ when (r1 /= r1'') $ Left "r1''"+ pure e0++ e0b <- do+ (s0, de) <- WCC.initial key+ either fail pure do+ let r0 = ""+ let e0 = WCC.encrypt s0 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}+ (mw1, look1) <- WCC.middleware c1++ WT.withSession (app look1 id) do+ sres1 <- WT.request WT.defaultRequest+ WT.assertBody "Nothing" sres1+ WT.assertNoClientCookieExists "t1-a" "SESSION"++ WT.withSession (mw1 $ app look1 id) do+ sres1 <- WT.request WT.defaultRequest+ WT.assertBody "Just Nothing" sres1+ WT.assertNoClientCookieExists "t2-a" "SESSION"++ sres1 <- WT.request WT.defaultRequest+ WT.assertBody "Just Nothing" sres1+ WT.assertNoClientCookieExists "t2-b" "SESSION"++ ck0 <- WT.withSession (mw1 $ app look1 (\_ -> Just 900)) do+ sres1 <- WT.request WT.defaultRequest+ WT.assertBody "Just Nothing" sres1+ WT.assertClientCookieExists "t3-a" "SESSION"++ sres2 <- WT.request WT.defaultRequest+ WT.assertBody "Just (Just 900)" sres2+ WT.assertClientCookieExists "t3-b" "SESSION"++ WT.getClientCookies++ WT.withSession (mw1 $ app look1 (\_ -> Nothing)) do+ WT.modifyClientCookies \_ -> ck0++ sres1 <- WT.request WT.defaultRequest+ WT.assertBody "Just (Just 900)" sres1+ WT.assertClientCookieExists "t4-a" "SESSION"++ sres2 <- WT.request WT.defaultRequest+ WT.assertBody "Just Nothing" sres2+ WT.assertClientCookieExists "t4-b" "SESSION"+ WT.assertClientCookieValue "t4-c" "SESSION" ""++ WT.withSession (mw1 $ app look1 (fmap (+ 1))) do+ sres1 <- WT.request WT.defaultRequest+ WT.assertBody "Just Nothing" sres1+ WT.assertNoClientCookieExists "t5-a" "SESSION"++ WT.modifyClientCookies \_ -> ck0++ sres2 <- WT.request WT.defaultRequest+ WT.assertBody "Just (Just 900)" sres2+ WT.assertClientCookieExists "t5-b" "SESSION"++ sres2 <- WT.request WT.defaultRequest+ WT.assertBody "Just (Just 901)" sres2+ WT.assertClientCookieExists "t5-c" "SESSION"++app+ :: (W.Request -> Maybe (WCC.CryptoCookie Word))+ -> (Maybe Word -> Maybe Word)+ -> W.Application+app look g = \req res -> do+ yyold <- forM (look req) \cc -> do+ let yold = WCC.get cc+ ynew = g yold+ when (ynew /= yold) do+ atomically $ WCC.set cc ynew+ pure yold+ res $ W.responseLBS HT.status200 [] $ fromString $ show yyold++withTmpDir :: (FilePath -> IO a) -> IO a+withTmpDir f = do+ tmp0 <- getTemporaryDirectory+ Ex.bracket (acq tmp0 0) (\_ -> pure () {-removeDirectoryRecursive-}) f+ where+ acq :: FilePath -> Word -> IO FilePath+ acq prefix !n = do+ let d1 = prefix </> ("wai-cryptocookie." <> show n)+ Ex.catchJust+ (guard . isAlreadyExistsError)+ (d1 <$ createDirectory d1)+ (\_ -> acq prefix (n + 1))
+ wai-cryptocookie.cabal view
@@ -0,0 +1,75 @@+cabal-version: 2.4+name: wai-cryptocookie+version: 0.0.1+license: Apache-2.0+license-file: LICENSE+extra-source-files: README.md CHANGELOG.md+author: Renzo Carbonara+maintainer: renλren.zone+copyright: Renzo Carbonara, 2024+category: Web+build-type: Simple+synopsis: Encrypted cookies for WAI+description: Encrypted cookies for WAI+homepage: https://github.com/k0001/hs-wai-cryptocookie+bug-reports: https://github.com/k0001/hs-wai-cryptocookie/issues+tested-with: GHC == 9.8.1++common basic+ default-language: GHC2021+ build-depends: base == 4.*+ default-extensions:+ BlockArguments+ DataKinds+ DerivingStrategies+ DuplicateRecordFields+ LambdaCase+ OverloadedRecordDot+ OverloadedStrings+ TypeFamilies+ ViewPatterns+++library+ import: basic+ ghc-options: -O2 -Wall+ hs-source-dirs: lib+ exposed-modules:+ Wai.CryptoCookie+ Wai.CryptoCookie.Encoding+ Wai.CryptoCookie.Encryption+ other-modules:+ Wai.CryptoCookie.Encryption.AEAD_AES_128_GCM_SIV+ Wai.CryptoCookie.Encryption.AEAD_AES_256_GCM_SIV+ Wai.CryptoCookie.Middleware+ build-depends:+ aeson,+ binary,+ bytestring,+ cookie,+ crypton,+ http-types,+ memory,+ stm,+ text,+ time,+ vault,+ wai,++test-suite test+ import: basic+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -threaded -with-rtsopts=-N+ build-depends:+ aeson,+ binary,+ directory,+ filepath,+ http-types,+ wai,+ wai-cryptocookie,+ wai-extra,+ stm,+