{-# LANGUAGE CPP #-}
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 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 :: CookieSettings -> JWTSettings -> AuthCheck usr
cookieAuthCheck CookieSettings
ccfg JWTSettings
jwtSettings = do
Request
req <- AuthCheck Request
forall r (m :: * -> *). MonadReader r m => m r
ask
ByteString
jwtCookie <- AuthCheck ByteString
-> (ByteString -> AuthCheck ByteString)
-> Maybe ByteString
-> AuthCheck ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthCheck ByteString
forall a. Monoid a => a
mempty ByteString -> AuthCheck ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> AuthCheck ByteString)
-> Maybe ByteString -> AuthCheck ByteString
forall a b. (a -> b) -> a -> b
$ do
ByteString
cookies' <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hCookie ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
let cookies :: Cookies
cookies = ByteString -> Cookies
parseCookies ByteString
cookies'
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
XsrfCookieSettings
xsrfCookieCfg <- CookieSettings -> Request -> Maybe XsrfCookieSettings
xsrfCheckRequired CookieSettings
ccfg Request
req
Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ XsrfCookieSettings -> Request -> Cookies -> Bool
xsrfCookieAuthCheck XsrfCookieSettings
xsrfCookieCfg Request
req Cookies
cookies
ByteString -> Cookies -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (CookieSettings -> ByteString
sessionCookieName CookieSettings
ccfg) Cookies
cookies
Maybe usr
verifiedJWT <- IO (Maybe usr) -> AuthCheck (Maybe usr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe usr) -> AuthCheck (Maybe usr))
-> IO (Maybe usr) -> AuthCheck (Maybe usr)
forall a b. (a -> b) -> a -> b
$ JWTSettings -> ByteString -> IO (Maybe usr)
forall a. FromJWT a => JWTSettings -> ByteString -> IO (Maybe a)
verifyJWT JWTSettings
jwtSettings ByteString
jwtCookie
case Maybe usr
verifiedJWT of
Maybe usr
Nothing -> AuthCheck usr
forall (m :: * -> *) a. MonadPlus m => m a
mzero
Just usr
v -> usr -> AuthCheck usr
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
methodGet
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
disableForGetReq
XsrfCookieSettings -> Maybe XsrfCookieSettings
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 = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
ByteString
xsrfCookie <- ByteString -> Cookies -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (XsrfCookieSettings -> ByteString
xsrfCookieName XsrfCookieSettings
xsrfCookieCfg) Cookies
cookies
ByteString
xsrfHeader <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ XsrfCookieSettings -> ByteString
xsrfHeaderName XsrfCookieSettings
xsrfCookieCfg) ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ByteString
xsrfCookie ByteString -> ByteString -> Bool
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 -> SetCookie -> IO SetCookie
forall (m :: * -> *) a. Monad m => a -> m a
return (SetCookie -> IO SetCookie) -> SetCookie -> IO SetCookie
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 (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getEntropy Int
32
SetCookie -> IO SetCookie
forall (m :: * -> *) a. Monad m => a -> m a
return
(SetCookie -> IO SetCookie) -> SetCookie -> IO SetCookie
forall a b. (a -> b) -> a -> b
$ XsrfCookieSettings -> SetCookie -> SetCookie
applyXsrfCookieSettings XsrfCookieSettings
xsrfCookieSettings
(SetCookie -> SetCookie) -> SetCookie -> SetCookie
forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettings
(SetCookie -> SetCookie) -> SetCookie -> SetCookie
forall a b. (a -> b) -> a -> b
$ SetCookie
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 :: CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeSessionCookie CookieSettings
cookieSettings JWTSettings
jwtSettings v
v = do
Either Error ByteString
ejwt <- v -> JWTSettings -> Maybe UTCTime -> IO (Either Error ByteString)
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
_ -> Maybe SetCookie -> IO (Maybe SetCookie)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SetCookie
forall a. Maybe a
Nothing
Right ByteString
jwt -> Maybe SetCookie -> IO (Maybe SetCookie)
forall (m :: * -> *) a. Monad m => a -> m a
return
(Maybe SetCookie -> IO (Maybe SetCookie))
-> Maybe SetCookie -> IO (Maybe SetCookie)
forall a b. (a -> b) -> a -> b
$ SetCookie -> Maybe SetCookie
forall a. a -> Maybe a
Just
(SetCookie -> Maybe SetCookie) -> SetCookie -> Maybe SetCookie
forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applySessionCookieSettings CookieSettings
cookieSettings
(SetCookie -> SetCookie) -> SetCookie -> SetCookie
forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettings
(SetCookie -> SetCookie) -> SetCookie -> SetCookie
forall a b. (a -> b) -> a -> b
$ SetCookie
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 (SetCookie -> SetCookie) -> SetCookie -> SetCookie
forall a b. (a -> b) -> a -> b
$ SetCookie
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
}
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
, setCookieSameSite :: Maybe SameSiteOption
setCookieSameSite = case CookieSettings -> SameSite
cookieSameSite CookieSettings
cookieSettings of
SameSite
AnySite -> Maybe SameSiteOption
anySite
SameSite
SameSiteStrict -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
sameSiteStrict
SameSite
SameSiteLax -> SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
sameSiteLax
, setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True
}
where
#if MIN_VERSION_cookie(0,4,5)
anySite :: Maybe SameSiteOption
anySite = SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
sameSiteNone
#else
anySite = Nothing
#endif
acceptLogin :: ( ToJWT session
, AddHeader "Set-Cookie" SetCookie response withOneCookie
, AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
=> CookieSettings
-> JWTSettings
-> session
-> IO (Maybe (response -> withTwoCookies))
acceptLogin :: CookieSettings
-> JWTSettings
-> session
-> IO (Maybe (response -> withTwoCookies))
acceptLogin CookieSettings
cookieSettings JWTSettings
jwtSettings session
session = do
Maybe SetCookie
mSessionCookie <- CookieSettings -> JWTSettings -> session -> IO (Maybe SetCookie)
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 -> Maybe (response -> withTwoCookies)
-> IO (Maybe (response -> withTwoCookies))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (response -> withTwoCookies)
forall a. Maybe a
Nothing
Just SetCookie
sessionCookie -> do
SetCookie
xsrfCookie <- CookieSettings -> IO SetCookie
makeXsrfCookie CookieSettings
cookieSettings
Maybe (response -> withTwoCookies)
-> IO (Maybe (response -> withTwoCookies))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (response -> withTwoCookies)
-> IO (Maybe (response -> withTwoCookies)))
-> Maybe (response -> withTwoCookies)
-> IO (Maybe (response -> withTwoCookies))
forall a b. (a -> b) -> a -> b
$ (response -> withTwoCookies) -> Maybe (response -> withTwoCookies)
forall a. a -> Maybe a
Just ((response -> withTwoCookies)
-> Maybe (response -> withTwoCookies))
-> (response -> withTwoCookies)
-> Maybe (response -> withTwoCookies)
forall a b. (a -> b) -> a -> b
$ SetCookie -> withOneCookie -> withTwoCookies
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader SetCookie
sessionCookie (withOneCookie -> withTwoCookies)
-> (response -> withOneCookie) -> response -> withTwoCookies
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> response -> withOneCookie
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 :: CookieSettings -> response -> withTwoCookies
clearSession CookieSettings
cookieSettings = SetCookie -> withOneCookie -> withTwoCookies
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader SetCookie
clearedSessionCookie (withOneCookie -> withTwoCookies)
-> (response -> withOneCookie) -> response -> withTwoCookies
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> response -> withOneCookie
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 = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
expireTime
, cookieMaxAge :: Maybe DiffTime
cookieMaxAge = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (Integer -> DiffTime
secondsToDiffTime Integer
0)
}
clearedSessionCookie :: SetCookie
clearedSessionCookie = CookieSettings -> SetCookie -> SetCookie
applySessionCookieSettings CookieSettings
cookieSettingsExpires (SetCookie -> SetCookie) -> SetCookie -> SetCookie
forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettingsExpires SetCookie
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 (SetCookie -> SetCookie) -> SetCookie -> SetCookie
forall a b. (a -> b) -> a -> b
$ CookieSettings -> SetCookie -> SetCookie
applyCookieSettings CookieSettings
cookieSettingsExpires SetCookie
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 :: CookieSettings -> JWTSettings -> v -> IO (Maybe ByteString)
makeSessionCookieBS CookieSettings
a JWTSettings
b v
c = (SetCookie -> ByteString) -> Maybe SetCookie -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Builder -> ByteString
toByteString (Builder -> ByteString)
-> (SetCookie -> Builder) -> SetCookie -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> Builder
renderSetCookie) (Maybe SetCookie -> Maybe ByteString)
-> IO (Maybe SetCookie) -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
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 :: CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeCookie = CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
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 :: CookieSettings -> JWTSettings -> v -> IO (Maybe ByteString)
makeCookieBS = CookieSettings -> JWTSettings -> v -> IO (Maybe ByteString)
forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe ByteString)
makeSessionCookieBS
{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-}