@@ -1,607 +0,0 @@
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−-- }}}