module CookieTray
  ( -- * Command
    render,
    renderLBS,
    ToCommandList (..),
    Command,
    Action (..),
    renderCommand,
    BinaryCommand,
    binaryCommandByteStringLazy,

    -- * Tray
    Tray (..),
    parse,
    lookup,
    fromList,
    toList,

    -- * Name
    Name (..),
    Named (..),

    -- * Value
    Value (..),

    -- * Expiry
    Expiry (..),
    Expiring (..),

    -- * Meta

    -- ** Security
    Security (..),
    Secured (..),
    Origin (..),
    TransportEncryption (..),
    SameSiteOptions (..),
    SameSiteStrictness (..),
    JavascriptAccess (..),

    -- ** Scope
    Scope (..),
    Domain (..),
    Path (..),
    Meta (..),
  )
where

import CookieTray.Command (Command, ToCommandList (..))
import CookieTray.Command qualified as Command
import CookieTray.Types
import Data.Binary.Builder qualified as Binary
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS.Char8
import Data.ByteString.Lazy qualified as LBS
import Data.Functor (Functor, fmap, (<&>))
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Monoid (Endo (..), Monoid (mempty))
import Data.Semigroup (Semigroup ((<>)))
import Data.Time.Clock.POSIX qualified as Time
import GHC.Exts (IsList, Item)
import GHC.Exts qualified as IsList (IsList (..))
import Web.Cookie qualified as Web
import Prelude (Bool (..), Eq, Maybe (..), Ord, Show, ($), (.))

---  Tray  ---

newtype Tray a = Tray (Map Name a)
  deriving (Tray a -> Tray a -> Bool
forall a. Eq a => Tray a -> Tray a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tray a -> Tray a -> Bool
$c/= :: forall a. Eq a => Tray a -> Tray a -> Bool
== :: Tray a -> Tray a -> Bool
$c== :: forall a. Eq a => Tray a -> Tray a -> Bool
Eq, Tray a -> Tray a -> Bool
Tray a -> Tray a -> Ordering
Tray a -> Tray a -> Tray a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Tray a)
forall a. Ord a => Tray a -> Tray a -> Bool
forall a. Ord a => Tray a -> Tray a -> Ordering
forall a. Ord a => Tray a -> Tray a -> Tray a
min :: Tray a -> Tray a -> Tray a
$cmin :: forall a. Ord a => Tray a -> Tray a -> Tray a
max :: Tray a -> Tray a -> Tray a
$cmax :: forall a. Ord a => Tray a -> Tray a -> Tray a
>= :: Tray a -> Tray a -> Bool
$c>= :: forall a. Ord a => Tray a -> Tray a -> Bool
> :: Tray a -> Tray a -> Bool
$c> :: forall a. Ord a => Tray a -> Tray a -> Bool
<= :: Tray a -> Tray a -> Bool
$c<= :: forall a. Ord a => Tray a -> Tray a -> Bool
< :: Tray a -> Tray a -> Bool
$c< :: forall a. Ord a => Tray a -> Tray a -> Bool
compare :: Tray a -> Tray a -> Ordering
$ccompare :: forall a. Ord a => Tray a -> Tray a -> Ordering
Ord, Int -> Tray a -> ShowS
forall a. Show a => Int -> Tray a -> ShowS
forall a. Show a => [Tray a] -> ShowS
forall a. Show a => Tray a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tray a] -> ShowS
$cshowList :: forall a. Show a => [Tray a] -> ShowS
show :: Tray a -> String
$cshow :: forall a. Show a => Tray a -> String
showsPrec :: Int -> Tray a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Tray a -> ShowS
Show, forall a b. a -> Tray b -> Tray a
forall a b. (a -> b) -> Tray a -> Tray b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Tray b -> Tray a
$c<$ :: forall a b. a -> Tray b -> Tray a
fmap :: forall a b. (a -> b) -> Tray a -> Tray b
$cfmap :: forall a b. (a -> b) -> Tray a -> Tray b
Functor)

-- | Left-biased map union
instance Semigroup (Tray a) where
  Tray Map Name a
x <> :: Tray a -> Tray a -> Tray a
<> Tray Map Name a
y = forall a. Map Name a -> Tray a
Tray (Map Name a
x forall a. Semigroup a => a -> a -> a
<> Map Name a
y)

instance Monoid (Tray a) where
  mempty :: Tray a
mempty = forall a. Map Name a -> Tray a
Tray forall a. Monoid a => a
mempty

instance IsList (Tray a) where
  type Item (Tray a) = Named a
  fromList :: [Item (Tray a)] -> Tray a
fromList = forall a. [Named a] -> Tray a
fromList
  toList :: Tray a -> [Item (Tray a)]
toList = forall a. Tray a -> [Named a]
toList

