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
(Tray a -> Tray a -> Bool)
-> (Tray a -> Tray a -> Bool) -> Eq (Tray a)
forall a. Eq a => Tray a -> Tray a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Tray a -> Tray a -> Bool
Eq, Eq (Tray a)
Eq (Tray a) =>
(Tray a -> Tray a -> Ordering)
-> (Tray a -> Tray a -> Bool)
-> (Tray a -> Tray a -> Bool)
-> (Tray a -> Tray a -> Bool)
-> (Tray a -> Tray a -> Bool)
-> (Tray a -> Tray a -> Tray a)
-> (Tray a -> Tray a -> Tray a)
-> Ord (Tray a)
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
$ccompare :: forall a. Ord a => Tray a -> Tray a -> Ordering
compare :: Tray a -> Tray a -> Ordering
$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
>= :: Tray a -> Tray a -> Bool
$cmax :: forall a. Ord a => Tray a -> Tray a -> Tray a
max :: Tray a -> Tray a -> Tray a
$cmin :: forall a. Ord a => Tray a -> Tray a -> Tray a
min :: Tray a -> Tray a -> Tray a
Ord, Int -> Tray a -> ShowS
[Tray a] -> ShowS
Tray a -> String
(Int -> Tray a -> ShowS)
-> (Tray a -> String) -> ([Tray a] -> ShowS) -> Show (Tray a)
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
$cshowsPrec :: forall a. Show a => Int -> Tray a -> ShowS
showsPrec :: Int -> Tray a -> ShowS
$cshow :: forall a. Show a => Tray a -> String
show :: Tray a -> String
$cshowList :: forall a. Show a => [Tray a] -> ShowS
showList :: [Tray a] -> ShowS
Show, (forall a b. (a -> b) -> Tray a -> Tray b)
-> (forall a b. a -> Tray b -> Tray a) -> Functor Tray
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
$cfmap :: forall a b. (a -> b) -> Tray a -> Tray b
fmap :: forall a b. (a -> b) -> Tray a -> Tray b
$c<$ :: forall a b. a -> Tray b -> Tray a
<$ :: forall a b. a -> Tray b -> Tray a
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 = Map Name a -> Tray a
forall a. Map Name a -> Tray a
Tray (Map Name a
x Map Name a -> Map Name a -> Map Name a
forall a. Semigroup a => a -> a -> a
<> Map Name a
y)

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

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

parse :: BS.ByteString -> Tray Value
parse :: ByteString -> Tray Value
parse =
  [Named Value] -> Tray Value
forall a. [Named a] -> Tray a
fromList
    ([Named Value] -> Tray Value)
-> (ByteString -> [Named Value]) -> ByteString -> Tray Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> Named Value)
-> [(ByteString, ByteString)] -> [Named Value]
forall a b. (a -> b) -> [a] -> [b]
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})
    ([(ByteString, ByteString)] -> [Named Value])
-> (ByteString -> [(ByteString, ByteString)])
-> ByteString
-> [Named Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, ByteString)]
Web.parseCookies

