diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Version 0.0.1 + +* Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/lib/Wai/CryptoCookie.hs b/lib/Wai/CryptoCookie.hs new file mode 100644 --- /dev/null +++ b/lib/Wai/CryptoCookie.hs @@ -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 . +-- +-- 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" + } + } diff --git a/lib/Wai/CryptoCookie/Encoding.hs b/lib/Wai/CryptoCookie/Encoding.hs new file mode 100644 --- /dev/null +++ b/lib/Wai/CryptoCookie/Encoding.hs @@ -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} diff --git a/lib/Wai/CryptoCookie/Encryption.hs b/lib/Wai/CryptoCookie/Encryption.hs new file mode 100644 --- /dev/null +++ b/lib/Wai/CryptoCookie/Encryption.hs @@ -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" diff --git a/lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs b/lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs new file mode 100644 --- /dev/null +++ b/lib/Wai/CryptoCookie/Encryption/AEAD_AES_128_GCM_SIV.hs @@ -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 . +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 diff --git a/lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs b/lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs new file mode 100644 --- /dev/null +++ b/lib/Wai/CryptoCookie/Encryption/AEAD_AES_256_GCM_SIV.hs @@ -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 . +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 diff --git a/lib/Wai/CryptoCookie/Middleware.hs b/lib/Wai/CryptoCookie/Middleware.hs new file mode 100644 --- /dev/null +++ b/lib/Wai/CryptoCookie/Middleware.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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)) diff --git a/wai-cryptocookie.cabal b/wai-cryptocookie.cabal new file mode 100644 --- /dev/null +++ b/wai-cryptocookie.cabal @@ -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, +