{-# 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'
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
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
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 }
makeCsrfCookie :: CookieSettings -> IO SetCookie
makeCsrfCookie :: CookieSettings -> IO SetCookie
makeCsrfCookie = CookieSettings -> IO SetCookie
makeXsrfCookie
{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}
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
}
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
expireTime :: UTCTime
expireTime :: UTCTime
expireTime = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
50000) DiffTime
0
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
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
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" #-}
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" #-}