diff --git a/servant-auth-server.cabal b/servant-auth-server.cabal --- a/servant-auth-server.cabal +++ b/servant-auth-server.cabal @@ -1,22 +1,22 @@ cabal-version: 2.2 name: servant-auth-server -version: 0.4.7.0 +version: 0.4.8.0 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server. . Both cookie- and token- (REST API) based authentication is provided. . - For a quick overview of the usage, see the . + For a quick overview of the usage, see the . category: Web, Servant, Authentication -homepage: http://github.com/haskell-servant/servant/servant-auth#readme +homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme bug-reports: https://github.com/haskell-servant/servant/issues author: Julian K. Arni maintainer: jkarni@gmail.com copyright: (c) Julian K. Arni license: BSD-3-Clause license-file: LICENSE -tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 +tested-with: GHC==8.6.5, GHC==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4 build-type: Simple extra-source-files: CHANGELOG.md @@ -31,27 +31,27 @@ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators ghc-options: -Wall build-depends: - base >= 4.10 && < 4.16 + base >= 4.10 && < 4.19 , aeson >= 1.0.0.1 && < 3 , base64-bytestring >= 1.0.0.1 && < 2 , blaze-builder >= 0.4.1.0 && < 0.5 - , bytestring >= 0.10.6.0 && < 0.11 + , bytestring >= 0.10.6.0 && < 0.12 , case-insensitive >= 1.2.0.11 && < 1.3 , cookie >= 0.4.4 && < 0.5 , data-default-class >= 0.1.2.0 && < 0.2 , entropy >= 0.4.1.3 && < 0.5 , http-types >= 0.12.2 && < 0.13 - , jose >= 0.7.0.0 && < 0.10 - , lens >= 4.16.1 && < 5.1 - , memory >= 0.14.16 && < 0.17 + , jose >= 0.10 && < 0.11 + , lens >= 4.16.1 && < 5.3 + , memory >= 0.14.16 && < 0.19 , monad-time >= 0.3.1.0 && < 0.4 - , mtl >= 2.2.2 && < 2.3 - , servant >= 0.13 && < 0.20 + , mtl ^>= 2.2.2 || ^>= 2.3.1 + , servant >= 0.13 && < 0.21 , servant-auth == 0.4.* - , servant-server >= 0.13 && < 0.20 + , servant-server >= 0.13 && < 0.21 , tagged >= 0.8.4 && < 0.9 - , text >= 1.2.3.0 && < 1.3 - , time >= 1.5.0.1 && < 1.10 + , text >= 1.2.3.0 && < 2.1 + , time >= 1.5.0.1 && < 1.13 , unordered-containers >= 0.2.9.0 && < 0.3 , wai >= 3.2.1.2 && < 3.3 @@ -102,7 +102,7 @@ test default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators ghc-options: -Wall - build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8 + build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.11 -- dependencies with bounds inherited from the library stanza build-depends: @@ -123,12 +123,13 @@ -- test dependencies build-depends: servant-auth-server - , hspec >= 2.5.5 && < 2.8 + , hspec >= 2.5.5 && < 2.11 , QuickCheck >= 2.11.3 && < 2.15 , http-client >= 0.5.13.1 && < 0.8 - , lens-aeson >= 1.0.2 && < 1.2 + , lens-aeson >= 1.0.2 && < 1.3 , warp >= 3.2.25 && < 3.4 , wreq >= 0.5.2.1 && < 0.6 + , text >= 1.2.3.0 && < 2.1 other-modules: Servant.Auth.ServerSpec default-language: Haskell2010 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 @@ -54,15 +54,12 @@ makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z))) makeCookies authResult = do - xsrf <- makeXsrfCookie cookieSettings - fmap (Just xsrf `SetCookieCons`) $ - case authResult of - (Authenticated v) -> do - ejwt <- makeSessionCookie cookieSettings jwtSettings v - case ejwt of - Nothing -> return $ Nothing `SetCookieCons` SetCookieNil - Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil - _ -> return $ Nothing `SetCookieCons` SetCookieNil + case authResult of + (Authenticated v) -> do + ejwt <- makeSessionCookie cookieSettings jwtSettings v + xsrf <- makeXsrfCookie cookieSettings + return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil) + _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil) go :: (AuthResult v -> ServerT api Handler) -> (AuthResult v, SetCookieList n) diff --git a/src/Servant/Auth/Server/Internal/AddSetCookie.hs b/src/Servant/Auth/Server/Internal/AddSetCookie.hs --- a/src/Servant/Auth/Server/Internal/AddSetCookie.hs +++ b/src/Servant/Auth/Server/Internal/AddSetCookie.hs @@ -11,6 +11,9 @@ import qualified Network.HTTP.Types as HTTP import Network.Wai (mapResponseHeaders) import Servant +import Servant.API.UVerb.Union +import Servant.API.Generic +import Servant.Server.Generic import Web.Cookie -- What are we doing here? Well, the idea is to add headers to the response, @@ -31,11 +34,24 @@ AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a +#if MIN_VERSION_servant_server(0,18,1) +type family MapAddSetCookieApiVerb (as :: [*]) where + MapAddSetCookieApiVerb '[] = '[] + MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as) +#endif + type family AddSetCookieApi a :: * type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b +#if MIN_VERSION_servant_server(0,19,0) +type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api) +#endif type instance AddSetCookieApi (Verb method stat ctyps a) = Verb method stat ctyps (AddSetCookieApiVerb a) +#if MIN_VERSION_servant_server(0,18,1) +type instance AddSetCookieApi (UVerb method ctyps as) + = UVerb method ctyps (MapAddSetCookieApiVerb as) +#endif type instance AddSetCookieApi Raw = Raw #if MIN_VERSION_servant_server(0,15,0) type instance AddSetCookieApi (Stream method stat framing ctyps a) @@ -54,7 +70,7 @@ => AddSetCookies ('S n) (a -> oldb) (a -> newb) where addSetCookies cookies oldfn = addSetCookies cookies . oldfn -instance AddSetCookies 'Z orig orig where +instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where addSetCookies _ = id instance {-# OVERLAPPABLE #-} @@ -71,6 +87,15 @@ (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b') => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b + +instance {-# OVERLAPS #-} + ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi + , Generic (api (AsServerT m)) + , GServantProduct (Rep (api (AsServerT m))) + , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m + ) + => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where + addSetCookies cookies = addSetCookies cookies . toServant -- | for @servant <0.11@ instance diff --git a/src/Servant/Auth/Server/Internal/ConfigTypes.hs b/src/Servant/Auth/Server/Internal/ConfigTypes.hs --- a/src/Servant/Auth/Server/Internal/ConfigTypes.hs +++ b/src/Servant/Auth/Server/Internal/ConfigTypes.hs @@ -33,7 +33,7 @@ -- | Algorithm used to sign JWT. , jwtAlg :: Maybe Jose.Alg -- | Keys used to validate JWT. - , validationKeys :: Jose.JWKSet + , validationKeys :: IO Jose.JWKSet -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the -- intended recipient of the JWT. , audienceMatches :: Jose.StringOrURI -> IsMatch @@ -44,7 +44,7 @@ defaultJWTSettings k = JWTSettings { signingKey = k , jwtAlg = Nothing - , validationKeys = Jose.JWKSet [k] + , validationKeys = pure $ Jose.JWKSet [k] , audienceMatches = const Matches } -- | The policies to use when generating cookies. 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 @@ -2,6 +2,7 @@ module Servant.Auth.Server.Internal.Cookie where import Blaze.ByteString.Builder (toByteString) +import Control.Monad (MonadPlus(..), guard) import Control.Monad.Except import Control.Monad.Reader import qualified Crypto.JOSE as Jose @@ -102,7 +103,17 @@ , setCookieSecure = case cookieIsSecure cookieSettings of Secure -> True NotSecure -> False + , setCookieSameSite = case cookieSameSite cookieSettings of + AnySite -> anySite + SameSiteStrict -> Just sameSiteStrict + SameSiteLax -> Just sameSiteLax } + where +#if MIN_VERSION_cookie(0,4,5) + anySite = Just sameSiteNone +#else + anySite = Nothing +#endif applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie @@ -114,18 +125,8 @@ applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie applySessionCookieSettings cookieSettings setCookie = setCookie { setCookieName = sessionCookieName cookieSettings - , setCookieSameSite = case cookieSameSite cookieSettings of - AnySite -> anySite - SameSiteStrict -> Just sameSiteStrict - SameSiteLax -> Just sameSiteLax , setCookieHttpOnly = True } - where -#if MIN_VERSION_cookie(0,4,5) - anySite = Just sameSiteNone -#else - anySite = Nothing -#endif -- | For a JWT-serializable session, returns a function that decorates a -- provided response object with XSRF and session cookies. This should be used 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,18 +1,14 @@ module Servant.Auth.Server.Internal.JWT where import Control.Lens -import Control.Monad.Except +import Control.Monad (MonadPlus(..), guard) import Control.Monad.Reader import qualified Crypto.JOSE as Jose import qualified Crypto.JWT as Jose -import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, - toJSON) import Data.ByteArray (constEq) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import qualified Data.HashMap.Strict as HM import Data.Maybe (fromMaybe) -import qualified Data.Text as T import Data.Time (UTCTime) import Network.Wai (requestHeaders) @@ -42,7 +38,7 @@ -- token expires. makeJWT :: ToJWT a => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString) -makeJWT v cfg expiry = runExceptT $ do +makeJWT v cfg expiry = Jose.runJOSE $ do bestAlg <- Jose.bestJWSAlg $ signingKey cfg let alg = fromMaybe bestAlg $ jwtAlg cfg ejwt <- Jose.signClaims (signingKey cfg) @@ -58,11 +54,12 @@ verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a) verifyJWT jwtCfg input = do - verifiedJWT <- liftIO $ runExceptT $ do + keys <- validationKeys jwtCfg + verifiedJWT <- Jose.runJOSE $ do unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input) Jose.verifyClaims (jwtSettingsToJwtValidationSettings jwtCfg) - (validationKeys jwtCfg) + keys unverifiedJWT return $ case verifiedJWT of Left (_ :: Jose.JWTError) -> Nothing diff --git a/src/Servant/Auth/Server/Internal/ThrowAll.hs b/src/Servant/Auth/Server/Internal/ThrowAll.hs --- a/src/Servant/Auth/Server/Internal/ThrowAll.hs +++ b/src/Servant/Auth/Server/Internal/ThrowAll.hs @@ -8,7 +8,10 @@ import Control.Monad.Error.Class import Data.Tagged (Tagged (..)) -import Servant ((:<|>) (..), ServerError(..)) +import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..)) +import Servant.API.Generic +import Servant.Server.Generic +import Servant.Server import Network.HTTP.Types import Network.Wai @@ -25,6 +28,12 @@ instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where throwAll e = throwAll e :<|> throwAll e + +instance + ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) => + ThrowAll (api (AsServerT m)) where + + throwAll = fromServant . throwAll -- Really this shouldn't be necessary - ((->) a) should be an instance of -- MonadError, no? 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 @@ -2,6 +2,7 @@ module Servant.Auth.Server.Internal.Types where import Control.Applicative +import Control.Monad (MonadPlus(..), ap) import Control.Monad.Reader import Control.Monad.Time import Data.Monoid (Monoid (..)) 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 TypeApplications #-} module Servant.Auth.ServerSpec (spec) where #if !MIN_VERSION_servant_server(0,16,0) @@ -6,13 +7,12 @@ #endif import Control.Lens -import Control.Monad.Except (runExceptT) import Control.Monad.IO.Class (liftIO) import Crypto.JOSE (Alg (HS256, None), Error, JWK, JWSHeader, KeyMaterialGenParam (OctGenParam), ToCompact, encodeCompact, - genJWK, newJWSHeader) + genJWK, newJWSHeader, runJOSE) import Crypto.JWT (Audience (..), ClaimsSet, NumericDate (NumericDate), SignedJWT, @@ -25,6 +25,7 @@ import Data.Aeson.Lens (_JSON) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Data.Text (Text, pack) import Data.CaseInsensitive (mk) import Data.Foldable (find) import Data.Monoid @@ -40,6 +41,7 @@ import Network.Wai (responseLBS) import Network.Wai.Handler.Warp (testWithApplication) import Network.Wreq (Options, auth, basicAuth, + checkResponse, cookieExpiryTime, cookies, defaults, get, getWith, postWith, header, oauth2Bearer, @@ -50,6 +52,7 @@ import Network.Wreq.Types (Postable(..)) import Servant hiding (BasicAuth, IsSecure (..), header) +import Servant.API.Generic ((:-)) import Servant.Auth.Server import Servant.Auth.Server.Internal.Cookie (expireTime) import Servant.Auth.Server.SetCookieOrphan () @@ -182,9 +185,22 @@ it "fails with no XSRF header or cookie" $ \port -> property $ \(user :: User) -> do jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) - opts <- addJwtToCookie cookieCfg jwt - getWith opts (url port) `shouldHTTPErrorWith` status401 + opts' <- addJwtToCookie cookieCfg jwt + let opts = opts' & checkResponse .~ Just mempty + resp <- getWith opts (url port) + resp ^. responseStatus `shouldBe` status401 + (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"] + -- Validating that the XSRF cookie isn't added for UVerb routes either. + -- These routes can return a 401 response directly without using throwError / throwAll, + -- which revealed a bug: + -- + -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449 + resp <- getWith opts (url port ++ "/uverb") + resp ^. responseStatus `shouldBe` status401 + (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"] + + it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property $ \(user :: User) -> do jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) @@ -405,17 +421,23 @@ = Auth auths User :> ( Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int + :<|> "named" :> NamedRoutes DummyRoutes :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int) #if MIN_VERSION_servant_server(0,15,0) :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) #endif :<|> "raw" :> Raw ) + :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text] :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie , Header "Set-Cookie" SetCookie ] NoContent) :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie , Header "Set-Cookie" SetCookie ] NoContent) +data DummyRoutes mode = DummyRoutes + { dummyInt :: mode :- "dummy" :> Get '[JSON] Int + } deriving Generic + jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) jwtOnlyApi = Proxy @@ -476,6 +498,7 @@ (\authResult -> case authResult of Authenticated usr -> getInt usr :<|> postInt usr + :<|> DummyRoutes { dummyInt = getInt usr } :<|> getHeaderInt #if MIN_VERSION_servant_server(0,15,0) :<|> return (S.source ["bytestring"]) @@ -483,6 +506,11 @@ :<|> raw Indefinite -> throwAll err401 _ -> throwAll err403 + ) :<|> + (\authResult -> case authResult of + Authenticated usr -> respond (WithStatus @200 (42 :: Int)) + Indefinite -> respond (WithStatus @401 $ pack "Authentication required") + _ -> respond (WithStatus @403 $ pack "Forbidden") ) :<|> getLogin :<|> getLogout @@ -533,7 +561,7 @@ $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v] createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT) -createJWT k a b = runExceptT $ signClaims k a b +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 @@ -562,6 +590,12 @@ shouldMatchCookieNames cj patterns = fmap cookie_name (destroyCookieJar cj) `shouldMatchList` patterns + +shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation +shouldNotHaveCookies cj patterns = + sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns + where cookieNames :: [BS.ByteString] + cookieNames = cookie_name <$> destroyCookieJar cj shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation shouldMatchCookieNameValues cj patterns