{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Web.Spock.Internal.Cookies where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import qualified Network.HTTP.Types.URI as URI (urlDecode, urlEncode)
import qualified Web.Cookie as C

#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative
#endif

-- | Cookie settings
data CookieSettings = CookieSettings
  { -- | cookie expiration setting, see 'CookieEOL'
    CookieSettings -> CookieEOL
cs_EOL :: CookieEOL,
    -- | a path for the cookie
    CookieSettings -> Maybe ByteString
cs_path :: Maybe BS.ByteString,
    -- | a domain for the cookie. 'Nothing' means no domain is set
    CookieSettings -> Maybe ByteString
cs_domain :: Maybe BS.ByteString,
    -- | whether the cookie should be set as HttpOnly
    CookieSettings -> Bool
cs_HTTPOnly :: Bool,
    -- | whether the cookie should be marked secure (sent over HTTPS only)
    CookieSettings -> Bool
cs_secure :: Bool,
    -- | Cross-site cookie policy. 'Nothing' omits the attribute. When using
    -- 'SameSiteNone', also enable 'cs_secure' for browser compatibility.
    CookieSettings -> Maybe SameSite
cs_sameSite :: Maybe SameSite
  }

data SameSite = SameSiteLax | SameSiteStrict | SameSiteNone
  deriving (SameSite -> SameSite -> Bool
(SameSite -> SameSite -> Bool)
-> (SameSite -> SameSite -> Bool) -> Eq SameSite
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SameSite -> SameSite -> Bool
== :: SameSite -> SameSite -> Bool
$c/= :: SameSite -> SameSite -> Bool
/= :: SameSite -> SameSite -> Bool
Eq, Int -> SameSite -> ShowS
[SameSite] -> ShowS
SameSite -> String
(Int -> SameSite -> ShowS)
-> (SameSite -> String) -> ([SameSite] -> ShowS) -> Show SameSite
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SameSite -> ShowS
showsPrec :: Int -> SameSite -> ShowS
$cshow :: SameSite -> String
show :: SameSite -> String
$cshowList :: [SameSite] -> ShowS
showList :: [SameSite] -> ShowS
Show)

-- | Setting cookie expiration
data CookieEOL
  = -- | a point in time in UTC until the cookie is valid
    CookieValidUntil UTCTime
  | -- | a period (in seconds) for which the cookie is valid
    CookieValidFor NominalDiffTime
  | -- | the cookie expires with the browser session
    CookieValidForSession
  | -- | the cookie will have an expiration date in the far future
    CookieValidForever

-- | Default cookie settings, equals
--
-- > CookieSettings
-- >   { cs_EOL      = CookieValidForSession
-- >   , cs_HTTPOnly = False
-- >   , cs_secure   = False
-- >   , cs_sameSite = Nothing
-- >   , cs_domain   = Nothing
-- >   , cs_path     = Just "/"
-- >   }
defaultCookieSettings :: CookieSettings
defaultCookieSettings :: CookieSettings
defaultCookieSettings =
  CookieSettings
    { cs_EOL :: CookieEOL
cs_EOL = CookieEOL
CookieValidForSession,
      cs_HTTPOnly :: Bool
cs_HTTPOnly = Bool
False,
      cs_secure :: Bool
cs_secure = Bool
False,
      cs_sameSite :: Maybe SameSite
cs_sameSite = Maybe SameSite
forall a. Maybe a
Nothing,
      cs_domain :: Maybe ByteString
cs_domain = Maybe ByteString
forall a. Maybe a
Nothing,
      cs_path :: Maybe ByteString
cs_path = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/"
    }

parseCookies :: BS.ByteString -> [(T.Text, T.Text)]
parseCookies :: ByteString -> [(Text, Text)]
parseCookies =
  ((ByteString, ByteString) -> (Text, Text))
-> [(ByteString, ByteString)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
a, ByteString
b) -> (ByteString -> Text
T.decodeUtf8 ByteString
a, ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
URI.urlDecode Bool
True ByteString
b))
    ([(ByteString, ByteString)] -> [(Text, Text)])
-> (ByteString -> [(ByteString, ByteString)])
-> ByteString
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, ByteString)]
C.parseCookies

generateCookieHeaderString ::
  T.Text ->
  T.Text ->
  CookieSettings ->
  UTCTime ->
  BS.ByteString
generateCookieHeaderString :: Text -> Text -> CookieSettings -> UTCTime -> ByteString
generateCookieHeaderString Text
name Text
value CookieSettings
cs UTCTime
now =
  let farFuture :: UTCTime
farFuture =
        -- don't forget to bump this ...
        Day -> DiffTime -> UTCTime
UTCTime (Year -> Int -> Int -> Day
fromGregorian Year
2030 Int
1 Int
1) DiffTime
0
      (Maybe UTCTime
expire, Maybe NominalDiffTime
maxAge) =
        case CookieSettings -> CookieEOL
cs_EOL CookieSettings
cs of
          CookieValidUntil UTCTime
t ->
            (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
t, NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (UTCTime
t UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
now))
          CookieValidFor NominalDiffTime
x ->
            (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (NominalDiffTime
x NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now), NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
x)
          CookieEOL
CookieValidForSession ->
            (Maybe UTCTime
forall a. Maybe a
Nothing, Maybe NominalDiffTime
forall a. Maybe a
Nothing)
          CookieEOL
CookieValidForever ->
            (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
farFuture, NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
2147483000)
      adjustMaxAge :: a -> a
adjustMaxAge a
t =
        if a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then a
0 else a
t
      cookieVal :: SetCookie
cookieVal =
        SetCookie
forall a. Default a => a
C.def
          { C.setCookieName = T.encodeUtf8 name,
            C.setCookieValue = URI.urlEncode True $ T.encodeUtf8 value,
            C.setCookiePath = cs_path cs,
            C.setCookieExpires = expire,
            C.setCookieMaxAge = (fromRational . adjustMaxAge . toRational) <$> maxAge,
            C.setCookieDomain = cs_domain cs,
            C.setCookieHttpOnly = cs_HTTPOnly cs,
            C.setCookieSecure = cs_secure cs,
            C.setCookieSameSite = fmap sameSiteOption (cs_sameSite cs)
          }
   in SetCookie -> ByteString
renderCookie SetCookie
cookieVal
  where
    sameSiteOption :: SameSite -> SameSiteOption
sameSiteOption SameSite
SameSiteLax = SameSiteOption
C.sameSiteLax
    sameSiteOption SameSite
SameSiteStrict = SameSiteOption
C.sameSiteStrict
    sameSiteOption SameSite
SameSiteNone = SameSiteOption
C.sameSiteNone

renderCookie :: C.SetCookie -> BS.ByteString
renderCookie :: SetCookie -> ByteString
renderCookie = LazyByteString -> ByteString
BSL.toStrict (LazyByteString -> ByteString)
-> (SetCookie -> LazyByteString) -> SetCookie -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
B.toLazyByteString (Builder -> LazyByteString)
-> (SetCookie -> Builder) -> SetCookie -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> Builder
C.renderSetCookie