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 - [email protected]
+
+- 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))]
+
