{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.Server.Handler where

import Data.Aeson (FromJSON, ToJSON, Value)
import Data.Aeson qualified as A
import Data.Kind (Type)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Reader.Dynamic
import Effectful.State.Dynamic
import Web.Hyperbole.Data.Encoded
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.Response (hyperView, parseError, respondError)
import Web.Hyperbole.HyperView
import Web.Hyperbole.Types.Event
import Web.Hyperbole.Types.Request
import Web.Hyperbole.Types.Response
import Web.Hyperbole.View


class RunHandlers (views :: [Type]) es where
  runHandlers :: (Hyperbole :> es) => Event TargetViewId Encoded Value -> Eff es (Maybe Response)


instance RunHandlers '[] es where
  runHandlers :: (Hyperbole :> es) =>
Event TargetViewId Encoded Value -> Eff es (Maybe Response)
runHandlers Event TargetViewId Encoded Value
_ = Maybe Response -> Eff es (Maybe Response)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Response
forall a. Maybe a
Nothing


instance (HyperView view es, ToJSON (ViewState view), FromJSON (ViewState view), RunHandlers views es) => RunHandlers (view : views) es where
  runHandlers :: (Hyperbole :> es) =>
Event TargetViewId Encoded Value -> Eff es (Maybe Response)
runHandlers Event TargetViewId Encoded Value
rawEvent = do
    mr <- forall id (es :: [Effect]).
(HyperView id es, ToJSON (ViewState id), FromJSON (ViewState id),
 Hyperbole :> es) =>
Event TargetViewId Encoded Value
-> (Action id
    -> Eff (Reader id : State (ViewState id) : es) (View id ()))
-> Eff es (Maybe Response)
runHandler @view Event TargetViewId Encoded Value
rawEvent (forall id (es :: [Effect]).
(HyperView id es, Hyperbole :> es) =>
Action id
-> Eff (Reader id : State (ViewState id) : es) (View id ())
update @view)
    case mr of
      Maybe Response
Nothing -> forall (views :: [*]) (es :: [Effect]).
(RunHandlers views es, Hyperbole :> es) =>
Event TargetViewId Encoded Value -> Eff es (Maybe Response)
runHandlers @views Event TargetViewId Encoded Value
rawEvent
      Just Response
r -> Maybe Response -> Eff es (Maybe Response)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
r)


runHandler
  :: forall id es
   . (HyperView id es, ToJSON (ViewState id), FromJSON (ViewState id), Hyperbole :> es)
  => Event TargetViewId Encoded Value
  -> (Action id -> Eff (Reader id : State (ViewState id) : es) (View id ()))
  -> Eff es (Maybe Response)
runHandler :: forall id (es :: [Effect]).
(HyperView id es, ToJSON (ViewState id), FromJSON (ViewState id),
 Hyperbole :> es) =>
Event TargetViewId Encoded Value
-> (Action id
    -> Eff (Reader id : State (ViewState id) : es) (View id ()))
-> Eff es (Maybe Response)
runHandler Event TargetViewId Encoded Value
rawEvent Action id
-> Eff (Reader id : State (ViewState id) : es) (View id ())
run = do
  -- Get an event matching our type. If it doesn't match, skip to the next handler
  mev <- forall id (es :: [Effect]).
(HyperView id es, FromJSON (ViewState id), Hyperbole :> es) =>
Event TargetViewId Encoded Value
-> Eff es (Maybe (Event id (Action id) (ViewState id)))
decodeEvent @id Event TargetViewId Encoded Value
rawEvent :: Eff es (Maybe (Event id (Action id) (ViewState id)))
  case mev of
    Just Event id (Action id) (ViewState id)
evt -> do
      (vw, st) <- ViewState id