toList :: Tray a -> [Named a]
toList :: forall a. Tray a -> [Named a]
toList (Tray Map Name a
m) =
  Map Name a -> [(Name, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Name a
m [(Name, a)] -> ((Name, a) -> Named a) -> [Named a]
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 = Map Name a -> Tray a
forall a. Map Name a -> Tray a
Tray (Map Name a -> Tray a)
-> ([Named a] -> Map Name a) -> [Named a] -> Tray a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, a)] -> Map Name a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, a)] -> Map Name a)
-> ([Named a] -> [(Name, a)]) -> [Named a] -> Map Name a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named a -> (Name, a)) -> [Named a] -> [(Name, a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Named a
x -> (Named a -> Name
forall a. Named a -> Name
name Named a
x, Named a -> a
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) = Name -> Map Name a -> Maybe a
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 (Endo SetCookie -> BinaryCommand)
-> (Command -> Endo SetCookie) -> Command -> BinaryCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie

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

renderLBS :: (ToCommandList a) => a -> [LBS.ByteString]
renderLBS :: forall a. ToCommandList a => a -> [ByteString]
renderLBS = (BinaryCommand -> ByteString) -> [BinaryCommand] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BinaryCommand -> ByteString
binaryCommandByteStringLazy ([BinaryCommand] -> [ByteString])
-> (a -> [BinaryCommand]) -> a -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [BinaryCommand]
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 (ByteString -> BinaryCommand) -> ByteString -> BinaryCommand
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Binary.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ SetCookie -> Builder
Web.renderSetCookie (SetCookie -> Builder) -> SetCookie -> Builder
forall a b. (a -> b) -> a -> b
$ Endo SetCookie -> SetCookie -> SetCookie
forall a. Endo a -> a -> a
appEndo Endo SetCookie
f SetCookie
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 =
    Name -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Command -> Name
Command.name Command
x)
      Endo SetCookie -> Endo SetCookie -> Endo SetCookie
forall a. Semigroup a => a -> a -> a
<> Meta -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Command -> Meta
Command.meta Command
x)
      Endo SetCookie -> Endo SetCookie -> Endo SetCookie
forall a. Semigroup a => a -> a -> a
<> Action (Expiring Value) -> Endo SetCookie
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 =
    Name -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Named a -> Name
forall a. Named a -> Name
name Named a
x)
      Endo SetCookie -> Endo SetCookie -> Endo SetCookie
forall a. Semigroup a => a -> a -> a
<> a -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Named a -> a
forall a. Named a -> a
value Named a
x)

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

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

instance ApplyToSetCookie TransportEncryption where
  applyToSetCookie :: TransportEncryption -> Endo SetCookie
applyToSetCookie TransportEncryption
x = (SetCookie -> SetCookie) -> Endo SetCookie
forall a. (a -> a) -> Endo a
Endo \SetCookie
sc -> SetCookie
sc {Web.setCookieSecure = 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 =
    JavascriptAccess -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Security -> JavascriptAccess
jsAccess Security
x)
      Endo SetCookie -> Endo SetCookie -> Endo SetCookie
forall a. Semigroup a => a -> a -> a
<> Origin -> Endo SetCookie
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 -> SameSiteOptions -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie SameSiteOptions
o
    Origin
CrossSite -> (SetCookie -> SetCookie) -> Endo SetCookie
forall a. (a -> a) -> Endo a
Endo \SetCookie
sc ->
      SetCookie
sc
        { Web.setCookieSameSite = Just Web.sameSiteNone,
          Web.setCookieSecure = True -- When SameSite=None, Secure is required
        }

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

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

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

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

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

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

instance ApplyToSetCookie Meta where
  applyToSetCookie :: Meta -> Endo SetCookie
applyToSetCookie Meta
x =
    Scope -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Meta -> Scope
metaScope Meta
x)
      Endo SetCookie -> Endo SetCookie -> Endo SetCookie
forall a. Semigroup a => a -> a -> a
<> Security -> Endo SetCookie
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 =
    Security -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Secured a -> Security
forall a. Secured a -> Security
security Secured a
x)
      Endo SetCookie -> Endo SetCookie -> Endo SetCookie
forall a. Semigroup a => a -> a -> a
<> a -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Secured a -> a
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 -> a -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie a
x
    Action a
Delete ->
      Expiry -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (UTCTime -> Expiry
ExpiryTime (POSIXTime -> UTCTime
Time.posixSecondsToUTCTime POSIXTime
0))
        Endo SetCookie -> Endo SetCookie -> Endo SetCookie
forall a. Semigroup a => a -> a -> a
<> Value -> Endo SetCookie
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 =
    Expiry -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Expiring a -> Expiry
forall a. Expiring a -> Expiry
expiry Expiring a
x)
      Endo SetCookie -> Endo SetCookie -> Endo SetCookie
forall a. Semigroup a => a -> a -> a
<> a -> Endo SetCookie
forall a. ApplyToSetCookie a => a -> Endo SetCookie
applyToSetCookie (Expiring a -> a
forall a. Expiring a -> a
expiring Expiring a
x)