diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -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 ~~~ diff --git a/servant-auth-server.cabal b/servant-auth-server.cabal --- a/servant-auth-server.cabal +++ b/servant-auth-server.cabal @@ -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 diff --git a/src/Servant/Auth/Server/Internal.hs b/src/Servant/Auth/Server/Internal.hs --- a/src/Servant/Auth/Server/Internal.hs +++ b/src/Servant/Auth/Server/Internal.hs @@ -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) diff --git a/src/Servant/Auth/Server/Internal/BasicAuth.hs b/src/Servant/Auth/Server/Internal/BasicAuth.hs --- a/src/Servant/Auth/Server/Internal/BasicAuth.hs +++ b/src/Servant/Auth/Server/Internal/BasicAuth.hs @@ -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 diff --git a/src/Servant/Auth/Server/Internal/Cookie.hs b/src/Servant/Auth/Server/Internal/Cookie.hs --- a/src/Servant/Auth/Server/Internal/Cookie.hs +++ b/src/Servant/Auth/Server/Internal/Cookie.hs @@ -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 diff --git a/src/Servant/Auth/Server/Internal/JWT.hs b/src/Servant/Auth/Server/Internal/JWT.hs --- a/src/Servant/Auth/Server/Internal/JWT.hs +++ b/src/Servant/Auth/Server/Internal/JWT.hs @@ -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 diff --git a/src/Servant/Auth/Server/Internal/Types.hs b/src/Servant/Auth/Server/Internal/Types.hs --- a/src/Servant/Auth/Server/Internal/Types.hs +++ b/src/Servant/Auth/Server/Internal/Types.hs @@ -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 diff --git a/test/Servant/Auth/ServerSpec.hs b/test/Servant/Auth/ServerSpec.hs --- a/test/Servant/Auth/ServerSpec.hs +++ b/test/Servant/Auth/ServerSpec.hs @@ -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