servant-auth-cookie 0.5.0.7 → 0.6.0
raw patch · 8 files changed
+1129/−482 lines, 8 filesdep +cereal-timedep +template-haskelldep ~cookiedep ~exceptionsdep ~time
Dependencies added: cereal-time, template-haskell
Dependency ranges changed: cookie, exceptions, time
Files
- CHANGELOG.md +32/−1
- example/AuthAPI.hs +393/−0
- example/FileKeySet.hs +114/−0
- example/Main.hs +3/−2
- example/Test.hs +89/−52
- servant-auth-cookie.cabal +11/−4
- src/Servant/Server/Experimental/Auth/Cookie.hs +420/−246
- tests/Main.hs +67/−177
CHANGELOG.md view
@@ -1,7 +1,37 @@ # Change Log ## [HEAD]+## [0.6.0] - 2017-11-08+### Added+- `getHeaderSession` function to access session data without denying access to a route (issue #30).+- `cookied`function:+ - support for multiple-parametered handlers (issue #34).+ - `CookiedWrapper` type synonym and `CookieWrapperClass` class to ease work with the function (issue #38). +- Support for session cookies (issue #35):+ - `ssExpirationType` of `SessionSetting` record+ - `ExpirationType` datatype++- Support for refreshing cookies (issue #37):+ - `ssAutoRenew` of `SessionSetting` record++- Type synonyms for common boilerplates:+ - `AuthCookieExceptionHandler`+ - `AuthCookieHandler`++### Changed+- `cookied` function's signature, added argument of type `Proxy Session`.+- `addSession*` functions' signatures, added argument of `SessionSettings` type. Use `def` (from `Data.Default`) for fallback mode.+- Fixed bug with wrong time format in `removeSession*` functions (issue #39).+- Refactored internals:+ - Format of encoding cookies is different.+ - `Cookie` record is completely changed.+ - `WithMetadata` replaced with `PayloadWrapper`/`ExtendedPayloadWrapper`. Use the latter one in cookie handlers.+ - `encryptCookie`/`decryptCookie` merged with their session counterparts.++### Removed+- `acsExpirationFormat` field and `CannotParseExpirationTime` exception constructor are no longer needed.+ ## [0.5.0.7] - 2017-11-08 ### Changed - Fixed dependencies' bounds.@@ -129,7 +159,8 @@ - Initial version of the package. -[HEAD]: ../../compare/v0.5.0.7...HEAD+[HEAD]: ../../compare/v0.6.0...HEAD+[0.6.0]: ../../compare/v0.5.0.7...v0.6.0 [0.5.0.7]: ../../compare/v0.5.0.6...v0.5.0.7 [0.5.0.6]: ../../compare/v0.5.0.5...v0.5.0.6 [0.5.0.5]: ../../compare/v0.5.0.4...v0.5.0.5
+ example/AuthAPI.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}++module AuthAPI (+ ExampleAPI+, Account (..)+, app+, authSettings+, LoginForm (..)+, homePage+, loginPage+) where++import Control.Monad (void, unless, when)+import Control.Monad.Catch (catch)+import Data.ByteString.Lazy (fromStrict)+import Data.Default (def)+import Data.List (find)+import Data.Maybe (catMaybes)+import Data.Serialize (Serialize)+import GHC.Exts (fromList)+import GHC.Generics+import Network.HTTP.Types (urlEncode)+import Network.Wai (Application)+import Prelude ()+import Prelude.Compat+import Servant ((:<|>)(..), (:>), errBody, err403, toQueryParam)+import Servant (Post, AuthProtect, Get, Server, Proxy)+import Servant (ReqBody, FormUrlEncoded, Header)+import Servant (addHeader, serveWithContext, Proxy(..), Context(..))+import Servant.HTML.Blaze+import Servant.Server.Experimental.Auth (mkAuthHandler)+import Servant.Server.Experimental.Auth.Cookie+import Text.Blaze.Html5 ((!), Markup)+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as BSC8+import qualified Data.Text as T+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A++#if MIN_VERSION_servant (0,9,1)+import Control.Monad.IO.Class (liftIO)+import Servant (Capture)+#else+import Servant (Headers)+#endif++#if MIN_VERSION_servant (0,9,0)+import Web.FormUrlEncoded (FromForm(..), ToForm(..), lookupUnique, lookupMaybe)+#else+import Servant (FromFormUrlEncoded(..), ToFormUrlEncoded(..))+#endif++#if MIN_VERSION_servant (0,7,0)+import Servant (Handler, throwError)+#else+import Control.Monad.Except (ExceptT, throwError)+import Servant (ServantErr)+#endif++#if !MIN_VERSION_servant (0,7,0)+type Handler a = ExceptT ServantErr IO a+#endif++----------------------------------------------------------------------------+-- Accounts++-- | A structure that will be stored in the cookies to identify the user.+data Account = Account+ { accUid :: Int+ , accUsername :: String+ , _accPassword :: String+ } deriving (Show, Eq, Generic)++instance Serialize Account++type instance AuthCookieData = Account++-- | In-memory database of "registered" users.+usersDB :: [Account]+usersDB =+ [ Account 101 "mr_foo" "password1"+ , Account 102 "mr_bar" "letmein"+ , Account 103 "mr_baz" "baseball" ]++-- | Function to retrieve users from db.+userLookup :: String -> String -> [Account] -> Maybe Int+userLookup username password db = accUid <$> find f db+ where f (Account _ u p) = u == username && p == password+++----------------------------------------------------------------------------+-- Login form++-- | Helper structure to get data from html-form.+data LoginForm = LoginForm+ { lfUsername :: String+ , lfPassword :: String+ , lfRemember :: Bool+ , lfRenew :: Bool+ } deriving (Eq, Show)+++#if MIN_VERSION_servant (0,9,0)+instance FromForm LoginForm where+ fromForm f = do+ lfUsername <- fmap T.unpack $ lookupUnique "username" f+ lfPassword <- fmap T.unpack $ lookupUnique "password" f+ lfRemember <- fmap (maybe False (const True)) $ lookupMaybe "remember" f+ lfRenew <- fmap (maybe False (const True)) $ lookupMaybe "renew" f+ return LoginForm {..}++instance ToForm LoginForm where+ toForm LoginForm {..} = fromList $+ ("username", toQueryParam lfUsername)+ : ("password", toQueryParam lfPassword)+ : (catMaybes $ [+ if lfRemember then Just ("remember", toQueryParam ()) else Nothing+ , if lfRenew then Just ("renew", toQueryParam ()) else Nothing+ ])+#else+instance FromFormUrlEncoded LoginForm where+ fromFormUrlEncoded d = do+ lfUsername <- case lookup "username" d of+ Nothing -> Left "username field is missing"+ Just x -> return (T.unpack x)+ lfPassword <- case lookup "password" d of+ Nothing -> Left "password field is missing"+ Just x -> return (T.unpack x)+ lfRemember <- case lookup "remember" d of+ Nothing -> return False+ Just _ -> return True+ lfRenew <- case lookup "renew" d of+ Nothing -> return False+ Just _ -> return True+ return LoginForm {..}++instance ToFormUrlEncoded LoginForm where+ toFormUrlEncoded LoginForm {..} = fromList $+ ("username", toQueryParam lfUsername)+ : ("password", toQueryParam lfPassword)+ : (catMaybes $ [+ if lfRemember then Just ("remember", "on") else Nothing+ , if lfRenew then Just ("renew", "on") else Nothing+ ])+#endif++----------------------------------------------------------------------------+-- API of the example++-- | Interface+#if MIN_VERSION_servant(0,9,1)+type ExampleAPI =+ Get '[HTML] Markup+ :<|> "login" :> Get '[HTML] Markup+ :<|> "login" :> ReqBody '[FormUrlEncoded] LoginForm :> Post '[HTML] (Cookied Markup)+ :<|> "logout" :> Get '[HTML] (Cookied Markup)+ :<|> "private" :> AuthProtect "cookie-auth" :> Get '[HTML] (Cookied Markup)+ :<|> "whoami" :> Header "cookie" T.Text :> Get '[HTML] Markup+ :<|> "keys" :> (+ Get '[HTML] Markup+ :<|> "add" :> Get '[HTML] Markup+ :<|> "rem" :> Capture "key" String :> Get '[HTML] Markup)+#else+type ExampleAPI =+ Get '[HTML] Markup+ :<|> "login" :> Get '[HTML] Markup+ :<|> "login"+ :> ReqBody '[FormUrlEncoded] LoginForm+ :> Post '[HTML] (Headers '[Header "Set-Cookie" EncryptedSession] Markup)+ :<|> "logout"+ :> Get '[HTML] (Headers '[Header "Set-Cookie" EncryptedSession] Markup)+ :<|> "private" :> AuthProtect "cookie-auth" :> Get '[HTML] Markup+ :<|> "keys" :> Get '[HTML] Markup+#endif++-- | Implementation+server :: (ServerKeySet s)+ => AuthCookieSettings+ -> (IO ())+ -> RandomSource+ -> s+ -> Server ExampleAPI+#if MIN_VERSION_servant(0,9,1)+server settings generateKey rs sks =+#else+server settings _generateKey rs sks =+#endif+ serveHome+ :<|> serveLogin+ :<|> serveLoginPost+ :<|> serveLogout+ :<|> servePrivate+#if MIN_VERSION_servant(0,9,1)+ :<|> serveWhoami+#endif+ :<|> serveKeys where++ addSession' = addSession+ settings -- the settings+ rs -- random source+ sks -- server key set++ serveHome = return homePage+ serveLogin = return (loginPage True)++ serveLoginPost LoginForm {..} =+ case userLookup lfUsername lfPassword usersDB of+ Nothing -> return $ addHeader emptyEncryptedSession (loginPage False)+ Just uid -> addSession'+ (def { ssExpirationType = if lfRemember then MaxAge else Session+ , ssAutoRenew = lfRenew })+ (Account uid lfUsername lfPassword)+ (redirectPage "/private" "Session has been started")++ serveLogout = removeSession settings (redirectPage "/" "Session has been terminated")++#if MIN_VERSION_servant(0,9,1)+ servePrivate = cookied settings rs sks (Proxy :: Proxy Account) servePrivate'++ serveWhoami Nothing = return $ whoamiPage Nothing+ serveWhoami (Just h) = do+ mwm <- getHeaderSession settings sks h `catch` handleEx+ return $ whoamiPage $ epwSession <$> mwm+ where+ handleEx :: AuthCookieExceptionHandler+ handleEx _ex = return Nothing+#else+ servePrivate = servePrivate' . epwSession+#endif++ servePrivate' :: Account -> Handler Markup+ servePrivate' (Account uid u p) = return $ privatePage uid u p++#if MIN_VERSION_servant(0,9,1)+ serveKeys = (keysPage True <$> getKeys sks) :<|> serveAddKey :<|> serveRemKey++ serveAddKey = do+ liftIO $ generateKey+ return $ redirectPage "/keys" "New key was added"++ serveRemKey b64key = either+ (\err -> throwError err403 { errBody = fromStrict . BSC8.pack $ err })+ (\key -> do+ removeKey sks key+ return $ redirectPage "/keys" "The key was removed")+ (Base64.decode . BSC8.pack $ b64key)+#else+ serveKeys = keysPage False <$> getKeys sks+#endif++-- | Custom handler that bluntly reports any occurred errors.+authHandler :: AuthCookieHandler Account+authHandler acs sks = mkAuthHandler $ \request ->+ (getSession acs sks request) `catch` handleEx >>= maybe+ (throwError err403 {errBody = "No cookies"})+ (return)+ where+ handleEx :: AuthCookieExceptionHandler+ handleEx ex = throwError err403 {errBody = fromStrict . BSC8.pack $ show ex}++-- | Authentication settings.+-- Note that we do not use "Secure" flag here. Cookies with this flag will be+-- accepted only if they were transfered over https. This is a must for+-- production server, but is an obstacle if you want to check it without+-- setting up TLS.+authSettings :: AuthCookieSettings+authSettings = def {acsCookieFlags = ["HttpOnly"]}++-- | Application+app :: (ServerKeySet s)+ => AuthCookieSettings+ -> IO () -- ^ An action to create a new key+ -> RandomSource+ -> s+ -> Application+app settings generateKey rs sks = serveWithContext+ (Proxy :: Proxy ExampleAPI)+ ((authHandler settings sks) :. EmptyContext)+ (server settings generateKey rs sks)+++----------------------------------------------------------------------------+-- Markup++pageMenu :: Markup+pageMenu = do+ H.a ! A.href "/" $ "home"+ void " "+ H.a ! A.href "/login" $ "login"+ void " "+ H.a ! A.href "/private" $ "private"+ void " "+#if MIN_VERSION_servant(0,9,1)+ H.a ! A.href "/whoami" $ "whoami"+ void " "+#endif+ H.a ! A.href "/keys" $ "keys"+ H.hr++homePage :: Markup+homePage = H.docTypeHtml $ do+ H.head (H.title "home")+ H.body $ do+ pageMenu+ H.p "This is an example of using servant-auth-cookie library."+ H.p "Use login page to get access to the private page."++loginPage :: Bool -> Markup+loginPage firstTime = H.docTypeHtml $ do+ H.head (H.title "login")+ H.body $ do+ pageMenu+ H.form ! A.method "post" ! A.action "/login" $ do+ H.table $ do+ H.tr $ do+ H.td "username:"+ H.td (H.input ! A.type_ "text" ! A.name "username")+ H.tr $ do+ H.td "password:"+ H.td (H.input ! A.type_ "password" ! A.name "password")+ H.tr $ do+ H.td ! A.colspan "2" $ H.label $ do+ H.input ! A.type_ "checkbox" ! A.name "remember" ! A.checked ""+ _ <- "Remember me"+ H.input ! A.type_ "hidden" ! A.name "renew" ! A.value "on"+ H.input ! A.type_ "submit"+ unless firstTime $+ H.p "Incorrect username/password"++privatePage :: Int -> String -> String -> Markup+privatePage uid username' password' = H.docTypeHtml $ do+ H.head (H.title "private")+ H.body $ do+ pageMenu+ H.p $ H.b "ID: " >> H.toHtml (show uid)+ H.p $ H.b "username: " >> H.toHtml username'+ H.p $ H.b "password: " >> H.toHtml password'+ H.hr+ H.a ! A.href "/logout" $ "logout"++#if MIN_VERSION_servant(0,9,1)+whoamiPage :: Maybe Account -> Markup+whoamiPage macc = H.docTypeHtml $ do+ H.head (H.title "whoami")+ H.body $ do+ pageMenu+ case macc of+ Nothing -> H.p $ H.b "Not authenticated"+ Just acc -> H.p $ H.b "username: " >> H.toHtml (accUsername acc)+#endif++keysPage :: Bool -> (BSC8.ByteString, [BSC8.ByteString]) -> Markup+keysPage showControls (k, ks) = H.docTypeHtml $ do+ H.head (H.title "keys")+ H.body $ do+ pageMenu+ when showControls $+ H.a ! A.href "/keys/add" $ "add new key"+ H.p $ H.b $ keyElement False k+ mapM_ H.p $ map (keyElement showControls) ks++keyElement :: Bool -> BSC8.ByteString -> Markup+keyElement removable key = let+ b64key = Base64.encode $ key+ url = "/keys/rem/" ++ (BSC8.unpack . urlEncode True $ b64key)+ in do+ H.span ! A.class_ "key" $ H.toHtml (BSC8.unpack b64key)+ when (removable) $ do+ void " "+ H.a ! A.href (H.stringValue url) $ "(remove)"++redirectPage :: String -> String -> Markup+redirectPage uri message = H.docTypeHtml $ do+ H.head $ do+ H.title "redirecting..."+ H.meta ! A.httpEquiv "refresh" ! A.content (H.toValue $ "1; url=" ++ uri)+ H.body $ do+ H.p $ H.toHtml message+ H.p "You are being redirected."+ H.p $ do+ void "If your browser does not refresh the page click "+ H.a ! A.href (H.toValue uri) $ "here"+
+ example/FileKeySet.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TupleSections #-}++module FileKeySet (+ FileKSParams (..)+, mkFileKey+, mkFileKeySet+) where++import Control.Concurrent (threadDelay)+import Control.Monad (when)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.List (sort)+import Data.Time (formatTime, defaultTimeLocale)+import Data.Time.Clock (UTCTime(..), getCurrentTime)+import Prelude ()+import Prelude.Compat+import Servant.Server.Experimental.Auth.Cookie+import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, listDirectory, removeFile)+import System.FilePath.Posix ((</>), (<.>))+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as BSC8++----------------------------------------------------------------------------+-- KeySet+-- A custom implementation of a keyset on top of 'RenewableKeySet'.+-- Keys are stored as files with base64 encoded data in 'test-key-set' directory.+-- To add a key just throw a file into the directory.+-- To remove a key delete corresponding file in the directory.+-- Both operations can be performed via web interface (see '/keys' page).+++data FileKSParams = FileKSParams+ { fkspPath :: FilePath+ , fkspMaxKeys :: Int+ , fkspKeySize :: Int+ }++data FileKSState = FileKSState+ { fkssLastModified :: UTCTime } deriving Eq+++mkFileKey :: FileKSParams -> IO ()+mkFileKey FileKSParams {..} = (,) <$> mkName <*> mkKey >>= uncurry writeFile where++ mkKey = generateRandomBytes fkspKeySize+ >>= return+ . BSC8.unpack+ . Base64.encode++ mkName = getCurrentTime+ >>= return+ . (fkspPath </>)+ . (<.> "b64")+ . formatTime defaultTimeLocale "%0Y%m%d%H%M%S"+ >>= \name -> do+ exists <- doesFileExist name+ if exists+ then (threadDelay 1000000) >> mkName+ -- ^ we don't want to change the keys that often+ else return name+++mkFileKeySet :: (MonadIO m, MonadThrow m)+ => FileKSParams+ -> m (RenewableKeySet FileKSState FileKSParams)+mkFileKeySet = mkKeySet where++ mkKeySet FileKSParams {..} = do+ liftIO $ do+ createDirectoryIfMissing True fkspPath+ listDirectory fkspPath >>= \fs -> when (null fs) $+ mkFileKey FileKSParams {..}++ let fkssLastModified = UTCTime (toEnum 0) 0++ mkRenewableKeySet+ RenewableKeySetHooks {..}+ FileKSParams {..}+ FileKSState {..}++ rkshNeedUpdate FileKSParams {..} (_, FileKSState {..}) = do+ lastModified <- liftIO $ getModificationTime fkspPath+ return (lastModified > fkssLastModified)++ getLastModifiedFiles FileKSParams {..} = listDirectory fkspPath+ >>= return . map (fkspPath </>)+ >>= \fs -> zip <$> (mapM getModificationTime fs) <*> (return fs)+ >>= return+ . map snd+ . take fkspMaxKeys+ . reverse+ . sort++ readKey = fmap (either (error "wrong key format") id . Base64.decode . BSC8.pack) . readFile++ rkshNewState FileKSParams {..} (_, s) = liftIO $ do+ lastModified <- getModificationTime fkspPath+ keys <- getLastModifiedFiles FileKSParams {..} >>= mapM readKey+ return (keys, s {fkssLastModified = lastModified})++ rkshRemoveKey FileKSParams {..} key = liftIO $ getLastModifiedFiles FileKSParams {..}+ >>= \fs -> zip fs <$> mapM readKey fs+ >>= return . filter ((== key) . snd)+ >>= mapM_ (removeFile . fst)
example/Main.hs view
@@ -3,11 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where+ import AuthAPI (app, authSettings)-import Prelude ()-import Prelude.Compat import Crypto.Random (drgNew) import Network.Wai.Handler.Warp (run)+import Prelude ()+import Prelude.Compat import Servant.Server.Experimental.Auth.Cookie #if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5)
example/Test.hs view
@@ -4,24 +4,26 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TupleSections #-} -import Prelude ()-import Prelude.Compat-import Data.Maybe (fromMaybe)-import Data.Int (Int64)-import Data.Time.Clock (UTCTime(..))-import Control.Monad.IO.Class (liftIO) import AuthAPI (app, authSettings, LoginForm(..), homePage, loginPage, Account(..))-import Test.Hspec (Spec, hspec, describe, context, it)-import Test.Hspec.Wai (WaiSession, WaiExpectation, shouldRespondWith, with, request, get)-import Text.Blaze.Renderer.Utf8 (renderMarkup)-import Text.Blaze (Markup)-import Servant (Proxy(..))+import Control.Monad.IO.Class (liftIO) import Crypto.Random (drgNew)-import Servant (FormUrlEncoded, contentType)-import Servant.Server.Experimental.Auth.Cookie-import Network.HTTP.Types (Header, methodGet, methodPost, hContentType, hCookie)+import Data.Default (def)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Time.Clock (UTCTime(..)) import Network.HTTP.Media.RenderHeader (renderHeader)+import Network.HTTP.Types (Header, methodGet, methodPost, hContentType, hCookie) import Network.Wai.Test (SResponse(..))+import Prelude ()+import Prelude.Compat+import Servant (FormUrlEncoded, contentType)+import Servant (Proxy(..))+import Servant.Server.Experimental.Auth.Cookie+import Test.Hspec (Spec, hspec, describe, context, it, shouldBe)+import Test.Hspec.Wai (WaiSession, WaiExpectation, shouldRespondWith, with, request, get)+import Text.Blaze (Markup)+import Text.Blaze.Renderer.Utf8 (renderMarkup)+import Web.Cookie (parseCookies) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC8@@ -45,14 +47,13 @@ import Data.Monoid ((<>)) import Control.Exception.Base (bracket) import Network.HTTP.Types (urlEncode)-import Test.Hspec (shouldBe, shouldSatisfy)+import Test.Hspec (shouldSatisfy) import System.Directory (removeDirectoryRecursive, doesDirectoryExist) import qualified Data.ByteString.Char8 as BSC8 import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A #endif - data SpecState where SpecState :: (ServerKeySet k) => { ssRandomSource :: RandomSource@@ -101,6 +102,13 @@ basicSpec ss@(SpecState {..}) = describe "basic functionality" $ with (return $ app ssAuthSettings ssGenerateKey ssRandomSource ssServerKeySet) $ do + let form = LoginForm {+ lfUsername = "mr_foo"+ , lfPassword = "password1"+ , lfRemember = False+ , lfRenew = False+ }+ context "home page" $ do it "responds successfully" $ do get "/" `shouldRespondWithMarkup` homePage@@ -110,46 +118,71 @@ get "/login" `shouldRespondWithMarkup` (loginPage True) it "shows message on incorrect login" $ do- login "noname" "noname" `shouldRespondWithMarkup` (loginPage False)+ (login form { lfPassword = "wrong" }) `shouldRespondWithMarkup` (loginPage False) - context "private page" $ do- let loginRequest = login "mr_foo" "password1"+ let hasExpirationFlags+ = not . null+ . filter ((`elem` ["Max-Age", "Expires"]) . fst)+ . parseCookies + it "responds with session cookies if 'Remember me' is not set" $ do+ (login form { lfRemember = False }+ >>= return . hasExpirationFlags . getCookieValue)+ >>= liftIO . (`shouldBe` False)++ it "responds with normal cookies if `Remember me` is set" $ do+ (login form { lfRemember = True }+ >>= return . hasExpirationFlags . getCookieValue)+ >>= liftIO . (`shouldBe` True)++ context "private page" $ do it "rejects requests without cookies" $ do get "/private" `shouldRespondWith` 403 { matchBody = matchBody' "No cookies" } it "accepts requests with proper cookies" $ do- (SResponse {..}) <- loginRequest- let cookieValue = fromMaybe- (error "cookies aren't available")- (lookup "set-cookie" simpleHeaders)- getPrivate cookieValue `shouldRespondWith` 200+ (login form+ >>= return . getCookieValue+ >>= getPrivate) `shouldRespondWith` 200 it "accepts requests with proper cookies (sanity check)" $ do- cookieValue <- loginRequest+ (login form >>= liftIO . forgeCookies ss authSettings ssServerKeySet- getPrivate cookieValue `shouldRespondWith` 200+ >>= getPrivate) `shouldRespondWith` 200 it "rejects requests with incorrect MAC" $ do let newServerKeySet = mkPersistentServerKey "0000000000000000"- cookieValue <- loginRequest+ (login form >>= liftIO . forgeCookies ss authSettings newServerKeySet- getPrivate cookieValue `shouldRespondWithException` (IncorrectMAC "")-- it "rejects requests with malformed expiration time" $ do- let newAuthSettings = authSettings { acsExpirationFormat = "%0Y%m%d" }- cookieValue <- loginRequest- >>= liftIO . forgeCookies ss newAuthSettings ssServerKeySet- getPrivate cookieValue `shouldRespondWithException` (CannotParseExpirationTime "")+ >>= getPrivate) `shouldRespondWithException` (IncorrectMAC "") it "rejects requests with expired cookies" $ do let newAuthSettings = authSettings { acsMaxAge = 0 }- cookieValue <- loginRequest- >>= liftIO . forgeCookies ss newAuthSettings ssServerKeySet let t = UTCTime (toEnum 0) 0- getPrivate cookieValue `shouldRespondWithException` (CookieExpired t t)+ (login form+ >>= liftIO . forgeCookies ss newAuthSettings ssServerKeySet+ >>= getPrivate) `shouldRespondWithException` (CookieExpired t t) + let hasSetCookieHeader+ = maybe False (const True)+ . lookup "set-cookie"+ . simpleHeaders + it "doesn't renew cookies when renew flag is not set" $ do+ (login (form { lfRemember = True, lfRenew = False })+ >>= return . getCookieValue+ >>= getPrivate+ >>= return . hasSetCookieHeader)+ >>= liftIO . (`shouldBe` False)++#if MIN_VERSION_servant(0,9,1)+ it "does renew cookies when renew flag is set" $ do+ (login form { lfRemember = True, lfRenew = True }+ >>= return . getCookieValue+ >>= getPrivate+ >>= return . hasSetCookieHeader)+ >>= liftIO . (`shouldBe` True)+#endif+ #if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) renewalSpec :: SpecState -> Spec renewalSpec (SpecState {..}) = describe "renewal functionality" $ with@@ -173,14 +206,15 @@ liftIO $ keys' `shouldBe` (init keys) context "cookies" $ do- let loginRequest = login "mr_foo" "password1"-- let getCookieValue req = req >>= \resp -> return $ fromMaybe- (error "cookies aren't available")- (lookup "set-cookie" $ simpleHeaders resp)+ let form = LoginForm {+ lfUsername = "mr_foo"+ , lfPassword = "password1"+ , lfRemember = False+ , lfRenew = False+ } it "rejects requests with deleted keys" $ do- cookieValue <- getCookieValue loginRequest+ cookieValue <- getCookieValue <$> login form getPrivate cookieValue `shouldRespondWith` 200 key <- head <$> extractKeys@@ -189,18 +223,18 @@ getPrivate cookieValue `shouldRespondWith` 403 it "accepts requests with old key and renews cookie" $ do- cookieValue <- getCookieValue loginRequest+ cookieValue <- getCookieValue <$> login form getPrivate cookieValue `shouldRespondWith` 200 key <- head <$> extractKeys addKey- newCookieValue <- getCookieValue (getPrivate cookieValue)+ newCookieValue <- getCookieValue <$> getPrivate cookieValue remKey key getPrivate newCookieValue `shouldRespondWith` 200 it "does not renew cookies for the newest key" $ do- cookieValue <- getCookieValue loginRequest+ cookieValue <- getCookieValue <$> login form _ <- getPrivate cookieValue `shouldRespondWith` 200 r <- getPrivate cookieValue liftIO $ (lookup "set-cookie" $ simpleHeaders r) `shouldBe` Nothing@@ -243,15 +277,15 @@ hContentType , renderHeader $ contentType (Proxy :: Proxy FormUrlEncoded)) -login :: String -> String -> WaiSession SResponse-login lfUsername lfPassword = request- methodPost "/login" [formContentType] (encode LoginForm {..})+login :: LoginForm -> WaiSession SResponse+login lf = request+ methodPost "/login" [formContentType] (encode lf) getPrivate :: BS.ByteString -> WaiSession SResponse getPrivate cookieValue = request methodGet "/private" [(hCookie, cookieValue)] "" -extractSession :: SpecState -> SResponse -> IO (WithMetadata Account)+extractSession :: SpecState -> SResponse -> IO (ExtendedPayloadWrapper Account) extractSession SpecState {..} SResponse {..} = maybe (error "cookies aren't available") (decryptSession ssAuthSettings ssServerKeySet)@@ -264,8 +298,7 @@ -> SResponse -> IO BS.ByteString forgeCookies ss newAuthSettings newServerKeySet r = extractSession ss r- >>= renderSession newAuthSettings (ssRandomSource ss) newServerKeySet . wmData-+ >>= \s -> renderSession newAuthSettings (ssRandomSource ss) newServerKeySet def (epwSession s) () #if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) extractKeys :: WaiSession [BS.ByteString]@@ -293,3 +326,7 @@ remKey key = void $ get $ "/keys/rem/" <> (urlEncode True $ key) #endif +getCookieValue :: SResponse -> BS.ByteString+getCookieValue = fromMaybe (error "cookies aren't available")+ . lookup "set-cookie"+ . simpleHeaders
servant-auth-cookie.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-cookie-version: 0.5.0.7+version: 0.6.0 synopsis: Authentication via encrypted cookies description: Authentication via encrypted client-side cookies, inspired by client-session library by Michael Snoyman and based on@@ -50,6 +50,7 @@ , blaze-builder >= 0.4 && < 0.4.1 , bytestring , cereal >= 0.5 && < 0.6+ , cereal-time >= 0.1 && < 0.2 , cookie >= 0.4.1 && < 0.5 , cryptonite >= 0.14 && < 0.25 , data-default@@ -60,7 +61,8 @@ , servant >= 0.5 && < 0.13 , servant-server >= 0.5 && < 0.13 , tagged == 0.8.*- , time >= 1.5 && < 1.8.1+ , text+ , time >= 1.6 && < 1.8.1 , transformers >= 0.4 && < 0.6 , wai >= 3.0 && < 3.3 @@ -101,13 +103,14 @@ , cryptonite >= 0.14 && < 0.25 , data-default , deepseq >= 1.3 && < 1.5+ , exceptions , hspec >= 2.0 && < 3.0 , servant-auth-cookie , servant-server >= 0.5 && < 0.13+ , tagged == 0.8.*+ , template-haskell , transformers >= 0.4 && < 0.6 , time >= 1.5 && < 1.8.1- if !impl(ghc >= 7.8)- build-depends: tagged == 0.8.* default-language: Haskell2010 @@ -144,6 +147,9 @@ build-depends: servant >= 0.9, http-api-data == 0.3.*+ other-modules:+ AuthAPI+ FileKeySet else build-depends: servant < 0.9,@@ -175,6 +181,7 @@ , blaze-html >= 0.8 && < 0.10 , bytestring , cereal >= 0.5 && < 0.6+ , cookie , exceptions , cryptonite >= 0.14 && < 0.25 , data-default
src/Servant/Server/Experimental/Auth/Cookie.hs view
@@ -12,28 +12,37 @@ paper \"A Secure Cookie Protocol\" by Alex Liu et al. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-} + module Servant.Server.Experimental.Auth.Cookie ( CipherAlgorithm , AuthCookieData- , Cookie (..) , AuthCookieException (..) - , WithMetadata (..)+ , AuthCookieExceptionHandler+ , AuthCookieHandler++ , PayloadWrapper(..)+ , ExtendedPayloadWrapper(..) #if MIN_VERSION_servant(0,9,1) , Cookied+ , CookiedWrapper+ , CookiedWrapperClass(..) , cookied #endif @@ -53,13 +62,12 @@ , mkRenewableKeySet , AuthCookieSettings (..)+ , SessionSettings (..)+ , ExpirationType (..) , EncryptedSession (..) , emptyEncryptedSession - , encryptCookie- , decryptCookie- , encryptSession , decryptSession @@ -68,13 +76,36 @@ , addSessionToErr , removeSessionFromErr , getSession+#if MIN_VERSION_servant(0,9,0)+ , getHeaderSession+#endif , defaultAuthHandler -- exposed for testing purpose+ , Cookie(..)+ , SerializedEncryptedCookie+ , EncryptedCookie++ , IVBytes+ , PayloadBytes+ , PaddingBytes+ , MACBytes++ , base64Encode+ , base64Decode+ , cerealEncode+ , cerealDecode+ , renderSession , parseSessionRequest , parseSessionResponse+ , unProxy++ , mkCookieKey+ , mkPadding+ , mkMAC+ , applyCipherAlgorithm ) where import Blaze.ByteString.Builder (toByteString)@@ -96,10 +127,12 @@ import Data.Maybe (listToMaybe) import Data.Monoid ((<>)) import Data.Proxy-import Data.Serialize-import Data.Time+import Data.Serialize (Serialize(..)) import Data.Tagged (Tagged (..), retag)+import Data.Time+import Data.Time.Clock.Serialize () import Data.Typeable+import GHC.Generics (Generic) import GHC.TypeLits (Symbol) import Network.HTTP.Types (hCookie, HeaderName, RequestHeaders, ResponseHeaders) import Network.Wai (Request, requestHeaders)@@ -114,20 +147,26 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as BSC8+import qualified Data.Serialize as Serialize (encode, decode) import qualified Network.HTTP.Types as N(Header) #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif +#if MIN_VERSION_servant(0,7,0)+import Servant.Server (Handler)+#endif+ #if MIN_VERSION_servant(0,9,0) import Servant (ToHttpApiData (..))+import Data.Text (Text) #else import Data.ByteString.Conversion (ToByteString (..)) #endif #if MIN_VERSION_servant(0,9,1)-import Servant (noHeader, Handler)+import Servant (noHeader) import Servant.API.ResponseHeaders (Headers) import qualified Servant.API.Header as S(Header) #endif@@ -136,6 +175,11 @@ import Network.HTTP.Types.Header (hSetCookie) #endif +#if MIN_VERSION_servant(0,7,0)+#else+type Handler = ExceptT ServantErr IO+#endif+ #if MIN_VERSION_http_types(0,10,0) #else hSetCookie :: HeaderName@@ -151,21 +195,67 @@ -- | A type family that maps user-defined data to 'AuthServerData'. type family AuthCookieData --- | Wrapper for cookies and sessions to keep some related metadata.-data WithMetadata a = WithMetadata- { wmData :: a -- ^ Value itself- , wmRenew :: Bool -- ^ Whether we should renew cookies/session+-- | How to represent expiration to the client's browser.+data ExpirationType+ = Expires -- ^ cookies will be provided with 'Expires' flag. Deprecated in favour of 'Max-Age'.+ | MaxAge -- ^ cookies will be provided with 'Max-Age' flag. Doesn't work with older versions of IE.+ | Session -- ^ cookies will be removed when the user closes the browser.+ deriving (Eq, Show, Generic)++instance Default ExpirationType where+ def = Session++instance Serialize ExpirationType++-- | Format used in 'Expires' cookie field.+expirationFormat :: String+expirationFormat = "%a, %d %b %Y %H:%M:%S GMT"+++-- | Wrapper for session value that goes into cookies' payload.+data PayloadWrapper a = PayloadWrapper {+ pwSession :: a+ , pwSettings :: SessionSettings+ , pwExpiration :: UTCTime+ } deriving (Generic)++instance (Serialize a) => Serialize (PayloadWrapper a)++-- | Wrapper for session value with metadata that doesn't go into payload.+data ExtendedPayloadWrapper a = ExtendedPayloadWrapper {+ epwSession :: a+ , epwSettings :: SessionSettings+ , epwExpiration :: UTCTime+ , epwRenew :: Bool } -type instance AuthServerData (AuthProtect "cookie-auth") = WithMetadata AuthCookieData --- | Cookie representation.-data Cookie = Cookie- { cookieIV :: ByteString -- ^ The initialization vector- , cookieExpirationTime :: UTCTime -- ^ The cookie's expiration time- , cookiePayload :: ByteString -- ^ The payload- } deriving (Eq, Show)+type instance AuthServerData (AuthProtect "cookie-auth") = ExtendedPayloadWrapper AuthCookieData ++-- | Representation of a cookie.+data Cookie = Cookie {+ cookieIV :: Tagged IVBytes ByteString+ , cookiePayload :: Tagged PayloadBytes ByteString+ , cookiePadding :: Tagged PaddingBytes ByteString+ , cookieMAC :: Tagged MACBytes ByteString+ }++instance Serialize Cookie where+ put Cookie {..} = do+ put $ unTagged cookieIV+ put $ unTagged cookiePayload+ put $ unTagged cookiePadding+ put $ unTagged cookieMAC++ get = do+ cookieIV <- Tagged <$> get+ cookiePayload <- Tagged <$> get+ cookiePadding <- Tagged <$> get+ cookieMAC <- Tagged <$> get+ return Cookie {..}++ -- | A newtype wrapper over 'ByteString' newtype EncryptedSession = EncryptedSession ByteString deriving (Eq, Show, Typeable)@@ -199,8 +289,6 @@ -- this constructor: minimal key length, actual key length. | IncorrectMAC ByteString -- ^ Thrown when Message Authentication Code (MAC) is not correct.- | CannotParseExpirationTime ByteString- -- ^ Thrown when expiration time cannot be parsed. | CookieExpired UTCTime UTCTime -- ^ Thrown when 'Cookie' has expired. Arguments of the constructor: -- expiration time, actual time.@@ -213,20 +301,51 @@ ---------------------------------------------------------------------------- -- Tags for various bytestrings --- | Tag encrypted cookie+-- | Tag for encrypted cookie. data EncryptedCookie --- | Tag for base64 serialized and encrypted cookie+-- | Tag for base64 serialized and encrypted cookie. data SerializedEncryptedCookie +-- | Tag for raw server key bytes.+data ServerKeyBytes++-- | Tag raw cookie key bytes.+data CookieKeyBytes++-- | Tag for IV bytes.+data IVBytes++-- | Tag for encrypted or raw payload bytes.+data PayloadBytes++-- | Tag for pading bytes.+data PaddingBytes++-- | Tag for MAC of a cookie.+data MACBytes+++-- | Wrapper for 'Base64.encode'. base64Encode :: Tagged EncryptedCookie ByteString -> Tagged SerializedEncryptedCookie ByteString base64Encode = retag . fmap Base64.encode -base64Decode- :: Tagged SerializedEncryptedCookie ByteString- -> Either String (Tagged EncryptedCookie ByteString)-base64Decode = fmap Tagged . Base64.decode . unTagged+-- | Wrapper for 'Base64.decode'.+base64Decode :: (MonadThrow m)+ => Tagged SerializedEncryptedCookie ByteString+ -> m (Tagged EncryptedCookie ByteString)+base64Decode = either (throwM . SessionDeserializationFailed) return+ . fmap Tagged . Base64.decode . unTagged +-- | Wrapper for 'Serialize.encode'.+cerealEncode :: (Serialize a) => a -> Tagged b ByteString+cerealEncode = Tagged . Serialize.encode++-- | Wrapper for 'Serialize.decode'.+cerealDecode :: (Serialize a, MonadThrow m) => Tagged b ByteString -> m a+cerealDecode = either (throwM . SessionDeserializationFailed) return+ . Serialize.decode . unTagged+ ---------------------------------------------------------------------------- -- Random source @@ -362,7 +481,6 @@ -- | Options that determine authentication mechanisms. Use 'def' to get -- default value of this type.- data AuthCookieSettings where AuthCookieSettings :: (HashAlgorithm h, BlockCipher c) => { acsSessionField :: ByteString@@ -371,9 +489,7 @@ -- ^ Session cookie's flags , acsMaxAge :: NominalDiffTime -- ^ For how long the cookie will be valid (corresponds to “Max-Age”- -- attribute).- , acsExpirationFormat :: String- -- ^ Expiration format as in 'formatTime'.+ -- or "Expires" attribute). , acsPath :: ByteString -- ^ Scope of the cookie (corresponds to “Path” attribute). , acsHashAlgorithm :: Proxy h@@ -391,17 +507,32 @@ { acsSessionField = "Session" , acsCookieFlags = ["HttpOnly", "Secure"] , acsMaxAge = fromIntegral (12 * 3600 :: Integer) -- 12 hours- , acsExpirationFormat = "%0Y%m%d%H%M%S" , acsPath = "/" , acsHashAlgorithm = Proxy :: Proxy SHA256 , acsCipher = Proxy :: Proxy AES256 , acsEncryptAlgorithm = ctrCombine , acsDecryptAlgorithm = ctrCombine } ++-- | Options that determine session mechanisms. Use 'def' to get+-- default value of this type.+data SessionSettings = SessionSettings {+ ssExpirationType :: ExpirationType -- ^ How to represent expiration to the client's browser.+ , ssAutoRenew :: Bool -- ^ Whether to renew cookies automatically.+ } deriving (Show, Eq, Generic)++instance Serialize SessionSettings++instance Default SessionSettings where+ def = SessionSettings {+ ssExpirationType = def+ , ssAutoRenew = False+ }+ ------------------------------------------------------------------------------- Encrypt/decrypt cookie+-- Encrypt/decrypt session --- | Encrypt given 'Cookie' with server key.+-- | Pack session object into a cookie. -- -- The function can throw the following exceptions (of type -- 'AuthCookieException'):@@ -409,32 +540,26 @@ -- * 'TooShortProperKey' -- * 'CannotMakeIV' -- * 'BadProperKey'-encryptCookie :: (MonadIO m, MonadThrow m, ServerKeySet k)+encryptSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> RandomSource -- ^ Random source to use -> k -- ^ Instance of 'ServerKeySet' to use- -> Cookie -- ^ The 'Cookie' to encrypt- -> m (Tagged EncryptedCookie ByteString) -- ^ Encrypted 'Cookie' is form of 'ByteString'-encryptCookie AuthCookieSettings {..} sks cookie = do- let iv = cookieIV cookie- expiration = BSC8.pack $ formatTime- defaultTimeLocale- acsExpirationFormat- (cookieExpirationTime cookie)- (serverKey, _) <- getKeys sks- key <- mkProperKey- (cipherKeySize $ unProxy acsCipher)- (sign acsHashAlgorithm serverKey $ iv <> expiration)- payload <- applyCipherAlgorithm acsEncryptAlgorithm- iv key (cookiePayload cookie)- let mac = sign acsHashAlgorithm serverKey- (BS.concat [iv, expiration, payload])- return . Tagged . runPut $ do- putByteString iv- putByteString expiration- putByteString payload- putByteString mac+ -> SessionSettings -- ^ Session settings+ -> a -- ^ Session value+ -> m (Tagged SerializedEncryptedCookie ByteString) -- ^ Serialized and encrypted session+encryptSession AuthCookieSettings {..} rs sks pwSettings pwSession = do+ pwExpiration <- liftM (addUTCTime acsMaxAge) (liftIO getCurrentTime)+ cookieIV <- mkIV rs acsCipher+ sk <- liftM (Tagged . fst) (getKeys sks)+ key <- mkCookieKey acsCipher acsHashAlgorithm sk cookieIV+ cookiePayload <- applyCipherAlgorithm acsEncryptAlgorithm cookieIV key (cerealEncode PayloadWrapper {..})+ cookiePadding <- mkPadding rs acsCipher cookiePayload+ let cookieMAC = mkMAC acsHashAlgorithm sk Cookie {cookieMAC = "", ..}+ return . base64Encode . cerealEncode $ Cookie {..} --- | Decrypt a 'Cookie' from 'ByteString'.++-- | Unpack session value from a cookie. The function can throw the same+-- exceptions as 'decryptCookie'. -- -- The function can throw the following exceptions (of type -- 'AuthCookieException'):@@ -443,178 +568,117 @@ -- * 'CannotMakeIV' -- * 'BadProperKey' -- * 'IncorrectMAC'--- * 'CannotParseExpirationTime' -- * 'CookieExpired'-decryptCookie :: (MonadIO m, MonadThrow m, ServerKeySet k)- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> k -- ^ Instance of 'ServerKeySet' to use- -> Tagged EncryptedCookie ByteString -- ^ The 'ByteString' to decrypt- -> m (WithMetadata Cookie) -- ^ The decrypted 'Cookie'-decryptCookie AuthCookieSettings {..} sks (Tagged s) = do- currentTime <- liftIO getCurrentTime- let ivSize = blockSize (unProxy acsCipher)- expSize =- length (formatTime defaultTimeLocale acsExpirationFormat currentTime)- payloadSize = BS.length s - ivSize - expSize -- hashDigestSize (unProxy acsHashAlgorithm)- butMacSize = ivSize + expSize + payloadSize- (iv, s0) = BS.splitAt ivSize s- (expirationRaw, s1) = BS.splitAt expSize s0- (payloadRaw, mac) = BS.splitAt payloadSize s1- checkMac sk = mac == sign acsHashAlgorithm sk (BS.take butMacSize s)-- (currentKey, rotatedKeys) <- getKeys sks- (serverKey, renew) <- if checkMac currentKey- then return (currentKey, False)- else liftM (,True) $ maybe- (throwM $ IncorrectMAC mac)+-- * 'SessionDeserializationFailed'+decryptSession :: (MonadIO m, MonadThrow m, ServerKeySet k, Serialize a)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> k -- ^ Instance of 'ServerKeySet' to use+ -> Tagged SerializedEncryptedCookie ByteString -- ^ The 'ByteString' to decrypt+ -> m (ExtendedPayloadWrapper a) -- ^ The decrypted 'Cookie'+decryptSession AuthCookieSettings {..} sks s = do+ Cookie {..} <- base64Decode s >>= cerealDecode+ let checkMAC sk = cookieMAC == mkMAC acsHashAlgorithm sk Cookie {..}+ (sk, renew) <- getKeys sks >>= \(currentKey, rotatedKeys) -> maybe+ (throwM $ IncorrectMAC (unTagged cookieMAC)) (return)- (listToMaybe . map fst . filter snd . map (id &&& checkMac) $ rotatedKeys)+ . listToMaybe+ . filter (checkMAC . fst)+ . map (first Tagged)+ $ ((currentKey, False):(map (,True) rotatedKeys))+ key <- mkCookieKey acsCipher acsHashAlgorithm sk cookieIV+ PayloadWrapper {..} <- applyCipherAlgorithm acsDecryptAlgorithm cookieIV key cookiePayload+ >>= cerealDecode - expirationTime <-- maybe (throwM $ CannotParseExpirationTime expirationRaw) return $- parseTimeM False defaultTimeLocale acsExpirationFormat- (BSC8.unpack expirationRaw)- when (currentTime >= expirationTime) $- throwM (CookieExpired expirationTime currentTime)- key <- mkProperKey- (cipherKeySize (unProxy acsCipher))- (sign acsHashAlgorithm serverKey $ BS.take (ivSize + expSize) s)- payload <- applyCipherAlgorithm acsDecryptAlgorithm iv key payloadRaw- let cookie = Cookie- { cookieIV = iv- , cookieExpirationTime = expirationTime- , cookiePayload = payload }- return WithMetadata- { wmData = cookie- , wmRenew = renew+ (liftIO getCurrentTime) >>= \t -> when (t >= pwExpiration) $ throwM (CookieExpired pwExpiration t)++ let SessionSettings {..} = pwSettings+ return ExtendedPayloadWrapper {+ epwSession = pwSession+ , epwSettings = pwSettings+ , epwExpiration = pwExpiration+ , epwRenew = renew || ((ssExpirationType /= Session) && ssAutoRenew) } ------------------------------------------------------------------------------- Encrypt/decrypt session+-- Add/remove session --- | Pack session object into a cookie. The function can throw the same--- exceptions as 'encryptCookie'.-encryptSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k)+type AddSession r s = forall m a k. (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' -> RandomSource -- ^ Random source to use -> k -- ^ Instance of 'ServerKeySet' to use- -> a -- ^ Session value- -> m (Tagged SerializedEncryptedCookie ByteString) -- ^ Serialized and encrypted session-encryptSession acs@AuthCookieSettings {..} randomSource sk session = do- iv <- getRandomBytes randomSource (blockSize $ unProxy acsCipher)- expirationTime <- liftM (addUTCTime acsMaxAge) (liftIO getCurrentTime)- let payload = runPut (put session)- padding <-- let bs = blockSize (unProxy acsCipher)- n = BS.length payload- l = (bs - (n `rem` bs)) `rem` bs- in getRandomBytes randomSource l- base64Encode `liftM` encryptCookie acs sk (Cookie- { cookieIV = iv- , cookieExpirationTime = expirationTime- , cookiePayload = BS.concat [payload, padding] })+ -> SessionSettings -- ^ Session settings+ -> a -- ^ The session value+ -> r -- ^ The original response+ -> m s -- ^ Modified response --- | Unpack session value from a cookie. The function can throw the same--- exceptions as 'decryptCookie'.-decryptSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k)- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> k -- ^ Instance of 'ServerKeySet' to use- -> Tagged SerializedEncryptedCookie ByteString -- ^ Cookie in binary form- -> m (WithMetadata a) -- ^ Unpacked session value-decryptSession acs@AuthCookieSettings {..} sks s =- let fromRight = either (throwM . SessionDeserializationFailed) return- in fromRight (base64Decode s) >>=- decryptCookie acs sks >>=- \w -> do- session <- fromRight . runGet get . cookiePayload $ wmData w- return w { wmData = session }+type RemoveSession r s = forall m. (Monad m)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> r -- ^ The original response+ -> m s -- ^ Modified response -------------------------------------------------------------------------------- Add/remove session -- | Add cookie header to response. The function can throw the same -- exceptions as 'encryptSession'.-addSession- :: ( MonadIO m- , MonadThrow m- , Serialize a- , AddHeader (e :: Symbol) EncryptedSession s r- , ServerKeySet k )- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> RandomSource -- ^ Random source to use- -> k -- ^ Instance of 'ServerKeySet' to use- -> a -- ^ The session value- -> s -- ^ Response to add session to- -> m r -- ^ Response with the session added-addSession acs rs sk sessionData response = do- header <- renderSession acs rs sk sessionData+addSession :: (AddHeader (e :: Symbol) EncryptedSession r s) => AddSession r s+addSession acs rs sk pwSettings pwSession response = do+ header <- renderSession acs rs sk pwSettings pwSession () return (addHeader (EncryptedSession header) response) --- | "Remove" a session by invalidating the cookie.-removeSession :: ( Monad m,- AddHeader (e :: Symbol) EncryptedSession s r )- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> s -- ^ Response to return with session removed- -> m r -- ^ Response with the session "removed"+-- | "Remove" a session by invalidating the cookie.+removeSession :: (AddHeader (e :: Symbol) EncryptedSession r s) => RemoveSession r s removeSession acs response =- return (addHeader (EncryptedSession $ expiredCookie acs) response)+ return (addHeader (EncryptedSession $ renderExpiredSession acs) response) -- | Add cookie session to error allowing to set cookie even if response is -- not 200.--addSessionToErr- :: ( MonadIO m- , MonadThrow m- , Serialize a- , ServerKeySet k )- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> RandomSource -- ^ Random source to use- -> k -- ^ Instance of 'ServerKeySet' to use- -> a -- ^ The session value- -> ServantErr -- ^ Servant error to add the cookie to- -> m ServantErr-addSessionToErr acs rs sk sessionData err = do- header <- renderSession acs rs sk sessionData+addSessionToErr :: AddSession ServantErr ServantErr+addSessionToErr acs rs sk pwSettings pwSession err = do+ header <- renderSession acs rs sk pwSettings pwSession () return err { errHeaders = (hSetCookie, header) : errHeaders err } --- | "Remove" a session by invalidating the cookie.+-- | "Remove" a session by invalidating the cookie. -- Cookie expiry date is set at 0 and content is wiped-removeSessionFromErr :: ( Monad m )- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> ServantErr -- ^ Servant error to add the cookie to- -> m ServantErr+removeSessionFromErr :: RemoveSession ServantErr ServantErr removeSessionFromErr acs err =- return $ err { errHeaders = (hSetCookie, expiredCookie acs) : errHeaders err }+ return $ err { errHeaders = (hSetCookie, renderExpiredSession acs) : errHeaders err } --- | Cookie expiry date is set at 0 and content is wiped.-expiredCookie :: AuthCookieSettings -> ByteString-expiredCookie AuthCookieSettings{..} = (toByteString . renderCookies) cookies- where- cookies =- (acsSessionField, "") :- ("Path", acsPath) :- ("Expires", invalidDate) :- ((,"") <$> acsCookieFlags)- invalidDate = BSC8.pack $ formatTime- defaultTimeLocale- acsExpirationFormat- timeOrigin- timeOrigin = UTCTime (toEnum 0) 0 -- | Request handler that checks cookies. If 'Cookie' is just missing, you -- get 'Nothing', but if something is wrong with its format, 'getSession' -- can throw the same exceptions as 'decryptSession'. getSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k)- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> k -- ^ 'ServerKeySet' to use- -> Request -- ^ The request- -> m (Maybe (WithMetadata a)) -- ^ The result-getSession acs@AuthCookieSettings {..} sk request = maybe+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> k -- ^ 'ServerKeySet' to use+ -> Request -- ^ The request+ -> m (Maybe (ExtendedPayloadWrapper a)) -- ^ The result+getSession acs sk request = getSession' (requestHeaders request) acs sk++#if MIN_VERSION_servant(0,9,0)+-- | Get session from `Header "cookie" ByteString` in a route. Useful+-- for checking authentication without denying access to route.+--+-- If 'Cookie' is missing, you get 'Nothing', but but if something is+-- wrong with its format, 'getSession' can throw the same exceptions+-- as 'decryptSession'.+getHeaderSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k)+ => AuthCookieSettings+ -> k+ -> Text+ -> m (Maybe (ExtendedPayloadWrapper a))+getHeaderSession acs sk h = getSession' [(hCookie, toHeader h)] acs sk+#endif++getSession' :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k)+ => RequestHeaders+ -> AuthCookieSettings+ -> k+ -> m (Maybe (ExtendedPayloadWrapper a))+getSession' headers acs@AuthCookieSettings {..} sk = maybe (return Nothing) (liftM Just . decryptSession acs sk)- (parseSessionRequest acs $ requestHeaders request)+ (parseSessionRequest acs headers) + parseSession :: AuthCookieSettings -> HeaderName@@ -638,49 +702,120 @@ -> Maybe (Tagged SerializedEncryptedCookie ByteString) parseSessionResponse acs hdrs = parseSession acs hSetCookie hdrs ++renderSession'+ :: AuthCookieSettings+ -> (Tagged SerializedEncryptedCookie ByteString)+ -> Maybe (ByteString, ByteString)+ -> ByteString+renderSession' AuthCookieSettings{..} (Tagged sessionBinary) expiration+ = toByteString . renderCookies+ $ (acsSessionField, sessionBinary)+ : ("Path", acsPath)+ : ((maybe id (:) expiration)+ $ ((,"") <$> acsCookieFlags))+ -- | Render session cookie to 'ByteString'.-renderSession- :: ( MonadIO m- , MonadThrow m- , Serialize a- , ServerKeySet k )- => AuthCookieSettings- -> RandomSource- -> k- -> a- -> m ByteString-renderSession acs@AuthCookieSettings {..} rs sk sessionData = do- Tagged sessionBinary <- encryptSession acs rs sk sessionData- let cookies =- (acsSessionField, sessionBinary) :- ("Path", acsPath) :- ("Max-Age", (BSC8.pack . show . n) acsMaxAge) :- ((,"") <$> acsCookieFlags)- n = floor :: NominalDiffTime -> Int- (return . toByteString . renderCookies) cookies+renderSession :: AddSession () ByteString+renderSession acs rs sk pwSettings pwSession _ = liftM2 (renderSession' acs)+ (encryptSession acs rs sk pwSettings pwSession)+ (renderExpiration (acsMaxAge acs) (ssExpirationType pwSettings)) +-- | Render expired session to 'ByteString' (the date is set at 0 and the content is wiped).+renderExpiredSession :: AuthCookieSettings -> ByteString+renderExpiredSession acs = renderSession' acs (Tagged "") (Just ("Expires", longTimeAgo)) where+ longTimeAgo = BSC8.pack $ formatTime+ defaultTimeLocale+ expirationFormat+ timeOrigin+ timeOrigin = UTCTime (toEnum 0) 0 +-- | Render expiration value depending on it's type.+renderExpiration :: (MonadIO m) => NominalDiffTime -> ExpirationType -> m (Maybe (ByteString, ByteString))++renderExpiration maxAge Expires+ = liftM (addUTCTime maxAge) (liftIO getCurrentTime)+ >>= \t -> return . Just $ ("Expires", BSC8.pack $ formatTime defaultTimeLocale expirationFormat t)++renderExpiration maxAge MaxAge = return . Just $ ("Max-Age", (BSC8.pack . show . n) maxAge)+ where n = floor :: NominalDiffTime -> Int++renderExpiration _ Session = return Nothing++ #if MIN_VERSION_servant(0,9,1)--- | Wrapper for an implementation of an endpoint to make it automatically--- renew the cookies.-cookied :: (Serialize a, ServerKeySet k)- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> RandomSource -- ^ Random source to use- -> k -- ^ Instance of 'ServerKeySet' to use- -> (a -> r) -- ^ Implementation of an endpoint- -> ((WithMetadata a) -> Handler (Cookied r)) -- ^ "Cookied" endpoint-cookied acs rs k f = \(WithMetadata {..}) ->- (if wmRenew then addSession acs rs k wmData else (return . noHeader)) $ f wmData+-- | Type for curried 'cookied' function (with fixed settings, random+-- source, keyset and session type).+type CookiedWrapper c = forall f r. (CookiedWrapperClass f r c) => f -> r++-- | Wrapper for endpoints that use cookies. It transforms function of type:+-- >>> q1 -> q2 -> ... -> Session -> ... -> qN -> Handler r+-- into+-- >>> q1 -> q2 -> ... -> ExtendedPayloadWrapper Session -> ... qN -> Handler (Cookied r)+--+-- Non-session variables number can be arbitrary. It supposed to be+-- used in tandem with 'Cookied' type.+--+-- Using this wrapper requires FlexibleContexts extention to be turned+-- on. In case of curring 'cookied' function, it's highly recommended+-- to provide signature for this (see 'CookiedWrapper').+cookied+ :: (ServerKeySet k, Serialize c)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> RandomSource -- ^ Random source to use+ -> k -- ^ Instance of 'ServerKeySet' to use+ -> Proxy c -- ^ Type of session+ -> CookiedWrapper c -- ^ Wrapper that transforms given functions.+cookied acs rs k p = wrapCookied (acs, rs, k, p) Nothing++-- | Class of functions that can be wrapped with 'cookied'.+class CookiedWrapperClass f r c where+ wrapCookied+ :: (ServerKeySet k)+ => (AuthCookieSettings, RandomSource, k, Proxy c) -- ^ Environment+ -> Maybe (PayloadWrapper c) -- ^ Session value (if found)+ -> f -- ^ Tail of function to process+ -> r -- ^ Wrapped function++-- When no arguments left: add session header to result.+instance (Serialize c)+ => CookiedWrapperClass (Handler b) (Handler (Cookied b)) c where+ wrapCookied _ Nothing = fmap noHeader+ wrapCookied (acs, rs, k, _) (Just PayloadWrapper {..}) = (>>= addSession acs rs k pwSettings pwSession)++-- When the next argument is the one that should be wrapped: wrap it and carry it's value to the result.+instance (Serialize c, CookiedWrapperClass b b' c)+ => CookiedWrapperClass (c -> b) ((ExtendedPayloadWrapper c) -> b') c where+ wrapCookied env _ f = \ExtendedPayloadWrapper {..} -> let+ mc = if epwRenew+ then (Just PayloadWrapper {+ pwSession = epwSession+ , pwSettings = epwSettings+ , pwExpiration = epwExpiration})+ else Nothing+ in wrapCookied env mc (f epwSession)++-- Otherwise: accept argument as is.+instance (Serialize c, CookiedWrapperClass b b' c)+ => CookiedWrapperClass (a -> b) (a -> b') c where+ wrapCookied env ms f = wrapCookied env ms . f #endif ---------------------------------------------------------------------------- -- Default auth handler +-- | Type for exception handler.+type AuthCookieExceptionHandler = forall a. AuthCookieException -> Handler (Maybe (ExtendedPayloadWrapper a))++-- | Type for cookied handler.+type AuthCookieHandler a+ = forall k. (ServerKeySet k)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> k -- ^ Instance of 'ServerKeySet' to use+ -> AuthHandler Request (ExtendedPayloadWrapper a) -- ^ The result+ -- | Cookie authentication handler.-defaultAuthHandler :: (Serialize a, ServerKeySet k)- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> k -- ^ Instance of 'ServerKeySet' to use- -> AuthHandler Request (WithMetadata a) -- ^ The result+defaultAuthHandler :: (Serialize a) => AuthCookieHandler a defaultAuthHandler acs sk = mkAuthHandler $ \request -> do msession <- liftIO (getSession acs sk request) maybe (throwError err403) return msession@@ -721,21 +856,60 @@ else return l return (BS.take plen s) +-- | Derives key for a cookie based on server key and IV.+mkCookieKey+ :: (MonadThrow m, HashAlgorithm h, BlockCipher c)+ => Proxy c+ -> Proxy h+ -> Tagged ServerKeyBytes ByteString+ -> Tagged IVBytes ByteString+ -> m (Tagged CookieKeyBytes ByteString)+mkCookieKey c h (Tagged sk) (Tagged iv) = liftM Tagged $ mkProperKey (cipherKeySize (unProxy c)) (sign h sk iv)++-- | Generates random initial vector.+mkIV :: (MonadIO m, BlockCipher c)+ => RandomSource+ -> Proxy c+ -> m (Tagged IVBytes ByteString)+mkIV rs c = liftM Tagged $ getRandomBytes rs (blockSize (unProxy c))++-- | Generates padding of random bytes to align payload's length.+mkPadding :: (MonadIO m, BlockCipher c)+ => RandomSource+ -> Proxy c+ -> Tagged PayloadBytes ByteString+ -> m (Tagged PaddingBytes ByteString)+mkPadding rs c (Tagged payload) = liftM Tagged $ getRandomBytes rs l where+ bs = blockSize (unProxy c)+ n = BS.length payload+ l = (bs - (n `rem` bs)) `rem` bs++-- | Generates cookie's signature.+mkMAC :: (HashAlgorithm h)+ => Proxy h+ -> Tagged ServerKeyBytes ByteString+ -> Cookie+ -> Tagged MACBytes ByteString+mkMAC h (Tagged sk) Cookie {..} = Tagged . sign h sk $+ unTagged cookieIV+ <> unTagged cookiePayload+ <> unTagged cookiePadding+ -- | Applies given encryption or decryption algorithm to given data. applyCipherAlgorithm :: forall c m. (BlockCipher c, MonadThrow m)- => CipherAlgorithm c -- ^ The cipher algorithm to apply- -> ByteString -- ^ 'ByteString' from which to create 'IV'- -> ByteString -- ^ Proper key- -> ByteString -- ^ Cookie payload- -> m ByteString -- ^ The resulting 'ByteString'-applyCipherAlgorithm f ivRaw keyRaw msg = do+ => CipherAlgorithm c+ -> Tagged IVBytes ByteString+ -> Tagged CookieKeyBytes ByteString+ -> Tagged PayloadBytes ByteString+ -> m (Tagged PayloadBytes ByteString)+applyCipherAlgorithm f (Tagged ivRaw) (Tagged keyRaw) (Tagged msg) = do iv <- case makeIV ivRaw :: Maybe (IV c) of Nothing -> throwM (CannotMakeIV ivRaw) Just x -> return x key <- case cipherInit keyRaw :: CryptoFailable c of CryptoFailed err -> throwM (BadProperKey err) CryptoPassed x -> return x- (return . BA.convert) (f key iv msg)+ (return . Tagged . BA.convert) (f key iv msg) -- | Return bottom of type provided as 'Proxy' tag.
tests/Main.hs view
@@ -1,35 +1,31 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} module Main (main) where -import Control.Concurrent (threadDelay)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Crypto.Cipher.AES (AES128, AES192,- AES256)-import Crypto.Cipher.Types-import Crypto.Hash (HashAlgorithm, SHA256,- SHA384, SHA512)-import Crypto.Random (drgNew)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Default-import Data.Proxy-import Data.Serialize (Serialize)-import Data.Time-import GHC.Generics (Generic)-import Servant.Server.Experimental.Auth.Cookie-import Test.Hspec-import Test.QuickCheck+import Control.Concurrent (threadDelay)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Crypto.Cipher.AES (AES128, AES192, AES256)+import Crypto.Cipher.Types ()+import Crypto.Hash (SHA256(..),SHA384(..), SHA512(..))+import Crypto.Random (drgNew)+import Data.Default ()+import Data.Proxy ()+import Data.Time (UTCTime(..), NominalDiffTime, addUTCTime, getCurrentTime)+import Servant.Server.Experimental.Auth.Cookie+import Test.Hspec (Spec, context, shouldBe, shouldNotBe, it, describe, hspec)+import Test.Hspec.QuickCheck (modifyMaxSuccess)+import Test.QuickCheck ()+import Utils+import qualified Data.ByteString as BS #if !MIN_VERSION_base(4,8,0)-import Control.Applicative+import Control.Applicative ((<*>), (<$>)) #endif + main :: IO () main = hspec spec @@ -38,7 +34,6 @@ describe "RandomSource" randomSourceSpec describe "PersistentServerKey" persistentServerKeySpec describe "RenewalKeySet" renewalKeySetSpec- describe "Cookie" cookieSpec describe "Session" sessionSpec randomSourceSpec :: Spec@@ -81,7 +76,6 @@ renewalKeySetSpec :: Spec renewalKeySetSpec = spec' where- keySize :: Int keySize = 16 @@ -139,162 +133,58 @@ (k:ks') `shouldBe` ks -cookieSpec :: Spec-cookieSpec = do- context "when used with different encryption/decryption algorithms" $ do- it "works in CBC mode" $- testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) cbcEncrypt cbcDecrypt 64- it "works in CFB mode" $- testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) cfbEncrypt cfbDecrypt 64- it "works in CTR combine mode" $- testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100- context "when used with different ciphers" $ do- it "works with AES256" $- testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100- it "works with AES192" $- testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES192) ctrCombine ctrCombine 100- it "works with AES128" $- testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES128) ctrCombine ctrCombine 100- context "when used with different hash algorithms" $ do- it "works with SHA512" $- testCipher (Proxy :: Proxy SHA512) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100- it "works with SHA384" $- testCipher (Proxy :: Proxy SHA384) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100- it "works with SHA256" $- testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100- context "when cookie is corrupted" $- it "throws" $- let selectIncorrectMAC (IncorrectMAC _) = True- selectIncorrectMAC _ = False- in testCustomCookie- (mkCookie 10 100)- (BS.drop 1)- selectIncorrectMAC- context "when cookie has expired" $- it "throws CookieExpired" $- let selectCookieExpired (CookieExpired _ _) = True- selectCookieExpired _ = False- in testCustomCookie- (mkCookie 0 100)- id- selectCookieExpired--testCipher :: (HashAlgorithm h, BlockCipher c)- => Proxy h -- ^ Hash algorithm- -> Proxy c -- ^ Cipher- -> CipherAlgorithm c -- ^ Encryption algorithm- -> CipherAlgorithm c -- ^ Decryption algorithm- -> Int -- ^ Payload size- -> Expectation-testCipher h c encryptAlgorithm decryptAlgorithm size = do- cookie <- mkCookie 10 size- result <- cipherId h c encryptAlgorithm decryptAlgorithm cookie id- cookieIV result `shouldBe` cookieIV cookie- diffUTCTime (cookieExpirationTime cookie) (cookieExpirationTime result)- `shouldSatisfy` (< fromIntegral (1 :: Integer))- cookiePayload result `shouldBe` cookiePayload cookie--testCustomCookie- :: IO Cookie- -> (ByteString -> ByteString)- -> Selector AuthCookieException- -> Expectation-testCustomCookie mkCookie' encryptionHook selector = do- cookie <- mkCookie'- cipherId- (Proxy :: Proxy SHA256)- (Proxy :: Proxy AES256)- ctrCombine ctrCombine- cookie- encryptionHook- `shouldThrow` selector--mkCookie :: Int -> Int -> IO Cookie-mkCookie dt size = do- rs <- mkRandomSource drgNew 1000- iv <- getRandomBytes rs 16- expiration <- addUTCTime (fromIntegral dt) <$> getCurrentTime- payload <- getRandomBytes rs size- return Cookie- { cookieIV = iv- , cookieExpirationTime = expiration- , cookiePayload = payload }--cipherId :: (HashAlgorithm h, BlockCipher c)- => Proxy h -- ^ Hash algorithm- -> Proxy c -- ^ Cipher- -> CipherAlgorithm c -- ^ Encryption algorithm- -> CipherAlgorithm c -- ^ Decryption algorithm- -> Cookie -- ^ 'Cookie' to encrypt- -> (BS.ByteString -> BS.ByteString) -- ^ Encryption hook- -> IO Cookie -- ^ Restored 'Cookie'-cipherId h c encryptAlgorithm decryptAlgorithm cookie encryptionHook = do- sk <- mkPersistentServerKey <$> generateRandomBytes 16-- let sts =- case def of- AuthCookieSettings {..} -> AuthCookieSettings- { acsEncryptAlgorithm = encryptAlgorithm- , acsDecryptAlgorithm = decryptAlgorithm- , acsHashAlgorithm = h- , acsCipher = c- , .. }- encryptCookie sts sk cookie >>= (fmap wmData . decryptCookie sts sk . fmap encryptionHook)- sessionSpec :: Spec-sessionSpec = do- let treesOfInt = Proxy :: Proxy Int- treesOfString = Proxy :: Proxy String-- context "when session is encrypted and decrypted" $ do- it "is not distorted in any way (1)" $- property $ \session -> encryptThenDecrypt treesOfInt def session `shouldReturn` session- it "is not distored in any way (2)" $- property $ \session -> encryptThenDecrypt treesOfString def session `shouldReturn` session- context "when session is encrypted and decrypted (CBC mode)" $ do- let sts = case def of- AuthCookieSettings{..} -> AuthCookieSettings- { acsEncryptAlgorithm = cbcEncrypt- , acsDecryptAlgorithm = cbcDecrypt- , .. }- it "is not distorted in any way (1)" $- property $ \session -> encryptThenDecrypt treesOfInt sts session `shouldReturn` session- it "is not distored in any way (2)" $- property $ \session -> encryptThenDecrypt treesOfString sts session `shouldReturn` session- context "when session is encrypted and decrypted (CFB mode)" $ do- let sts =- case def of- AuthCookieSettings {..} -> AuthCookieSettings- { acsEncryptAlgorithm = cfbEncrypt- , acsDecryptAlgorithm = cfbDecrypt- , .. }- it "is not distorted in any way (1)" $- property $ \session -> encryptThenDecrypt treesOfInt sts session `shouldReturn` session- it "is not distored in any way (2)" $- property $ \session -> encryptThenDecrypt treesOfString sts session `shouldReturn` session--encryptThenDecrypt :: Serialize a- => Proxy a- -> AuthCookieSettings- -> Tree a- -> IO (Tree a)-encryptThenDecrypt _ settings x = do- rs <- mkRandomSource drgNew 1000- sk <- mkPersistentServerKey <$> generateRandomBytes 16- encryptSession settings rs sk x >>= (fmap wmData . decryptSession settings sk)+sessionSpec = modifyMaxSuccess (const 10) $ do+ context "when session is encrypted and decrypted"+ $(groupRoundTrip $ map (\(h, c, m, a) -> genPropRoundTrip h c m a 'modifyId 'checkEquals)+ [(h, c, m, a) |+ h <- [''SHA256, ''SHA384, ''SHA512]+ , c <- [''AES128, ''AES192, ''AES256]+ , m <- [''CBCMode, ''CFBMode, ''CTRMode]+ , a <- [''Int, ''String]+ ]) -data Tree a = Leaf a | Node a [Tree a] deriving (Eq, Show, Generic)+ context "when base64 encoding is erroneous"+ $(groupRoundTrip $ map (\(h, c, m, a) -> genPropRoundTrip h c m a 'modifyBase64 'checkSessionDeserializationFailed)+ [(h, c, m, a) |+ h <- [''SHA256, ''SHA384, ''SHA512]+ , c <- [''AES128, ''AES192, ''AES256]+ , m <- [''CBCMode, ''CFBMode, ''CTRMode]+ , a <- [''Int, ''String]+ ]) -instance Serialize a => Serialize (Tree a)+ context "when cereal encoding is erroneous (cookie)" $+ $(groupRoundTrip $ map (\(h, c, m, a) -> genPropRoundTrip h c m a 'modifyCookie 'checkSessionDeserializationFailed)+ [(h, c, m, a) |+ h <- [''SHA256, ''SHA384, ''SHA512]+ , c <- [''AES128, ''AES192, ''AES256]+ , m <- [''CBCMode, ''CFBMode, ''CTRMode]+ , a <- [''Int, ''String]+ ]) -instance Arbitrary a => Arbitrary (Tree a) where- arbitrary = sized arbitraryTree+ context "when cereal encoding is erroneous (payload)" $+ $(groupRoundTrip $ map (\(h, c, m, a) -> genPropRoundTrip h c m a 'modifyPayload 'checkSessionDeserializationFailed)+ [(h, c, m, a) |+ h <- [''SHA256, ''SHA384, ''SHA512]+ , c <- [''AES128, ''AES192, ''AES256]+ , m <- [''CBCMode, ''CFBMode, ''CTRMode]+ , a <- [''Int, ''String]+ ]) -arbitraryTree :: Arbitrary a => Int -> Gen (Tree a)-arbitraryTree 0 = Leaf <$> arbitrary-arbitraryTree n = do- l <- choose (0, n `quot` 2)- oneof- [ Leaf <$> arbitrary- , Node <$> arbitrary <*> vectorOf l (arbitraryTree (n `quot` 2))]+ context "when MAC is erroneous" $+ $(groupRoundTrip $ map (\(h, c, m, a) -> genPropRoundTrip h c m a 'modifyMAC 'checkIncorrectMAC)+ [(h, c, m, a) |+ h <- [''SHA256, ''SHA384, ''SHA512]+ , c <- [''AES128, ''AES192, ''AES256]+ , m <- [''CBCMode, ''CFBMode, ''CTRMode]+ , a <- [''Int, ''String]+ ]) + context "when cookie has expired" $+ $(groupRoundTrip $ map (\(h, c, m, a) -> genPropRoundTrip h c m a 'modifyExpiration 'checkCookieExpired)+ [(h, c, m, a) |+ h <- [''SHA256, ''SHA384, ''SHA512]+ , c <- [''AES128, ''AES192, ''AES256]+ , m <- [''CBCMode, ''CFBMode, ''CTRMode]+ , a <- [''Int, ''String]+ ])