Merge pull request haskell-servant#54 from grafted-in/csrf-check-origin

RFC: Add check-origin method for CSRF

servant-auth-server/src/Servant/Auth/Server.hs

@@ -67,13 +67,17 @@ module Servant.Auth.Server
 
   -- ** Settings
   , CookieSettings(..)
+  , XsrfCookieSettings(..)
   , defaultCookieSettings
+  , defaultXsrfCookieSettings
   , makeSessionCookie
   , makeSessionCookieBS
   , makeCsrfCookie
   , makeCookie
   , makeCookieBS
   , acceptLogin
+  , clearSession
+  , checkOriginAndReferer
 
 
   -- ** Related types

servant-auth-server/src/Servant/Auth/Server/Internal.hs

@@ -53,7 +53,7 @@ instance ( n ~ 'S ('S 'Z)
 
       makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
       makeCookies authResult = do
-        csrf <- makeCsrfCookie cookieSettings
+        csrf <- makeXsrfCookie cookieSettings
         fmap (Just csrf `SetCookieCons`) $
           case authResult of
             (Authenticated v) -> do

servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs

@@ -6,6 +6,7 @@ import qualified Data.ByteString    as BS
 import           Data.Default.Class
 import           Data.Time
 import           GHC.Generics       (Generic)
+import           Network.Wai        (Request)
 
 data IsMatch = Matches | DoesNotMatch
   deriving (Eq, Show, Read, Generic, Ord)
@@ -48,40 +49,60 @@ data CookieSettings = CookieSettings
   {
   -- | 'Secure' means browsers will only send cookies over HTTPS. Default:
   -- @Secure@.
-    cookieIsSecure    :: IsSecure
+    cookieIsSecure          :: !IsSecure
   -- | How long from now until the cookie expires. Default: @Nothing@.
-  , cookieMaxAge      :: Maybe DiffTime
+  , cookieMaxAge            :: !(Maybe DiffTime)
   -- | At what time the cookie expires. Default: @Nothing@.
-  , cookieExpires     :: Maybe UTCTime
+  , cookieExpires           :: !(Maybe UTCTime)
   -- | The URL path and sub-paths for which this cookie is used. Default @Just "/"@.
-  , cookiePath        :: Maybe BS.ByteString
+  , cookiePath              :: !(Maybe BS.ByteString)
   -- | 'SameSite' settings. Default: @SameSiteLax@.
-  , cookieSameSite    :: SameSite
+  , cookieSameSite          :: !SameSite
   -- | What name to use for the cookie used for the session.
-  , sessionCookieName :: BS.ByteString
-  -- | What name to use for the cookie used for CSRF protection.
-  , xsrfCookieName    :: BS.ByteString
-  -- | What path to use for the cookie used for CSRF protection. Default @Just "/"@.
-  , xsrfCookiePath    :: Maybe BS.ByteString
-  -- | What name to use for the header used for CSRF protection.
-  , xsrfHeaderName    :: BS.ByteString
-  } deriving (Eq, Show, Generic)
+  , cookieSessionCookieName :: !BS.ByteString
+  -- | The optional settings to use for XSRF protection. Default @Just def@.
+  , cookieXsrfSetting       :: !(Maybe XsrfCookieSettings)
+  -- | An arbitrary check for the request. Use this to implement validating
+  --   the Origin/Referer headers. Default @const True@.
+  , cookieCheckRequest      :: !(Request -> Bool)
+  } deriving (Generic)
 
 instance Default CookieSettings where
   def = defaultCookieSettings
 
 defaultCookieSettings :: CookieSettings
 defaultCookieSettings = CookieSettings
