servant-auth-server-0.4.9.2: test/Servant/Auth/ServerSpec.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# 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 (forM_)
import Control.Monad.IO.Class (liftIO)
{- FOURMOLU_DISABLE -}
import Crypto.JOSE
( Alg (HS256, None)
, Error
, JWK
, JWSHeader
, KeyMaterialGenParam (OctGenParam)
, ToCompact
, encodeCompact
, genJWK
#if MIN_VERSION_jose(0,12,0)
, newJWSHeaderProtected
#else
, newJWSHeader
#endif
, runJOSE
)
import Crypto.JWT
( Audience (..)
, ClaimsSet
, NumericDate (NumericDate)
, SignedJWT
#if MIN_VERSION_jose(0,12,0)
, RequiredProtection
#endif
, 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.Text (Text, pack)
import Data.Time
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 . pure $ 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
#if MIN_VERSION_jose(0,12,0)
(newJWSHeaderProtected HS256)
#else
(newJWSHeader ((), HS256))
#endif
(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 ?~ 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
#if MIN_VERSION_jose(0,12,0)
(newJWSHeaderProtected HS256)
#else
(newJWSHeader ((), HS256))
#endif
(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
#if MIN_VERSION_jose(0,12,0)
(newJWSHeaderProtected HS256)
#else
(newJWSHeader ((), HS256))
#endif
(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 . pure $ app cookieOnlyApi) $ do
it "fails if XSRF header and cookie don't match" $ \port -> property $
\(user :: User) -> do
#if MIN_VERSION_jose(0,12,0)
jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)
#else
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
#endif
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
#if MIN_VERSION_jose(0,12,0)
jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)
#else
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
#endif
opts' <- addJwtToCookie cookieCfg jwt
let opts = opts' & checkResponse ?~ 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
#if MIN_VERSION_jose(0,12,0)
jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)
#else
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
#endif
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 ?~ 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 = noXsrfGet <$> cookieXsrfSetting cookieCfg}
in
aroundAll (testWithApplication . pure $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do
it "succeeds with no XSRF header or cookie for GET" $ \port -> property $
\(user :: User) -> do
#if MIN_VERSION_jose(0,12,0)
jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)
#else
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
#endif
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
#if MIN_VERSION_jose(0,12,0)
jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)
#else
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
#endif
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 . pure $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do
it "succeeds with no XSRF header or cookie for GET" $ \port -> property $
\(user :: User) -> do
#if MIN_VERSION_jose(0,12,0)
jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)
#else
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
#endif
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
#if MIN_VERSION_jose(0,12,0)
jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)
#else
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
#endif
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 ?~ (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 . pure $ app jwtOnlyApi) $ do
it "fails if 'aud' does not match predicate" $ \port -> property $
\(user :: User) -> do
jwt <-
createJWT
theKey
#if MIN_VERSION_jose(0,12,0)
(newJWSHeaderProtected HS256)
#else
(newJWSHeader ((), HS256))
#endif
(claims (toJSON user) & claimAud ?~ Audience ["boo"])
opts <- addJwtToHeader (jwt <&> encodeCompact)
getWith opts (url port) `shouldHTTPErrorWith` status401
it "succeeds if 'aud' does match predicate" $ \port -> property $
\(user :: User) -> do
jwt <-
createJWT
theKey
#if MIN_VERSION_jose(0,12,0)
(newJWSHeaderProtected HS256)
#else
(newJWSHeader ((), HS256))
#endif
(claims (toJSON user) & claimAud ?~ Audience ["anythingElse"])
opts <- addJwtToHeader (jwt <&> 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
#if MIN_VERSION_jose(0,12,0)
(newJWSHeaderProtected HS256)
#else
(newJWSHeader ((), HS256))
#endif
(claims (toJSON user) & claimNbf ?~ NumericDate future)
opts <- addJwtToHeader (jwt <&> 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
#if MIN_VERSION_jose(0,12,0)
(newJWSHeaderProtected None)
#else
(newJWSHeader ((), None))
#endif
(claims $ toJSON user)
opts <- addJwtToHeader (jwt <&> 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
#if MIN_VERSION_jose(0,12,0)
jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims "{{")
#else
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")
#endif
opts <- addJwtToHeader (jwt <&> encodeCompact)
getWith opts (url port) `shouldHTTPErrorWith` status401
it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do
jwt <-
createJWT
theKey
#if MIN_VERSION_jose(0,12,0)
(newJWSHeaderProtected HS256)
#else
(newJWSHeader ((), HS256))
#endif
(claims $ toJSON user)
resp <- case jwt <&> 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 . pure $ 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 -}
newtype 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) _ =
pure $
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 =
( \case
Authenticated usr ->
getInt usr
:<|> postInt usr
:<|> DummyRoutes{dummyInt = getInt usr}
:<|> getHeaderInt
#if MIN_VERSION_servant_server(0,15,0)
:<|> pure (S.source ["bytestring"])
#endif
:<|> raw
Indefinite -> throwAll err401
_ -> throwAll err403
)
:<|> ( \case
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 = pure . length $ name usr
postInt :: User -> Int -> Handler Int
postInt _ = pure
getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)
getHeaderInt = pure $ 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 -> pure $ applyCookies NoContent
Nothing -> error "cookies failed to apply"
getLogout
:: Handler
( Headers
'[ Header "Set-Cookie" SetCookie
, Header "Set-Cookie" SetCookie
]
NoContent
)
getLogout = pure $ clearSession ccfg NoContent
raw :: Server Raw
raw = tagged $ \_req respond ->
respond $ responseLBS status200 [("hi", "there")] "how are you?"
#if MIN_VERSION_servant_server(0,11,0)
tagged :: Application -> Tagged Handler Application
tagged = Tagged
#else
tagged :: Application -> Application
tagged = id
#endif
{- 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 = \case
Left e -> fail $ show e
Right v ->
pure $
defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
#if MIN_VERSION_jose(0,12,0)
createJWT :: JWK -> JWSHeader Crypto.JWT.RequiredProtection -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
#else
createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
#endif
createJWT k a b = runJOSE $ signClaims k a b
addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
addJwtToCookie ccfg jwt = case jwt <&> encodeCompact of
Left e -> fail $ show e
Right v ->
pure $
defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]
addCookie :: Options -> BS.ByteString -> Options
addCookie opts cookie' =
opts
& header "Cookie" %~ \case
[h] -> [cookie' <> "; " <> h]
[] -> [cookie']
_ -> error "expecting single cookie header"
{- FOURMOLU_DISABLE -}
shouldHTTPErrorWith :: IO a -> Status -> Expectation
shouldHTTPErrorWith act stat = act `shouldThrow` \case
#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 =
forM_ patterns (\cookieName -> cookieNames `shouldNotContain` [cookieName])
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" ?~ 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 =
pure $
request
{ HCli.requestBody = HCli.RequestBodyLBS $ encode user
, HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request
}
-- }}}