Hello community, here is the log from the commit of package ghc-servant-auth-cookie for openSUSE:Factory checked in at 2017-08-31 20:59:08 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-auth-cookie (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-auth-cookie.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-auth-cookie" Thu Aug 31 20:59:08 2017 rev:3 rq:513483 version:0.5.0.5 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-auth-cookie/ghc-servant-auth-cookie.changes 2017-05-18 20:51:03.384090972 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-auth-cookie.new/ghc-servant-auth-cookie.changes 2017-08-31 20:59:11.188461327 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:14 UTC 2017 - psimons@suse.com + +- Update to version 0.5.0.5. + +------------------------------------------------------------------- Old: ---- servant-auth-cookie-0.4.4.tar.gz New: ---- servant-auth-cookie-0.5.0.5.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-auth-cookie.spec ++++++ --- /var/tmp/diff_new_pack.ZmsgKF/_old 2017-08-31 20:59:12.300305110 +0200 +++ /var/tmp/diff_new_pack.ZmsgKF/_new 2017-08-31 20:59:12.316302863 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant-auth-cookie %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.4 +Version: 0.5.0.5 Release: 0 Summary: Authentication via encrypted cookies License: BSD-3-Clause ++++++ servant-auth-cookie-0.4.4.tar.gz -> servant-auth-cookie-0.5.0.5.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/CHANGELOG.md new/servant-auth-cookie-0.5.0.5/CHANGELOG.md --- old/servant-auth-cookie-0.4.4/CHANGELOG.md 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/CHANGELOG.md 2017-07-13 10:40:23.000000000 +0200 @@ -1,6 +1,40 @@ # Change Log -## [0.4.4] +## [HEAD] + +## [0.5.0.5] - 2017-07-13 +### Changed +- Fixed dependencies' bounds. + +## [0.5.0.4] - 2017-05-27 +### Changed +- Fixed dependencies' bounds. + +## [0.5.0.3] - 2017-05-24 +### Changed +- Fixed dependencies' bounds. + +## [0.5.0.2] - 2017-04-26 +### Changed +- Fixed dependencies' bounds. + +## [0.5.0.1] - 2017-04-16 +### Changed +- Fixed incompatibility with older versions of GHC. + +## [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. @@ -87,7 +121,13 @@ - Initial version of the package. -[HEAD]: ../../compare/v0.4.4...HEAD +[HEAD]: ../../compare/v0.5.0.5...HEAD +[0.5.0.5]: ../../compare/v0.5.0.4...v0.5.0.5 +[0.5.0.4]: ../../compare/v0.5.0.3...v0.5.0.4 +[0.5.0.3]: ../../compare/v0.5.0.2...v0.5.0.3 +[0.5.0.2]: ../../compare/v0.5.0.1...v0.5.0.2 +[0.5.0.1]: ../../compare/v0.5.0...v0.5.0.1 +[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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/example/Main.hs new/servant-auth-cookie-0.5.0.5/example/Main.hs --- old/servant-auth-cookie-0.4.4/example/Main.hs 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/example/Main.hs 2017-07-13 10:40:23.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/example/Test.hs new/servant-auth-cookie-0.5.0.5/example/Test.hs --- old/servant-auth-cookie-0.4.4/example/Test.hs 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/example/Test.hs 2017-07-13 10:40:23.000000000 +0200 @@ -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 where + SpecState :: (ServerKeySet k) => + { ssRandomSource :: RandomSource + , ssAuthSettings :: AuthCookieSettings + , ssServerKeySet :: k + , ssGenerateKey :: IO () + } -> SpecState -data SpecState = SpecState { - ssRandomSource :: RandomSource - , ssServerKey :: ServerKey - , ssAuthSettings :: AuthCookieSettings - } main :: IO () -main = withState (hspec . spec) where - withState f = do - let ssAuthSettings = authSettings - ssRandomSource <- mkRandomSource drgNew 1000 - ssServerKey <- mkServerKey 16 Nothing - f $ SpecState {..} - - -spec :: SpecState -> Spec -spec SpecState {..} = with (return $ app ssAuthSettings ssRandomSource ssServerKey) $ do - - let formContentType = ( - hContentType - , renderHeader $ contentType (Proxy :: Proxy FormUrlEncoded)) +main = do + rs <- mkRandomSource drgNew 1000 + + return SpecState + { ssRandomSource = rs + , ssAuthSettings = authSettings + , ssServerKeySet = mkPersistentServerKey "0123456789abcdef" + , ssGenerateKey = return () + } >>= hspec . basicSpec + +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) + let rmDir name = doesDirectoryExist name + >>= \exists -> when exists $ removeDirectoryRecursive name + + bracket + (do + let keySetDir = "./test-key-set" + rmDir keySetDir + return FileKSParams + { fkspMaxKeys = 3 + , fkspKeySize = 16 + , fkspPath = keySetDir + } >>= \fksp -> (fksp,) <$> mkFileKeySet fksp) + + (rmDir . fkspPath . fst) + + (\(fksp, ks) -> hspec . renewalSpec $ SpecState + { ssRandomSource = rs + , ssAuthSettings = authSettings + , ssServerKeySet = ks + , ssGenerateKey = mkFileKey fksp + }) +#endif - describe "home page" $ do +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) - } - - describe "private page" $ do - let loginForm = encode $ LoginForm { - lfUsername = "mr_foo" - , lfPassword = "password1" - } - let loginRequest = request methodPost "/login" [formContentType] loginForm + login "noname" "noname" `shouldRespondWithMarkup` (loginPage False) + + 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 - - cookieValue <- liftIO $ do - session <- maybe - (error "cookies aren't available") - (decryptSession ssAuthSettings ssServerKey) - (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account - - sk <- mkServerKey 16 Nothing - renderSession ssAuthSettings ssRandomSource sk session + let newServerKeySet = mkPersistentServerKey "0000000000000000" + cookieValue <- loginRequest + >>= liftIO . forgeCookies ss authSettings newServerKeySet + getPrivate cookieValue `shouldRespondWithException` (IncorrectMAC "") - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - - r `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 "") + 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) + + +#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 "adds new key" $ do + keys <- extractKeys + addKey + keys' <- extractKeys + liftIO $ keys `shouldBe` (tail keys') + + it "removes a key" $ do + keys <- extractKeys + remKey $ last keys + keys' <- extractKeys + liftIO $ keys' `shouldBe` (init keys) - it "rejects requests with malformed expiration time" $ do - (SResponse {..}) <- loginRequest + context "cookies" $ do + let loginRequest = login "mr_foo" "password1" - cookieValue <- liftIO $ do - session <- maybe + let getCookieValue req = req >>= \resp -> return $ fromMaybe (error "cookies aren't available") - (decryptSession ssAuthSettings ssServerKey) - (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account + (lookup "set-cookie" $ simpleHeaders resp) - renderSession - ssAuthSettings { acsExpirationFormat = "%0Y%m%d" } - ssRandomSource - ssServerKey - session + it "rejects requests with deleted keys" $ do + cookieValue <- getCookieValue loginRequest + getPrivate cookieValue `shouldRespondWith` 200 - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - r `shouldRespondWithException` (CannotParseExpirationTime "") + key <- head <$> extractKeys + addKey >> remKey key + getPrivate cookieValue `shouldRespondWith` 403 - it "rejects requests with expired cookies" $ do - (SResponse {..}) <- loginRequest - - cookieValue <- liftIO $ do - session <- maybe - (error "cookies aren't available") - (decryptSession ssAuthSettings ssServerKey) - (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account + it "accepts requests with old key and renews cookie" $ do + cookieValue <- getCookieValue loginRequest + getPrivate cookieValue `shouldRespondWith` 200 - renderSession - ssAuthSettings { acsMaxAge = 0 } - ssRandomSource - ssServerKey - session + key <- head <$> extractKeys + addKey + newCookieValue <- getCookieValue (getPrivate cookieValue) - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - let dummyTime = UTCTime (toEnum 0) 0 - - 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 + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/servant-auth-cookie.cabal new/servant-auth-cookie-0.5.0.5/servant-auth-cookie.cabal --- old/servant-auth-cookie-0.4.4/servant-auth-cookie.cabal 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/servant-auth-cookie.cabal 2017-07-13 10:40:23.000000000 +0200 @@ -1,5 +1,5 @@ name: servant-auth-cookie -version: 0.4.4 +version: 0.5.0.5 synopsis: Authentication via encrypted cookies description: Authentication via encrypted client-side cookies, inspired by client-session library by Michael Snoyman and based on @@ -26,12 +26,18 @@ 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. + manual: True default: False @@ -45,14 +51,14 @@ , bytestring , cereal >= 0.5 && < 0.6 , cookie >= 0.4.1 && < 0.5 - , cryptonite >= 0.14 && < 0.23 + , cryptonite >= 0.14 && < 0.25 , data-default , exceptions >= 0.8 && < 0.9 , http-types >= 0.9 && < 0.10 , memory >= 0.11 && < 0.15 , mtl >= 2.0 && < 3.0 - , servant >= 0.5 && < 0.11 - , servant-server >= 0.5 && < 0.11 + , servant >= 0.5 && < 0.12 + , servant-server >= 0.5 && < 0.12 , tagged == 0.8.* , time >= 1.5 && < 1.8.1 , transformers >= 0.4 && < 0.6 @@ -70,9 +76,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 @@ -87,12 +98,13 @@ , QuickCheck >= 2.4 && < 3.0 , bytestring , cereal >= 0.5 && < 0.6 - , cryptonite >= 0.14 && < 0.23 + , cryptonite >= 0.14 && < 0.25 , data-default , deepseq >= 1.3 && < 1.5 , hspec >= 2.0 && < 3.0 , servant-auth-cookie - , servant-server >= 0.5 && < 0.11 + , servant-server >= 0.5 && < 0.12 + , transformers >= 0.4 && < 0.6 , time >= 1.5 && < 1.8.1 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* @@ -106,21 +118,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 + , cryptonite >= 0.14 && < 0.25 , data-default + , directory , exceptions + , filepath , http-media + , http-types , mtl >= 2.0 && < 3.0 - , servant >= 0.5 && < 0.11 + , servant >= 0.5 && < 0.12 , servant-auth-cookie , servant-blaze >= 0.5 && < 0.10 - , servant-server >= 0.5 && < 0.11 + , servant-server >= 0.5 && < 0.12 , 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,25 +170,29 @@ 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 , cereal >= 0.5 && < 0.6 , exceptions - , cryptonite >= 0.14 && < 0.23 + , cryptonite >= 0.14 && < 0.25 , 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 + , servant-server >= 0.5 && < 0.12 , 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 +200,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.* @@ -201,10 +227,10 @@ build-depends: base >= 4.7 && < 5.0 , bytestring - , criterion >= 0.6.2.1 && < 1.2 - , cryptonite >= 0.14 && < 0.23 + , criterion >= 0.6.2.1 && < 1.3 + , cryptonite >= 0.14 && < 0.25 , servant-auth-cookie - , servant-server >= 0.5 && < 0.11 + , servant-server >= 0.5 && < 0.12 if flag(dev) ghc-options: -Wall -Werror else diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/src/Servant/Server/Experimental/Auth/Cookie.hs new/servant-auth-cookie-0.5.0.5/src/Servant/Server/Experimental/Auth/Cookie.hs --- old/servant-auth-cookie-0.4.4/src/Servant/Server/Experimental/Auth/Cookie.hs 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/src/Servant/Server/Experimental/Auth/Cookie.hs 2017-07-13 10:40:23.000000000 +0200 @@ -23,6 +23,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} module Servant.Server.Experimental.Auth.Cookie ( CipherAlgorithm @@ -30,14 +31,26 @@ , 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 (..) @@ -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) 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,7 +150,14 @@ -- | 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 @@ -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 {..} - --- | 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 {..} +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 + + removeKey RenewableKeySet {..} key = do + found <- liftIO $ atomicModifyIORef' rksState $ \(keys, s) -> let + (found, keys') = first (not . null) . partition (== key) $ keys + in ((keys', s), found) + when found $ (rkshRemoveKey rksHooks) rksParameters key + +-- | 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 {..} --- | 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 - --- | 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 liftM (,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) + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/tests/Main.hs new/servant-auth-cookie-0.5.0.5/tests/Main.hs --- old/servant-auth-cookie-0.4.4/tests/Main.hs 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/tests/Main.hs 2017-07-13 10:40:23.000000000 +0200 @@ -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,33 +63,81 @@ 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 @@ -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))] +