-> Eff (State (ViewState id) : es) (View id ())
-> Eff es (View id (), ViewState id)
forall s (es :: [Effect]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es (a, s)
runStateLocal Event id (Action id) (ViewState id)
evt.state (Eff (State (ViewState id) : es) (View id ())
 -> Eff es (View id (), ViewState id))
-> Eff (State (ViewState id) : es) (View id ())
-> Eff es (View id (), ViewState id)
forall a b. (a -> b) -> a -> b
$ id
-> Eff (Reader id : State (ViewState id) : es) (View id ())
-> Eff (State (ViewState id) : es) (View id ())
forall r (es :: [Effect]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader Event id (Action id) (ViewState id)
evt.viewId (Eff (Reader id : State (ViewState id) : es) (View id ())
 -> Eff (State (ViewState id) : es) (View id ()))
-> Eff (Reader id : State (ViewState id) : es) (View id ())
-> Eff (State (ViewState id) : es) (View id ())
forall a b. (a -> b) -> a -> b
$ Action id
-> Eff (Reader id : State (ViewState id) : es) (View id ())
run Event id (Action id) (ViewState id)
evt.action
      res <- hyperView evt.viewId st vw
      pure $ Just res
    Maybe (Event id (Action id) (ViewState id))
_ -> do
      Maybe Response -> Eff es (Maybe Response)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Response
forall a. Maybe a
Nothing


runLoad
  :: forall views es
   . (Hyperbole :> es, RunHandlers views es)
  => Eff es (View (Root views) ())
  -> Eff es Response
runLoad :: forall (views :: [*]) (es :: [Effect]).
(Hyperbole :> es, RunHandlers views es) =>
Eff es (View (Root views) ()) -> Eff es Response
runLoad Eff es (View (Root views) ())
page = do
  ev <- (.event) (Request -> Maybe (Event TargetViewId Encoded Value))
-> Eff es Request
-> Eff es (Maybe (Event TargetViewId Encoded Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hyperbole (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 Hyperbole (Eff es) Request
forall (a :: * -> *). Hyperbole a Request
GetRequest
  case ev of
    Just Event TargetViewId Encoded Value
rawEvent -> do
      res <- forall (views :: [*]) (es :: [Effect]).
(RunHandlers views es, Hyperbole :> es) =>
Event TargetViewId Encoded Value -> Eff es (Maybe Response)
runHandlers @views Event TargetViewId Encoded Value
rawEvent
      case res of
        -- if we found an event, it should have been handled by one of the views
        Maybe Response
Nothing -> ResponseError -> Eff es Response
forall (es :: [Effect]) a.
(Hyperbole :> es) =>
ResponseError -> Eff es a
respondError (ResponseError -> Eff es Response)
-> ResponseError -> Eff es Response
forall a b. (a -> b) -> a -> b
$ Event TargetViewId Encoded Value -> ResponseError
ErrNotHandled Event TargetViewId Encoded Value
rawEvent
        Just Response
r -> Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
r
    Maybe (Event TargetViewId Encoded Value)
Nothing -> do
      Eff es (View (Root views) ()) -> Eff es Response
forall (es :: [Effect]) (total :: [*]).
Eff es (View (Root total) ()) -> Eff es Response
loadPageResponse Eff es (View (Root views) ())
page


loadPageResponse :: Eff es (View (Root total) ()) -> Eff es Response
loadPageResponse :: forall (es :: [Effect]) (total :: [*]).
Eff es (View (Root total) ()) -> Eff es Response
loadPageResponse Eff es (View (Root total) ())
run = do
  vw <- Eff es (View (Root total) ())
run
  let vid = Encoded -> TargetViewId
TargetViewId (Encoded -> TargetViewId) -> Encoded -> TargetViewId
forall a b. (a -> b) -> a -> b
$ Root (ZonkAny 0) -> Encoded
forall a. ViewId a => a -> Encoded
toViewId Root (ZonkAny 0)
forall (views :: [*]). Root views
Root
  let res = ViewUpdate -> Response
Response (ViewUpdate -> Response) -> ViewUpdate -> Response
forall a b. (a -> b) -> a -> b
$ TargetViewId -> Body -> ViewUpdate
ViewUpdate TargetViewId
vid (Body -> ViewUpdate) -> Body -> ViewUpdate
forall a b. (a -> b) -> a -> b
$ View () () -> Body
renderBody (View () () -> Body) -> View () () -> Body
forall a b. (a -> b) -> a -> b
$ Root total
-> ViewState (Root total) -> View (Root total) () -> View () ()
forall ctx c. ctx -> ViewState ctx -> View ctx () -> View c ()
runViewContext Root total
forall (views :: [*]). Root views
Root () View (Root total) ()
vw
  pure res


-- despite not needing any effects, this must be in Eff es to get `es` on the RHS
decodeEvent :: forall id es. (HyperView id es, FromJSON (ViewState id), Hyperbole :> es) => Event TargetViewId Encoded Value -> Eff es (Maybe (Event id (Action id) (ViewState id)))
decodeEvent :: forall id (es :: [Effect]).
(HyperView id es, FromJSON (ViewState id), Hyperbole :> es) =>
Event TargetViewId Encoded Value
-> Eff es (Maybe (Event id (Action id) (ViewState id)))
decodeEvent (Event (TargetViewId Encoded
ti) Encoded
eact Value
est) =
  -- First, parse the view id. These should be unique on each page
  case Encoded -> Either String id
forall a. ViewId a => Encoded -> Either String a
parseViewId Encoded
ti of
    Left String
_ -> Maybe (Event id (Action id) (ViewState id))
-> Eff es (Maybe (Event id (Action id) (ViewState id)))
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Event id (Action id) (ViewState id))
forall a. Maybe a
Nothing
    Right id
vid -> do
      -- Then if parsing the state or action fails, throw an erro
      (String -> Eff es (Maybe (Event id (Action id) (ViewState id))))
-> (Event id (Action id) (ViewState id)
    -> Eff es (Maybe (Event id (Action id) (ViewState id))))
-> Either String (Event id (Action id) (ViewState id))
-> Eff es (Maybe (Event id (Action id) (ViewState id)))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Eff es (Maybe (Event id (Action id) (ViewState id)))
forall (es :: [Effect]) a. (Hyperbole :> es) => String -> Eff es a
parseError (Maybe (Event id (Action id) (ViewState id))
-> Eff es (Maybe (Event id (Action id) (ViewState id)))
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Event id (Action id) (ViewState id))
 -> Eff es (Maybe (Event id (Action id) (ViewState id))))
-> (Event id (Action id) (ViewState id)
    -> Maybe (Event id (Action id) (ViewState id)))
-> Event id (Action id) (ViewState id)
-> Eff es (Maybe (Event id (Action id) (ViewState id)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event id (Action id) (ViewState id)
-> Maybe (Event id (Action id) (ViewState id))
forall a. a -> Maybe a
Just) (Either String (Event id (Action id) (ViewState id))
 -> Eff es (Maybe (Event id (Action id) (ViewState id))))
-> Either String (Event id (Action id) (ViewState id))
-> Eff es (Maybe (Event id (Action id) (ViewState id)))
forall a b. (a -> b) -> a -> b
$ do
        act <- Encoded -> Either String (Action id)
forall a. ViewAction a => Encoded -> Either String a
parseAction Encoded
eact
        st <- parseState est
        pure $ Event vid act st


parseState :: (FromJSON a) => Value -> Either String a
parseState :: forall a. FromJSON a => Value -> Either String a
parseState Value
v =
  case Value -> Result a
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
v of
    A.Success a
a -> a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    A.Error String
e -> String -> Either String a
forall a b. a -> Either a b
Left String
e