-    { cookieIsSecure    = Secure
-    , cookieMaxAge      = Nothing
-    , cookieExpires     = Nothing
-    , cookiePath        = Just "/"
-    , cookieSameSite    = SameSiteLax
-    , sessionCookieName = "JWT-Cookie"
-    , xsrfCookieName    = "XSRF-TOKEN"
-    , xsrfCookiePath    = Just "/"
-    , xsrfHeaderName    = "X-XSRF-TOKEN"
-    }
+  { cookieIsSecure          = Secure
+  , cookieMaxAge            = Nothing
+  , cookieExpires           = Nothing
+  , cookiePath              = Just "/"
+  , cookieSameSite          = SameSiteLax
+  , cookieSessionCookieName = "JWT-Cookie"
+  , cookieXsrfSetting       = Just def
+  , cookieCheckRequest      = const True
+  }
+
+
+-- | The policies to use when generating and verifying XSRF cookies
+data XsrfCookieSettings = XsrfCookieSettings
+  {
+  -- | What name to use for the cookie used for CSRF protection.
+    xsrfCookieName :: !BS.ByteString
+  -- | What path to use for the cookie used for CSRF protection. Default @Just "/"@.
+  , xsrfCookiePath :: !(Maybe BS.ByteString)
+  -- | What name to use for the header used for CSRF protection.
+  , xsrfHeaderName :: !BS.ByteString
+  } deriving (Eq, Show, Generic)
+
+instance Default XsrfCookieSettings where
+  def = defaultXsrfCookieSettings
+
+defaultXsrfCookieSettings :: XsrfCookieSettings
+defaultXsrfCookieSettings = XsrfCookieSettings
+  { xsrfCookieName = "XSRF-TOKEN"
+  , xsrfCookiePath = Just "/"
+  , xsrfHeaderName = "X-XSRF-TOKEN"
+  }
 
 
 ------------------------------------------------------------------------------
@@ -91,6 +112,6 @@ jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings
 jwtSettingsToJwtValidationSettings s
   = defaultJWTValidationSettings (toBool <$> audienceMatches s)
   where
-    toBool Matches = True
+    toBool Matches      = True
     toBool DoesNotMatch = False
 -- }}}

servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs

@@ -3,16 +3,19 @@ module Servant.Auth.Server.Internal.Cookie where
 import           Blaze.ByteString.Builder (toByteString)
 import           Control.Monad.Except
 import           Control.Monad.Reader
-import qualified Crypto.JOSE              as Jose
-import qualified Crypto.JWT               as Jose
-import           Crypto.Util              (constTimeEq)
-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           Network.Wai              (requestHeaders)
-import           Servant                  (AddHeader, addHeader)
-import           System.Entropy           (getEntropy)
+import qualified Crypto.JOSE               as Jose
+import qualified Crypto.JWT                as Jose
+import           Crypto.Util               (constTimeEq)
+import qualified Data.ByteString           as BS
+import qualified Data.ByteString.Char8     as BSC
+import qualified Data.ByteString.Base64    as BS64
+import qualified Data.ByteString.Lazy      as BSL
+import           Data.CaseInsensitive      (mk)
+import           Data.Maybe                (fromMaybe, isJust)
+import           Network.HTTP.Types.Header (hCookie, hReferer)
+import           Network.Wai               (Request, requestHeaders)
+import           Servant                   (AddHeader, addHeader)
+import           System.Entropy            (getEntropy)
 import           Web.Cookie
 
 import Servant.Auth.Server.Internal.ConfigTypes
@@ -25,13 +28,19 @@ cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr
 cookieAuthCheck ccfg jwtCfg = do
   req <- ask
   jwtCookie <- maybe mempty return $ do
-    cookies' <- lookup "Cookie" $ requestHeaders req
+    cookies' <- lookup hCookie $ requestHeaders req
     let cookies = parseCookies cookies'
-    xsrfCookie <- lookup (xsrfCookieName ccfg) cookies
-    xsrfHeader <- lookup (mk $ xsrfHeaderName ccfg) $ requestHeaders req
-    guard $ xsrfCookie `constTimeEq` xsrfHeader
+
+    -- Apply the XSRF check if enabled.
+    guard $ case cookieXsrfSetting ccfg of
+      Just xsrfCookieSettings -> xsrfCookieAuthCheck xsrfCookieSettings req cookies
+      Nothing                 -> True
+
+    -- Apply the arbitrary request check from the configuration.
+    guard $ cookieCheckRequest ccfg req
+
     -- session cookie *must* be HttpOnly and Secure
-    lookup (sessionCookieName ccfg) cookies
+    lookup (cookieSessionCookieName ccfg) cookies
   verifiedJWT <- liftIO $ runExceptT $ do
     unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict jwtCookie
     Jose.verifyClaims (jwtSettingsToJwtValidationSettings jwtCfg)
@@ -43,38 +52,71 @@ cookieAuthCheck ccfg jwtCfg = do
       Left _ -> mzero
       Right v' -> return v'
 
--- | Makes a cookie to be used for CSRF.
+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 `constTimeEq` 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
+  where
+    makeRealCookie xsrfCookieSettings = do
+      xsrfValue <- BS64.encode <$> getEntropy 32
+      return
+        $ applyXsrfCookieSettings xsrfCookieSettings
+        $ applyCookieSettings cookieSettings
+        $ def{ setCookieValue = xsrfValue }
+
+
+-- | Alias for 'makeXsrfCookie'.
 makeCsrfCookie :: CookieSettings -> IO SetCookie
