diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,14 @@ ## [Unreleased] +## [0.4.3.0] - 2019-01-17 + +## Changed +- #117 Avoid running auth checks unnecessarily [@sopvop] +- #110 Get rid of crypto-api dependency [@domenkozar] +- #130 clearSession: improve cross-browser compatibility [@domenkozar] +- #136 weed out bytestring-conversion [@stephenirl] + ## [0.4.2.0] - 2018-11-05 ### Added diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -218,7 +218,6 @@ api = Proxy :: Proxy (API '[Cookie]) run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) - -- Here is the login handler checkCreds :: CookieSettings -> JWTSettings diff --git a/servant-auth-server.cabal b/servant-auth-server.cabal --- a/servant-auth-server.cabal +++ b/servant-auth-server.cabal @@ -1,5 +1,5 @@ name: servant-auth-server -version: 0.4.2.0 +version: 0.4.3.0 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server. @@ -15,7 +15,7 @@ copyright: (c) Julian K. Arni license: BSD3 license-file: LICENSE -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.2 build-type: Simple cabal-version: >= 1.10 extra-source-files: @@ -31,34 +31,32 @@ default-extensions: AutoDeriveTypeable 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.8 && < 4.13 - , aeson >= 0.11 && < 2 - , base64-bytestring >= 1 && < 2 - , blaze-builder >= 0.4 && < 0.5 - , bytestring >= 0.10 && < 0.11 - , bytestring-conversion >= 0.3 && < 0.4 - , case-insensitive >= 1.2 && < 1.3 - , cookie >= 0.4 && < 0.5 - , crypto-api >= 0.13 && < 0.14 - , data-default-class >= 0.0 && < 0.2 - , entropy >= 0.3 && < 0.5 - , http-api-data >= 0.3.10 && < 0.4 - , http-types >= 0.9 && < 0.13 - , jose >= 0.6 && < 0.8 - , lens >= 4 && < 5 - , monad-time >= 0.2 && < 0.4 - , mtl >= 2.2 && < 2.3 - , servant >= 0.9.1 && < 0.15 + base >= 4.8 && < 4.13 + , aeson >= 1.3.1.1 && < 1.5 + , base64-bytestring >= 1.0.0.1 && < 1.1 + , blaze-builder >= 0.4.1.0 && < 0.5 + , bytestring >= 0.10.6.0 && < 0.11 + , 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.9 + , lens >= 4.16.1 && < 4.18 + , memory >= 0.14.16 && < 0.15 + , monad-time >= 0.3.1.0 && < 0.4 + , mtl >= 2.2.2 && < 2.3 + , servant >= 0.13 && < 0.16 , servant-auth == 0.3.* - , servant-server >= 0.9.1 && < 0.15 - , tagged >= 0.7.3 && < 0.9 - , text >= 1 && < 2 - , time >= 1.5 && < 1.9 - , unordered-containers >= 0.2 && < 0.3 - , wai >= 3.2 && < 3.3 + , servant-server >= 0.13 && < 0.16 + , tagged >= 0.8.4 && < 0.9 + , text >= 1.2.3.0 && < 1.3 + , time >= 1.5.0.1 && < 1.9 + , unordered-containers >= 0.2.9.0 && < 0.3 + , wai >= 3.2.1.2 && < 3.3 if !impl(ghc >= 8.0) build-depends: - semigroups >= 0.18.1 && <0.19 + semigroups >= 0.18.5 && <0.19 exposed-modules: Servant.Auth.Server Servant.Auth.Server.Internal @@ -88,8 +86,6 @@ , aeson , mtl , warp - , transformers - , markdown-unlit default-language: Haskell2010 if impl(ghcjs) buildable: False @@ -101,7 +97,7 @@ test default-extensions: AutoDeriveTypeable 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 + build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.7 -- dependencies with bounds inherited from the library stanza build-depends: @@ -121,12 +117,12 @@ -- test dependencies build-depends: servant-auth-server - , hspec > 2 && < 3 - , QuickCheck >= 2.8 && < 2.13 - , http-client >= 0.4 && < 0.6 - , lens-aeson - , warp - , wreq + , hspec >= 2.5.5 && < 2.7.0 + , QuickCheck >= 2.11.3 && < 2.13 + , http-client >= 0.5.13.1 && < 0.6 + , lens-aeson >= 1.0.2 && < 1.1 + , warp >= 3.2.25 && < 3.3 + , wreq >= 0.5.2.1 && < 0.6 other-modules: Servant.Auth.ServerSpec default-language: Haskell2010 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 @@ -5,12 +5,14 @@ import Control.Monad.Reader import qualified Crypto.JOSE as Jose import qualified Crypto.JWT as Jose -import Crypto.Util (constTimeEq) +import Data.ByteArray (constEq) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as BS64 import qualified Data.ByteString.Lazy as BSL import Data.CaseInsensitive (mk) import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day(..)) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime) import Network.HTTP.Types (methodGet) import Network.HTTP.Types.Header(hCookie) import Network.Wai (Request, requestHeaders, requestMethod) @@ -58,7 +60,7 @@ xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req - return $ xsrfCookie `constTimeEq` xsrfHeader + return $ xsrfCookie `constEq` xsrfHeader -- | Makes a cookie to be used for XSRF. makeXsrfCookie :: CookieSettings -> IO SetCookie @@ -142,7 +144,12 @@ xsrfCookie <- makeXsrfCookie cookieSettings return $ Just $ addHeader sessionCookie . addHeader xsrfCookie --- | Adds headers to a response that clears all session cookies. +-- | Arbitrary cookie expiry time set back in history after unix time 0 +expireTime :: UTCTime +expireTime = UTCTime (ModifiedJulianDay 50000) 0 + +-- | Adds headers to a response that clears all session cookies +-- | using max-age and expires cookie attributes. clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) => CookieSettings @@ -150,10 +157,15 @@ -> withTwoCookies clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie where - clearedSessionCookie = applySessionCookieSettings cookieSettings $ applyCookieSettings cookieSettings def + -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both + cookieSettingsExpires = cookieSettings + { cookieExpires = Just expireTime + , cookieMaxAge = Just (secondsToDiffTime 0) + } + clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def clearedXsrfCookie = case cookieXsrfSetting cookieSettings of - Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettings def - Nothing -> noXsrfTokenCookie cookieSettings + Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def + Nothing -> noXsrfTokenCookie cookieSettingsExpires makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c 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 @@ -5,9 +5,9 @@ import Control.Monad.Reader import qualified Crypto.JOSE as Jose import qualified Crypto.JWT as Jose -import Crypto.Util (constTimeEq) 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 @@ -52,7 +52,7 @@ authHdr <- lookup "Authorization" $ requestHeaders req let bearer = "Bearer " (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr - guard (mbearer `constTimeEq` bearer) + guard (mbearer `constEq` bearer) return rest verifiedJWT <- liftIO $ runExceptT $ do unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict token 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 @@ -53,7 +53,7 @@ -- | An @AuthCheck@ is the function used to decide the authentication status -- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a -- Monoid or Alternative; the semantics of this is that the *first* --- non-'Indefinite' result from left to right is used. +-- non-'Indefinite' result from left to right is used and the rest are ignored. newtype AuthCheck val = AuthCheck { runAuthCheck :: Request -> IO (AuthResult val) } deriving (Generic, Functor) @@ -61,8 +61,9 @@ instance Semigroup (AuthCheck val) where AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do fx <- f x - gx <- g x - return $ fx <> gx + case fx of + Indefinite -> g x + r -> pure r instance Monoid (AuthCheck val) where mempty = AuthCheck $ const $ return mempty 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 @@ -25,9 +25,11 @@ import Data.Foldable (find) import Data.Monoid import Data.Time +import Data.Time.Clock (getCurrentTime) import GHC.Generics (Generic) import Network.HTTP.Client (cookie_http_only, cookie_name, cookie_value, + cookie_expiry_time, destroyCookieJar) import Network.HTTP.Types (Status, status200, status401) @@ -45,6 +47,7 @@ import Servant hiding (BasicAuth, IsSecure (..), header) import Servant.Auth.Server +import Servant.Auth.Server.Internal.Cookie (expireTime) import Servant.Auth.Server.SetCookieOrphan () import System.IO.Unsafe (unsafePerformIO) import Test.Hspec @@ -203,13 +206,15 @@ resp <- getWith loggedInOpts (url port) resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + -- logout resp <- getWith loggedInOpts (url port ++ "/logout") - (resp ^. responseCookieJar) `shouldMatchCookieNameValues` - [ (sessionCookieName cookieCfg, "value") - , (xsrfField xsrfCookieName cookieCfg, "value") - ] - let loggedOutOpts = optsFromResp resp + -- assert cookies were expired + now <- getCurrentTime + let assertCookie c = now >= cookie_expiry_time c + all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True + + let loggedOutOpts = optsFromResp resp getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 describe "With no XSRF check for GET requests" $ let @@ -268,6 +273,12 @@ [ (sessionCookieName cookieCfg, "value") , ("NO-XSRF-TOKEN", "") ] + + -- assert cookies were expired + now <- getCurrentTime + let assertCookie c = now >= cookie_expiry_time c + all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True + let loggedOutOpts = optsFromResp resp getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401