servant-auth-server 0.4.7.0 → 0.4.8.0

raw patch · 9 files changed

+118/−53 lines, 9 filesdep ~QuickCheckdep ~basedep ~bytestringnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck, base, bytestring, cookie, hspec, jose, lens, lens-aeson, monad-time, mtl, servant, servant-server, text, warp

API changes (from Hackage documentation)

Files

• servant-auth-server.cabal +18/−17
• src/Servant/Auth/Server/Internal.hs +6/−9
• src/Servant/Auth/Server/Internal/AddSetCookie.hs +26/−1
• src/Servant/Auth/Server/Internal/ConfigTypes.hs +2/−2
• src/Servant/Auth/Server/Internal/Cookie.hs +11/−10
• src/Servant/Auth/Server/Internal/JWT.hs +5/−8
• src/Servant/Auth/Server/Internal/ThrowAll.hs +10/−1
• src/Servant/Auth/Server/Internal/Types.hs +1/−0
• test/Servant/Auth/ServerSpec.hs +39/−5

@@ -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 <http://github.com/haskell-servant/servant/servant-auth#readme README>.+                For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>. 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

@@ -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)

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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?

@@ -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 (..))

@@ -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