diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2016 Habib Alamin + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,28 @@ +# wai-secure-cookies + +I extracted a WAI middleware to automatically encrypt and sign cookies. + +--- + +** WARNING ** + +I am not a cryptographer, and the crypto libraries in Haskell are not nearly as easy to use as what I'm used to in Ruby, so I wouldn't depend on this for a serious project until it's had some proper eyes on it. + +--- + +# Usage + +Populate the following environment variables in your WAI application process: + +``` +WAI\_COOKIE\_VALIDATION\_KEY # key to sign cookie names and values +WAI\_COOKIE\_ENCRYPTION\_KEY # key to encrypt cookie names and values +``` + +You can generate random keys with `waicookie-genkey`: + +``` +waicookie-genkey ... +key types: encryption + validation +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/keygensrc/Main.hs b/keygensrc/Main.hs new file mode 100644 --- /dev/null +++ b/keygensrc/Main.hs @@ -0,0 +1,57 @@ +module Main (main) where + +import System.Environment (getArgs) +import System.IO (hPutStrLn, stderr) +import System.Exit (exitFailure) +import Control.Monad (unless) +import Data.List (intercalate) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Builder (toLazyByteString, byteStringHex) +import Crypto.Random.Types (getRandomBytes) +import Crypto.Hash (hashBlockSize, SHA256) +import Crypto.Cipher.Types (BlockCipher(..)) +import Crypto.Cipher.AES (AES256) + +main :: IO () +main = getArgs >>= mainWithArgs + +mainWithArgs :: [String] -> IO () +mainWithArgs [] = do + hPutStrLn stderr $ "usage: waicookie-genkey ...\n\n" ++ + "key types: encryption\n" ++ + " validation" + exitFailure +mainWithArgs xs = do + unless (null invalidKeyTypes) $ do + hPutStrLn stderr $ + "Unrecognised key types: " ++ intercalate ", " invalidKeyTypes + exitFailure + + printRandomKeys xs + + where + invalidKeyTypes = filter (not . isValidKeyType) xs + +isValidKeyType :: String -> Bool +isValidKeyType "encryption" = True +isValidKeyType "validation" = True +isValidKeyType _ = False + +printRandomKeys :: [String] -> IO () +printRandomKeys = mapM_ printRandomKey + +printRandomKey :: String -> IO () +-- I know, partial functions suck, but it's only a tiny program. +printRandomKey "encryption" = BS.putStrLn =<< getRandomEncryptionKey +printRandomKey "validation" = BS.putStrLn =<< getRandomValidationKey + +getRandomValidationKey :: IO ByteString +getRandomValidationKey = toLazyByteString . byteStringHex <$> rawKey + where + rawKey = getRandomBytes $ hashBlockSize (undefined :: SHA256) + +getRandomEncryptionKey :: IO ByteString +getRandomEncryptionKey = toLazyByteString . byteStringHex <$> rawKey + where + rawKey = getRandomBytes $ blockSize (undefined :: AES256) diff --git a/src/Cookie/Secure.hs b/src/Cookie/Secure.hs new file mode 100644 --- /dev/null +++ b/src/Cookie/Secure.hs @@ -0,0 +1,82 @@ +module Cookie.Secure (encryptAndSign + , verifyAndDecrypt + , encryptAndSignIO + , encryptNullIVAndSignIO + , verifyAndDecryptIO) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Crypto.Error (CryptoFailable, maybeCryptoError, throwCryptoErrorIO) +import System.Random (getStdRandom, randomR) +import Data.Char (chr) +import Control.Monad (replicateM) +import System.Environment (getEnv) + +import Crypto.Encryption (encrypt, decrypt) +import Crypto.Verification (sign + , verify + , serialize + , deserialize + , getSignable) + +encryptAndSign + :: String + -> String + -> String + -> ByteString + -> CryptoFailable ByteString +encryptAndSign iv encryptKey authKey message = serialize <$> signed + where + signed = sign authKey <$> encrypted + encrypted = encrypt iv encryptKey message + +-- OPTIMIZE: wrap result in Either errorType, instead of Maybe. +-- Ideally, wrap it in a CryptoFailable, but that does not take +-- any error type except CryptoError, which has no constructors +-- for any signing/verification failures (/deserialization). +verifyAndDecrypt :: String -> String -> ByteString -> Maybe ByteString +verifyAndDecrypt authKey encryptKey message = + deserialize message >>= verifyAndDecryptDeserialized + where + verifyAndDecryptDeserialized signed = + if verify authKey signed + then maybeCryptoError $ decrypt encryptKey (getSignable signed) + else Nothing + +encryptAndSignIO :: ByteString -> IO ByteString +encryptAndSignIO message = do + (iv, validationKey, encryptionKey) <- getIVAuthKeyEncryptKey + + throwCryptoErrorIO + $ encryptAndSign iv encryptionKey validationKey message + +-- OPTIMIZE: DRY this up. +encryptNullIVAndSignIO :: ByteString -> IO ByteString +encryptNullIVAndSignIO message = do + -- This is currently ignored and a null IV used in its place, because we + -- need a deterministic output for cookies to be removed or changed, and + -- a random IV breaks that. + (_, validationKey, encryptionKey) <- getIVAuthKeyEncryptKey + + throwCryptoErrorIO + $ encryptAndSign nullStringIV encryptionKey validationKey message + where + nullStringIV = replicate 16 '\0' + +verifyAndDecryptIO :: ByteString -> IO (Maybe ByteString) +verifyAndDecryptIO message = do + (_, validationKey, encryptionKey) <- getIVAuthKeyEncryptKey + + return $ verifyAndDecrypt validationKey encryptionKey message + +getIVAuthKeyEncryptKey :: IO (String, String, String) +getIVAuthKeyEncryptKey = (,,) + -- The function takes a string for the IV, but the AES-256/CTR algorithm + -- is just looking for bytes. Printability in ASCII, UTF-8, or any other + -- encoding doesn't matter. + <$> get16RandomBytes + <*> getEnv "WAI_COOKIE_VALIDATION_KEY" + <*> getEnv "WAI_COOKIE_ENCRYPTION_KEY" + where + get16RandomBytes = + replicateM 16 . getStdRandom $ randomR (chr 0, chr 255) diff --git a/src/Cookie/Secure/Middleware.hs b/src/Cookie/Secure/Middleware.hs new file mode 100644 --- /dev/null +++ b/src/Cookie/Secure/Middleware.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cookie.Secure.Middleware (secureCookies) where + +import Network.Wai (Middleware + , Request + , ResponseReceived + , responseLBS + , requestHeaders + , responseHeaders) +import Network.Wai.Internal (Response(..)) +import Network.HTTP.Types.Header (Header + , RequestHeaders + , ResponseHeaders) +import Network.HTTP.Types.Status (status200) +import qualified Data.ByteString.Char8 as BS +import Data.Maybe (catMaybes) +import Cookie.Secure (encryptNullIVAndSignIO, verifyAndDecryptIO) +import Data.List.Split (splitOn) + +secureCookies :: Middleware +secureCookies app request respondWith = + verifyAndDecryptCookies request + >>= flip app (encryptAndSignCookies respondWith) + +verifyAndDecryptCookies :: Request -> IO Request +verifyAndDecryptCookies request = + replaceRequestHeaders request + <$> mapM verifyAndDecryptIfCookieHeader (requestHeaders request) + +encryptAndSignCookies + :: (Response -> IO ResponseReceived) + -> Response -> IO ResponseReceived +encryptAndSignCookies respondWith response = do + mapM encryptAndSignIfSetCookieHeader (responseHeaders response) + >>= respondWith . replaceResponseHeaders response + +encryptAndSignIfSetCookieHeader :: Header -> IO Header +encryptAndSignIfSetCookieHeader header = + if fst header == "Set-Cookie" + then encryptAndSignCookieHeader header + else return header + +encryptAndSignCookieHeader :: Header -> IO Header +encryptAndSignCookieHeader (name, value) = (,) + <$> return name + <*> encryptedSignedCookieHeaderValue + where + (cookie, metadata) = BS.break (== ';') value + encryptedSignedCookieHeaderValue = + flip BS.append metadata <$> encryptAndSignCookie cookie + encryptAndSignCookie c = + BS.intercalate "=" + -- OPTIMIZE: Use IV for value, but not name, so that the cookie + -- can actually be deleted while keeping the value as secure as + -- possible. + <$> mapM encryptNullIVAndSignIO + (map BS.pack (splitOn "=" (BS.unpack c))) + +replaceRequestHeaders :: Request -> RequestHeaders -> Request +replaceRequestHeaders request newHeaders = + request { requestHeaders = newHeaders } + +-- OPTIMIZE: Response is imported from Network.Wai.Internal, which +-- interface is not guaranteed to be stable. +replaceResponseHeaders :: Response -> ResponseHeaders -> Response +replaceResponseHeaders + (ResponseFile status headers filepath possibleFilepart) newHeaders = + ResponseFile status newHeaders filepath possibleFilepart +replaceResponseHeaders (ResponseBuilder status headers builder) newHeaders = + ResponseBuilder status newHeaders builder +replaceResponseHeaders (ResponseStream status headers body) newHeaders = + ResponseStream status newHeaders body +replaceResponseHeaders (ResponseRaw toStreaming response) newHeaders = + ResponseRaw toStreaming (replaceResponseHeaders response newHeaders) + +verifyAndDecryptIfCookieHeader :: Header -> IO Header +verifyAndDecryptIfCookieHeader header = + if fst header == "Cookie" + then verifyAndDecryptCookieHeader header + else return header + +verifyAndDecryptCookieHeader :: Header -> IO Header +verifyAndDecryptCookieHeader (name, value) = (,) + <$> return name + <*> verifyAndDecryptCookieHeaderValue value + where + verifyAndDecryptCookieHeaderValue value = + BS.intercalate "; " + <$> mapM verifyAndDecryptCookie + (splitOn "; " (BS.unpack value)) + verifyAndDecryptCookie cookie = + -- OPTIMIZE: maybe silently dropping cookies which fail to verify + -- or decrypt isn't the best idea? + BS.intercalate "=" . catMaybes + <$> mapM verifyAndDecryptIO + (map BS.pack (splitOn "=" cookie)) diff --git a/src/Crypto/Encryption.hs b/src/Crypto/Encryption.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Encryption.hs @@ -0,0 +1,36 @@ +module Crypto.Encryption (Encrypted(..) + , getIV + , getSecret + , encrypt + , decrypt) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Crypto.Error (CryptoFailable(..), CryptoError(..)) +import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.Types (BlockCipher(..), Cipher(..), makeIV) + +data Encrypted = Encrypted String ByteString deriving (Eq, Show) + +encrypt :: String -> String -> ByteString -> CryptoFailable Encrypted +encrypt stringIV key secret = + aes256Init key >>= + \context -> case makeIV $ BS.pack stringIV of + Nothing -> CryptoFailed CryptoError_IvSizeInvalid + Just iv -> CryptoPassed + . Encrypted stringIV + . ctrCombine context iv + $ secret + +decrypt :: String -> Encrypted -> CryptoFailable ByteString +-- AES/CTR decrypt operation is identical to encrypt +decrypt key (Encrypted iv secret) = getSecret <$> encrypt iv key secret + +getIV :: Encrypted -> String +getIV (Encrypted iv _) = iv + +getSecret :: Encrypted -> ByteString +getSecret (Encrypted _ secret) = secret + +aes256Init :: String -> CryptoFailable AES256 +aes256Init = cipherInit . BS.pack diff --git a/src/Crypto/Verification.hs b/src/Crypto/Verification.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Verification.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Crypto.Verification (Signed(..) + , getSignable + , sign + , verify + , serialize + , deserialize + , deserializeSignable) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Crypto.Hash.Algorithms (SHA256) +import Crypto.MAC.HMAC (HMAC(..), hmac) +import Crypto.Hash (Digest, digestFromByteString) +import Data.ByteArray.Encoding (Base(..) + , convertToBase + , convertFromBase) +import Protolude (rightToMaybe) +import Data.Tuple (swap) + +import Crypto.Encryption (Encrypted(..), getIV, getSecret) +import qualified Extension.ByteString as EBS + +data Signed signable = + Signed signable (Digest SHA256) deriving (Show, Eq) + +class Eq signable => Signable signable where + sign :: String -> signable -> Signed signable + + verify :: String -> Signed signable -> Bool + verify key signed@(Signed message _) = sign key message == signed + + getSignable :: Signed signable -> signable + getSignable (Signed signable _) = signable + + serializeSignable :: signable -> ByteString + + deserializeSignable :: ByteString -> Maybe signable + + serialize :: Signed signable -> ByteString + serialize (Signed signable digest) = + convertToBase Base64URLUnpadded (serializeSignable signable) + `BS.append` "|signature," `BS.append` + BS.pack (show digest) + + deserialize :: ByteString -> Maybe (Signed signable) + deserialize bs = Signed + <$> (rightToMaybe message >>= deserializeSignable) + <*> (rightToMaybe signature >>= digestFromByteString) + where + (encodedMessage, base16Signature) = + EBS.stripPrefix "|signature," + <$> BS.span (/= '|') bs + signature :: Either String ByteString + signature = convertFromBase Base16 base16Signature + message = convertFromBase Base64URLUnpadded encodedMessage + +instance {-# OVERLAPPING #-} Signable String where + sign key message = Signed message digest + where + digest = hmacGetDigest hmac'ed + hmac'ed = hmac (BS.pack key) (BS.pack message) :: HMAC SHA256 + + serializeSignable = convertToBase Base64URLUnpadded . BS.pack + + deserializeSignable bs = BS.unpack + <$> rightToMaybe (convertFromBase Base64URLUnpadded bs) + +instance Signable Encrypted where + sign key message = Signed message digest + where + digest = hmacGetDigest hmac'ed + hmac'ed = + hmac (BS.pack key) + (serializeSignable message) :: HMAC SHA256 + + serializeSignable encrypted = + "iv," `BS.append` + convertToBase Base64URLUnpadded (BS.pack . getIV $ encrypted) + `BS.append` "|" `BS.append` + convertToBase Base64URLUnpadded (getSecret encrypted) + + deserializeSignable bs = Encrypted + <$> (BS.unpack <$> rightToMaybe iv) + <*> (rightToMaybe secret) + where + (base64Secret, base64IV) = + EBS.stripPrefix "iv," . EBS.stripSuffix "|" + <$> swap (BS.spanEnd (/= '|') bs) + iv = convertFromBase Base64URLUnpadded base64IV + secret = convertFromBase Base64URLUnpadded base64Secret diff --git a/src/Extension/ByteString.hs b/src/Extension/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Extension/ByteString.hs @@ -0,0 +1,14 @@ +module Extension.ByteString (stripPrefix, stripSuffix) where + +import Data.ByteString (ByteString(..)) +import qualified Data.ByteString.Char8 as BS +import Data.Maybe (fromMaybe) + +stripPrefix :: ByteString -> ByteString -> ByteString +stripPrefix prefix = maybeOriginal $ BS.stripPrefix prefix + +stripSuffix :: ByteString -> ByteString -> ByteString +stripSuffix suffix = maybeOriginal $ BS.stripSuffix suffix + +maybeOriginal :: (a -> Maybe a) -> a -> a +maybeOriginal f g = fromMaybe g $ f g diff --git a/wai-secure-cookies.cabal b/wai-secure-cookies.cabal new file mode 100644 --- /dev/null +++ b/wai-secure-cookies.cabal @@ -0,0 +1,41 @@ +name: wai-secure-cookies +version: 0.1.0.0 +description: WAI middleware to automatically encrypt and sign cookies +homepage: https://github.com/habibalamin/wai-secure-cookies +license: MIT +license-file: LICENSE +author: Habib Alamin +maintainer: ha.alamin@gmail.com +copyright: © حبيب الامين‪ 2017 +category: Web +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +library + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Cookie.Secure.Middleware + other-modules: Cookie.Secure + , Crypto.Encryption + , Crypto.Verification + , Extension.ByteString + build-depends: base >= 4.7 && < 5 + , protolude >= 0.2 && < 0.3 + , wai >= 3.2 && < 4 + , cryptonite >= 0.24 && < 0.25 + , bytestring >= 0.10 && < 0.11 + , memory >= 0.14 && < 0.15 + , random >= 1.1 && < 2 + , split >= 0.2 && < 0.3 + , http-types >= 0.9 && < 0.10 + +executable waicookie-genkey + hs-source-dirs: keygensrc + default-language: Haskell2010 + main-is: Main.hs + build-depends: base >= 4.7 && < 5 + , cryptonite >= 0.24 && < 0.25 + , bytestring >= 0.10 && < 0.11 + , base64-bytestring >= 1 && < 2 + , memory >= 0.14 && < 0.15