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

module Web.Hyperbole.Effect.Session where

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.Encoded as Encoded
import Web.Hyperbole.Data.Param
import Web.Hyperbole.Data.URI (Path)
import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..))
import Web.Hyperbole.Effect.Request (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

@
data Preferences = Preferences
  { color :: AppColor
  }
  deriving (Generic, ToEncoded, FromEncoded, '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 Any -> Key
forall p. Rep a p -> Key
forall {k} (f :: k -> *) (p :: k). GDatatypeName f => f p -> Key
gDatatypeName (Rep a Any -> Key) -> Rep a Any -> Key
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
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


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


  -- | Decode from a cookie value. Defaults to FromJSON
  parseCookie :: CookieValue -> Either String a
  default parseCookie :: (FromEncoded a) => CookieValue -> Either String a
  parseCookie (CookieValue ByteString
bs) = do
    Key -> Either String a
forall a. FromEncoded a => Key -> Either String a
Encoded.decodeEither (ByteString -> Key
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

@
data Preferences = Preferences
  { color :: AppColor
  }
  deriving (Generic, ToEncoded, FromEncoded, '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
  Maybe a
ms <- Eff es (Maybe a)
forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
Eff es (Maybe a)
lookupSession
  a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Eff es a) -> a -> Eff es a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. Default a => a
def Maybe a
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
  Maybe CookieValue
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 Maybe CookieValue
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
val -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Eff es a -> Eff es (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> CookieValue -> Eff es a
forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
Key -> CookieValue -> Eff es a
parseSession Key
key CookieValue
val


{- | Persist datatypes in browser cookies

@
data Preferences = Preferences
  { color :: AppColor
  }
  deriving (Generic, ToEncoded, FromEncoded, '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
  a
s <- Eff es a
forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
Eff es a
session
  let updated :: a
updated = a -> a
f a
s
  a -> Eff es ()
forall a (es :: [Effect]).
(Session a, Hyperbole :> es) =>
a -> Eff es ()
saveSession a
updated
  a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
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 -> a) -> Eff es a
forall a (es :: [Effect]).
(Session a, Default a, Hyperbole :> es) =>
(a -> a) -> Eff es a
modifySession a -> a
f
  () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
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 -> Cookie
Cookie (forall a. Session a => Key
sessionKey @a) (forall a. Session a => Maybe Path
cookiePath @a) Maybe CookieValue
forall a. Maybe a
Nothing
  (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 :: (ToParam a, Hyperbole :> es) => Cookie -> Eff es ()
setCookie :: forall a (es :: [Effect]).
(ToParam 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
  Cookies
clt <- Eff es Cookies
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Cookies
clientSessionCookies
  Cookies
req <- Eff es Cookies
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Cookies
requestSessionCookies
  Cookies -> Eff es Cookies
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cookies -> Eff es Cookies) -> Cookies -> Eff es Cookies
forall a b. (a -> b) -> a -> b
$ Cookies
clt Cookies -> Cookies -> Cookies
forall a. Semigroup a => a -> a -> a
<> Cookies
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 -> 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)


-- | generic datatype name
genericTypeName :: forall a. (Generic a, GDatatypeName (Rep a)) => Text
genericTypeName :: forall a. (Generic a, GDatatypeName (Rep a)) => Key
genericTypeName =
  Rep a Any -> Key
forall p. Rep a p -> Key
forall {k} (f :: k -> *) (p :: k). GDatatypeName f => f p -> Key
gDatatypeName (Rep a Any -> Key) -> Rep a Any -> Key
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
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 Any -> 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)