servant-auth-cookie 0.4.3.3 → 0.4.4
raw patch · 5 files changed
+332/−26 lines, 5 filesdep +hspec-waidep +wai-extradep ~blaze-markupdep ~exceptionsdep ~http-types
Dependencies added: hspec-wai, wai-extra
Dependency ranges changed: blaze-markup, exceptions, http-types, servant, time, wai
Files
- CHANGELOG.md +9/−2
- example/Main.hs +4/−0
- example/Test.hs +199/−0
- servant-auth-cookie.cabal +52/−3
- src/Servant/Server/Experimental/Auth/Cookie.hs +68/−21
CHANGELOG.md view
@@ -1,7 +1,13 @@ # Change Log -## [Unreleased]+## [0.4.4]+### Added+- Tests for the example.+- `parseSessionRequest` and `parseSessionResponse` functions.+- `removeSessionFromErr` function. +### Changed+- Fixed constraint for `removeSession`. ## [0.4.3.3] ### Added@@ -81,7 +87,8 @@ - Initial version of the package. -[HEAD]: ../../compare/v0.4.3.3...HEAD+[HEAD]: ../../compare/v0.4.4...HEAD+[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 [0.4.3.1]: ../../compare/v0.4.3...v0.4.3.1
example/Main.hs view
@@ -18,6 +18,10 @@ 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)
+ example/Test.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++import Prelude ()+import Prelude.Compat+import Data.Maybe (fromMaybe)+import Data.Int (Int64)+import Data.Time.Clock (UTCTime(..))+import Control.Monad.IO.Class (liftIO)+import AuthAPI (app, authSettings, LoginForm(..), homePage, loginPage, Account(..))+import Test.Hspec (Spec, hspec, describe, it)+import Test.Hspec.Wai (WaiSession, WaiExpectation, shouldRespondWith, with, request, get)+import Text.Blaze.Renderer.Utf8 (renderMarkup)+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.Media.RenderHeader (renderHeader)+import Network.Wai.Test (SResponse(..))+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSC8++#if MIN_VERSION_hspec_wai (0,7,0)+import Test.Hspec.Wai.Matcher (bodyEquals, ResponseMatcher(..), MatchBody(..))+#else+import Test.Hspec.Wai (matchBody)+#endif++#if MIN_VERSION_servant (0,9,0)+import Web.FormUrlEncoded (ToForm, toForm, urlEncodeForm)+#else+import Servant (ToFormUrlEncoded, mimeRender)+#endif+++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))++ describe "home page" $ do+ it "responds successfully" $ do+ get "/" `shouldRespondWith` 200 {+ matchBody = matchBody' $ renderMarkup homePage+ }++ describe "login page" $ do+ it "responds successfully" $ do+ get "/login" `shouldRespondWith` 200 {+ matchBody = matchBody' $ renderMarkup (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++ it "rejects requests without cookies" $ do+ let r = get "/private"+ r `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++ 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+++ 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 r = request methodGet "/private" [(hCookie, cookieValue)] ""++ r `shouldRespondWithException` (IncorrectMAC "")+++ it "rejects requests with malformed expiration time" $ do+ (SResponse {..}) <- loginRequest++ cookieValue <- liftIO $ do+ session <- maybe+ (error "cookies aren't available")+ (decryptSession ssAuthSettings ssServerKey)+ (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account++ renderSession+ ssAuthSettings { acsExpirationFormat = "%0Y%m%d" }+ ssRandomSource+ ssServerKey+ session++ let r = request methodGet "/private" [(hCookie, cookieValue)] ""+ r `shouldRespondWithException` (CannotParseExpirationTime "")+++ 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++ renderSession+ ssAuthSettings { acsMaxAge = 0 }+ ssRandomSource+ ssServerKey+ session++ let r = request methodGet "/private" [(hCookie, cookieValue)] ""+ let dummyTime = UTCTime (toEnum 0) 0++ r `shouldRespondWithException` (CookieExpired dummyTime dummyTime)+++#if MIN_VERSION_hspec_wai (0,7,0)+matchBody' :: BSL.ByteString -> MatchBody+matchBody' = bodyEquals+#else+matchBody' :: BSL.ByteString -> Maybe BSL.ByteString+matchBody' = Just+#endif++#if MIN_VERSION_servant (0,9,0)+encode :: ToForm a => a -> BSL.ByteString+encode = urlEncodeForm . toForm+#else+encode :: ToFormUrlEncoded a => a -> BSL.ByteString+encode = mimeRender (Proxy :: Proxy FormUrlEncoded)+#endif++shrinkBody :: Int64 -> SResponse -> SResponse+shrinkBody len r = r { simpleBody = BSL.take len $ simpleBody r }++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+ }+
servant-auth-cookie.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-cookie-version: 0.4.3.3+version: 0.4.4 synopsis: Authentication via encrypted cookies description: Authentication via encrypted client-side cookies, inspired by client-session library by Michael Snoyman and based on@@ -54,7 +54,7 @@ , servant >= 0.5 && < 0.11 , servant-server >= 0.5 && < 0.11 , tagged == 0.8.*- , time >= 1.5 && < 1.8+ , time >= 1.5 && < 1.8.1 , transformers >= 0.4 && < 0.6 , wai >= 3.0 && < 3.3 @@ -93,7 +93,7 @@ , hspec >= 2.0 && < 3.0 , servant-auth-cookie , servant-server >= 0.5 && < 0.11- , time >= 1.5 && < 1.8+ , time >= 1.5 && < 1.8.1 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* default-language: Haskell2010@@ -140,6 +140,55 @@ ghc-options: -O2 -Wall default-language: Haskell2010 ++test-suite example-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: example+ main-is: Test.hs+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall++ if flag(build-examples)+ build-depends: base >= 4.7 && < 5.0+ , base-compat >= 0.9.1 && <0.10+ , blaze-markup+ , blaze-html >= 0.8 && < 0.10+ , bytestring+ , cereal >= 0.5 && < 0.6+ , exceptions+ , cryptonite >= 0.14 && < 0.23+ , data-default+ , deepseq >= 1.3 && < 1.5+ , http-media+ , http-types+ , hspec >= 2.0 && < 3.0+ , hspec-wai+ , QuickCheck >= 2.4 && < 3.0+ , servant-auth-cookie+ , servant-blaze >= 0.5 && < 0.10+ , servant-server >= 0.5 && < 0.11+ , text+ , time >= 1.5 && < 1.8.1+ , transformers >= 0.4 && < 0.6+ , wai+ , wai-extra+ if flag(servant9)+ build-depends:+ servant >= 0.9,+ 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.*+ else+ buildable: False++ default-language: Haskell2010 benchmark bench
src/Servant/Server/Experimental/Auth/Cookie.hs view
@@ -53,10 +53,13 @@ , addSession , removeSession , addSessionToErr+ , removeSessionFromErr , getSession -- exposed for testing purpose , renderSession+ , parseSessionRequest+ , parseSessionResponse , defaultAuthHandler ) where@@ -84,7 +87,7 @@ import Data.Tagged (Tagged (..), retag) import Data.Typeable import GHC.TypeLits (Symbol)-import Network.HTTP.Types (hCookie)+import Network.HTTP.Types (hCookie, HeaderName, RequestHeaders, ResponseHeaders) import Network.Wai (Request, requestHeaders) import Servant (addHeader, ServantErr (..)) import Servant.API.Experimental.Auth (AuthProtect)@@ -97,6 +100,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as BSC8+import qualified Network.HTTP.Types as N(Header) #if !MIN_VERSION_base(4,8,0) import Control.Applicative@@ -108,6 +112,14 @@ import Data.ByteString.Conversion (ToByteString (..)) #endif +#if MIN_VERSION_http_types(0,9,2)+import Network.HTTP.Types (hSetCookie)+#else+hSetCookie :: HeaderName+hSetCookie = "Set-Cookie"+#endif++ ---------------------------------------------------------------------------- -- General types @@ -464,25 +476,13 @@ return (addHeader (EncryptedSession header) response) -- | "Remove" a session by invalidating the cookie.--- Cookie expiry date is set at 0 and content is wiped removeSession :: ( Monad m,- AddHeader (e :: Symbol) ByteString s r )+ AddHeader (e :: Symbol) EncryptedSession s r ) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' -> s -- ^ Response to return with session removed -> m r -- ^ Response with the session "removed"-removeSession AuthCookieSettings{..} response = - let invalidDate = BSC8.pack $ formatTime- defaultTimeLocale- acsExpirationFormat- timeOrigin- timeOrigin = UTCTime (toEnum 0) 0- cookies =- (acsSessionField, "") :- ("Path", acsPath) :- ("Expires", invalidDate) :- ((,"") <$> acsCookieFlags)- header = (toByteString . renderCookies) cookies- in return (addHeader header response)+removeSession acs response =+ return (addHeader (EncryptedSession $ expiredCookie acs) response) -- | Add cookie session to error allowing to set cookie even if response is -- not 200.@@ -499,8 +499,32 @@ -> m ServantErr addSessionToErr acs rs sk sessionData err = do header <- renderSession acs rs sk sessionData- return err { errHeaders = ("set-cookie", header) : errHeaders err }+ return err { errHeaders = (hSetCookie, header) : errHeaders err } +-- | "Remove" a session by invalidating the cookie.+-- Cookie expiry date is set at 0 and content is wiped+removeSessionFromErr :: ( Monad m )+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> ServantErr -- ^ Servant error to add the cookie to+ -> m ServantErr+removeSessionFromErr acs err =+ return $ err { errHeaders = (hSetCookie, expiredCookie acs) : errHeaders err }++-- | Cookie expiry date is set at 0 and content is wiped.+expiredCookie :: AuthCookieSettings -> ByteString+expiredCookie AuthCookieSettings{..} = (toByteString . renderCookies) cookies+ where+ cookies =+ (acsSessionField, "") :+ ("Path", acsPath) :+ ("Expires", invalidDate) :+ ((,"") <$> acsCookieFlags)+ invalidDate = BSC8.pack $ formatTime+ defaultTimeLocale+ acsExpirationFormat+ timeOrigin+ timeOrigin = UTCTime (toEnum 0) 0+ -- | Request handler that checks cookies. If 'Cookie' is just missing, you -- get 'Nothing', but if something is wrong with its format, 'getSession' -- can throw the same exceptions as 'decryptSession'.@@ -509,10 +533,33 @@ -> ServerKey -- ^ 'ServerKey' to use -> Request -- ^ The request -> m (Maybe a) -- ^ The result-getSession acs@AuthCookieSettings {..} sk request = do- let cookies = parseCookies <$> lookup hCookie (requestHeaders request)- sessionBinary = cookies >>= lookup acsSessionField- maybe (return Nothing) (liftM Just . decryptSession acs sk . Tagged) sessionBinary+getSession acs@AuthCookieSettings {..} sk request = maybe+ (return Nothing)+ (liftM Just . decryptSession acs sk)+ (parseSessionRequest acs $ requestHeaders request)++parseSession+ :: AuthCookieSettings+ -> HeaderName+ -> [N.Header]+ -> Maybe (Tagged SerializedEncryptedCookie ByteString)+parseSession AuthCookieSettings {..} hdr hdrs = sessionBinary where+ cookies = parseCookies <$> lookup hdr hdrs+ sessionBinary = Tagged <$> (cookies >>= lookup acsSessionField)++-- | Parse session cookie from 'RequestHeaders'.+parseSessionRequest+ :: AuthCookieSettings+ -> RequestHeaders+ -> Maybe (Tagged SerializedEncryptedCookie ByteString)+parseSessionRequest acs hdrs = parseSession acs hCookie hdrs++-- | Parse session cookie from 'ResponseHeaders'.+parseSessionResponse+ :: AuthCookieSettings+ -> ResponseHeaders+ -> Maybe (Tagged SerializedEncryptedCookie ByteString)+parseSessionResponse acs hdrs = parseSession acs hSetCookie hdrs -- | Render session cookie to 'ByteString'. renderSession