servant-auth-cookie 0.4.4 → 0.5.0
raw patch · 6 files changed
+582/−285 lines, 6 filesdep +directorydep +filepathdep ~http-typesdep ~servantdep ~time
Dependencies added: directory, filepath
Dependency ranges changed: http-types, servant, time
Files
- CHANGELOG.md +17/−2
- example/Main.hs +26/−14
- example/Test.hs +197/−101
- servant-auth-cookie.cabal +35/−10
- src/Servant/Server/Experimental/Auth/Cookie.hs +222/−125
- tests/Main.hs +85/−33
CHANGELOG.md view
@@ -1,7 +1,21 @@ # Change Log -## [0.4.4]+## [HEAD]++## [0.5.0] - 2017-04-15+### Changed+- Server keys management:+ - `ServerKey` becomes `ServerKeySet`.+ - `mkServerKeyFromBytes` becomes `mkPersistentServerKey`.++### Deleted+- `mkServerKey` (instead use custom instance of `ServerKeySet`.+ ### Added+- class `Cookied` and function `cookied` to faciliate usage of mutable server keys.++## [0.4.4] - 2017-04-15+### Added - Tests for the example. - `parseSessionRequest` and `parseSessionResponse` functions. - `removeSessionFromErr` function.@@ -87,7 +101,8 @@ - Initial version of the package. -[HEAD]: ../../compare/v0.4.4...HEAD+[HEAD]: ../../compare/v0.5.0...HEAD+[0.5.0]: ../../compare/v0.4.4...v0.5.0 [0.4.4]: ../../compare/v0.4.3.3...v0.4.4 [0.4.3.3]: ../../compare/v0.4.3.2...v0.4.3.3 [0.4.3.2]: ../../compare/v0.4.3.1...v0.4.3.2
example/Main.hs view
@@ -1,11 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Main (main) where import AuthAPI (app, authSettings)@@ -15,13 +10,30 @@ import Network.Wai.Handler.Warp (run) import Servant.Server.Experimental.Auth.Cookie +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5)+import FileKeySet (mkFileKeySet, FileKSParams(..), mkFileKey)+#endif++-- To use mutable server keys we need servant-9.1 and+-- directory-1.2.5 (or higher). Otherwise the only (sane) choice is a+-- persistent key.+ main :: IO () main = do rs <- mkRandomSource drgNew 1000- -- NOTE:- -- Every time the application is executed, a new server key is- -- created. This means, once you restart the app, already existing- -- cookies will be invalidated.- sk <- mkServerKey 16 Nothing- run 8080 (app authSettings rs sk) +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5)+ let fksp = FileKSParams+ { fkspKeySize = 16+ , fkspMaxKeys = 3+ , fkspPath = "./test-key-set"+ }++ k <- mkFileKeySet fksp+ let generateKey = mkFileKey fksp+#else+ let k = mkPersistentServerKey "0123456789abcdef"+ let generateKey = return ()+#endif++ run 8080 (app authSettings generateKey rs k)
example/Test.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TupleSections #-} import Prelude () import Prelude.Compat@@ -9,18 +11,20 @@ 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, it)+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 Crypto.Random (drgNew) import Servant (FormUrlEncoded, contentType) import Servant.Server.Experimental.Auth.Cookie-import Network.HTTP.Types (methodGet, methodPost, hContentType, hCookie)+import Network.HTTP.Types (Header, methodGet, methodPost, hContentType, hCookie) import Network.HTTP.Media.RenderHeader (renderHeader) import Network.Wai.Test (SResponse(..))+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSC8+import qualified Data.ByteString.Lazy.Char8 as BSLC8 #if MIN_VERSION_hspec_wai (0,7,0) import Test.Hspec.Wai.Matcher (bodyEquals, ResponseMatcher(..), MatchBody(..))@@ -34,142 +38,173 @@ import Servant (ToFormUrlEncoded, mimeRender) #endif +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5)+import FileKeySet (mkFileKeySet, FileKSParams(..), mkFileKey)+import Control.Arrow ((***))+import Control.Monad (void, when)+import Data.Monoid ((<>))+import Control.Exception.Base (bracket)+import Network.HTTP.Types (urlEncode)+import Test.Hspec (shouldBe, 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 = SpecState {- ssRandomSource :: RandomSource- , ssServerKey :: ServerKey- , ssAuthSettings :: AuthCookieSettings- } +data SpecState where+ SpecState :: (ServerKeySet k) =>+ { ssRandomSource :: RandomSource+ , ssAuthSettings :: AuthCookieSettings+ , ssServerKeySet :: k+ , ssGenerateKey :: IO ()+ } -> SpecState++ main :: IO ()-main = withState (hspec . spec) where- withState f = do- let ssAuthSettings = authSettings- ssRandomSource <- mkRandomSource drgNew 1000- ssServerKey <- mkServerKey 16 Nothing- f $ SpecState {..}+main = do+ rs <- mkRandomSource drgNew 1000 + return SpecState+ { ssRandomSource = rs+ , ssAuthSettings = authSettings+ , ssServerKeySet = mkPersistentServerKey "0123456789abcdef"+ , ssGenerateKey = return ()+ } >>= hspec . basicSpec -spec :: SpecState -> Spec-spec SpecState {..} = with (return $ app ssAuthSettings ssRandomSource ssServerKey) $ do+#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5)+ let rmDir name = doesDirectoryExist name+ >>= \exists -> when exists $ removeDirectoryRecursive name - let formContentType = (- hContentType- , renderHeader $ contentType (Proxy :: Proxy FormUrlEncoded))+ bracket+ (do+ let keySetDir = "./test-key-set"+ rmDir keySetDir+ return FileKSParams+ { fkspMaxKeys = 3+ , fkspKeySize = 16+ , fkspPath = keySetDir+ } >>= \fksp -> (fksp,) <$> mkFileKeySet fksp) - describe "home page" $ do+ (rmDir . fkspPath . fst)++ (\(fksp, ks) -> hspec . renewalSpec $ SpecState+ { ssRandomSource = rs+ , ssAuthSettings = authSettings+ , ssServerKeySet = ks+ , ssGenerateKey = mkFileKey fksp+ })+#endif++basicSpec :: SpecState -> Spec+basicSpec ss@(SpecState {..}) = describe "basic functionality" $ with+ (return $ app ssAuthSettings ssGenerateKey ssRandomSource ssServerKeySet) $ do++ context "home page" $ do it "responds successfully" $ do- get "/" `shouldRespondWith` 200 {- matchBody = matchBody' $ renderMarkup homePage- }+ get "/" `shouldRespondWithMarkup` homePage - describe "login page" $ do+ context "login page" $ do it "responds successfully" $ do- get "/login" `shouldRespondWith` 200 {- matchBody = matchBody' $ renderMarkup (loginPage True)- }+ get "/login" `shouldRespondWithMarkup` (loginPage True) it "shows message on incorrect login" $ do- let loginForm = encode $ LoginForm {- lfUsername = "noname"- , lfPassword = "noname"- }- let r = request methodPost "/login" [formContentType] loginForm- r `shouldRespondWith` 200 {- matchBody = matchBody' $ renderMarkup (loginPage False)- }+ login "noname" "noname" `shouldRespondWithMarkup` (loginPage False) - describe "private page" $ do- let loginForm = encode $ LoginForm {- lfUsername = "mr_foo"- , lfPassword = "password1"- }- let loginRequest = request methodPost "/login" [formContentType] loginForm+ context "private page" $ do+ let loginRequest = login "mr_foo" "password1" it "rejects requests without cookies" $ do- let r = get "/private"- r `shouldRespondWith` 403 { matchBody = matchBody' "No cookies" }+ 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)-- let r = request methodGet "/private" [(hCookie, cookieValue)] ""- r `shouldRespondWith` 200+ getPrivate cookieValue `shouldRespondWith` 200 it "accepts requests with proper cookies (sanity check)" $ do- (SResponse {..}) <- loginRequest-- cookieValue <- liftIO $ do- session <- maybe- (error "cookies aren't available")- (decryptSession ssAuthSettings ssServerKey)- (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account-- renderSession ssAuthSettings ssRandomSource ssServerKey session-- let r = request methodGet "/private" [(hCookie, cookieValue)] ""- r `shouldRespondWith` 200-+ cookieValue <- loginRequest+ >>= liftIO . forgeCookies ss authSettings ssServerKeySet+ getPrivate cookieValue `shouldRespondWith` 200 it "rejects requests with incorrect MAC" $ do- (SResponse {..}) <- loginRequest+ let newServerKeySet = mkPersistentServerKey "0000000000000000"+ cookieValue <- loginRequest+ >>= liftIO . forgeCookies ss authSettings newServerKeySet+ getPrivate cookieValue `shouldRespondWithException` (IncorrectMAC "") - cookieValue <- liftIO $ do- session <- maybe- (error "cookies aren't available")- (decryptSession ssAuthSettings ssServerKey)- (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account+ 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 "") - sk <- mkServerKey 16 Nothing- renderSession ssAuthSettings ssRandomSource sk session+ 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) - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - r `shouldRespondWithException` (IncorrectMAC "")+#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5)+renewalSpec :: SpecState -> Spec+renewalSpec (SpecState {..}) = describe "renewal functionality" $ with+ (return $ app ssAuthSettings ssGenerateKey ssRandomSource ssServerKeySet) $ do + context "keys" $ do+ it "automatically creates a key" $ do+ keys <- extractKeys+ liftIO $ keys `shouldSatisfy` ((== 1) . length) - it "rejects requests with malformed expiration time" $ do- (SResponse {..}) <- loginRequest+ it "adds new key" $ do+ keys <- extractKeys+ addKey+ keys' <- extractKeys+ liftIO $ keys `shouldBe` (tail keys') - cookieValue <- liftIO $ do- session <- maybe- (error "cookies aren't available")- (decryptSession ssAuthSettings ssServerKey)- (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account+ it "removes a key" $ do+ keys <- extractKeys+ remKey $ last keys+ keys' <- extractKeys+ liftIO $ keys' `shouldBe` (init keys) - renderSession- ssAuthSettings { acsExpirationFormat = "%0Y%m%d" }- ssRandomSource- ssServerKey- session+ context "cookies" $ do+ let loginRequest = login "mr_foo" "password1" - let r = request methodGet "/private" [(hCookie, cookieValue)] ""- r `shouldRespondWithException` (CannotParseExpirationTime "")+ let getCookieValue req = req >>= \resp -> return $ fromMaybe+ (error "cookies aren't available")+ (lookup "set-cookie" $ simpleHeaders resp) + it "rejects requests with deleted keys" $ do+ cookieValue <- getCookieValue loginRequest+ getPrivate cookieValue `shouldRespondWith` 200 - it "rejects requests with expired cookies" $ do- (SResponse {..}) <- loginRequest+ key <- head <$> extractKeys+ addKey >> remKey key - cookieValue <- liftIO $ do- session <- maybe- (error "cookies aren't available")- (decryptSession ssAuthSettings ssServerKey)- (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account+ getPrivate cookieValue `shouldRespondWith` 403 - renderSession- ssAuthSettings { acsMaxAge = 0 }- ssRandomSource- ssServerKey- session+ it "accepts requests with old key and renews cookie" $ do+ cookieValue <- getCookieValue loginRequest+ getPrivate cookieValue `shouldRespondWith` 200 - let r = request methodGet "/private" [(hCookie, cookieValue)] ""- let dummyTime = UTCTime (toEnum 0) 0+ key <- head <$> extractKeys+ addKey+ newCookieValue <- getCookieValue (getPrivate cookieValue) - r `shouldRespondWithException` (CookieExpired dummyTime dummyTime)+ remKey key+ getPrivate newCookieValue `shouldRespondWith` 200 + it "does not renew cookies for the newest key" $ do+ cookieValue <- getCookieValue loginRequest+ _ <- getPrivate cookieValue `shouldRespondWith` 200+ r <- getPrivate cookieValue+ liftIO $ (lookup "set-cookie" $ simpleHeaders r) `shouldBe` Nothing+#endif #if MIN_VERSION_hspec_wai (0,7,0) matchBody' :: BSL.ByteString -> MatchBody@@ -192,8 +227,69 @@ shouldRespondWithException :: WaiSession SResponse -> AuthCookieException -> WaiExpectation shouldRespondWithException req ex = do- let exception = BSC8.pack . head . words . show $ ex- (shrinkBody (BSC8.length exception) <$> req) `shouldRespondWith` 403 {- matchBody = matchBody' exception+ let exception = BSLC8.pack . head . words . show $ ex+ (shrinkBody (BSLC8.length exception) <$> req) `shouldRespondWith` 403 {+ matchBody = matchBody' exception }++shouldRespondWithMarkup :: WaiSession SResponse -> Markup -> WaiExpectation+shouldRespondWithMarkup req markup = do+ req `shouldRespondWith` 200 {+ matchBody = matchBody' $ renderMarkup markup+ }++formContentType :: Header+formContentType = (+ hContentType+ , renderHeader $ contentType (Proxy :: Proxy FormUrlEncoded))++login :: String -> String -> WaiSession SResponse+login lfUsername lfPassword = request+ methodPost "/login" [formContentType] (encode LoginForm {..})++getPrivate :: BS.ByteString -> WaiSession SResponse+getPrivate cookieValue = request+ methodGet "/private" [(hCookie, cookieValue)] ""++extractSession :: SpecState -> SResponse -> IO (WithMetadata Account)+extractSession SpecState {..} SResponse {..} = maybe+ (error "cookies aren't available")+ (decryptSession ssAuthSettings ssServerKeySet)+ (parseSessionResponse ssAuthSettings simpleHeaders)++forgeCookies :: (ServerKeySet k)+ => SpecState+ -> AuthCookieSettings+ -> k+ -> SResponse+ -> IO BS.ByteString+forgeCookies ss newAuthSettings newServerKeySet r = extractSession ss r+ >>= renderSession newAuthSettings (ssRandomSource ss) newServerKeySet . wmData+++#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5)+extractKeys :: WaiSession [BS.ByteString]+extractKeys = (extractKeys' . BSL.toStrict . simpleBody) <$> get "/keys" where+ del = '#'++ (openTag, closeTag) = (id *** BS.drop 1) $ BSC8.span (/= del) $+ BSL.toStrict . renderMarkup $+ H.span H.! A.class_ "key" $ H.toHtml [del]++ shrinkBy prefix = BS.drop . BS.length $ prefix++ extractKeys' body = let+ body' = snd $ BS.breakSubstring openTag body+ (key, rest) = shrinkBy openTag *** shrinkBy closeTag $+ BS.breakSubstring closeTag body'+ in if BS.null body'+ then []+ else key:(extractKeys' rest)++addKey :: WaiSession ()+addKey = void $ get "/keys/add"++remKey :: BS.ByteString -> WaiSession ()+remKey key = void $ get $ "/keys/rem/" <> (urlEncode True $ key)+#endif
servant-auth-cookie.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-cookie-version: 0.4.4+version: 0.5.0 synopsis: Authentication via encrypted cookies description: Authentication via encrypted client-side cookies, inspired by client-session library by Michael Snoyman and based on@@ -26,10 +26,15 @@ default: False flag servant9- description: Use servant-0.9+ description: Use servant-0.9 (or higher) manual: False default: True +flag servant91+ description: Use servant-0.9.1 (or higher)+ manual: False+ default: True+ flag build-examples description: Build example executables. default: False@@ -70,9 +75,14 @@ servant >= 0.9, http-api-data == 0.3.* else- build-depends:- servant < 0.9,- bytestring-conversion >= 0.3.1 && <0.4+ if flag(servant91)+ build-depends:+ servant >= 0.9,+ http-api-data == 0.3.*+ else+ build-depends:+ servant < 0.9,+ bytestring-conversion >= 0.3.1 && <0.4 test-suite tests type: exitcode-stdio-1.0@@ -93,6 +103,7 @@ , hspec >= 2.0 && < 3.0 , servant-auth-cookie , servant-server >= 0.5 && < 0.11+ , transformers >= 0.4 && < 0.6 , time >= 1.5 && < 1.8.1 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.*@@ -106,21 +117,26 @@ if flag(build-examples) build-depends: base >= 4.7 && < 5.0 , base-compat >= 0.9.1 && <0.10+ , base64-bytestring , blaze-html >= 0.8 && < 0.10 , blaze-markup >= 0.7 && < 0.9 , bytestring , cereal >= 0.5 && < 0.6 , cryptonite >= 0.14 && < 0.23 , data-default+ , directory , exceptions+ , filepath , http-media+ , http-types , mtl >= 2.0 && < 3.0 , servant >= 0.5 && < 0.11 , servant-auth-cookie , servant-blaze >= 0.5 && < 0.10 , servant-server >= 0.5 && < 0.11 , text- , transformers >= 0.4 && < 0.6+ , time+ , transformers >= 0.4 && < 0.6 , wai >= 3.0 && < 3.3 , warp >= 3.0 && < 3.3 if flag(servant9)@@ -153,6 +169,7 @@ if flag(build-examples) build-depends: base >= 4.7 && < 5.0 , base-compat >= 0.9.1 && <0.10+ , base64-bytestring , blaze-markup , blaze-html >= 0.8 && < 0.10 , bytestring@@ -161,17 +178,20 @@ , cryptonite >= 0.14 && < 0.23 , data-default , deepseq >= 1.3 && < 1.5+ , directory+ , filepath , http-media , http-types , hspec >= 2.0 && < 3.0 , hspec-wai+ , mtl >= 2.0 && < 3.0 , QuickCheck >= 2.4 && < 3.0 , servant-auth-cookie , servant-blaze >= 0.5 && < 0.10 , servant-server >= 0.5 && < 0.11 , text , time >= 1.5 && < 1.8.1- , transformers >= 0.4 && < 0.6+ , transformers >= 0.4 && < 0.6 , wai , wai-extra if flag(servant9)@@ -179,9 +199,14 @@ servant >= 0.9, http-api-data == 0.3.* else- build-depends:- servant < 0.9,- bytestring-conversion >= 0.3.1 && <0.4+ if flag(servant91)+ build-depends:+ servant >= 0.9.1,+ http-api-data == 0.3.*+ else+ build-depends:+ servant < 0.9,+ bytestring-conversion >= 0.3.1 && <0.4 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.*
src/Servant/Server/Experimental/Auth/Cookie.hs view
@@ -23,6 +23,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-} module Servant.Server.Experimental.Auth.Cookie ( CipherAlgorithm@@ -30,15 +31,27 @@ , Cookie (..) , AuthCookieException (..) + , WithMetadata (..)+#if MIN_VERSION_servant(0,9,1)+ , Cookied+ , cookied+#endif+ , RandomSource , mkRandomSource , getRandomBytes+ , generateRandomBytes , ServerKey- , mkServerKey- , mkServerKeyFromBytes- , getServerKey+ , ServerKeySet (..) + , PersistentServerKey+ , mkPersistentServerKey++ , RenewableKeySet+ , RenewableKeySetHooks (..)+ , mkRenewableKeySet+ , AuthCookieSettings (..) , EncryptedSession (..)@@ -56,16 +69,16 @@ , removeSessionFromErr , getSession + , defaultAuthHandler+ -- exposed for testing purpose , renderSession , parseSessionRequest , parseSessionResponse-- , defaultAuthHandler ) where import Blaze.ByteString.Builder (toByteString)-import Control.Arrow ((&&&))+import Control.Arrow ((&&&), first, second) import Control.Monad import Control.Monad.Catch (MonadThrow (..), Exception) import Control.Monad.Except@@ -75,11 +88,12 @@ import Crypto.Hash (HashAlgorithm(..)) import Crypto.Hash.Algorithms (SHA256) import Crypto.MAC.HMAC (HMAC)-import Crypto.Random (drgNew, DRG(..))+import Crypto.Random (DRG(..), drgNew) import Data.ByteString (ByteString) import Data.Default import Data.IORef-import Data.Maybe (fromMaybe)+import Data.List (partition)+import Data.Maybe (listToMaybe) import Data.Monoid ((<>)) import Data.Proxy import Data.Serialize@@ -112,14 +126,22 @@ import Data.ByteString.Conversion (ToByteString (..)) #endif +#if MIN_VERSION_servant(0,9,1)+import Servant (noHeader, Handler)+import Servant.API.ResponseHeaders (Headers)+import qualified Servant.API.Header as S(Header)+#endif+ #if MIN_VERSION_http_types(0,9,2) import Network.HTTP.Types (hSetCookie)+#endif++#if MIN_VERSION_http_types(0,9,2) #else hSetCookie :: HeaderName hSetCookie = "Set-Cookie" #endif - ---------------------------------------------------------------------------- -- General types @@ -128,8 +150,15 @@ -- | A type family that maps user-defined data to 'AuthServerData'. type family AuthCookieData-type instance AuthServerData (AuthProtect "cookie-auth") = 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+ }++type instance AuthServerData (AuthProtect "cookie-auth") = WithMetadata AuthCookieData+ -- | Cookie representation. data Cookie = Cookie { cookieIV :: ByteString -- ^ The initialization vector@@ -154,8 +183,12 @@ builder (EncryptedSession s) = builder s #endif --- | The exception is thrown when something goes wrong with this package.+#if MIN_VERSION_servant(0,9,1)+-- | Helper type to wrap endpoints.+type Cookied a = Headers '[S.Header "Set-Cookie" EncryptedSession] a+#endif +-- | The exception is thrown when something goes wrong with this package. data AuthCookieException = CannotMakeIV ByteString -- ^ Could not make 'IV' for block cipher.@@ -203,8 +236,8 @@ -- | Constructor for 'RandomSource' value. mkRandomSource :: (MonadIO m, DRG d)- => IO d -- ^ How to get deterministic random generator- -> Int -- ^ Threshold (number of bytes to be generated before resetting)+ => IO d -- ^ How to get deterministic random generator+ -> Int -- ^ Threshold (number of bytes to be generated before resetting) -> m RandomSource -- ^ New 'RandomSource' value mkRandomSource mkDRG threshold = RandomSource mkDRG threshold `liftM` liftIO ((,0) <$> mkDRG >>= newIORef)@@ -226,74 +259,103 @@ ---------------------------------------------------------------------------- -- Server key --- | A mutable state of ServerKey.-data ServerKeyState = ServerKeyState- { sksBytes :: ByteString- -- ^ Current value of the key- , sksExpirationTime :: UTCTime- -- ^ When the key is expires+-- | Internal representation of a server key.+type ServerKey = ByteString++-- | Interface for a set of server keys.+class ServerKeySet k where+ getKeys :: (MonadThrow m, MonadIO m) => k -> m (ServerKey, [ServerKey])+ -- ^ Retrieve current and rotated keys respectively.++ removeKey :: (MonadThrow m, MonadIO m) => k -> ServerKey -> m ()+ -- ^ Non-graciously remove the key from a keyset.+++-- | A keyset containing only one key, that doesn't change.+data PersistentServerKey = PersistentServerKey+ { pskBytes :: ServerKey }++instance ServerKeySet PersistentServerKey where+ getKeys = return . (,[]) . pskBytes+ removeKey _ = error "removeKey @PersistentServerKey: not implemented"++-- | Create instance of 'PersistentServerKey'.+mkPersistentServerKey :: ByteString -> PersistentServerKey+mkPersistentServerKey bytes = PersistentServerKey { pskBytes = bytes }+++-- | Customizable actions for 'RenewableKeySet'.+data RenewableKeySetHooks s p = RenewableKeySetHooks+ { rkshNewState :: forall m. (MonadIO m, MonadThrow m)+ => p -- KeySet parameters+ -> ([ServerKey], s) -- Current state+ -> m ([ServerKey], s) -- New state+ -- ^ Called when a keyset needs to refresh it's state. It's result might be+ -- discarded occasionally in favour of result yielded in another thread.++ , rkshNeedUpdate :: forall m. (MonadIO m, MonadThrow m)+ => p -- KeySet parameters+ -> ([ServerKey], s) -- Current state+ -> m Bool -- Whether to update the state+ -- ^ Called before retrieving the keys and refreshing the state.++ , rkshRemoveKey :: forall m. (MonadIO m, MonadThrow m)+ => p -- KeySet parameters+ -> ServerKey -- Key to remove+ -> m () -- Action to perform+ -- ^ Called after removing the key. This hook is called only if the key+ -- belongs to a keyset and called once per key. The only purpose of it is+ -- to clear the garbage after removing the key. The state might differs+ -- after removing the key and before calling the hook, therefore the hook+ -- doesn't rely on the state. } --- | A wrapper of self-resetting 'ByteString' of random symbols suitable for--- concurrent usage.-data ServerKey = ServerKey- { skSize :: Int- -- ^ Size of the key (in bytes)- , skMaxAge :: Maybe NominalDiffTime- -- ^ Expiration time ('Nothing' is enternity)- , skState :: IORef ServerKeyState- -- ^ Mutable state of the key++-- | Customizable key set, that provides partial implementation of+-- 'ServerKeySet'.+data RenewableKeySet s p = RenewableKeySet+ { rksState :: IORef ([ServerKey], s)+ -- ^ Key set state (keys and user-defined state).++ , rksParameters :: p+ -- ^ User-defined parameters of the key set.++ , rksHooks :: RenewableKeySetHooks s p+ -- ^ USer-defined hooks of the key set. } --- | Constructor for 'ServerKey' value.-mkServerKey :: MonadIO m- => Int -- ^ Size of the server key- -> Maybe NominalDiffTime -- ^ Expiration time ('Nothing' is eternity)- -> m ServerKey -- ^ New 'ServerKey'-mkServerKey skSize skMaxAge = liftIO $ do- skState <- mkServerKeyState skSize skMaxAge >>= newIORef- return ServerKey {..}+instance (Eq s) => ServerKeySet (RenewableKeySet s p) where+ getKeys RenewableKeySet {..} = getKeys' rksHooks where+ getKeys' RenewableKeySetHooks {..} = do+ state <- liftIO $ readIORef rksState+ rkshNeedUpdate rksParameters state+ >>= \needUpdate -> if not needUpdate+ then return $ toResult state+ else do+ state' <- rkshNewState rksParameters state+ liftIO $ atomicModifyIORef' rksState $ \state'' -> id &&& toResult $+ if (userState state /= userState state'')+ then state''+ else state'+ toResult = (head &&& tail) . fst+ userState = snd --- | Constructor for 'ServerKey' value using predefined key.-mkServerKeyFromBytes :: MonadIO m- => ByteString -- ^ Predefined key- -> m ServerKey -- ^ New 'ServerKey'-mkServerKeyFromBytes bytes = liftIO $ do- let skSize = BS.length bytes- let skMaxAge = Nothing- skState <- newIORef ServerKeyState- { sksBytes = bytes- , sksExpirationTime = UTCTime (toEnum 0) 0- -- we don't care about the time as the key never expires- }- return ServerKey {..}+ removeKey RenewableKeySet {..} key = do+ found <- liftIO $ atomicModifyIORef' rksState $ \state -> let+ (keys', found) = second (not . null) . partition (/= key) . fst $ state+ in (first (const keys') state, found)+ when found $ (rkshRemoveKey rksHooks) rksParameters key --- | Extract value from 'ServerKey'.-getServerKey :: MonadIO m- => ServerKey -- ^ The 'ServerKey'- -> m ByteString -- ^ Its random symbol-getServerKey ServerKey {..} = liftIO $ maybe- (sksBytes <$> readIORef skState)- (\_ -> do- currentTime <- getCurrentTime- state <- readIORef skState- case (currentTime > sksExpirationTime state) of- False -> return $ sksBytes state- True -> do- state' <- mkServerKeyState skSize skMaxAge- atomicModifyIORef' skState $ \state'' -> id &&& sksBytes $- if (sksBytes state == sksBytes state'') then state' else state'')- skMaxAge+-- | Create instance of 'RenewableKeySet'.+mkRenewableKeySet :: (MonadIO m)+ => RenewableKeySetHooks s p -- ^ Hooks+ -> p -- ^ Parameters+ -> s -- ^ Initial state+ -> m (RenewableKeySet s p)+mkRenewableKeySet rksHooks rksParameters userState = liftIO $ do+ rksState <- newIORef ([], userState)+ return RenewableKeySet {..} --- | An initializer of 'ServerKey' state.-mkServerKeyState- :: Int -- ^ Size of the server key- -> Maybe NominalDiffTime -- ^ Expiration time ('Nothing' is eternity)- -> IO ServerKeyState-mkServerKeyState skSize skMaxAge = do- sksBytes <- fst . randomBytesGenerate skSize <$> drgNew- sksExpirationTime <- addUTCTime (fromMaybe 0 skMaxAge) <$> getCurrentTime- return ServerKeyState {..} ---------------------------------------------------------------------------- -- Settings@@ -347,18 +409,18 @@ -- * 'TooShortProperKey' -- * 'CannotMakeIV' -- * 'BadProperKey'-encryptCookie :: (MonadIO m, MonadThrow m)+encryptCookie :: (MonadIO m, MonadThrow m, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> ServerKey -- ^ 'ServerKey' to use- -> Cookie -- ^ The 'Cookie' to encrypt+ -> k -- ^ Instance of 'ServerKeySet' to use+ -> Cookie -- ^ The 'Cookie' to encrypt -> m (Tagged EncryptedCookie ByteString) -- ^ Encrypted 'Cookie' is form of 'ByteString'-encryptCookie AuthCookieSettings {..} sk cookie = do+encryptCookie AuthCookieSettings {..} sks cookie = do let iv = cookieIV cookie expiration = BSC8.pack $ formatTime defaultTimeLocale acsExpirationFormat (cookieExpirationTime cookie)- serverKey <- getServerKey sk+ (serverKey, _) <- getKeys sks key <- mkProperKey (cipherKeySize $ unProxy acsCipher) (sign acsHashAlgorithm serverKey $ iv <> expiration)@@ -383,12 +445,12 @@ -- * 'IncorrectMAC' -- * 'CannotParseExpirationTime' -- * 'CookieExpired'-decryptCookie :: (MonadIO m, MonadThrow m)+decryptCookie :: (MonadIO m, MonadThrow m, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> ServerKey -- ^ 'ServerKey' to use+ -> k -- ^ Instance of 'ServerKeySet' to use -> Tagged EncryptedCookie ByteString -- ^ The 'ByteString' to decrypt- -> m Cookie -- ^ The decrypted 'Cookie'-decryptCookie AuthCookieSettings {..} sk (Tagged s) = do+ -> m (WithMetadata Cookie) -- ^ The decrypted 'Cookie'+decryptCookie AuthCookieSettings {..} sks (Tagged s) = do currentTime <- liftIO getCurrentTime let ivSize = blockSize (unProxy acsCipher) expSize =@@ -399,9 +461,16 @@ (iv, s0) = BS.splitAt ivSize s (expirationRaw, s1) = BS.splitAt expSize s0 (payloadRaw, mac) = BS.splitAt payloadSize s1- serverKey <- getServerKey sk- when (mac /= sign acsHashAlgorithm serverKey (BS.take butMacSize s)) $- throwM (IncorrectMAC mac)+ checkMac sk = mac == sign acsHashAlgorithm sk (BS.take butMacSize s)++ (currentKey, rotatedKeys) <- getKeys sks+ (serverKey, renew) <- if checkMac currentKey+ then return (currentKey, False)+ else (,True) <$> maybe+ (throwM $ IncorrectMAC mac)+ (return)+ (listToMaybe . map fst . filter snd . map (id &&& checkMac) $ rotatedKeys)+ expirationTime <- maybe (throwM $ CannotParseExpirationTime expirationRaw) return $ parseTimeM False defaultTimeLocale acsExpirationFormat@@ -412,21 +481,25 @@ (cipherKeySize (unProxy acsCipher)) (sign acsHashAlgorithm serverKey $ BS.take (ivSize + expSize) s) payload <- applyCipherAlgorithm acsDecryptAlgorithm iv key payloadRaw- return Cookie- { cookieIV = iv- , cookieExpirationTime = expirationTime- , cookiePayload = payload }+ let cookie = Cookie+ { cookieIV = iv+ , cookieExpirationTime = expirationTime+ , cookiePayload = payload }+ return WithMetadata+ { wmData = cookie+ , wmRenew = renew+ } ---------------------------------------------------------------------------- -- Encrypt/decrypt session -- | Pack session object into a cookie. The function can throw the same -- exceptions as 'encryptCookie'.-encryptSession :: (MonadIO m, MonadThrow m, Serialize a)+encryptSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> RandomSource -- ^ Random source to use- -> ServerKey -- ^ 'ServerKey' to use- -> a -- ^ Session value+ -> 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)@@ -444,16 +517,18 @@ -- | Unpack session value from a cookie. The function can throw the same -- exceptions as 'decryptCookie'.-decryptSession :: (MonadIO m, MonadThrow m, Serialize a)+decryptSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> ServerKey -- ^ 'ServerKey' to use+ -> k -- ^ Instance of 'ServerKeySet' to use -> Tagged SerializedEncryptedCookie ByteString -- ^ Cookie in binary form- -> m a -- ^ Unpacked session value-decryptSession acs@AuthCookieSettings {..} sk s =+ -> m (WithMetadata a) -- ^ Unpacked session value+decryptSession acs@AuthCookieSettings {..} sks s = let fromRight = either (throwM . SessionDeserializationFailed) return in fromRight (base64Decode s) >>=- decryptCookie acs sk >>=- fromRight . runGet get . cookiePayload+ decryptCookie acs sks >>=+ \w -> do+ session <- fromRight . runGet get . cookiePayload $ wmData w+ return w { wmData = session } ---------------------------------------------------------------------------- -- Add/remove session@@ -464,13 +539,14 @@ :: ( MonadIO m , MonadThrow m , Serialize a- , AddHeader (e :: Symbol) EncryptedSession s r )+ , AddHeader (e :: Symbol) EncryptedSession s r+ , ServerKeySet k ) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> RandomSource -- ^ Random source to use- -> ServerKey -- ^ 'ServerKey' to use- -> a -- ^ The session value- -> s -- ^ Response to add session to- -> m r -- ^ Response with the session added+ -> 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 return (addHeader (EncryptedSession header) response)@@ -490,12 +566,13 @@ addSessionToErr :: ( MonadIO m , MonadThrow m- , Serialize a )+ , Serialize a+ , ServerKeySet k ) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> RandomSource -- ^ Random source to use- -> ServerKey -- ^ 'ServerKey' to use- -> a -- ^ The session value- -> ServantErr -- ^ Servant error to add the cookie to+ -> 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@@ -528,11 +605,11 @@ -- | 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)- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> ServerKey -- ^ 'ServerKey' to use- -> Request -- ^ The request- -> m (Maybe a) -- ^ The result+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 (return Nothing) (liftM Just . decryptSession acs sk)@@ -565,10 +642,11 @@ renderSession :: ( MonadIO m , MonadThrow m- , Serialize a )+ , Serialize a+ , ServerKeySet k ) => AuthCookieSettings -> RandomSource- -> ServerKey+ -> k -> a -> m ByteString renderSession acs@AuthCookieSettings {..} rs sk sessionData = do@@ -581,14 +659,28 @@ n = floor :: NominalDiffTime -> Int (return . toByteString . renderCookies) cookies ++#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+#endif+ ---------------------------------------------------------------------------- -- Default auth handler -- | Cookie authentication handler.-defaultAuthHandler :: Serialize a- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> ServerKey -- ^ 'ServerKey' to use- -> AuthHandler Request a -- ^+defaultAuthHandler :: (Serialize a, ServerKeySet k)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> k -- ^ Instance of 'ServerKeySet' to use+ -> AuthHandler Request (WithMetadata a) -- ^ The result defaultAuthHandler acs sk = mkAuthHandler $ \request -> do msession <- liftIO (getSession acs sk request) maybe (throwError err403) return msession@@ -599,9 +691,9 @@ -- | Applies 'H.hmac' algorithm to given data. sign :: forall h. HashAlgorithm h => Proxy h -- ^ The hash algorithm to use- -> ByteString -- ^- -> ByteString- -> ByteString+ -> ByteString -- ^ The key+ -> ByteString -- ^ The message+ -> ByteString -- ^ The result sign Proxy key msg = BA.convert (H.hmac key msg :: HMAC h) {-# INLINE sign #-} @@ -649,3 +741,8 @@ unProxy :: Proxy a -> a unProxy Proxy = undefined++-- | Generates random sequence of bytes from new DRG+generateRandomBytes :: Int -> IO ByteString+generateRandomBytes size = (fst . randomBytesGenerate size <$> drgNew)+
tests/Main.hs view
@@ -8,6 +8,7 @@ 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@@ -34,10 +35,11 @@ spec :: Spec spec = do- describe "RandomSource" randomSourceSpec- describe "ServerKey" serverKeySpec- describe "Cookie" cookieSpec- describe "Session" sessionSpec+ describe "RandomSource" randomSourceSpec+ describe "PersistentServerKey" persistentServerKeySpec+ describe "RenewalKeySet" renewalKeySetSpec+ describe "Cookie" cookieSpec+ describe "Session" sessionSpec randomSourceSpec :: Spec randomSourceSpec = do@@ -61,34 +63,82 @@ s2 <- getRandomBytes rs 10 s1 `shouldNotBe` s2 -serverKeySpec :: Spec-serverKeySpec = do- context "when creating a new server key" $+persistentServerKeySpec :: Spec+persistentServerKeySpec = do+ context "when creating a new persistent server key" $ do+ let keySize = 64+ let getSK = mkPersistentServerKey <$> generateRandomBytes keySize+ >>= getKeys+ it "has correct size" $ do- let keySize = 64- sk <- mkServerKey keySize Nothing- k <- getServerKey sk+ (k, _) <- getSK BS.length k `shouldNotBe` (keySize `div` 8)- context "when creating a new server key from data" $- it "has data as server key" $ do- let bytes = "0123456789"- sk <- mkServerKeyFromBytes bytes- k <- getServerKey sk- k `shouldBe` bytes- context "until expiration" $- it "returns the same key" $ do- sk <- mkServerKey 16 Nothing- k0 <- getServerKey sk- k1 <- getServerKey sk- k0 `shouldBe` k1- context "when a key expires" $- it "is reset" $ do- sk <- mkServerKey 16 (Just $ fromIntegral (1 :: Integer))- k1 <- getServerKey sk- threadDelay 2000000- k2 <- getServerKey sk- k1 `shouldNotBe` k2 + it "has no rotated keys" $ do+ (_, ks) <- getSK+ length ks `shouldBe` 0+++renewalKeySetSpec :: Spec+renewalKeySetSpec = spec' where++ keySize :: Int+ keySize = 16++ rkshNewState :: (MonadIO m)+ => NominalDiffTime+ -> ([ServerKey], UTCTime)+ -> m ([ServerKey], UTCTime)+ rkshNewState _ (keys, _) = liftIO $ (,)+ <$> (fmap (:keys) $ generateRandomBytes keySize)+ <*> getCurrentTime++ rkshNeedUpdate :: (MonadIO m)+ => NominalDiffTime+ -> ([ServerKey], UTCTime)+ -> m Bool+ rkshNeedUpdate dt (_, t) = liftIO $ getCurrentTime >>= return . ((dt `addUTCTime` t) <)++ rkshRemoveKey :: (MonadIO m)+ => NominalDiffTime+ -> ServerKey+ -> m ()+ rkshRemoveKey _ _ = return ()++ spec' = do+ let makeSK = mkRenewableKeySet+ RenewableKeySetHooks {..}+ (fromIntegral (1 :: Integer))+ (UTCTime (toEnum 0) 0)++ context "when accessing a renewable key set" $ do+ it "updates the keys when needed" $ do+ sk <- makeSK++ (k, ks) <- getKeys sk+ BS.length k `shouldNotBe` 0++ (_, ks') <- threadDelay 1500000 >> getKeys sk+ ks' `shouldBe` (k:ks)++ it "doesn't update the keys when not needed" $ do+ sk <- makeSK+ k <- getKeys sk+ k' <- getKeys sk+ k' `shouldBe` k++ context "when removing key from a renewable key set" $ do+ it "removes specified key" $ do+ sk <- makeSK+ (_, ks) <- getKeys sk >> threadDelay 1500000 >> getKeys sk+ length ks `shouldNotBe` 0++ let k = head ks+ removeKey sk k+ (_, ks') <- getKeys sk+ (k:ks') `shouldBe` ks++ cookieSpec :: Spec cookieSpec = do context "when used with different encryption/decryption algorithms" $ do@@ -179,7 +229,8 @@ -> (BS.ByteString -> BS.ByteString) -- ^ Encryption hook -> IO Cookie -- ^ Restored 'Cookie' cipherId h c encryptAlgorithm decryptAlgorithm cookie encryptionHook = do- sk <- mkServerKey 16 Nothing+ sk <- mkPersistentServerKey <$> generateRandomBytes 16+ let sts = case def of AuthCookieSettings {..} -> AuthCookieSettings@@ -188,7 +239,7 @@ , acsHashAlgorithm = h , acsCipher = c , .. }- encryptCookie sts sk cookie >>= decryptCookie sts sk . fmap encryptionHook+ encryptCookie sts sk cookie >>= (fmap wmData . decryptCookie sts sk . fmap encryptionHook) sessionSpec :: Spec sessionSpec = do@@ -229,8 +280,8 @@ -> IO (Tree a) encryptThenDecrypt _ settings x = do rs <- mkRandomSource drgNew 1000- sk <- mkServerKey 16 Nothing- encryptSession settings rs sk x >>= decryptSession settings sk+ sk <- mkPersistentServerKey <$> generateRandomBytes 16+ encryptSession settings rs sk x >>= (fmap wmData . decryptSession settings sk) data Tree a = Leaf a | Node a [Tree a] deriving (Eq, Show, Generic) @@ -246,3 +297,4 @@ oneof [ Leaf <$> arbitrary , Node <$> arbitrary <*> vectorOf l (arbitraryTree (n `quot` 2))]+