{-# LANGUAGE CPP #-}
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
import qualified Crypto.JWT               as Jose
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)
import           Servant                  (AddHeader, addHeader)
import           System.Entropy           (getEntropy)
import           Web.Cookie

import Servant.Auth.JWT                          (FromJWT (decodeJWT), ToJWT)
import Servant.Auth.Server.Internal.ConfigTypes
import Servant.Auth.Server.Internal.JWT          (makeJWT, verifyJWT)
import Servant.Auth.Server.Internal.Types


cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr
cookieAuthCheck :: forall usr.
FromJWT usr =>
CookieSettings -> JWTSettings -> AuthCheck usr
cookieAuthCheck CookieSettings
ccfg JWTSettings
jwtSettings = do
  Request
req <- forall r (m :: * -> *). MonadReader r m => m r
ask
  ByteString
jwtCookie <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
    ByteString
cookies' <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hCookie forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req
    let cookies :: Cookies
cookies = ByteString -> Cookies
parseCookies ByteString
cookies'
    -- Apply the XSRF check if enabled.
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Bool
True forall a b. (a -> b) -> a -> b
$ do
      XsrfCookieSettings
xsrfCookieCfg <- CookieSettings -> Request -> Maybe XsrfCookieSettings
xsrfCheckRequired CookieSettings
ccfg Request
req
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ XsrfCookieSettings -> Request -> Cookies -> Bool
xsrfCookieAuthCheck XsrfCookieSettings
xsrfCookieCfg Request
req Cookies
cookies
    -- session cookie *must* be HttpOnly and Secure
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (CookieSettings -> ByteString
sessionCookieName CookieSettings
ccfg) Cookies
cookies
  Maybe usr
verifiedJWT <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FromJWT a => JWTSettings -> ByteString -> IO (Maybe a)
verifyJWT JWTSettings
jwtSettings ByteString
jwtCookie
  case Maybe usr
verifiedJWT of
    Maybe usr
Nothing -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Just usr
v -> forall (m :: * -> *) a. Monad m => a -> m a
return usr
v

xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings
xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings
xsrfCheckRequired CookieSettings
cookieSettings Request
req = do
    XsrfCookieSettings
xsrfCookieCfg <- CookieSettings -> Maybe XsrfCookieSettings
cookieXsrfSetting CookieSettings
cookieSettings
    let disableForGetReq :: Bool
disableForGetReq = XsrfCookieSettings -> Bool
xsrfExcludeGet XsrfCookieSettings
xsrfCookieCfg Bool -> Bool -> Bool
&& Request -> ByteString
requestMethod Request
req forall a. Eq a => a -> a -> Bool
== ByteString
methodGet
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
disableForGetReq
    forall (m :: * -> *) a. Monad m => a -> m a
return XsrfCookieSettings
xsrfCookieCfg

xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool
xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> Cookies -> Bool
xsrfCookieAuthCheck XsrfCookieSettings
xsrfCookieCfg Request
req Cookies
cookies = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
  ByteString
xsrfCookie <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (XsrfCookieSettings -> ByteString
xsrfCookieName XsrfCookieSettings
xsrfCookieCfg) Cookies
cookies
  ByteString
xsrfHeader <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall s. FoldCase s => s -> CI s
mk forall a b. (a -> b) -> a -> b
$ XsrfCookieSettings -> ByteString
xsrfHeaderName XsrfCookieSettings
xsrfCookieCfg) forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
xsrfCookie forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
`constEq` ByteString
xsrfHeader

-- | Makes a cookie to be used for XSRF.
makeXsrfCookie :: CookieSettings -> IO SetCookie
makeXsrfCookie :: CookieSettings -> IO SetCookie
makeXsrfCookie CookieSettings
cookieSettings = case CookieSettings -> Maybe XsrfCookieSettings
cookieXsrfSetting CookieSettings
cookieSettings of
  Just XsrfCookieSettings
xsrfCookieSettings -> XsrfCookieSettings -> IO SetCookie
makeRealCookie XsrfCookieSettings
xsrfCookieSettings
  Maybe XsrfCookieSettings
Nothing                 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie
noXsrfTokenCookie CookieSettings
cookieSettings
  where
    makeRealCookie :: XsrfCookieSettings -> IO SetCookie
