{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}

module Web.Hyperbole.Effect.Session where

import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as A
import Data.Default (Default (..))
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic
import GHC.Generics
import Web.Hyperbole.Data.Cookie as Cookie
import Web.Hyperbole.Data.URI (Path)
import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..), request)
import Web.Hyperbole.Types.Client (Client (..), clientModCookies)
import Web.Hyperbole.Types.Request
import Web.Hyperbole.Types.Response


{- ! Configure a data type to persist in the 'session' as a cookie. These are type-indexed, so only one of each can exist in the session

@
#EMBED Example.Docs.Sessions data Preferences

#EMBED Example.Docs.Sessions instance Default Preferences
@
-}

{- | Configure a data type to persist in the 'session' as a cookie. These are type-indexed, so only one of each can exist in the session

@
data Preferences = Preferences
  { color :: AppColor
  }
  deriving (Generic, ToJSON, FromJSON, 'Session')

instance Default Preferences where
  def = Preferences White
@
-}
class Session a where
  -- | Unique key for this Session Type. Defaults to the datatypeName
  sessionKey :: Key
  default sessionKey :: (Generic a, GDatatypeName (Rep a)) => Key
  sessionKey = Rep a (ZonkAny 1) -> Key
forall p. Rep a p -> Key
forall {k} (f :: k -> *) (p :: k). GDatatypeName f => f p -> Key
gDatatypeName (Rep a (ZonkAny 1) -> Key) -> Rep a (ZonkAny 1) -> Key
forall a b. (a -> b) -> a -> b
$ a -> Rep a (ZonkAny 1)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (a
forall a. HasCallStack => a
undefined :: a)


  -- | By default Sessions are persisted only to the current page. Set to `Just "/"` to make an instance available application-wide
  cookiePath :: Maybe Path
  default cookiePath :: Maybe Path
  cookiePath = Maybe Path
forall a. Maybe a
Nothing


  -- | By default cookies are secure (HTTPS only). Set to False for local development or LAN usage
  cookieSecure :: Bool
  default cookieSecure :: Bool
  cookieSecure = Bool
True


  -- | Encode type to a a cookie value
  toCookie :: a -> CookieValue
  default toCookie :: (ToJSON a) => a -> CookieValue
  toCookie = ByteString -> CookieValue
CookieValue (ByteString -> CookieValue)
-> (a -> ByteString) -> a -> CookieValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode


  -- | Decode from a cookie value. Defaults to FromJSON
  parseCookie :: CookieValue -> Either String a
  default parseCookie :: (FromJSON a) => CookieValue -> Either String a
  parseCookie (CookieValue ByteString
bs) = do
    ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
bs)


{- ! Load data from a browser cookie. If it doesn't exist, the 'Default' instance is used

@
#EMBED Example.Docs.Sessions data Preferences

#EMBED Example.Docs.Sessions instance Default Preferences

#EMBED Example.Docs.Sessions page
@
-}

{- | Load data from a browser cookie. If it doesn't exist, the 'Default' instance is used

@
data Preferences = Preferences
  { color :: AppColor
  }
  deriving (Generic, ToJSON, FromJSON, 'Session')

instance Default Preferences where
  def = Preferences White

page :: ('Hyperbole' :> es) => 'Page' es '[Content]
page = do
  prefs <- session @Preferences
  pure $ 'el' ~ bg prefs.color $ \"Custom Background\"
@
-}
session :: (Session a, Default a, Hyperbole :> es) => Eff es a
session :: forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
Eff es a
session = do
  ms <- Eff es (Maybe a)
forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
Eff es (Maybe a)
lookupSession
  pure $ fromMaybe def ms


-- | Return a session if it exists
lookupSession :: forall a es. (Session a, Hyperbole :> es) => Eff es (Maybe a)
lookupSession :: forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
Eff es (Maybe a)
lookupSession = do
  let key :: Key
key = forall a. Session a => Key
sessionKey @a
  mck <- Key -> Cookies -> Maybe CookieValue
