Cookie.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Web.Hyperbole.Data.Cookie where

import Data.ByteString (ByteString)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as M
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Network.HTTP.Types (urlDecode, urlEncode)
import Web.Hyperbole.Data.URI


type Key = Text


data Cookie = Cookie
  { key :: Key
  , path :: Maybe Path
  , value :: Maybe CookieValue
  }
  deriving (Show, Eq)


newtype Cookies = Cookies (Map Key Cookie)
  deriving newtype (Monoid, Semigroup, Show, Eq)


newtype CookieValue = CookieValue ByteString
  deriving newtype (Show, Eq)


insert :: Cookie -> Cookies -> Cookies
insert cookie (Cookies m) =
  Cookies $ M.insert cookie.key cookie m


delete :: Key -> Cookies -> Cookies
delete key (Cookies m) =
  Cookies $ M.delete key m


lookup :: Key -> Cookies -> Maybe CookieValue
lookup key (Cookies m) = do
  cook <- M.lookup key m
  cook.value


fromList :: [Cookie] -> Cookies
fromList cks = Cookies $ M.fromList (fmap keyValue cks)
 where
  keyValue c = (c.key, c)


toList :: Cookies -> [Cookie]
toList (Cookies m) = M.elems m


render :: Path -> Cookie -> ByteString
render requestPath cookie =
  let p = fromMaybe requestPath cookie.path
   in cs cookie.key <> "=" <> value cookie.value <> "; SameSite=None; secure; path=" <> cs (uriToText (pathUri p))
 where
  value Nothing = "; expires=Thu, 01 Jan 1970 00:00:00 GMT"
  value (Just (CookieValue val)) = urlEncode True $ cs val


parse :: [(ByteString, ByteString)] -> Either String Cookies
parse kvs = do
  cks <- mapM (uncurry parseValue) kvs
  pure $ fromList cks


parseValue :: ByteString -> ByteString -> Either String Cookie
parseValue k val = do
  let cval = CookieValue $ cs $ urlDecode True val
  pure $ Cookie (cs k) Nothing (Just $ cval)