parse :: BS.ByteString -> Tray Value
parse :: ByteString -> Tray Value
parse =
  forall a. [Named a] -> Tray a
fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ByteString
a, ByteString
b) -> Named {name :: Name
name = ByteString -> Name
Name ByteString
a, value :: Value
value = ByteString -> Value
Value ByteString
b})
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Cookies
Web.parseCookies

toList :: Tray a -> [Named a]
toList :: forall a. Tray a -> [Named a]
toList (Tray Map Name a
m) =
  forall k a. Map k a -> [(k, a)]
Map.toList Map Name a
m forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
a, a
b) ->
    Named {name :: Name
name = Name
a, value :: a
value = a
b}

fromList :: [Named a] -> Tray a
fromList :: forall a. [Named a] -> Tray a
fromList = forall a. Map Name a -> Tray a
Tray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Named a
x -> (forall a. Named a -> Name
name Named a
x, forall a. Named a -> a
value Named a
x))

lookup :: Name -> Tray a -> Maybe a
lookup :: forall a. Name -> Tray a -> Maybe a
lookup Name
x (Tray Map Name a
m) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x Map Name a
m

---  Command  ---

renderCommand :: Command -> BinaryCommand
renderCommand :: Command -> BinaryCommand
renderCommand = Endo SetCookie -> BinaryCommand
renderSetCookie forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie

render :: (ToCommandList a) => a -> [BinaryCommand]
render :: forall a. ToCommandList a => a -> [BinaryCommand]
render = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Command -> BinaryCommand
renderCommand forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToCommandList a => a -> [Command]
toCommandList

renderLBS :: (ToCommandList a) => a -> [LBS.ByteString]
renderLBS :: forall a. ToCommandList a => a -> [ByteString]
renderLBS = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BinaryCommand -> ByteString
binaryCommandByteStringLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToCommandList a => a -> [BinaryCommand]
render

---  Rendering internals  ---

renderSetCookie :: Endo Web.SetCookie -> BinaryCommand
renderSetCookie :: Endo SetCookie -> BinaryCommand
renderSetCookie Endo SetCookie
f =
  ByteString -> BinaryCommand
BinaryCommand forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Binary.toLazyByteString forall a b. (a -> b) -> a -> b
$ SetCookie -> Builder
Web.renderSetCookie forall a b. (a -> b) -> a -> b
$ forall a. Endo a -> a -> a
appEndo Endo SetCookie
f forall a. Default a => a
Web.def

class ApplyToSetCookie a where
  applyToSetCookie :: a -> Endo Web.SetCookie

instance ApplyToSetCookie Command where
  applyToSetCookie :: Command -> Endo SetCookie
applyToSetCookie Command
x =
    forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Command -> Name
Command.name Command
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Command -> Meta
Command.meta Command
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Command -> Action (Expiring Value)
Command.action Command
x)

instance (ApplyToSetCookie a) => ApplyToSetCookie (Named a) where
  applyToSetCookie :: Named a -> Endo SetCookie
applyToSetCookie Named a
x =
    forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (forall a. Named a -> Name
name Named a
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (forall a. Named a -> a
value Named a
x)

instance ApplyToSetCookie Name where
  applyToSetCookie :: Name -> Endo SetCookie
applyToSetCookie Name
x = forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {setCookieName :: ByteString
Web.setCookieName = Name -> ByteString
nameByteString Name
x}

instance ApplyToSetCookie Value where
  applyToSetCookie :: Value -> Endo SetCookie
applyToSetCookie Value
x = forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {setCookieValue :: ByteString
Web.setCookieValue = Value -> ByteString
valueByteString Value
x}

instance ApplyToSetCookie TransportEncryption where
  applyToSetCookie :: TransportEncryption -> Endo SetCookie
applyToSetCookie TransportEncryption
x = forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {setCookieSecure :: Bool
Web.setCookieSecure = Bool
y}
    where
      y :: Bool
y = case TransportEncryption
x of
        TransportEncryption
RequireEncryptedTransport -> Bool
True
        TransportEncryption
AllowUnencryptedTransport -> Bool
False

instance ApplyToSetCookie Security where
  applyToSetCookie :: Security -> Endo SetCookie
applyToSetCookie Security
x =
    forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Security -> JavascriptAccess
jsAccess Security
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Security -> Origin
origin Security
x)

instance ApplyToSetCookie Origin where
  applyToSetCookie :: Origin -> Endo SetCookie
applyToSetCookie = \case
    SameSite SameSiteOptions
o -> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie SameSiteOptions
o
    Origin
CrossSite -> forall a. (a -> a) -> Endo a
Endo \SetCookie
sc ->
      SetCookie
sc
        { setCookieSameSite :: Maybe SameSiteOption
Web.setCookieSameSite = forall a. a -> Maybe a
Just SameSiteOption
Web.sameSiteNone,
          setCookieSecure :: Bool
Web.setCookieSecure = Bool
True -- When SameSite=None, Secure is required
        }

