servant-auth-server 0.4.9.1 → 0.4.9.2
raw patch · 8 files changed
+176/−89 lines, 8 filesdep ~josedep ~servantdep ~servant-auth
Dependency ranges changed: jose, servant, servant-auth, servant-server
Files
- README.lhs +2/−2
- servant-auth-server.cabal +7/−7
- src/Servant/Auth/Server/Internal.hs +3/−3
- src/Servant/Auth/Server/Internal/BasicAuth.hs +1/−1
- src/Servant/Auth/Server/Internal/Cookie.hs +10/−12
- src/Servant/Auth/Server/Internal/JWT.hs +18/−8
- src/Servant/Auth/Server/Internal/Types.hs +8/−10
- test/Servant/Auth/ServerSpec.hs +127/−46
README.lhs view
@@ -80,7 +80,7 @@ protected :: Servant.Auth.Server.AuthResult User -> Server Protected -- If we get an "Authenticated v", we can trust the information in v, since -- it was signed by a key we trust.-protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user)+protected (Servant.Auth.Server.Authenticated user) = pure (name user) :<|> pure (email user) -- Otherwise, we return a 401. protected _ = throwAll err401 @@ -231,7 +231,7 @@ mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr case mApplyCookies of Nothing -> throwError err401- Just applyCookies -> return $ applyCookies NoContent+ Just applyCookies -> pure $ applyCookies NoContent checkCreds _ _ _ = throwError err401 ~~~
servant-auth-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: servant-auth-server-version: 0.4.9.1+version: 0.4.9.2 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server.@@ -41,14 +41,14 @@ , data-default >= 0.2 && < 0.9 , entropy >= 0.4.1.3 && < 0.5 , http-types >= 0.12.2 && < 0.13- , jose >= 0.10 && < 0.12+ , jose >= 0.10 && < 0.13 , lens >= 4.16.1 && < 5.4 , memory >= 0.14.16 && < 0.19 , monad-time >= 0.3.1.0 && < 0.5 , mtl ^>= 2.2.2 || ^>= 2.3.1- , servant >= 0.20.2 && < 0.21- , servant-auth >= 0.4.2.0 && < 0.5- , servant-server >= 0.20.2 && < 0.21+ , servant >= 0.20.3 && < 0.21+ , servant-auth == 0.4.9.2+ , servant-server >= 0.20.3 && < 0.21 , tagged >= 0.8.4 && < 0.9 , text >= 1.2.3.0 && < 2.2 , time >= 1.5.0.1 && < 1.15@@ -101,7 +101,7 @@ hs-source-dirs: test default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators- ghc-options: -Wall+ ghc-options: -Wall -threaded build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.12 -- dependencies with bounds inherited from the library stanza@@ -124,7 +124,7 @@ build-depends: servant-auth-server , hspec >= 2.5.5 && < 2.12- , QuickCheck >= 2.11.3 && < 2.16+ , QuickCheck >= 2.11.3 && < 2.17 , http-client >= 0.5.13.1 && < 0.8 , lens-aeson >= 1.0.2 && < 1.3 , warp >= 3.2.25 && < 3.5
src/Servant/Auth/Server/Internal.hs view
@@ -48,7 +48,7 @@ authCheck = withRequest $ \req -> liftIO $ do authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req cookies <- makeCookies authResult- return (authResult, cookies)+ pure (authResult, cookies) jwtSettings :: JWTSettings jwtSettings = getContextEntry context@@ -62,8 +62,8 @@ (Authenticated v) -> do ejwt <- makeSessionCookie cookieSettings jwtSettings v xsrf <- makeXsrfCookie cookieSettings- return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)- _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)+ pure $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)+ _ -> pure $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil) go :: (AuthResult v -> ServerT api Handler)
src/Servant/Auth/Server/Internal/BasicAuth.hs view
@@ -54,5 +54,5 @@ basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of- Nothing -> return Indefinite+ Nothing -> pure Indefinite Just baData -> fromBasicAuthData baData cfg
src/Servant/Auth/Server/Internal/Cookie.hs view
@@ -29,42 +29,40 @@ cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr cookieAuthCheck ccfg jwtSettings = do req <- ask- jwtCookie <- maybe mempty return $ do+ jwtCookie <- maybe mempty pure $ do cookies' <- lookup hCookie $ requestHeaders req let cookies = parseCookies cookies' -- Apply the XSRF check if enabled. guard $ fromMaybe True $ do xsrfCookieCfg <- xsrfCheckRequired ccfg req- return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies+ pure $ xsrfCookieAuthCheck xsrfCookieCfg req cookies -- session cookie *must* be HttpOnly and Secure lookup (sessionCookieName ccfg) cookies verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie- case verifiedJWT of- Nothing -> mzero- Just v -> return v+ maybe mzero pure verifiedJWT xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings xsrfCheckRequired cookieSettings req = do xsrfCookieCfg <- cookieXsrfSetting cookieSettings let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet guard $ not disableForGetReq- return xsrfCookieCfg+ pure xsrfCookieCfg xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req- return $ xsrfCookie `constEq` xsrfHeader+ pure $ xsrfCookie `constEq` xsrfHeader -- | Makes a cookie to be used for XSRF. makeXsrfCookie :: CookieSettings -> IO SetCookie makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings- Nothing -> return $ noXsrfTokenCookie cookieSettings+ Nothing -> pure $ noXsrfTokenCookie cookieSettings where makeRealCookie xsrfCookieSettings = do xsrfValue <- BS64.encode <$> getEntropy 32- return $+ pure $ applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettings $ def{setCookieValue = xsrfValue}@@ -79,9 +77,9 @@ makeSessionCookie cookieSettings jwtSettings v = do ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings) case ejwt of- Left _ -> return Nothing+ Left _ -> pure Nothing Right jwt ->- return $+ pure $ Just $ applySessionCookieSettings cookieSettings $ applyCookieSettings cookieSettings $@@ -146,7 +144,7 @@ Nothing -> pure Nothing Just sessionCookie -> do xsrfCookie <- makeXsrfCookie cookieSettings- return $ Just $ addHeader' sessionCookie . addHeader' xsrfCookie+ pure $ Just $ addHeader' sessionCookie . addHeader' xsrfCookie -- | Arbitrary cookie expiry time set back in history after unix time 0 expireTime :: UTCTime
src/Servant/Auth/Server/Internal/JWT.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Servant.Auth.Server.Internal.JWT where import Control.Lens@@ -21,17 +23,16 @@ jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr jwtAuthCheck jwtSettings = do req <- ask- token <- maybe mempty return $ do+ token <- maybe mempty pure $ do authHdr <- lookup "Authorization" $ requestHeaders req let bearer = "Bearer " (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr guard (mbearer `constEq` bearer)- return rest+ pure rest verifiedJWT <- liftIO $ verifyJWT jwtSettings token- case verifiedJWT of- Nothing -> mzero- Just v -> return v+ maybe mzero pure verifiedJWT +{- FOURMOLU_DISABLE -} -- | Creates a JWT containing the specified data. The data is stored in the -- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the -- token expires.@@ -47,10 +48,14 @@ ejwt <- Jose.signClaims (signingKey cfg)+#if MIN_VERSION_jose(0,12,0)+ (Jose.newJWSHeaderProtected alg)+#else (Jose.newJWSHeader ((), alg))+#endif (addExp $ encodeJWT v) - return $ Jose.encodeCompact ejwt+ pure $ Jose.encodeCompact ejwt where addExp claims = case expiry of Nothing -> claims@@ -60,12 +65,17 @@ verifyJWT jwtCfg input = do keys <- validationKeys jwtCfg verifiedJWT <- Jose.runJOSE $ do- unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)+#if MIN_VERSION_jose(0,12,0)+ unverifiedJWT :: Jose.SignedJWTWithHeader Jose.JWSHeader <-+#else+ unverifiedJWT :: Jose.SignedJWT <-+#endif+ Jose.decodeCompact (BSL.fromStrict input) Jose.verifyClaims (jwtSettingsToJwtValidationSettings jwtCfg) keys unverifiedJWT- return $ case verifiedJWT of+ pure $ case verifiedJWT of Left (_ :: Jose.JWTError) -> Nothing Right v -> case decodeJWT v of Left _ -> Nothing
src/Servant/Auth/Server/Internal/Types.hs view
@@ -35,11 +35,10 @@ mappend = (<>) instance Applicative AuthResult where- pure = return+ pure = Authenticated (<*>) = ap instance Monad AuthResult where- return = Authenticated Authenticated v >>= f = f v BadPassword >>= _ = BadPassword NoSuchUser >>= _ = NoSuchUser@@ -69,32 +68,31 @@ r -> pure r instance Monoid (AuthCheck val) where- mempty = AuthCheck $ const $ return mempty+ mempty = AuthCheck $ const $ pure mempty mappend = (<>) instance Applicative AuthCheck where- pure = return+ pure = AuthCheck . pure . pure . pure (<*>) = ap instance Monad AuthCheck where- return = AuthCheck . return . return . return AuthCheck ac >>= f = AuthCheck $ \req -> do aresult <- ac req case aresult of Authenticated usr -> runAuthCheck (f usr) req- BadPassword -> return BadPassword- NoSuchUser -> return NoSuchUser- Indefinite -> return Indefinite+ BadPassword -> pure BadPassword+ NoSuchUser -> pure NoSuchUser+ Indefinite -> pure Indefinite #if !MIN_VERSION_base(4,13,0) fail = Fail.fail #endif instance Fail.MonadFail AuthCheck where- fail _ = AuthCheck . const $ return Indefinite+ fail _ = AuthCheck . const $ pure Indefinite instance MonadReader Request AuthCheck where- ask = AuthCheck $ \x -> return (Authenticated x)+ ask = AuthCheck $ \x -> pure (Authenticated x) local f (AuthCheck check) = AuthCheck $ \req -> check (f req) instance MonadIO AuthCheck where
test/Servant/Auth/ServerSpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module Servant.Auth.ServerSpec (spec) where@@ -8,7 +9,9 @@ #endif import Control.Lens+import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO)+{- FOURMOLU_DISABLE -} import Crypto.JOSE ( Alg (HS256, None) , Error@@ -18,7 +21,11 @@ , ToCompact , encodeCompact , genJWK+#if MIN_VERSION_jose(0,12,0)+ , newJWSHeaderProtected+#else , newJWSHeader+#endif , runJOSE ) import Crypto.JWT@@ -26,6 +33,9 @@ , ClaimsSet , NumericDate (NumericDate) , SignedJWT+#if MIN_VERSION_jose(0,12,0)+ , RequiredProtection+#endif , claimAud , claimNbf , emptyClaimsSet@@ -38,10 +48,8 @@ import qualified Data.ByteString.Lazy as BSL import Data.CaseInsensitive (mk) import Data.Foldable (find)-import Data.Monoid import Data.Text (Text, pack) import Data.Time-import Data.Time.Clock (getCurrentTime) import GHC.Generics (Generic) import Network.HTTP.Client ( cookie_expiry_time@@ -101,7 +109,7 @@ authSpec :: Spec authSpec = describe "The Auth combinator" $- aroundAll (testWithApplication . return $ app jwtAndCookieApi) $ do+ aroundAll (testWithApplication . pure $ app jwtAndCookieApi) $ do it "returns a 401 if all authentications are Indefinite" $ \port -> do get (url port) `shouldHTTPErrorWith` status401 @@ -144,7 +152,11 @@ jwt <- createJWT theKey+#if MIN_VERSION_jose(0,12,0)+ (newJWSHeaderProtected HS256)+#else (newJWSHeader ((), HS256))+#endif (claims $ toJSON user) opts' <- addJwtToCookie cookieCfg jwt let opts =@@ -158,7 +170,7 @@ destroyCookieJar cookieJar opts2 = defaults- & cookies .~ Just cookieJar+ & cookies ?~ cookieJar & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf] resp2 <- getWith opts2 (url port) resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)@@ -167,7 +179,11 @@ jwt <- createJWT theKey+#if MIN_VERSION_jose(0,12,0)+ (newJWSHeaderProtected HS256)+#else (newJWSHeader ((), HS256))+#endif (claims $ toJSON user) opts' <- addJwtToCookie cookieCfg jwt let opts =@@ -185,7 +201,11 @@ jwt <- createJWT theKey+#if MIN_VERSION_jose(0,12,0)+ (newJWSHeaderProtected HS256)+#else (newJWSHeader ((), HS256))+#endif (claims $ toJSON user) opts' <- addJwtToCookie cookieCfg jwt let opts =@@ -208,10 +228,14 @@ cookieAuthSpec = describe "The Auth combinator" $ do describe "With XSRF check" $- aroundAll (testWithApplication . return $ app cookieOnlyApi) $ do+ aroundAll (testWithApplication . pure $ app cookieOnlyApi) $ do it "fails if XSRF header and cookie don't match" $ \port -> property $ \(user :: User) -> do+#if MIN_VERSION_jose(0,12,0)+ jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)+#else jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)+#endif opts' <- addJwtToCookie cookieCfg jwt let opts = addCookie@@ -221,9 +245,13 @@ it "fails with no XSRF header or cookie" $ \port -> property $ \(user :: User) -> do+#if MIN_VERSION_jose(0,12,0)+ jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)+#else jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)+#endif opts' <- addJwtToCookie cookieCfg jwt- let opts = opts' & checkResponse .~ Just mempty+ let opts = opts' & checkResponse ?~ mempty resp <- getWith opts (url port) resp ^. responseStatus `shouldBe` status401 (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]@@ -239,7 +267,11 @@ it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property $ \(user :: User) -> do+#if MIN_VERSION_jose(0,12,0)+ jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)+#else jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)+#endif opts' <- addJwtToCookie cookieCfg jwt let opts = addCookie@@ -254,7 +286,7 @@ let jar = resp ^. responseCookieJar Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar) in defaults- & cookies .~ Just jar -- real cookie jars aren't updated by being replaced+ & cookies ?~ jar -- real cookie jars aren't updated by being replaced & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue] resp <- postWith defaults (url port ++ "/login") user@@ -281,19 +313,27 @@ describe "With no XSRF check for GET requests" $ let noXsrfGet xsrfCfg = xsrfCfg{xsrfExcludeGet = True}- cookieCfgNoXsrfGet = cookieCfg{cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg}+ cookieCfgNoXsrfGet = cookieCfg{cookieXsrfSetting = noXsrfGet <$> cookieXsrfSetting cookieCfg} in- aroundAll (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do+ aroundAll (testWithApplication . pure $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do it "succeeds with no XSRF header or cookie for GET" $ \port -> property $ \(user :: User) -> do+#if MIN_VERSION_jose(0,12,0)+ jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)+#else jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)+#endif opts <- addJwtToCookie cookieCfgNoXsrfGet jwt resp <- getWith opts (url port) resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) it "fails with no XSRF header or cookie for POST" $ \port -> property $ \(user :: User) number -> do+#if MIN_VERSION_jose(0,12,0)+ jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)+#else jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)+#endif opts <- addJwtToCookie cookieCfgNoXsrfGet jwt postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401 @@ -301,17 +341,25 @@ let cookieCfgNoXsrf = cookieCfg{cookieXsrfSetting = Nothing} in- aroundAll (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do+ aroundAll (testWithApplication . pure $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do it "succeeds with no XSRF header or cookie for GET" $ \port -> property $ \(user :: User) -> do+#if MIN_VERSION_jose(0,12,0)+ jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)+#else jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)+#endif opts <- addJwtToCookie cookieCfgNoXsrf jwt resp <- getWith opts (url port) resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) it "succeeds with no XSRF header or cookie for POST" $ \port -> property $ \(user :: User) number -> do+#if MIN_VERSION_jose(0,12,0)+ jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims $ toJSON user)+#else jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)+#endif opts <- addJwtToCookie cookieCfgNoXsrf jwt resp <- postWith opts (url port) $ toJSON (number :: Int) resp ^? responseBody . _JSON `shouldBe` Just number@@ -320,7 +368,7 @@ \(user :: User) -> do let optsFromResp resp = defaults- & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced+ & cookies ?~ (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced resp <- postWith defaults (url port ++ "/login") user (resp ^. responseCookieJar) `shouldMatchCookieNames` [ sessionCookieName cookieCfg@@ -328,7 +376,7 @@ ] let loggedInOpts = optsFromResp resp - resp <- getWith (loggedInOpts) (url port)+ resp <- getWith loggedInOpts (url port) resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) resp <- getWith loggedInOpts (url port ++ "/logout")@@ -354,15 +402,19 @@ jwtAuthSpec :: Spec jwtAuthSpec = describe "The JWT combinator" $- aroundAll (testWithApplication . return $ app jwtOnlyApi) $ do+ aroundAll (testWithApplication . pure $ app jwtOnlyApi) $ do it "fails if 'aud' does not match predicate" $ \port -> property $ \(user :: User) -> do jwt <- createJWT theKey+#if MIN_VERSION_jose(0,12,0)+ (newJWSHeaderProtected HS256)+#else (newJWSHeader ((), HS256))- (claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))- opts <- addJwtToHeader (jwt >>= (return . encodeCompact))+#endif+ (claims (toJSON user) & claimAud ?~ Audience ["boo"])+ opts <- addJwtToHeader (jwt <&> encodeCompact) getWith opts (url port) `shouldHTTPErrorWith` status401 it "succeeds if 'aud' does match predicate" $ \port -> property $@@ -370,9 +422,13 @@ jwt <- createJWT theKey+#if MIN_VERSION_jose(0,12,0)+ (newJWSHeaderProtected HS256)+#else (newJWSHeader ((), HS256))- (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))- opts <- addJwtToHeader (jwt >>= (return . encodeCompact))+#endif+ (claims (toJSON user) & claimAud ?~ Audience ["anythingElse"])+ opts <- addJwtToHeader (jwt <&> encodeCompact) resp <- getWith opts (url port) resp ^. responseStatus `shouldBe` status200 @@ -381,9 +437,13 @@ jwt <- createJWT theKey+#if MIN_VERSION_jose(0,12,0)+ (newJWSHeaderProtected HS256)+#else (newJWSHeader ((), HS256))- (claims (toJSON user) & claimNbf .~ Just (NumericDate future))- opts <- addJwtToHeader (jwt >>= (return . encodeCompact))+#endif+ (claims (toJSON user) & claimNbf ?~ NumericDate future)+ opts <- addJwtToHeader (jwt <&> encodeCompact) getWith opts (url port) `shouldHTTPErrorWith` status401 it "fails if 'exp' is set to a past date" $ \port -> property $@@ -403,9 +463,13 @@ jwt <- createJWT theKey+#if MIN_VERSION_jose(0,12,0)+ (newJWSHeaderProtected None)+#else (newJWSHeader ((), None))+#endif (claims $ toJSON user)- opts <- addJwtToHeader (jwt >>= (return . encodeCompact))+ opts <- addJwtToHeader (jwt <&> encodeCompact) getWith opts (url port) `shouldHTTPErrorWith` status401 it "fails if JWT does not use expected algorithm" $@@ -413,17 +477,25 @@ pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19" it "fails if data is not valid JSON" $ \port -> do+#if MIN_VERSION_jose(0,12,0)+ jwt <- createJWT theKey (newJWSHeaderProtected HS256) (claims "{{")+#else jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")- opts <- addJwtToHeader (jwt >>= (return . encodeCompact))+#endif+ opts <- addJwtToHeader (jwt <&> encodeCompact) getWith opts (url port) `shouldHTTPErrorWith` status401 it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do jwt <- createJWT theKey+#if MIN_VERSION_jose(0,12,0)+ (newJWSHeaderProtected HS256)+#else (newJWSHeader ((), HS256))+#endif (claims $ toJSON user)- resp <- case jwt >>= (return . encodeCompact) of+ resp <- case jwt <&> encodeCompact of Left (e :: Error) -> fail $ show e Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port) resp ^. responseStatus `shouldBe` status200@@ -435,7 +507,7 @@ basicAuthSpec :: Spec basicAuthSpec = describe "The BasicAuth combinator" $- aroundAll (testWithApplication . return $ app basicAuthApi) $ do+ aroundAll (testWithApplication . pure $ app basicAuthApi) $ do it "succeeds with the correct password and username" $ \port -> do resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port) resp ^. responseStatus `shouldBe` status200@@ -493,7 +565,7 @@ , Header "Set-Cookie" SetCookie ] NoContent) {- FOURMOLU_ENABLE -} -data DummyRoutes mode = DummyRoutes+newtype DummyRoutes mode = DummyRoutes { dummyInt :: mode :- "dummy" :> Get '[JSON] Int } deriving (Generic)@@ -540,7 +612,7 @@ instance FromBasicAuthData User where fromBasicAuthData (BasicAuthData usr pwd) _ =- return $+ pure $ if usr == "ali" && pwd == "Open sesame" then Authenticated $ User "ali" "ali@the-thieves-den.com" else Indefinite@@ -566,22 +638,23 @@ app api = appWithCookie api cookieCfg {- FOURMOLU_DISABLE -}+ server :: CookieSettings -> Server (API auths) server ccfg =- ( \authResult -> case authResult of+ ( \case Authenticated usr -> getInt usr :<|> postInt usr :<|> DummyRoutes{dummyInt = getInt usr} :<|> getHeaderInt #if MIN_VERSION_servant_server(0,15,0)- :<|> return (S.source ["bytestring"])+ :<|> pure (S.source ["bytestring"]) #endif :<|> raw Indefinite -> throwAll err401 _ -> throwAll err403 )- :<|> ( \authResult -> case authResult of+ :<|> ( \case Authenticated usr -> respond (WithStatus @200 (42 :: Int)) Indefinite -> respond (WithStatus @401 $ pack "Authentication required") _ -> respond (WithStatus @403 $ pack "Forbidden")@@ -590,13 +663,13 @@ :<|> getLogout where getInt :: User -> Handler Int- getInt usr = return . length $ name usr+ getInt usr = pure . length $ name usr postInt :: User -> Int -> Handler Int- postInt _ = return+ postInt _ = pure getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)- getHeaderInt = return $ addHeader 1797 17+ getHeaderInt = pure $ addHeader 1797 17 getLogin :: User@@ -610,7 +683,7 @@ getLogin user = do maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user case maybeApplyCookies of- Just applyCookies -> return $ applyCookies NoContent+ Just applyCookies -> pure $ applyCookies NoContent Nothing -> error "cookies failed to apply" getLogout@@ -621,15 +694,19 @@ ] NoContent )- getLogout = return $ clearSession ccfg NoContent+ getLogout = pure $ clearSession ccfg NoContent raw :: Server Raw- raw =+ raw = tagged $ \_req respond ->+ respond $ responseLBS status200 [("hi", "there")] "how are you?"+ #if MIN_VERSION_servant_server(0,11,0)- Tagged $+ tagged :: Application -> Tagged Handler Application+ tagged = Tagged+#else+ tagged :: Application -> Application+ tagged = id #endif- \_req respond ->- respond $ responseLBS status200 [("hi", "there")] "how are you?" {- FOURMOLU_ENABLE -} -- }}}@@ -644,33 +721,37 @@ future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01" addJwtToHeader :: Either Error BSL.ByteString -> IO Options-addJwtToHeader jwt = case jwt of+addJwtToHeader = \case Left e -> fail $ show e Right v ->- return $+ pure $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v] +#if MIN_VERSION_jose(0,12,0)+createJWT :: JWK -> JWSHeader Crypto.JWT.RequiredProtection -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)+#else createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)+#endif createJWT k a b = runJOSE $ signClaims k a b addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options-addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of+addJwtToCookie ccfg jwt = case jwt <&> encodeCompact of Left e -> fail $ show e Right v ->- return $+ pure $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v] addCookie :: Options -> BS.ByteString -> Options addCookie opts cookie' = opts- & header "Cookie" %~ \c -> case c of+ & header "Cookie" %~ \case [h] -> [cookie' <> "; " <> h] [] -> [cookie'] _ -> error "expecting single cookie header" {- FOURMOLU_DISABLE -} shouldHTTPErrorWith :: IO a -> Status -> Expectation-shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of+shouldHTTPErrorWith act stat = act `shouldThrow` \case #if MIN_VERSION_http_client(0,5,0) HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _) -> HCli.responseStatus resp == stat@@ -687,7 +768,7 @@ shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation shouldNotHaveCookies cj patterns =- sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns+ forM_ patterns (\cookieName -> cookieNames `shouldNotContain` [cookieName]) where cookieNames :: [BS.ByteString] cookieNames = cookie_name <$> destroyCookieJar cj@@ -701,7 +782,7 @@ url port = "http://localhost:" <> show port claims :: Value -> ClaimsSet-claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val+claims val = emptyClaimsSet & unregisteredClaims . at "dat" ?~ val -- }}} ------------------------------------------------------------------------------@@ -727,7 +808,7 @@ instance Postable User where postPayload user request =- return $+ pure $ request { HCli.requestBody = HCli.RequestBodyLBS $ encode user , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request