-makeCsrfCookie cookieSettings = do
-  csrfValue <- BS64.encode <$> getEntropy 32
-  return $ def
-    { setCookieName = xsrfCookieName cookieSettings
-    , setCookieValue = csrfValue
-    , setCookieMaxAge = cookieMaxAge cookieSettings
-    , setCookieExpires = cookieExpires cookieSettings
-    , setCookiePath = xsrfCookiePath cookieSettings
-    , setCookieSecure = case cookieIsSecure cookieSettings of
-        Secure -> True
-        NotSecure -> False
-    }
+makeCsrfCookie = makeXsrfCookie
+{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}
+
 
 -- | Makes a cookie with session information.
 makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
 makeSessionCookie cookieSettings jwtSettings v = do
   ejwt <- makeJWT v jwtSettings Nothing
   case ejwt of
     Left _ -> return Nothing
-    Right jwt -> return $ Just $ def
-      { setCookieName = sessionCookieName cookieSettings
-      , setCookieValue = BSL.toStrict jwt
-      , setCookieHttpOnly = True
-      , setCookieMaxAge = cookieMaxAge cookieSettings
-      , setCookieExpires = cookieExpires cookieSettings
-      , setCookiePath = cookiePath cookieSettings
-      , setCookieSecure = case cookieIsSecure cookieSettings of
-          Secure -> True
-          NotSecure -> False
-      }
+    Right jwt -> return
+      $ Just
+      $ applySessionCookieSettings cookieSettings
+      $ applyCookieSettings cookieSettings
+      $ def{ setCookieValue = BSL.toStrict jwt }
+
+noXsrfTokenCookie :: CookieSettings -> SetCookie
+noXsrfTokenCookie cookieSettings =
+  applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" }
+
+applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie
+applyCookieSettings cookieSettings setCookie = setCookie
+  { setCookieMaxAge = cookieMaxAge cookieSettings
+  , setCookieExpires = cookieExpires cookieSettings
+  , setCookiePath = cookiePath cookieSettings
+  , setCookieSecure = case cookieIsSecure cookieSettings of
+      Secure -> True
+      NotSecure -> False
+  }
+
+applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie
+applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie
+  { setCookieName = xsrfCookieName xsrfCookieSettings
+  , setCookiePath = xsrfCookiePath xsrfCookieSettings
+  , setCookieHttpOnly = False
+  }
+
+applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie
+applySessionCookieSettings cookieSettings setCookie = setCookie
+  { setCookieName = cookieSessionCookieName cookieSettings
+  , setCookieHttpOnly = True
+  }
 
 -- | For a JWT-serializable session, returns a function that decorates a
 -- provided response object with CSRF and session cookies. This should be used
@@ -91,8 +133,31 @@ acceptLogin cookieSettings jwtSettings session = do
   case mSessionCookie of
     Nothing            -> pure Nothing
     Just sessionCookie -> do
-      csrfCookie <- makeCsrfCookie cookieSettings
-      return $ Just $ addHeader sessionCookie . addHeader csrfCookie
+      xsrfCookie <- makeXsrfCookie cookieSettings
+      return $ Just $ addHeader sessionCookie . addHeader xsrfCookie
+
+-- | Adds headers to a response that clears all session cookies.
+clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie
+                , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
+             => CookieSettings
+             -> response
+             -> withTwoCookies
+clearSession cookieSettings
+  = addHeader (applySessionCookieSettings cookieSettings $ applyCookieSettings cookieSettings def)
+  . addHeader (noXsrfTokenCookie cookieSettings)
+
+-- | A helper for use with 'cookieCheckRequest' which verifies that either the request's @Origin@
+--   header or its @Referer@ header matches the expected origin. If neither header is available,
+--   this blockes the request.
+checkOriginAndReferer :: BS.ByteString -> Request -> Bool
+checkOriginAndReferer expectedOrigin req
+  =  (isJust origin || isJust referer)
+  && maybe True (expectedOrigin ==) origin
+  && maybe True (\x -> expectedOrigin == x || (expectedOrigin `BSC.snoc` '/') `BS.isPrefixOf` x) referer
+  where
+    headers = requestHeaders req
+    origin  = lookup "Origin" headers
+    referer = lookup hReferer headers
 
 makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
 makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie)  <$> makeSessionCookie a b c