instance ApplyToSetCookie SameSiteOptions where
  applyToSetCookie :: SameSiteOptions -> Endo SetCookie
applyToSetCookie SameSiteOptions
x =
    forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (SameSiteOptions -> SameSiteStrictness
sameSiteStrictness SameSiteOptions
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (SameSiteOptions -> TransportEncryption
transportEncryption SameSiteOptions
x)

instance ApplyToSetCookie SameSiteStrictness where
  applyToSetCookie :: SameSiteStrictness -> Endo SetCookie
applyToSetCookie SameSiteStrictness
x = forall a. (a -> a) -> Endo a
Endo \SetCookie
sc ->
    SetCookie
sc
      { setCookieSameSite :: Maybe SameSiteOption
Web.setCookieSameSite = forall a. a -> Maybe a
Just
          case SameSiteStrictness
x of
            SameSiteStrictness
SameSiteStrict -> SameSiteOption
Web.sameSiteStrict
            SameSiteStrictness
SameSiteLax -> SameSiteOption
Web.sameSiteLax
      }

instance ApplyToSetCookie JavascriptAccess where
  applyToSetCookie :: JavascriptAccess -> Endo SetCookie
applyToSetCookie JavascriptAccess
x = forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {setCookieHttpOnly :: Bool
Web.setCookieHttpOnly = Bool
y}
    where
      y :: Bool
y = case JavascriptAccess
x of
        JavascriptAccess
HiddenFromJavascript -> Bool
True
        JavascriptAccess
AccessibleFromJavascript -> Bool
False

instance ApplyToSetCookie Domain where
  applyToSetCookie :: Domain -> Endo SetCookie
applyToSetCookie Domain
x = forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {setCookieDomain :: Maybe ByteString
Web.setCookieDomain = Maybe ByteString
y}
    where
      y :: Maybe ByteString
y = case Domain
x of
        Domain ByteString
z -> forall a. a -> Maybe a
Just ByteString
z
        Domain
CurrentHostExcludingSubdomains -> forall a. Maybe a
Nothing

instance ApplyToSetCookie Expiry where
  applyToSetCookie :: Expiry -> Endo SetCookie
applyToSetCookie = \case
    ExpiryTime UTCTime
x -> forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {setCookieExpires :: Maybe UTCTime
Web.setCookieExpires = forall a. a -> Maybe a
Just UTCTime
x}
    ExpiryAge DiffTime
x -> forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {setCookieMaxAge :: Maybe DiffTime
Web.setCookieMaxAge = forall a. a -> Maybe a
Just DiffTime
x}

instance ApplyToSetCookie Path where
  applyToSetCookie :: Path -> Endo SetCookie
applyToSetCookie Path
x = forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {setCookiePath :: Maybe ByteString
Web.setCookiePath = Maybe ByteString
y}
    where
      y :: Maybe ByteString
y = case Path
x of
        Path ByteString
z -> forall a. a -> Maybe a
Just ByteString
z
        Path
CurrentPath -> forall a. Maybe a
Nothing

instance ApplyToSetCookie Scope where
  applyToSetCookie :: Scope -> Endo SetCookie
applyToSetCookie Scope
x =
    forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Scope -> Domain
domain Scope
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Scope -> Path
path Scope
x)

instance ApplyToSetCookie Meta where
  applyToSetCookie :: Meta -> Endo SetCookie
applyToSetCookie Meta
x =
    forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Meta -> Scope
metaScope Meta
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Meta -> Security
metaSecurity Meta
x)

instance (ApplyToSetCookie a) => ApplyToSetCookie (Secured a) where
  applyToSetCookie :: Secured a -> Endo SetCookie
applyToSetCookie Secured a
x =
    forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (forall a. Secured a -> Security
security Secured a
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (forall a. Secured a -> a
secured Secured a
x)

instance (ApplyToSetCookie a) => ApplyToSetCookie (Action a) where
  applyToSetCookie :: Action a -> Endo SetCookie
applyToSetCookie = \case
    Put a
x -> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie a
x
    Action a
Delete ->
      forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (UTCTime -> Expiry
ExpiryTime (POSIXTime -> UTCTime
Time.posixSecondsToUTCTime POSIXTime
0))
        forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (ByteString -> Value
Value (String -> ByteString
BS.Char8.pack String
"x"))

instance (ApplyToSetCookie a) => ApplyToSetCookie (Expiring a) where
  applyToSetCookie :: Expiring a -> Endo SetCookie
applyToSetCookie Expiring a
x =
    forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (forall a. Expiring a -> Expiry
expiry Expiring a
x)
      forall a. Semigroup a => a -> a -> a
<> forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (forall a. Expiring a -> a
expiring Expiring a
x)