module CookieTray
(
render,
renderLBS,
ToCommandList (..),
Command,
Action (..),
renderCommand,
BinaryCommand,
binaryCommandByteStringLazy,
Tray (..),
parse,
lookup,
fromList,
toList,
Name (..),
Named (..),
Value (..),
Expiry (..),
Expiring (..),
Security (..),
Secured (..),
Origin (..),
TransportEncryption (..),
SameSiteOptions (..),
SameSiteStrictness (..),
JavascriptAccess (..),
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, ($), (.))
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)
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
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
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
}
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)