makeRealCookie XsrfCookieSettings
xsrfCookieSettings = do
      ByteString
xsrfValue <- ByteString -> ByteString
BS64.encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getEntropy Int
32
      forall (m :: * -> *) a. Monad m => a -> m a
return
        forall a b. (a -> b) -> a -> b
$ XsrfCookieSettings -> SetCookie -> SetCookie
applyXsrfCookieSettings XsrfCookieSettings
xsrfCookieSettings
        forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettings
        forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def{ setCookieValue :: ByteString
setCookieValue = ByteString
xsrfValue }


-- | Alias for 'makeXsrfCookie'.
makeCsrfCookie :: CookieSettings -> IO SetCookie
makeCsrfCookie :: CookieSettings -> IO SetCookie
makeCsrfCookie = CookieSettings -> IO SetCookie
makeXsrfCookie
{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}


-- | Makes a cookie with session information.
makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeSessionCookie :: forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeSessionCookie CookieSettings
cookieSettings JWTSettings
jwtSettings v
v = do
  Either Error ByteString
ejwt <- forall a.
ToJWT a =>
a -> JWTSettings -> Maybe UTCTime -> IO (Either Error ByteString)
makeJWT v
v JWTSettings
jwtSettings (CookieSettings -> Maybe UTCTime
cookieExpires CookieSettings
cookieSettings)
  case Either Error ByteString
ejwt of
    Left Error
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Right ByteString
jwt -> forall (m :: * -> *) a. Monad m => a -> m a
return
      forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
      forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applySessionCookieSettings CookieSettings
cookieSettings
      forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettings
      forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def{ setCookieValue :: ByteString
setCookieValue = ByteString -> ByteString
BSL.toStrict ByteString
jwt }

noXsrfTokenCookie :: CookieSettings -> SetCookie
noXsrfTokenCookie :: CookieSettings -> SetCookie
noXsrfTokenCookie CookieSettings
cookieSettings =
  CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettings forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def{ setCookieName :: ByteString
setCookieName = ByteString
"NO-XSRF-TOKEN", setCookieValue :: ByteString
setCookieValue = ByteString
"" }

applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie
applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettings SetCookie
setCookie = SetCookie
setCookie
  { setCookieMaxAge :: Maybe DiffTime
setCookieMaxAge = CookieSettings -> Maybe DiffTime
cookieMaxAge CookieSettings
cookieSettings
  , setCookieExpires :: Maybe UTCTime
setCookieExpires = CookieSettings -> Maybe UTCTime
cookieExpires CookieSettings
cookieSettings
  , setCookiePath :: Maybe ByteString
setCookiePath = CookieSettings -> Maybe ByteString
cookiePath CookieSettings
cookieSettings
  , setCookieDomain :: Maybe ByteString
setCookieDomain = CookieSettings -> Maybe ByteString
cookieDomain CookieSettings
cookieSettings
  , setCookieSecure :: Bool
setCookieSecure = case CookieSettings -> IsSecure
cookieIsSecure CookieSettings
cookieSettings of
      IsSecure
Secure -> Bool
True
      IsSecure
NotSecure -> Bool
False
  , setCookieSameSite :: Maybe SameSiteOption
setCookieSameSite = case CookieSettings -> SameSite
cookieSameSite CookieSettings
cookieSettings of
      SameSite
AnySite -> Maybe SameSiteOption
anySite
      SameSite
SameSiteStrict -> forall a. a -> Maybe a
Just SameSiteOption
sameSiteStrict
      SameSite
SameSiteLax -> forall a. a -> Maybe a
Just SameSiteOption
sameSiteLax
  }
  where
#if MIN_VERSION_cookie(0,4,5)
    anySite :: Maybe SameSiteOption
anySite = forall a. a -> Maybe a
Just SameSiteOption
sameSiteNone
#else
    anySite = Nothing
#endif

applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie
applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie
applyXsrfCookieSettings XsrfCookieSettings
xsrfCookieSettings SetCookie
setCookie = SetCookie
setCookie
  { setCookieName :: ByteString
setCookieName = XsrfCookieSettings -> ByteString
xsrfCookieName XsrfCookieSettings
xsrfCookieSettings
  , setCookiePath :: Maybe ByteString
setCookiePath = XsrfCookieSettings -> Maybe ByteString
xsrfCookiePath XsrfCookieSettings
xsrfCookieSettings
  , setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
False
  }

applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie
applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie
applySessionCookieSettings CookieSettings
cookieSettings SetCookie
setCookie = SetCookie
setCookie
  { setCookieName :: ByteString
setCookieName = CookieSettings -> ByteString
sessionCookieName CookieSettings
cookieSettings
  , setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True
  }

-- | For a JWT-serializable session, returns a function that decorates a
-- provided response object with XSRF and session cookies. This should be used
-- when a user successfully authenticates with credentials.
acceptLogin :: ( ToJWT session
               , AddHeader "Set-Cookie" SetCookie response withOneCookie
               , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
            => CookieSettings
            -> JWTSettings
            -> session
            -> IO (Maybe (response -> withTwoCookies))
acceptLogin :: forall session response withOneCookie withTwoCookies.
(ToJWT session,
 AddHeader "Set-Cookie" SetCookie response withOneCookie,
 AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies) =>
CookieSettings
-> JWTSettings
-> session
-> IO (Maybe (response -> withTwoCookies))
acceptLogin CookieSettings
cookieSettings JWTSettings
jwtSettings session
session = do
  Maybe SetCookie
mSessionCookie <- forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeSessionCookie CookieSettings
cookieSettings JWTSettings
jwtSettings session
session
  case Maybe SetCookie
mSessionCookie of
    Maybe SetCookie
Nothing            -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just SetCookie
sessionCookie -> do
      SetCookie
xsrfCookie <- CookieSettings -> IO SetCookie
makeXsrfCookie CookieSettings
cookieSettings
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader SetCookie
sessionCookie forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader SetCookie
xsrfCookie

-- | Arbitrary cookie expiry time set back in history after unix time 0
expireTime :: UTCTime
expireTime :: UTCTime
expireTime = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
50000) DiffTime
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
             -> response
             -> withTwoCookies
clearSession :: forall response withOneCookie withTwoCookies.
(AddHeader "Set-Cookie" SetCookie response withOneCookie,
 AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies) =>
CookieSettings -> response -> withTwoCookies
clearSession CookieSettings
cookieSettings = forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader SetCookie
clearedSessionCookie forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader SetCookie
clearedXsrfCookie
  where
    -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both
    cookieSettingsExpires :: CookieSettings
cookieSettingsExpires = CookieSettings
cookieSettings
      { cookieExpires :: Maybe UTCTime
cookieExpires = forall a. a -> Maybe a
Just UTCTime
expireTime
      , cookieMaxAge :: Maybe DiffTime
cookieMaxAge = forall a. a -> Maybe a
Just (Integer -> DiffTime
secondsToDiffTime Integer
0)
      }
    clearedSessionCookie :: SetCookie
clearedSessionCookie = CookieSettings -> SetCookie -> SetCookie
applySessionCookieSettings CookieSettings
cookieSettingsExpires forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettingsExpires forall a. Default a => a
def
    clearedXsrfCookie :: SetCookie
clearedXsrfCookie = case CookieSettings -> Maybe XsrfCookieSettings
cookieXsrfSetting CookieSettings
cookieSettings of
        Just XsrfCookieSettings
xsrfCookieSettings -> XsrfCookieSettings -> SetCookie -> SetCookie
applyXsrfCookieSettings XsrfCookieSettings
xsrfCookieSettings forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettingsExpires forall a. Default a => a
def
        Maybe XsrfCookieSettings
Nothing                 -> CookieSettings -> SetCookie
noXsrfTokenCookie CookieSettings
cookieSettingsExpires

makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
makeSessionCookieBS :: forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe ByteString)
makeSessionCookieBS CookieSettings
a JWTSettings
b v
c = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Builder -> ByteString
toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> Builder
renderSetCookie)  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeSessionCookie CookieSettings
a JWTSettings
b v
c

-- | Alias for 'makeSessionCookie'.
makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeCookie :: forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeCookie = forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeSessionCookie
{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-}

-- | Alias for 'makeSessionCookieBS'.
makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
makeCookieBS :: forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe ByteString)
makeCookieBS = forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe ByteString)
makeSessionCookieBS
{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-}