Cookie.lookup Key
key (Cookies -> Maybe CookieValue)
-> Eff es Cookies -> Eff es (Maybe CookieValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es Cookies
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Cookies
sessionCookies
  case mck of
    Maybe CookieValue
Nothing -> Maybe a -> Eff es (Maybe a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Just CookieValue
cook ->
      case CookieValue -> Either String a
forall a. Session a => CookieValue -> Either String a
parseCookie CookieValue
cook of
        Left String
_ -> Maybe a -> Eff es (Maybe a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        Right a
a -> Maybe a -> Eff es (Maybe a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Eff es (Maybe a)) -> Maybe a -> Eff es (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a


{- ! Persist datatypes in browser cookies

@
#EMBED Example.Docs.Sessions data Preferences

#EMBED Example.Docs.Sessions instance Default Preferences

#EMBED Example.Docs.Sessions instance HyperView Content
@
-}

{- | Persist datatypes in browser cookies

@
data Preferences = Preferences
  { color :: AppColor
  }
  deriving (Generic, ToJSON, FromJSON, 'Session')

instance Default Preferences where
  def = Preferences White

instance 'HyperView' Content es where
  data 'Action' Content
    = SetColor AppColor
    deriving (Generic, 'ViewAction')

  'update' (SetColor clr) = do
    let prefs = Preferences clr
    saveSession prefs
    pure $ 'el' ~ bg prefs.color $ \"Custom Background\"
@
-}
saveSession :: forall a es. (Session a, Hyperbole :> es) => a -> Eff es ()
saveSession :: forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
a -> Eff es ()
saveSession a
a = do
  (Cookies -> Cookies) -> Eff es ()
forall (es :: [Effect]).
(Hyperbole :> es) =>
(Cookies -> Cookies) -> Eff es ()
modifyCookies ((Cookies -> Cookies) -> Eff es ())
-> (Cookies -> Cookies) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Cookie -> Cookies -> Cookies
Cookie.insert (Cookie -> Cookies -> Cookies) -> Cookie -> Cookies -> Cookies
forall a b. (a -> b) -> a -> b
$ a -> Cookie
forall a. Session a => a -> Cookie
sessionCookie a
a


modifySession :: (Session a, Default a, Hyperbole :> es) => (a -> a) -> Eff es a
modifySession :: forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
(a -> a) -> Eff es a
modifySession a -> a
f = do
  s <- Eff es a
forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
Eff es a
session
  let updated = a -> a
f a
s
  saveSession updated
  pure updated


modifySession_ :: (Session a, Default a, Hyperbole :> es) => (a -> a) -> Eff es ()
modifySession_ :: forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
(a -> a) -> Eff es ()
modifySession_ a -> a
f = do
  _ <- (a -> a) -> Eff es a
forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
(a -> a) -> Eff es a
modifySession a -> a
f
  pure ()


-- | Remove a single 'Session' from the browser cookies
deleteSession :: forall a es. (Session a, Hyperbole :> es) => Eff es ()
deleteSession :: forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
Eff es ()
deleteSession = do
  let cookie :: Cookie
cookie = Key -> Maybe Path -> Maybe CookieValue -> Bool -> Cookie
Cookie (forall a. Session a => Key
sessionKey @a) (forall a. Session a => Maybe Path
cookiePath @a) Maybe CookieValue
forall a. Maybe a
Nothing (forall a. Session a => Bool
cookieSecure @a)
  (Cookies -> Cookies) -> Eff es ()
forall (es :: [Effect]).
(Hyperbole :> es) =>
(Cookies -> Cookies) -> Eff es ()
modifyCookies ((Cookies -> Cookies) -> Eff es ())
-> (Cookies -> Cookies) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Cookie -> Cookies -> Cookies
Cookie.insert Cookie
cookie


parseSession :: (Session a, Hyperbole :> es) => Key -> CookieValue -> Eff es a
parseSession :: forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
Key -> CookieValue -> Eff es a
parseSession Key
prm CookieValue
cook = do
  case CookieValue -> Either String a
forall a. Session a => CookieValue -> Either String a
parseCookie CookieValue
cook of
    Left String
e -> Hyperbole (Eff es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Hyperbole (Eff es) a -> Eff es a)
-> Hyperbole (Eff es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Response -> Hyperbole (Eff es) a
forall (a :: * -> *) b. Response -> Hyperbole a b
RespondNow (Response -> Hyperbole (Eff es) a)
-> Response -> Hyperbole (Eff es) a
forall a b. (a -> b) -> a -> b
$ ResponseError -> Response
Err (ResponseError -> Response) -> ResponseError -> Response
forall a b. (a -> b) -> a -> b
$ Key -> String -> ResponseError
ErrSession Key
prm String
e
    Right a
a -> a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a


-- | save a single datatype to a specific key in the session
setCookie :: (ToJSON a, Hyperbole :> es) => Cookie -> Eff es ()
setCookie :: forall a (es :: [Effect]).
(ToJSON a, Hyperbole :> es) =>
Cookie -> Eff es ()
setCookie Cookie
ck = do
  (Cookies -> Cookies) -> Eff es ()
forall (es :: [Effect]).
(Hyperbole :> es) =>
(Cookies -> Cookies) -> Eff es ()
modifyCookies (Cookie -> Cookies -> Cookies
Cookie.insert Cookie
ck)


-- | Modify the client cookies
modifyCookies :: (Hyperbole :> es) => (Cookies -> Cookies) -> Eff es ()
modifyCookies :: forall (es :: [Effect]).
(Hyperbole :> es) =>
(Cookies -> Cookies) -> Eff es ()
modifyCookies Cookies -> Cookies
f =
  Hyperbole (Eff es) () -> Eff es ()
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Hyperbole (Eff es) () -> Eff es ())
-> Hyperbole (Eff es) () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ (Client -> Client) -> Hyperbole (Eff es) ()
forall (a :: * -> *). (Client -> Client) -> Hyperbole a ()
ModClient ((Client -> Client) -> Hyperbole (Eff es) ())
-> (Client -> Client) -> Hyperbole (Eff es) ()
forall a b. (a -> b) -> a -> b
$ (Cookies -> Cookies) -> Client -> Client
clientModCookies Cookies -> Cookies
f


-- | Return all the cookies, both those sent in the request and others added by the page
sessionCookies :: (Hyperbole :> es) => Eff es Cookies
sessionCookies :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Cookies
sessionCookies = do
  clt <- Eff es Cookies
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Cookies
clientSessionCookies
  req <- requestSessionCookies
  pure $ clt <> req


-- | Return the session from the Client cookies
clientSessionCookies :: (Hyperbole :> es) => Eff es Cookies
clientSessionCookies :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Cookies
clientSessionCookies = do
  (.session) (Client -> Cookies) -> Eff es Client -> Eff es Cookies
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hyperbole (Eff es) Client -> Eff es Client
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send Hyperbole (Eff es) Client
forall (a :: * -> *). Hyperbole a Client
GetClient


-- | Return the session from the 'Request' cookies
requestSessionCookies :: (Hyperbole :> es) => Eff es Cookies
requestSessionCookies :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Cookies
requestSessionCookies = do
  (.cookies) (Request -> Cookies) -> Eff es Request -> Eff es Cookies
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es Request
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request


sessionCookie :: forall a. (Session a) => a -> Cookie
sessionCookie :: forall a. Session a => a -> Cookie
sessionCookie a
a =
  Key -> Maybe Path -> Maybe CookieValue -> Bool -> Cookie
Cookie (forall a. Session a => Key
sessionKey @a) (forall a. Session a => Maybe Path
cookiePath @a) (CookieValue -> Maybe CookieValue
forall a. a -> Maybe a
Just (CookieValue -> Maybe CookieValue)
-> CookieValue -> Maybe CookieValue
forall a b. (a -> b) -> a -> b
$ a -> CookieValue
forall a. Session a => a -> CookieValue
toCookie a
a) (forall a. Session a => Bool
cookieSecure @a)


-- | generic datatype name
genericTypeName :: forall a. (Generic a, GDatatypeName (Rep a)) => Text
genericTypeName :: forall a. (Generic a, GDatatypeName (Rep a)) => Key
genericTypeName =
  Rep a (ZonkAny 0) -> Key
forall p. Rep a p -> Key
forall {k} (f :: k -> *) (p :: k). GDatatypeName f => f p -> Key
gDatatypeName (Rep a (ZonkAny 0) -> Key) -> Rep a (ZonkAny 0) -> Key
forall a b. (a -> b) -> a -> b
$ a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (a
forall a. HasCallStack => a
undefined :: a)


class GDatatypeName f where
  gDatatypeName :: f p -> Text


instance (Datatype d) => GDatatypeName (M1 D d f) where
  gDatatypeName :: forall (p :: k). M1 D d f p -> Key
gDatatypeName M1 D d f p
_ =
    String -> Key
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ M1 D d f (ZonkAny 2) -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t d f a -> String
datatypeName (M1 D d f p
forall {p :: k}. M1 D d f p
forall a. HasCallStack => a
undefined :: M1 D d f p)