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