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