{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.Effect.Hyperbole where

import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Effectful.State.Static.Local
import Web.Hyperbole.Effect.QueryData
import Web.Hyperbole.Effect.Server
import Web.Hyperbole.Effect.Session as Session


{- | In any 'load' or 'handle', you can use this Effect to get extra request information or control the response manually.

For most 'Page's, you won't need to use this effect directly. Use custom 'Route's for request info, and return 'View's to respond
-}
data Hyperbole :: Effect where
  GetRequest :: Hyperbole m Request
  RespondEarly :: Response -> Hyperbole m a
  ModSession :: (Session -> Session) -> Hyperbole m ()
  GetSession :: Hyperbole m Session


type instance DispatchOf Hyperbole = 'Dynamic


-- | Run the 'Hyperbole' effect to 'Server'
runHyperbole
  :: (Server :> es)
  => Eff (Hyperbole : es) Response
  -> Eff es Response
runHyperbole :: forall (es :: [Effect]).
(Server :> es) =>
Eff (Hyperbole : es) Response -> Eff es Response
runHyperbole = (Eff es (Either Response (Response, HyperState))
 -> Eff es Response)
-> (Eff (Hyperbole : es) Response
    -> Eff es (Either Response (Response, HyperState)))
-> Eff (Hyperbole : es) Response
-> Eff es Response
forall a b.
(a -> b)
-> (Eff (Hyperbole : es) Response -> a)
-> Eff (Hyperbole : es) Response
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Eff es (Either Response (Response, HyperState)) -> Eff es Response
forall (es :: [Effect]).
(Server :> es) =>
Eff es (Either Response (Response, HyperState)) -> Eff es Response
combine ((Eff (Hyperbole : es) Response
  -> Eff es (Either Response (Response, HyperState)))
 -> Eff (Hyperbole : es) Response -> Eff es Response)
-> (Eff (Hyperbole : es) Response
    -> Eff es (Either Response (Response, HyperState)))
-> Eff (Hyperbole : es) Response
-> Eff es Response
forall a b. (a -> b) -> a -> b
$ (Eff (State HyperState : Error Response : es) Response
 -> Eff es (Either Response (Response, HyperState)))
-> EffectHandler Hyperbole (State HyperState : Error Response : es)
-> Eff (Hyperbole : es) Response
-> Eff es (Either Response (Response, HyperState))
forall (e :: Effect) (handlerEs :: [Effect]) a (es :: [Effect]) b.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret Eff (State HyperState : Error Response : es) Response
-> Eff es (Either Response (Response, HyperState))
forall (es :: [Effect]) a.
(Server :> es) =>
Eff (State HyperState : Error Response : es) a
-> Eff es (Either Response (a, HyperState))
runLocal (EffectHandler Hyperbole (State HyperState : Error Response : es)
 -> Eff (Hyperbole : es) Response
 -> Eff es (Either Response (Response, HyperState)))
-> EffectHandler Hyperbole (State HyperState : Error Response : es)
-> Eff (Hyperbole : es) Response
-> Eff es (Either Response (Response, HyperState))
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (State HyperState : Error Response : es)
_ -> \case
  Hyperbole (Eff localEs) a
GetRequest -> do
    forall s (es :: [Effect]) a.
(HasCallStack, State s :> es) =>
(s -> a) -> Eff es a
gets @HyperState (.request)
  RespondEarly Response
r -> do
    Session
s <- forall s (es :: [Effect]) a.
(HasCallStack, State s :> es) =>
(s -> a) -> Eff es a
gets @HyperState (.session)
    Server (Eff (State HyperState : Error Response : es)) ()
-> Eff (State HyperState : Error Response : es) ()
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Server (Eff (State HyperState : Error Response : es)) ()
 -> Eff (State HyperState : Error Response : es) ())
-> Server (Eff (State HyperState : Error Response : es)) ()
-> Eff (State HyperState : Error Response : es) ()
forall a b. (a -> b) -> a -> b
$ Session
-> Response
-> Server (Eff (State HyperState : Error Response : es)) ()
forall (a :: * -> *). Session -> Response -> Server a ()
SendResponse Session
s Response
r
    Response -> Eff (State HyperState : Error Response : es) a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError_ Response
r
  Hyperbole (Eff localEs) a
GetSession -> do
    forall s (es :: [Effect]) a.
(HasCallStack, State s :> es) =>
(s -> a) -> Eff es a
gets @HyperState (.session)
  ModSession Session -> Session
f -> do
    forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify @HyperState ((HyperState -> HyperState)
 -> Eff (State HyperState : Error Response : es) ())
