servant-auth-server-0.4.9.1: test/Servant/Auth/ServerSpec.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
module Servant.Auth.ServerSpec (spec) where
#if !MIN_VERSION_servant_server(0,16,0)
#define ServerError ServantErr
#endif
import Control.Lens
import Control.Monad.IO.Class (liftIO)
import Crypto.JOSE
( Alg (HS256, None)
, Error
, JWK
, JWSHeader
, KeyMaterialGenParam (OctGenParam)
, ToCompact
, encodeCompact
, genJWK
, newJWSHeader
, runJOSE
)
import Crypto.JWT
( Audience (..)
, ClaimsSet
, NumericDate (NumericDate)
, SignedJWT
, claimAud
, claimNbf
, emptyClaimsSet
, signClaims
, unregisteredClaims
)
import Data.Aeson (FromJSON, ToJSON, Value, encode, toJSON)
import Data.Aeson.Lens (_JSON)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.CaseInsensitive (mk)
import Data.Foldable (find)
import Data.Monoid
import Data.Text (Text, pack)
import Data.Time
import Data.Time.Clock (getCurrentTime)
import GHC.Generics (Generic)
import Network.HTTP.Client
( cookie_expiry_time
, cookie_http_only
, cookie_name
, cookie_value
, destroyCookieJar
)
import Network.HTTP.Types (Status, status200, status401)
import Network.Wai (responseLBS)
import Network.Wai.Handler.Warp (testWithApplication)
import Network.Wreq
( Options
, auth
, basicAuth
, checkResponse
, cookieExpiryTime
, cookies
, defaults
, get
, getWith
, header
, oauth2Bearer
, postWith
, responseBody
, responseCookieJar
, responseHeader
, responseStatus
)
import Network.Wreq.Types (Postable (..))
import Servant hiding (BasicAuth, IsSecure (..), header)
import Servant.API.Generic ((:-))
import Servant.Auth.Server
import Servant.Auth.Server.Internal.Cookie (expireTime)
import Servant.Auth.Server.SetCookieOrphan ()
#if MIN_VERSION_servant_server(0,15,0)
import qualified Servant.Types.SourceT as S
#endif
import qualified Network.HTTP.Client as HCli
import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec
import Test.QuickCheck
spec :: Spec
spec = do
authSpec
cookieAuthSpec
jwtAuthSpec
throwAllSpec
basicAuthSpec
------------------------------------------------------------------------------
-- * Auth {{{
authSpec :: Spec
authSpec =
describe "The Auth combinator" $
aroundAll (testWithApplication . return $ app jwtAndCookieApi) $ do
it "returns a 401 if all authentications are Indefinite" $ \port -> do
get (url port) `shouldHTTPErrorWith` status401
it "succeeds if one authentication suceeds" $ \port -> property $
\(user :: User) -> do
jwt <- makeJWT user jwtCfg Nothing
opts <- addJwtToHeader jwt
resp <- getWith opts (url port)
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
it "fails (403) if one authentication fails" $
const $
pendingWith "Authentications don't yet fail, only are Indefinite"
it "doesn't clobber pre-existing response headers" $ \port -> property $
\(user :: User) -> do
jwt <- makeJWT user jwtCfg Nothing
opts <- addJwtToHeader jwt
resp <- getWith opts (url port ++ "/header")
resp ^. responseHeader "Blah" `shouldBe` "1797"
resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
context "Raw" $ do
it "gets the response body" $ \port -> property $ \(user :: User) -> do
jwt <- makeJWT user jwtCfg Nothing
opts <- addJwtToHeader jwt
resp <- getWith opts (url port ++ "/raw")
resp ^. responseBody `shouldBe` "how are you?"
it "doesn't clobber pre-existing reponse headers" $ \port -> property $
\(user :: User) -> do
jwt <- makeJWT user jwtCfg Nothing
opts <- addJwtToHeader jwt
resp <- getWith opts (url port ++ "/raw")
resp ^. responseHeader "hi" `shouldBe` "there"
resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
context "Setting cookies" $ do
it "sets cookies that it itself accepts" $ \port -> property $ \user -> do
jwt <-
createJWT
theKey
(newJWSHeader ((), HS256))
(claims $ toJSON user)
opts' <- addJwtToCookie cookieCfg jwt
let opts =
addCookie
(opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
(xsrfField xsrfCookieName cookieCfg <> "=blah")
resp <- getWith opts (url port)
let (cookieJar : _) = resp ^.. responseCookieJar
Just xxsrf =
find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) $
destroyCookieJar cookieJar
opts2 =
defaults
& cookies .~ Just cookieJar
& header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]
resp2 <- getWith opts2 (url port)
resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)
it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do
jwt <-
createJWT
theKey
(newJWSHeader ((), HS256))
(claims $ toJSON user)
opts' <- addJwtToCookie cookieCfg jwt
let opts =
addCookie
(opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
(xsrfField xsrfCookieName cookieCfg <> "=blah")
resp <- getWith opts (url port)
let (cookieJar : _) = resp ^.. responseCookieJar
Just xxsrf =
find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) $
destroyCookieJar cookieJar
xxsrf ^. cookieExpiryTime `shouldBe` future
it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do
jwt <-
createJWT
theKey
(newJWSHeader ((), HS256))
(claims $ toJSON user)
opts' <- addJwtToCookie cookieCfg jwt
let opts =
addCookie
(opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
(xsrfField xsrfCookieName cookieCfg <> "=blah")
resp <- getWith opts (url port)
let (cookieJar : _) = resp ^.. responseCookieJar
Just token =
find (\x -> cookie_name x == sessionCookieName cookieCfg) $
destroyCookieJar cookieJar
cookie_http_only token `shouldBe` True
-- }}}
------------------------------------------------------------------------------
-- * Cookie Auth {{{
cookieAuthSpec :: Spec
cookieAuthSpec =
describe "The Auth combinator" $ do
describe "With XSRF check" $
aroundAll (testWithApplication . return $ app cookieOnlyApi) $ do
it "fails if XSRF header and cookie don't match" $ \port -> property $
\(user :: User) -> do
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
opts' <- addJwtToCookie cookieCfg jwt
let opts =
addCookie
(opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
(xsrfField xsrfCookieName cookieCfg <> "=blerg")
getWith opts (url port) `shouldHTTPErrorWith` status401
it "fails with no XSRF header or cookie" $ \port -> property $
\(user :: User) -> do
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
opts' <- addJwtToCookie cookieCfg jwt
let opts = opts' & checkResponse .~ Just mempty
resp <- getWith opts (url port)
resp ^. responseStatus `shouldBe` status401
(resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
-- Validating that the XSRF cookie isn't added for UVerb routes either.
-- These routes can return a 401 response directly without using throwError / throwAll,
-- which revealed a bug:
--
-- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449
resp <- getWith opts (url port ++ "/uverb")
resp ^. responseStatus `shouldBe` status401
(resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property $
\(user :: User) -> do
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
opts' <- addJwtToCookie cookieCfg jwt
let opts =
addCookie
(opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
(xsrfField xsrfCookieName cookieCfg <> "=blah")
resp <- getWith opts (url port)
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
it "sets and clears the right cookies" $ \port -> property $
\(user :: User) -> do
let optsFromResp resp =
let jar = resp ^. responseCookieJar
Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)
in defaults
& cookies .~ Just jar -- real cookie jars aren't updated by being replaced
& header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]
resp <- postWith defaults (url port ++ "/login") user
(resp ^. responseCookieJar)
`shouldMatchCookieNames` [ sessionCookieName cookieCfg
, xsrfField xsrfCookieName cookieCfg
]
let loggedInOpts = optsFromResp resp
resp <- getWith loggedInOpts (url port)
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
-- logout
resp <- getWith loggedInOpts (url port ++ "/logout")
-- assert cookies were expired
now <- getCurrentTime
let assertCookie c = now >= cookie_expiry_time c
all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
let loggedOutOpts = optsFromResp resp
getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
describe "With no XSRF check for GET requests" $
let
noXsrfGet xsrfCfg = xsrfCfg{xsrfExcludeGet = True}
cookieCfgNoXsrfGet = cookieCfg{cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg}
in
aroundAll (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do
it "succeeds with no XSRF header or cookie for GET" $ \port -> property $
\(user :: User) -> do
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
resp <- getWith opts (url port)
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
it "fails with no XSRF header or cookie for POST" $ \port -> property $
\(user :: User) number -> do
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401
describe "With no XSRF check at all" $
let
cookieCfgNoXsrf = cookieCfg{cookieXsrfSetting = Nothing}
in
aroundAll (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do
it "succeeds with no XSRF header or cookie for GET" $ \port -> property $
\(user :: User) -> do
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
opts <- addJwtToCookie cookieCfgNoXsrf jwt
resp <- getWith opts (url port)
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
it "succeeds with no XSRF header or cookie for POST" $ \port -> property $
\(user :: User) number -> do
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
opts <- addJwtToCookie cookieCfgNoXsrf jwt
resp <- postWith opts (url port) $ toJSON (number :: Int)
resp ^? responseBody . _JSON `shouldBe` Just number
it "sets and clears the right cookies" $ \port -> property $
\(user :: User) -> do
let optsFromResp resp =
defaults
& cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced
resp <- postWith defaults (url port ++ "/login") user
(resp ^. responseCookieJar)
`shouldMatchCookieNames` [ sessionCookieName cookieCfg
, "NO-XSRF-TOKEN"
]
let loggedInOpts = optsFromResp resp
resp <- getWith (loggedInOpts) (url port)
resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
resp <- getWith loggedInOpts (url port ++ "/logout")
(resp ^. responseCookieJar)
`shouldMatchCookieNameValues` [ (sessionCookieName cookieCfg, "value")
, ("NO-XSRF-TOKEN", "")
]
-- assert cookies were expired
now <- getCurrentTime
let assertCookie c = now >= cookie_expiry_time c
all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
let loggedOutOpts = optsFromResp resp
getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
-- }}}
------------------------------------------------------------------------------
-- * JWT Auth {{{
jwtAuthSpec :: Spec
jwtAuthSpec =
describe "The JWT combinator" $
aroundAll (testWithApplication . return $ app jwtOnlyApi) $ do
it "fails if 'aud' does not match predicate" $ \port -> property $
\(user :: User) -> do
jwt <-
createJWT
theKey
(newJWSHeader ((), HS256))
(claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
getWith opts (url port) `shouldHTTPErrorWith` status401
it "succeeds if 'aud' does match predicate" $ \port -> property $
\(user :: User) -> do
jwt <-
createJWT
theKey
(newJWSHeader ((), HS256))
(claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
resp <- getWith opts (url port)
resp ^. responseStatus `shouldBe` status200
it "fails if 'nbf' is set to a future date" $ \port -> property $
\(user :: User) -> do
jwt <-
createJWT
theKey
(newJWSHeader ((), HS256))
(claims (toJSON user) & claimNbf .~ Just (NumericDate future))
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
getWith opts (url port) `shouldHTTPErrorWith` status401
it "fails if 'exp' is set to a past date" $ \port -> property $
\(user :: User) -> do
jwt <- makeJWT user jwtCfg (Just past)
opts <- addJwtToHeader jwt
getWith opts (url port) `shouldHTTPErrorWith` status401
it "succeeds if 'exp' is set to a future date" $ \port -> property $
\(user :: User) -> do
jwt <- makeJWT user jwtCfg (Just future)
opts <- addJwtToHeader jwt
resp <- getWith opts (url port)
resp ^. responseStatus `shouldBe` status200
it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do
jwt <-
createJWT
theKey
(newJWSHeader ((), None))
(claims $ toJSON user)
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
getWith opts (url port) `shouldHTTPErrorWith` status401
it "fails if JWT does not use expected algorithm" $
const $
pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"
it "fails if data is not valid JSON" $ \port -> do
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")
opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
getWith opts (url port) `shouldHTTPErrorWith` status401
it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do
jwt <-
createJWT
theKey
(newJWSHeader ((), HS256))
(claims $ toJSON user)
resp <- case jwt >>= (return . encodeCompact) of
Left (e :: Error) -> fail $ show e
Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)
resp ^. responseStatus `shouldBe` status200
-- }}}
------------------------------------------------------------------------------
-- * Basic Auth {{{
basicAuthSpec :: Spec
basicAuthSpec = describe "The BasicAuth combinator" $
aroundAll (testWithApplication . return $ app basicAuthApi) $ do
it "succeeds with the correct password and username" $ \port -> do
resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)
resp ^. responseStatus `shouldBe` status200
it "fails with non-existent user" $ \port -> do
getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)
`shouldHTTPErrorWith` status401
it "fails with incorrect password" $ \port -> do
getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)
`shouldHTTPErrorWith` status401
it "fails with no auth header" $ \port -> do
get (url port) `shouldHTTPErrorWith` status401
-- }}}
------------------------------------------------------------------------------
-- * ThrowAll {{{
throwAllSpec :: Spec
throwAllSpec = describe "throwAll" $ do
it "works for plain values" $ do
let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String
t = throwAll err401
t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401
it "works for function types" $ property $ \i -> do
let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)
t = throwAll err401
expected _ = throwError err401 :<|> throwError err401
t i `shouldBe` expected i
-- }}}
------------------------------------------------------------------------------
-- * API and Server {{{
{- FOURMOLU_DISABLE -}
type API auths
= Auth auths User :>
( Get '[JSON] Int
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int
:<|> "named" :> NamedRoutes DummyRoutes
:<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
#if MIN_VERSION_servant_server(0,15,0)
:<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
#endif
:<|> "raw" :> Raw
)
:<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]
:<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
, Header "Set-Cookie" SetCookie ] NoContent)
:<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
, Header "Set-Cookie" SetCookie ] NoContent)
{- FOURMOLU_ENABLE -}
data DummyRoutes mode = DummyRoutes
{ dummyInt :: mode :- "dummy" :> Get '[JSON] Int
}
deriving (Generic)
jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
jwtOnlyApi = Proxy
cookieOnlyApi :: Proxy (API '[Cookie])
cookieOnlyApi = Proxy
basicAuthApi :: Proxy (API '[BasicAuth])
basicAuthApi = Proxy
jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])
jwtAndCookieApi = Proxy
theKey :: JWK
theKey = unsafePerformIO . genJWK $ OctGenParam 256
{-# NOINLINE theKey #-}
cookieCfg :: CookieSettings
cookieCfg =
def
{ cookieExpires = Just future
, cookieIsSecure = NotSecure
, sessionCookieName = "RuncibleSpoon"
, cookieXsrfSetting =
pure $
def
{ xsrfCookieName = "TheyDinedOnMince"
, xsrfHeaderName = "AndSlicesOfQuince"
}
}
xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a
xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting
jwtCfg :: JWTSettings
jwtCfg =
(defaultJWTSettings theKey)
{ audienceMatches = \x ->
if x == "boo" then DoesNotMatch else Matches
}
instance FromBasicAuthData User where
fromBasicAuthData (BasicAuthData usr pwd) _ =
return $
if usr == "ali" && pwd == "Open sesame"
then Authenticated $ User "ali" "ali@the-thieves-den.com"
else Indefinite
-- Could be anything, really, but since this is already in the cfg we don't
-- have to add it
type instance BasicAuthCfg = JWK
appWithCookie
:: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
=> Proxy (API auths)
-> CookieSettings
-> Application
appWithCookie api ccfg = serveWithContext api ctx $ server ccfg
where
ctx = ccfg :. jwtCfg :. theKey :. EmptyContext
-- | Takes a proxy parameter indicating which authentication systems to enable.
app
:: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
=> Proxy (API auths)
-> Application
app api = appWithCookie api cookieCfg
{- FOURMOLU_DISABLE -}
server :: CookieSettings -> Server (API auths)
server ccfg =
( \authResult -> case authResult of
Authenticated usr ->
getInt usr
:<|> postInt usr
:<|> DummyRoutes{dummyInt = getInt usr}
:<|> getHeaderInt
#if MIN_VERSION_servant_server(0,15,0)
:<|> return (S.source ["bytestring"])
#endif
:<|> raw
Indefinite -> throwAll err401
_ -> throwAll err403
)
:<|> ( \authResult -> case authResult of
Authenticated usr -> respond (WithStatus @200 (42 :: Int))
Indefinite -> respond (WithStatus @401 $ pack "Authentication required")
_ -> respond (WithStatus @403 $ pack "Forbidden")
)
:<|> getLogin
:<|> getLogout
where
getInt :: User -> Handler Int
getInt usr = return . length $ name usr
postInt :: User -> Int -> Handler Int
postInt _ = return
getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)
getHeaderInt = return $ addHeader 1797 17
getLogin
:: User
-> Handler
( Headers
'[ Header "Set-Cookie" SetCookie
, Header "Set-Cookie" SetCookie
]
NoContent
)
getLogin user = do
maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user
case maybeApplyCookies of
Just applyCookies -> return $ applyCookies NoContent
Nothing -> error "cookies failed to apply"
getLogout
:: Handler
( Headers
'[ Header "Set-Cookie" SetCookie
, Header "Set-Cookie" SetCookie
]
NoContent
)
getLogout = return $ clearSession ccfg NoContent
raw :: Server Raw
raw =
#if MIN_VERSION_servant_server(0,11,0)
Tagged $
#endif
\_req respond ->
respond $ responseLBS status200 [("hi", "there")] "how are you?"
{- FOURMOLU_ENABLE -}
-- }}}
------------------------------------------------------------------------------
-- * Utils {{{
past :: UTCTime
past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
future :: UTCTime
future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
addJwtToHeader :: Either Error BSL.ByteString -> IO Options
addJwtToHeader jwt = case jwt of
Left e -> fail $ show e
Right v ->
return $
defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
createJWT k a b = runJOSE $ signClaims k a b
addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
Left e -> fail $ show e
Right v ->
return $
defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]
addCookie :: Options -> BS.ByteString -> Options
addCookie opts cookie' =
opts
& header "Cookie" %~ \c -> case c of
[h] -> [cookie' <> "; " <> h]
[] -> [cookie']
_ -> error "expecting single cookie header"
{- FOURMOLU_DISABLE -}
shouldHTTPErrorWith :: IO a -> Status -> Expectation
shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of
#if MIN_VERSION_http_client(0,5,0)
HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)
-> HCli.responseStatus resp == stat
#else
HCli.StatusCodeException x _ _ -> x == stat
#endif
_ -> False
{- FOURMOLU_ENABLE -}
shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation
shouldMatchCookieNames cj patterns =
fmap cookie_name (destroyCookieJar cj)
`shouldMatchList` patterns
shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation
shouldNotHaveCookies cj patterns =
sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns
where
cookieNames :: [BS.ByteString]
cookieNames = cookie_name <$> destroyCookieJar cj
shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
shouldMatchCookieNameValues cj patterns =
fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
`shouldMatchList` patterns
url :: Int -> String
url port = "http://localhost:" <> show port
claims :: Value -> ClaimsSet
claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val
-- }}}
------------------------------------------------------------------------------
-- * Types {{{
data User = User
{ name :: String
, _id :: String
}
deriving (Eq, Generic, Read, Show)
instance FromJWT User
instance ToJWT User
instance FromJSON User
instance ToJSON User
instance Arbitrary User where
arbitrary = User <$> arbitrary <*> arbitrary
instance Postable User where
postPayload user request =
return $
request
{ HCli.requestBody = HCli.RequestBodyLBS $ encode user
, HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request
}
-- }}}