@@ -0,0 +1,600 @@
1+{-# LANGUAGE CPP #-}
2+module Servant.Auth.ServerSpec (spec) where
3+
4+#if !MIN_VERSION_servant_server(0,16,0)
5+#define ServerError ServantErr
6+#endif
7+
8+import Control.Lens
9+import Control.Monad.Except (runExceptT)
10+import Control.Monad.IO.Class (liftIO)
11+import Crypto.JOSE (Alg (HS256, None), Error,
12+ JWK, JWSHeader,
13+ KeyMaterialGenParam (OctGenParam),
14+ ToCompact, encodeCompact,
15+ genJWK, newJWSHeader)
16+import Crypto.JWT (Audience (..), ClaimsSet,
17+ NumericDate (NumericDate),
18+ SignedJWT,
19+ claimAud, claimNbf,
20+ signClaims,
21+ emptyClaimsSet,
22+ unregisteredClaims)
23+import Data.Aeson (FromJSON, ToJSON, Value,
24+ toJSON, encode)
25+import Data.Aeson.Lens (_JSON)
26+import qualified Data.ByteString as BS
27+import qualified Data.ByteString.Lazy as BSL
28+import Data.CaseInsensitive (mk)
29+import Data.Foldable (find)
30+import Data.Monoid
31+import Data.Time
32+import Data.Time.Clock (getCurrentTime)
33+import GHC.Generics (Generic)
34+import Network.HTTP.Client (cookie_http_only,
35+ cookie_name, cookie_value,
36+ cookie_expiry_time,
37+ destroyCookieJar)
38+import Network.HTTP.Types (Status, status200,
39+ status401)
40+import Network.Wai (responseLBS)
41+import Network.Wai.Handler.Warp (testWithApplication)
42+import Network.Wreq (Options, auth, basicAuth,
43+ cookieExpiryTime, cookies,
44+ defaults, get, getWith, postWith,
45+ header, oauth2Bearer,
46+ responseBody,
47+ responseCookieJar,
48+ responseHeader,
49+ responseStatus)
50+import Network.Wreq.Types (Postable(..))
51+import Servant hiding (BasicAuth,
52+ IsSecure (..), header)
53+import Servant.Auth.Server
54+import Servant.Auth.Server.Internal.Cookie (expireTime)
55+import Servant.Auth.Server.SetCookieOrphan ()
56+#if MIN_VERSION_servant_server(0,15,0)
57+import qualified Servant.Types.SourceT as S
58+#endif
59+import System.IO.Unsafe (unsafePerformIO)
60+import Test.Hspec
61+import Test.QuickCheck
62+import qualified Network.HTTP.Client as HCli
63+
64+
65+
66+spec :: Spec
67+spec = do
68+ authSpec
69+ cookieAuthSpec
70+ jwtAuthSpec
71+ throwAllSpec
72+ basicAuthSpec
73+
74+------------------------------------------------------------------------------
75+-- * Auth {{{
76+
77+authSpec :: Spec
78+authSpec
79+ = describe "The Auth combinator"
80+ $ around (testWithApplication . return $ app jwtAndCookieApi) $ do
81+
82+ it "returns a 401 if all authentications are Indefinite" $ \port -> do
83+ get (url port) `shouldHTTPErrorWith` status401
84+
85+ it "succeeds if one authentication suceeds" $ \port -> property $
86+ \(user :: User) -> do
87+ jwt <- makeJWT user jwtCfg Nothing
88+ opts <- addJwtToHeader jwt
89+ resp <- getWith opts (url port)
90+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
91+
92+ it "fails (403) if one authentication fails" $ const $
93+ pendingWith "Authentications don't yet fail, only are Indefinite"
94+
95+ it "doesn't clobber pre-existing response headers" $ \port -> property $
96+ \(user :: User) -> do
97+ jwt <- makeJWT user jwtCfg Nothing
98+ opts <- addJwtToHeader jwt
99+ resp <- getWith opts (url port ++ "/header")
100+ resp ^. responseHeader "Blah" `shouldBe` "1797"
101+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
102+
103+ context "Raw" $ do
104+
105+ it "gets the response body" $ \port -> property $ \(user :: User) -> do
106+ jwt <- makeJWT user jwtCfg Nothing
107+ opts <- addJwtToHeader jwt
108+ resp <- getWith opts (url port ++ "/raw")
109+ resp ^. responseBody `shouldBe` "how are you?"
110+
111+ it "doesn't clobber pre-existing reponse headers" $ \port -> property $
112+ \(user :: User) -> do
113+ jwt <- makeJWT user jwtCfg Nothing
114+ opts <- addJwtToHeader jwt
115+ resp <- getWith opts (url port ++ "/raw")
116+ resp ^. responseHeader "hi" `shouldBe` "there"
117+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
118+
119+
120+ context "Setting cookies" $ do
121+
122+ it "sets cookies that it itself accepts" $ \port -> property $ \user -> do
123+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
124+ (claims $ toJSON user)
125+ opts' <- addJwtToCookie cookieCfg jwt
126+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
127+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
128+ resp <- getWith opts (url port)
129+ let (cookieJar:_) = resp ^.. responseCookieJar
130+ Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
131+ $ destroyCookieJar cookieJar
132+ opts2 = defaults
133+ & cookies .~ Just cookieJar
134+ & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]
135+ resp2 <- getWith opts2 (url port)
136+ resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)
137+
138+ it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do
139+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
140+ (claims $ toJSON user)
141+ opts' <- addJwtToCookie cookieCfg jwt
142+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
143+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
144+ resp <- getWith opts (url port)
145+ let (cookieJar:_) = resp ^.. responseCookieJar
146+ Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
147+ $ destroyCookieJar cookieJar
148+ xxsrf ^. cookieExpiryTime `shouldBe` future
149+
150+ it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do
151+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
152+ (claims $ toJSON user)
153+ opts' <- addJwtToCookie cookieCfg jwt
154+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
155+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
156+ resp <- getWith opts (url port)
157+ let (cookieJar:_) = resp ^.. responseCookieJar
158+ Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg)
159+ $ destroyCookieJar cookieJar
160+ cookie_http_only token `shouldBe` True
161+
162+
163+
164+-- }}}
165+------------------------------------------------------------------------------
166+-- * Cookie Auth {{{
167+
168+cookieAuthSpec :: Spec
169+cookieAuthSpec
170+ = describe "The Auth combinator" $ do
171+ describe "With XSRF check" $
172+ around (testWithApplication . return $ app cookieOnlyApi) $ do
173+
174+ it "fails if XSRF header and cookie don't match" $ \port -> property
175+ $ \(user :: User) -> do
176+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
177+ opts' <- addJwtToCookie cookieCfg jwt
178+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
179+ (xsrfField xsrfCookieName cookieCfg <> "=blerg")
180+ getWith opts (url port) `shouldHTTPErrorWith` status401
181+
182+ it "fails with no XSRF header or cookie" $ \port -> property
183+ $ \(user :: User) -> do
184+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
185+ opts <- addJwtToCookie cookieCfg jwt
186+ getWith opts (url port) `shouldHTTPErrorWith` status401
187+
188+ it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
189+ $ \(user :: User) -> do
190+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
191+ opts' <- addJwtToCookie cookieCfg jwt
192+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
193+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
194+ resp <- getWith opts (url port)
195+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
196+
197+ it "sets and clears the right cookies" $ \port -> property
198+ $ \(user :: User) -> do
199+ let optsFromResp resp =
200+ let jar = resp ^. responseCookieJar
201+ Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)
202+ in defaults
203+ & cookies .~ Just jar -- real cookie jars aren't updated by being replaced
204+ & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]
205+
206+ resp <- postWith defaults (url port ++ "/login") user
207+ (resp ^. responseCookieJar) `shouldMatchCookieNames`
208+ [ sessionCookieName cookieCfg
209+ , xsrfField xsrfCookieName cookieCfg
210+ ]
211+ let loggedInOpts = optsFromResp resp
212+
213+ resp <- getWith loggedInOpts (url port)
214+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
215+
216+ -- logout
217+ resp <- getWith loggedInOpts (url port ++ "/logout")
218+
219+ -- assert cookies were expired
220+ now <- getCurrentTime
221+ let assertCookie c = now >= cookie_expiry_time c
222+ all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
223+
224+ let loggedOutOpts = optsFromResp resp
225+ getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
226+
227+ describe "With no XSRF check for GET requests" $ let
228+ noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True }
229+ cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg }
230+ in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do
231+
232+ it "succeeds with no XSRF header or cookie for GET" $ \port -> property
233+ $ \(user :: User) -> do
234+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
235+ opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
236+ resp <- getWith opts (url port)
237+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
238+
239+ it "fails with no XSRF header or cookie for POST" $ \port -> property
240+ $ \(user :: User) number -> do
241+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
242+ opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
243+ postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401
244+
245+ describe "With no XSRF check at all" $ let
246+ cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing }
247+ in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do
248+
249+ it "succeeds with no XSRF header or cookie for GET" $ \port -> property
250+ $ \(user :: User) -> do
251+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
252+ opts <- addJwtToCookie cookieCfgNoXsrf jwt
253+ resp <- getWith opts (url port)
254+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
255+
256+ it "succeeds with no XSRF header or cookie for POST" $ \port -> property
257+ $ \(user :: User) number -> do
258+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
259+ opts <- addJwtToCookie cookieCfgNoXsrf jwt
260+ resp <- postWith opts (url port) $ toJSON (number :: Int)
261+ resp ^? responseBody . _JSON `shouldBe` Just number
262+
263+ it "sets and clears the right cookies" $ \port -> property
264+ $ \(user :: User) -> do
265+ let optsFromResp resp = defaults
266+ & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced
267+
268+ resp <- postWith defaults (url port ++ "/login") user
269+ (resp ^. responseCookieJar) `shouldMatchCookieNames`
270+ [ sessionCookieName cookieCfg
271+ , "NO-XSRF-TOKEN"
272+ ]
273+ let loggedInOpts = optsFromResp resp
274+
275+ resp <- getWith (loggedInOpts) (url port)
276+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
277+
278+ resp <- getWith loggedInOpts (url port ++ "/logout")
279+ (resp ^. responseCookieJar) `shouldMatchCookieNameValues`
280+ [ (sessionCookieName cookieCfg, "value")
281+ , ("NO-XSRF-TOKEN", "")
282+ ]
283+
284+ -- assert cookies were expired
285+ now <- getCurrentTime
286+ let assertCookie c = now >= cookie_expiry_time c
287+ all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
288+
289+ let loggedOutOpts = optsFromResp resp
290+
291+ getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
292+
293+-- }}}
294+------------------------------------------------------------------------------
295+-- * JWT Auth {{{
296+
297+jwtAuthSpec :: Spec
298+jwtAuthSpec
299+ = describe "The JWT combinator"
300+ $ around (testWithApplication . return $ app jwtOnlyApi) $ do
301+
302+ it "fails if 'aud' does not match predicate" $ \port -> property $
303+ \(user :: User) -> do
304+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
305+ (claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))
306+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
307+ getWith opts (url port) `shouldHTTPErrorWith` status401
308+
309+ it "succeeds if 'aud' does match predicate" $ \port -> property $
310+ \(user :: User) -> do
311+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
312+ (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))
313+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
314+ resp <- getWith opts (url port)
315+ resp ^. responseStatus `shouldBe` status200
316+
317+ it "fails if 'nbf' is set to a future date" $ \port -> property $
318+ \(user :: User) -> do
319+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
320+ (claims (toJSON user) & claimNbf .~ Just (NumericDate future))
321+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
322+ getWith opts (url port) `shouldHTTPErrorWith` status401
323+
324+ it "fails if 'exp' is set to a past date" $ \port -> property $
325+ \(user :: User) -> do
326+ jwt <- makeJWT user jwtCfg (Just past)
327+ opts <- addJwtToHeader jwt
328+ getWith opts (url port) `shouldHTTPErrorWith` status401
329+
330+ it "succeeds if 'exp' is set to a future date" $ \port -> property $
331+ \(user :: User) -> do
332+ jwt <- makeJWT user jwtCfg (Just future)
333+ opts <- addJwtToHeader jwt
334+ resp <- getWith opts (url port)
335+ resp ^. responseStatus `shouldBe` status200
336+
337+ it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do
338+ jwt <- createJWT theKey (newJWSHeader ((), None))
339+ (claims $ toJSON user)
340+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
341+ getWith opts (url port) `shouldHTTPErrorWith` status401
342+
343+ it "fails if JWT does not use expected algorithm" $ const $
344+ pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"
345+
346+ it "fails if data is not valid JSON" $ \port -> do
347+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")
348+ opts <- addJwtToHeader (jwt >>= (return .encodeCompact))
349+ getWith opts (url port) `shouldHTTPErrorWith` status401
350+
351+ it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do
352+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
353+ (claims $ toJSON user)
354+ resp <- case jwt >>= (return . encodeCompact) of
355+ Left (e :: Error) -> fail $ show e
356+ Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)
357+ resp ^. responseStatus `shouldBe` status200
358+
359+-- }}}
360+------------------------------------------------------------------------------
361+-- * Basic Auth {{{
362+
363+basicAuthSpec :: Spec
364+basicAuthSpec = describe "The BasicAuth combinator"
365+ $ around (testWithApplication . return $ app basicAuthApi) $ do
366+
367+ it "succeeds with the correct password and username" $ \port -> do
368+ resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)
369+ resp ^. responseStatus `shouldBe` status200
370+
371+ it "fails with non-existent user" $ \port -> do
372+ getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)
373+ `shouldHTTPErrorWith` status401
374+
375+ it "fails with incorrect password" $ \port -> do
376+ getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)
377+ `shouldHTTPErrorWith` status401
378+
379+ it "fails with no auth header" $ \port -> do
380+ get (url port) `shouldHTTPErrorWith` status401
381+
382+-- }}}
383+------------------------------------------------------------------------------
384+-- * ThrowAll {{{
385+
386+throwAllSpec :: Spec
387+throwAllSpec = describe "throwAll" $ do
388+
389+ it "works for plain values" $ do
390+ let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String
391+ t = throwAll err401
392+ t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401
393+
394+ it "works for function types" $ property $ \i -> do
395+ let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)
396+ t = throwAll err401
397+ expected _ = throwError err401 :<|> throwError err401
398+ t i `shouldBe` expected i
399+
400+-- }}}
401+------------------------------------------------------------------------------
402+-- * API and Server {{{
403+
404+type API auths
405+ = Auth auths User :>
406+ ( Get '[JSON] Int
407+ :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
408+ :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
409+#if MIN_VERSION_servant_server(0,15,0)
410+ :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
411+#endif
412+ :<|> "raw" :> Raw
413+ )
414+ :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
415+ , Header "Set-Cookie" SetCookie ] NoContent)
416+ :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
417+ , Header "Set-Cookie" SetCookie ] NoContent)
418+
419+jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
420+jwtOnlyApi = Proxy
421+
422+cookieOnlyApi :: Proxy (API '[Cookie])
423+cookieOnlyApi = Proxy
424+
425+basicAuthApi :: Proxy (API '[BasicAuth])
426+basicAuthApi = Proxy
427+
428+jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])
429+jwtAndCookieApi = Proxy
430+
431+theKey :: JWK
432+theKey = unsafePerformIO . genJWK $ OctGenParam 256
433+{-# NOINLINE theKey #-}
434+
435+
436+cookieCfg :: CookieSettings
437+cookieCfg = def
438+ { cookieExpires = Just future
439+ , cookieIsSecure = NotSecure
440+ , sessionCookieName = "RuncibleSpoon"
441+ , cookieXsrfSetting = pure $ def
442+ { xsrfCookieName = "TheyDinedOnMince"
443+ , xsrfHeaderName = "AndSlicesOfQuince"
444+ }
445+ }
446+xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a
447+xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting
448+
449+jwtCfg :: JWTSettings
450+jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x ->
451+ if x == "boo" then DoesNotMatch else Matches }
452+
453+instance FromBasicAuthData User where
454+ fromBasicAuthData (BasicAuthData usr pwd) _
455+ = return $ if usr == "ali" && pwd == "Open sesame"
456+ then Authenticated $ User "ali" "ali@the-thieves-den.com"
457+ else Indefinite
458+
459+-- Could be anything, really, but since this is already in the cfg we don't
460+-- have to add it
461+type instance BasicAuthCfg = JWK
462+
463+appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
464+ => Proxy (API auths) -> CookieSettings -> Application
465+appWithCookie api ccfg = serveWithContext api ctx $ server ccfg
466+ where
467+ ctx = ccfg :. jwtCfg :. theKey :. EmptyContext
468+
469+-- | Takes a proxy parameter indicating which authentication systems to enable.
470+app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
471+ => Proxy (API auths) -> Application
472+app api = appWithCookie api cookieCfg
473+
474+server :: CookieSettings -> Server (API auths)
475+server ccfg =
476+ (\authResult -> case authResult of
477+ Authenticated usr -> getInt usr
478+ :<|> postInt usr
479+ :<|> getHeaderInt
480+#if MIN_VERSION_servant_server(0,15,0)
481+ :<|> return (S.source ["bytestring"])
482+#endif
483+ :<|> raw
484+ Indefinite -> throwAll err401
485+ _ -> throwAll err403
486+ )
487+ :<|> getLogin
488+ :<|> getLogout
489+ where
490+ getInt :: User -> Handler Int
491+ getInt usr = return . length $ name usr
492+
493+ postInt :: User -> Int -> Handler Int
494+ postInt _ = return
495+
496+ getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)
497+ getHeaderInt = return $ addHeader 1797 17
498+
499+ getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie
500+ , Header "Set-Cookie" SetCookie ] NoContent)
501+ getLogin user = do
502+ maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user
503+ case maybeApplyCookies of
504+ Just applyCookies -> return $ applyCookies NoContent
505+ Nothing -> error "cookies failed to apply"
506+
507+ getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie
508+ , Header "Set-Cookie" SetCookie ] NoContent)
509+ getLogout = return $ clearSession ccfg NoContent
510+
511+ raw :: Server Raw
512+ raw =
513+#if MIN_VERSION_servant_server(0,11,0)
514+ Tagged $
515+#endif
516+ \_req respond ->
517+ respond $ responseLBS status200 [("hi", "there")] "how are you?"
518+
519+-- }}}
520+------------------------------------------------------------------------------
521+-- * Utils {{{
522+
523+past :: UTCTime
524+past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
525+
526+future :: UTCTime
527+future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
528+
529+addJwtToHeader :: Either Error BSL.ByteString -> IO Options
530+addJwtToHeader jwt = case jwt of
531+ Left e -> fail $ show e
532+ Right v -> return
533+ $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
534+
535+createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
536+createJWT k a b = runExceptT $ signClaims k a b
537+
538+addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
539+addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
540+ Left e -> fail $ show e
541+ Right v -> return
542+ $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]
543+
544+addCookie :: Options -> BS.ByteString -> Options
545+addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of
546+ [h] -> [cookie' <> "; " <> h]
547+ [] -> [cookie']
548+ _ -> error "expecting single cookie header"
549+
550+
551+shouldHTTPErrorWith :: IO a -> Status -> Expectation
552+shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of
553+#if MIN_VERSION_http_client(0,5,0)
554+ HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)
555+ -> HCli.responseStatus resp == stat
556+#else
557+ HCli.StatusCodeException x _ _ -> x == stat
558+#endif
559+ _ -> False
560+
561+shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation
562+shouldMatchCookieNames cj patterns
563+ = fmap cookie_name (destroyCookieJar cj)
564+ `shouldMatchList` patterns
565+
566+shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
567+shouldMatchCookieNameValues cj patterns
568+ = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
569+ `shouldMatchList` patterns
570+
571+url :: Int -> String
572+url port = "http://localhost:" <> show port
573+
574+claims :: Value -> ClaimsSet
575+claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val
576+-- }}}
577+------------------------------------------------------------------------------
578+-- * Types {{{
579+
580+data User = User
581+ { name :: String
582+ , _id :: String
583+ } deriving (Eq, Show, Read, Generic)
584+
585+instance FromJWT User
586+instance ToJWT User
587+instance FromJSON User
588+instance ToJSON User
589+
590+instance Arbitrary User where
591+ arbitrary = User <$> arbitrary <*> arbitrary
592+
593+instance Postable User where
594+ postPayload user request = return $ request
595+ { HCli.requestBody = HCli.RequestBodyLBS $ encode user
596+ , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request
597+ }
598+
599+
600+-- }}}