{-# 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
  }

-- | 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_domain   = Nothing
-- >   , cs_path     = Just "/"
-- >   }
defaultCookieSettings :: CookieSettings
defaultCookieSettings :: CookieSettings
defaultCookieSettings =
  CookieSettings :: CookieEOL
-> Maybe ByteString
-> Maybe ByteString
-> Bool
-> Bool
-> CookieSettings
CookieSettings
    { cs_EOL :: CookieEOL
cs_EOL = CookieEOL
CookieValidForSession,
      cs_HTTPOnly :: Bool
cs_HTTPOnly = Bool
False,
      cs_secure :: Bool
cs_secure = Bool
False,
      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 (Integer -> Int -> Int -> Day
fromGregorian Integer
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 :: p -> p
adjustMaxAge p
t =
        if p
t p -> p -> Bool
forall a. Ord a => a -> a -> Bool
< p
0 then p
0 else p
t
      cookieVal :: SetCookie
cookieVal =
        SetCookie
forall a. Default a => a
C.def
          { setCookieName :: ByteString
C.setCookieName = Text -> ByteString
T.encodeUtf8 Text
name,
            setCookieValue :: ByteString
C.setCookieValue = Bool -> ByteString -> ByteString
URI.urlEncode Bool
True (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
value,
            setCookiePath :: Maybe ByteString
C.setCookiePath = CookieSettings -> Maybe ByteString
cs_path CookieSettings
cs,
            setCookieExpires :: Maybe UTCTime
C.setCookieExpires = Maybe UTCTime
expire,
            setCookieMaxAge :: Maybe DiffTime
C.setCookieMaxAge = (Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> DiffTime)
-> (NominalDiffTime -> Rational) -> NominalDiffTime -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
forall p. (Ord p, Num p) => p -> p
adjustMaxAge (Rational -> Rational)
-> (NominalDiffTime -> Rational) -> NominalDiffTime -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational) (NominalDiffTime -> DiffTime)
-> Maybe NominalDiffTime -> Maybe DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
maxAge,
            setCookieDomain :: Maybe ByteString
C.setCookieDomain = CookieSettings -> Maybe ByteString
cs_domain CookieSettings
cs,
            setCookieHttpOnly :: Bool
C.setCookieHttpOnly = CookieSettings -> Bool
cs_HTTPOnly CookieSettings
cs,
            setCookieSecure :: Bool
C.setCookieSecure = CookieSettings -> Bool
cs_secure CookieSettings
cs
          }
   in SetCookie -> ByteString
renderCookie SetCookie
cookieVal

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