diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/example/AuthAPI.hs b/example/AuthAPI.hs new file mode 100644 --- /dev/null +++ b/example/AuthAPI.hs @@ -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" + diff --git a/example/FileKeySet.hs b/example/FileKeySet.hs new file mode 100644 --- /dev/null +++ b/example/FileKeySet.hs @@ -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) diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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) diff --git a/example/Test.hs b/example/Test.hs --- a/example/Test.hs +++ b/example/Test.hs @@ -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 diff --git a/servant-auth-cookie.cabal b/servant-auth-cookie.cabal --- a/servant-auth-cookie.cabal +++ b/servant-auth-cookie.cabal @@ -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 diff --git a/src/Servant/Server/Experimental/Auth/Cookie.hs b/src/Servant/Server/Experimental/Auth/Cookie.hs --- a/src/Servant/Server/Experimental/Auth/Cookie.hs +++ b/src/Servant/Server/Experimental/Auth/Cookie.hs @@ -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. diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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] + ])