-> (HyperState -> HyperState)
-> Eff (State HyperState : Error Response : es) ()
forall a b. (a -> b) -> a -> b
$ \HyperState
st -> HyperState
st{session = f st.session}
 where
  runLocal :: (Server :> es) => Eff (State HyperState : Error Response : es) a -> Eff es (Either Response (a, HyperState))
  runLocal :: forall (es :: [Effect]) a.
(Server :> es) =>
Eff (State HyperState : Error Response : es) a
-> Eff es (Either Response (a, HyperState))
runLocal Eff (State HyperState : Error Response : es) a
eff = do
    -- Load the request ONCE right when we start
    Request
r <- Server (Eff es) Request -> Eff es Request
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send Server (Eff es) Request
forall (a :: * -> *). Server a Request
LoadRequest
    let st :: HyperState
st = Request -> Session -> HyperState
HyperState Request
r ([(ByteString, ByteString)] -> Session
sessionFromCookies Request
r.cookies)
    forall e (es :: [Effect]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @Response (Eff (Error Response : es) (a, HyperState)
 -> Eff es (Either Response (a, HyperState)))
-> (Eff (State HyperState : Error Response : es) a
    -> Eff (Error Response : es) (a, HyperState))
-> Eff (State HyperState : Error Response : es) a
-> Eff es (Either Response (a, HyperState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HyperState
-> Eff (State HyperState : Error Response : es) a
-> Eff (Error Response : es) (a, HyperState)
forall s (es :: [Effect]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es (a, s)
runState HyperState
st (Eff (State HyperState : Error Response : es) a
 -> Eff es (Either Response (a, HyperState)))
-> Eff (State HyperState : Error Response : es) a
-> Eff es (Either Response (a, HyperState))
forall a b. (a -> b) -> a -> b
$ Eff (State HyperState : Error Response : es) a
eff

  combine :: (Server :> es) => Eff es (Either Response (Response, HyperState)) -> Eff es Response
  combine :: forall (es :: [Effect]).
(Server :> es) =>
Eff es (Either Response (Response, HyperState)) -> Eff es Response
combine Eff es (Either Response (Response, HyperState))
eff = do
    Either Response (Response, HyperState)
er <- Eff es (Either Response (Response, HyperState))
eff
    case Either Response (Response, HyperState)
er of
      Left Response
res ->
        -- responded early, don't need to respond again
        Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
res
      Right (Response
res, HyperState
st) -> do
        Server (Eff es) () -> Eff es ()
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Server (Eff es) () -> Eff es ())
-> Server (Eff es) () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Session -> Response -> Server (Eff es) ()
forall (a :: * -> *). Session -> Response -> Server a ()
SendResponse HyperState
st.session Response
res
        Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
res


data HyperState = HyperState
  { HyperState -> Request
request :: Request
  , HyperState -> Session
session :: Session
  }


-- | Lookup a session variable by keyword
session :: (FromQueryData a, Hyperbole :> es) => Text -> Eff es (Maybe a)
session :: forall a (es :: [Effect]).
(FromQueryData a, Hyperbole :> es) =>
Text -> Eff es (Maybe a)
session Text
k = do
  Session
s <- Hyperbole (Eff es) Session -> Eff es Session
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send Hyperbole (Eff es) Session
forall (m :: * -> *). Hyperbole m Session
GetSession
  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
$ Text -> Session -> Maybe a
forall a. FromQueryData a => Text -> Session -> Maybe a
sessionLookup Text
k Session
s


-- | Set a session variable by keyword
setSession :: (ToQueryData a, Hyperbole :> es) => Text -> a -> Eff es ()
setSession :: forall a (es :: [Effect]).
(ToQueryData a, Hyperbole :> es) =>
Text -> a -> Eff es ()
setSession Text
k a
v = do
  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
$ (Session -> Session) -> Hyperbole (Eff es) ()
forall (m :: * -> *). (Session -> Session) -> Hyperbole m ()
ModSession (Text -> a -> Session -> Session
forall a. ToQueryData a => Text -> a -> Session -> Session
sessionSet Text
k a
v)


-- | Clear a session variable
clearSession :: (Hyperbole :> es) => Text -> Eff es ()
clearSession :: forall (es :: [Effect]). (Hyperbole :> es) => Text -> Eff es ()
clearSession Text
k = do
  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
$ (Session -> Session) -> Hyperbole (Eff es) ()
forall (m :: * -> *). (Session -> Session) -> Hyperbole m ()
ModSession (Text -> Session -> Session
sessionDel Text
k)