{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Effect where

import Control.Monad (join)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.String.Conversions
import Data.Text
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Effectful.Reader.Static
import Network.HTTP.Types (Query)
import Web.FormUrlEncoded (Form, urlDecodeForm)
import Web.Hyperbole.HyperView
import Web.Hyperbole.Route
import Web.View


data Request = Request
  { Request -> [Text]
path :: [Text]
  , Request -> Query
query :: Query
  , Request -> ByteString
body :: BL.ByteString
  }
  deriving (Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Request -> ShowS
showsPrec :: Int -> Request -> ShowS
$cshow :: Request -> String
show :: Request -> String
$cshowList :: [Request] -> ShowS
showList :: [Request] -> ShowS
Show)


data Response
  = ErrParse Text
  | ErrNoHandler
  | Response (View () ())
  | NotFound


newtype Page es a = Page (Eff es a)
  deriving newtype (Functor (Page es)
Functor (Page es) =>
(forall a. a -> Page es a)
-> (forall a b. Page es (a -> b) -> Page es a -> Page es b)
-> (forall a b c.
    (a -> b -> c) -> Page es a -> Page es b -> Page es c)
-> (forall a b. Page es a -> Page es b -> Page es b)
-> (forall a b. Page es a -> Page es b -> Page es a)
-> Applicative (Page es)
forall (es :: [Effect]). Functor (Page es)
forall (es :: [Effect]) a. a -> Page es a
forall (es :: [Effect]) a b. Page es a -> Page es b -> Page es a
forall (es :: [Effect]) a b. Page es a -> Page es b -> Page es b
forall (es :: [Effect]) a b.
Page es (a -> b) -> Page es a -> Page es b
forall (es :: [Effect]) a b c.
(a -> b -> c) -> Page es a -> Page es b -> Page es c
forall a. a -> Page es a
forall a b. Page es a -> Page es b -> Page es a
forall a b. Page es a -> Page es b -> Page es b
forall a b. Page es (a -> b) -> Page es a -> Page es b
forall a b c. (a -> b -> c) -> Page es a -> Page es b -> Page es c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (es :: [Effect]) a. a -> Page es a
pure :: forall a. a -> Page es a
$c<*> :: forall (es :: [Effect]) a b.
Page es (a -> b) -> Page es a -> Page es b
<*> :: forall a b. Page es (a -> b) -> Page es a -> Page es b
$cliftA2 :: forall (es :: [Effect]) a b c.
(a -> b -> c) -> Page es a -> Page es b -> Page es c
liftA2 :: forall a b c. (a -> b -> c) -> Page es a -> Page es b -> Page es c
$c*> :: forall (es :: [Effect]) a b. Page es a -> Page es b -> Page es b
*> :: forall a b. Page es a -> Page es b -> Page es b
$c<* :: forall (es :: [Effect]) a b. Page es a -> Page es b -> Page es a
<* :: forall a b. Page es a -> Page es b -> Page es a
Applicative, Applicative (Page es)
Applicative (Page es) =>
(forall a b. Page es a -> (a -> Page es b) -> Page es b)
-> (forall a b. Page es a -> Page es b -> Page es b)
-> (forall a. a -> Page es a)
-> Monad (Page es)
forall (es :: [Effect]). Applicative (Page es)
forall (es :: [Effect]) a. a -> Page es a
forall (es :: [Effect]) a b. Page es a -> Page es b -> Page es b
forall (es :: [Effect]) a b.
Page es a -> (a -> Page es b) -> Page es b
forall a. a -> Page es a
forall a b. Page es a -> Page es b -> Page es b
forall a b. Page es a -> (a -> Page es b) -> Page es b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (es :: [Effect]) a b.
Page es a -> (a -> Page es b) -> Page es b
>>= :: forall a b. Page es a -> (a -> Page es b) -> Page es b
$c>> :: forall (es :: [Effect]) a b. Page es a -> Page es b -> Page es b
>> :: forall a b. Page es a -> Page es b -> Page es b
$creturn :: forall (es :: [Effect]) a. a -> Page es a
return :: forall a. a -> Page es a
Monad, (forall a b. (a -> b) -> Page es a -> Page es b)
-> (forall a b. a -> Page es b -> Page es a) -> Functor (Page es)
forall (es :: [Effect]) a b. a -> Page es b -> Page es a
forall (es :: [Effect]) a b. (a -> b) -> Page es a -> Page es b
forall a b. a -> Page es b -> Page es a
forall a b. (a -> b) -> Page es a -> Page es b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (es :: [Effect]) a b. (a -> b) -> Page es a -> Page es b
fmap :: forall a b. (a -> b) -> Page es a -> Page es b
$c<$ :: forall (es :: [Effect]) a b. a -> Page es b -> Page es a
<$ :: forall a b. a -> Page es b -> Page es a
Functor)


data Event act id = Event
  { forall act id. Event act id -> id
viewId :: id
  , forall act id. Event act id -> act
action :: act
  }


data Hyperbole :: Effect where
  GetForm :: Hyperbole m Form
  GetEvent :: (HyperView id) => Hyperbole m (Maybe (Event (Action id) id))
  Respond :: Response -> Hyperbole m a


-- ParseError :: HyperError -> Hyperbole m a

type instance DispatchOf Hyperbole = 'Dynamic


runHyperboleRoute
  :: (Route route)
  => Request
  -> (route -> Eff (Hyperbole : es) ())
  -> Eff es Response
runHyperboleRoute :: forall route (es :: [Effect]).
Route route =>
Request -> (route -> Eff (Hyperbole : es) ()) -> Eff es Response
runHyperboleRoute Request
req route -> Eff (Hyperbole : es) ()
actions = do
  case [Text] -> Maybe route
forall a. Route a => [Text] -> Maybe a
findRoute Request
req.path of
    Maybe route
Nothing -> Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
NotFound
    Just route
rt -> do
      Either Response ()
er <- Request -> Eff (Hyperbole : es) () -> Eff es (Either Response ())
forall (es :: [Effect]) a.
Request -> Eff (Hyperbole : es) a -> Eff es (Either Response a)
runHyperbole Request
req (route -> Eff (Hyperbole : es) ()
actions route
rt)
      case Either Response ()
er of
        Left Response
r -> Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
r
        Right ()
_ -> Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
ErrNoHandler


runHyperbole
  :: Request
  -> Eff (Hyperbole : es) a
  -> Eff es (Either Response a)
runHyperbole :: forall (es :: [Effect]) a.
Request -> Eff (Hyperbole : es) a -> Eff es (Either Response a)
runHyperbole Request
req =
  (Eff (Reader Request : Error Response : es) a
 -> Eff es (Either Response a))
-> (forall {a} {localEs :: [Effect]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv localEs (Reader Request : Error Response : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (Reader Request : Error Response : es) a)
-> Eff (Hyperbole : es) a
-> Eff es (Either Response a)
forall (e :: Effect) (handlerEs :: [Effect]) a (es :: [Effect]) b.
(DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret Eff (Reader Request : Error Response : es) a
-> Eff es (Either Response a)
runLocal ((forall {a} {localEs :: [Effect]}.
  (HasCallStack, Hyperbole :> localEs) =>
  LocalEnv localEs (Reader Request : Error Response : es)
  -> Hyperbole (Eff localEs) a
  -> Eff (Reader Request : Error Response : es) a)
 -> Eff (Hyperbole : es) a -> Eff es (Either Response a))
-> (forall {a} {localEs :: [Effect]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv localEs (Reader Request : Error Response : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (Reader Request : Error Response : es) a)
-> Eff (Hyperbole : es) a
-> Eff es (Either Response a)
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (Reader Request : Error Response : es)
_ -> \case
    Hyperbole (Eff localEs) a
GetForm -> Eff (Reader Request : Error Response : es) a
Eff (Reader Request : Error Response : es) Form
forall (es :: [Effect]).
(Reader Request :> es, Error Response :> es) =>
Eff es Form
getForm
    Hyperbole (Eff localEs) a
GetEvent -> Eff (Reader Request : Error Response : es) a
Eff
  (Reader Request : Error Response : es)
  (Maybe (Event (Action id) id))
forall (es :: [Effect]) id.
(Reader Request :> es, HyperView id) =>
Eff es (Maybe (Event (Action id) id))
getEvent
    Respond Response
r -> Response -> Eff (Reader Request : Error Response : es) a
forall (es :: [Effect]) a.
(Error Response :> es) =>
Response -> Eff es a
respond Response
r
 where
  respond :: (Error Response :> es) => Response -> Eff es a
  respond :: forall (es :: [Effect]) a.
(Error Response :> es) =>
Response -> Eff es a
respond = Response -> Eff es a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError

  runLocal :: Eff (Reader Request : Error Response : es) a
-> Eff es (Either Response a)
runLocal =
    forall e (es :: [Effect]) a.
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @Response
      (Eff (Error Response : es) a -> Eff es (Either Response a))
-> (Eff (Reader Request : Error Response : es) a
    -> Eff (Error Response : es) a)
-> Eff (Reader Request : Error Response : es) a
-> Eff es (Either Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request
-> Eff (Reader Request : Error Response : es) a
-> Eff (Error Response : es) a
forall r (es :: [Effect]) a. r -> Eff (Reader r : es) a -> Eff es a
runReader Request
req

  getForm :: (Reader Request :> es, Error Response :> es) => Eff es Form
  getForm :: forall (es :: [Effect]).
(Reader Request :> es, Error Response :> es) =>
Eff es Form
getForm = do
    ByteString
bd <- forall r (es :: [Effect]) a.
(Reader r :> es) =>
(r -> a) -> Eff es a
asks @Request (.body)
    let ef :: Either Text Form
ef = ByteString -> Either Text Form
urlDecodeForm ByteString
bd
    (Text -> Eff es Form)
-> (Form -> Eff es Form) -> Either Text Form -> Eff es Form
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Response -> Eff es Form
forall (es :: [Effect]) a.
(Error Response :> es) =>
Response -> Eff es a
respond (Response -> Eff es Form)
-> (Text -> Response) -> Text -> Eff es Form
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Response
ErrParse) Form -> Eff es Form
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Text Form
ef

  getEvent :: (Reader Request :> es, HyperView id) => Eff es (Maybe (Event (Action id) id))
  getEvent :: forall (es :: [Effect]) id.
(Reader Request :> es, HyperView id) =>
Eff es (Maybe (Event (Action id) id))
getEvent = do
    Query
q <- forall r (es :: [Effect]) a.
(Reader r :> es) =>
(r -> a) -> Eff es a
asks @Request (.query)
    Maybe (Event (Action id) id)
-> Eff es (Maybe (Event (Action id) id))
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Event (Action id) id)
 -> Eff es (Maybe (Event (Action id) id)))
-> Maybe (Event (Action id) id)
-> Eff es (Maybe (Event (Action id) id))
forall a b. (a -> b) -> a -> b
$ do
      Event Text
ti Text
ta <- Query -> Maybe (Event Text Text)
lookupEvent Query
q
      id
vid <- Text -> Maybe id
forall a. Param a => Text -> Maybe a
parseParam Text
ti
      Action id
act <- Text -> Maybe (Action id)
forall a. Param a => Text -> Maybe a
parseParam Text
ta
      Event (Action id) id -> Maybe (Event (Action id) id)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event (Action id) id -> Maybe (Event (Action id) id))
-> Event (Action id) id -> Maybe (Event (Action id) id)
forall a b. (a -> b) -> a -> b
$ id -> Action id -> Event (Action id) id
forall act id. id -> act -> Event act id
Event id
vid Action id
act

  lookupParam :: BS.ByteString -> Query -> Maybe Text
  lookupParam :: ByteString -> Query -> Maybe Text
lookupParam ByteString
p Query
q =
    (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Maybe ByteString -> Maybe Text)
-> (Maybe (Maybe ByteString) -> Maybe ByteString)
-> Maybe (Maybe ByteString)
-> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ByteString) -> Maybe Text)
-> Maybe (Maybe ByteString) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Query -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
p Query
q

  lookupEvent :: Query -> Maybe (Event Text Text)
  lookupEvent :: Query -> Maybe (Event Text Text)
lookupEvent Query
q =
    Text -> Text -> Event Text Text
forall act id. id -> act -> Event act id
Event
      (Text -> Text -> Event Text Text)
-> Maybe Text -> Maybe (Text -> Event Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Query -> Maybe Text
lookupParam ByteString
"id" Query
q
      Maybe (Text -> Event Text Text)
-> Maybe Text -> Maybe (Event Text Text)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Query -> Maybe Text
lookupParam ByteString
"action" Query
q


formData :: (Hyperbole :> es) => Eff es Form
formData :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Form
formData = Hyperbole (Eff es) Form -> Eff es Form
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send Hyperbole (Eff es) Form
forall (m :: * -> *). Hyperbole m Form
GetForm


notFound :: (Hyperbole :> es) => Eff es a
notFound :: forall (es :: [Effect]) a. (Hyperbole :> es) => Eff es a
notFound = 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 (m :: * -> *) a. Response -> Hyperbole m a
Respond Response
NotFound


parseError :: (Hyperbole :> es) => Text -> Eff es a
parseError :: forall (es :: [Effect]) a. (Hyperbole :> es) => Text -> Eff es a
parseError Text
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 (m :: * -> *) a. Response -> Hyperbole m a
Respond (Response -> Hyperbole (Eff es) a)
-> Response -> Hyperbole (Eff es) a
forall a b. (a -> b) -> a -> b
$ Text -> Response
ErrParse Text
e


-- | Set the response to the view. Note that `page` already expects a view to be returned from the effect
view :: (Hyperbole :> es) => View () () -> Eff es ()
view :: forall (es :: [Effect]).
(Hyperbole :> es) =>
View () () -> Eff es ()
view View () ()
vw = 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
$ Response -> Hyperbole (Eff es) ()
forall (m :: * -> *) a. Response -> Hyperbole m a
Respond (Response -> Hyperbole (Eff es) ())
-> Response -> Hyperbole (Eff es) ()
forall a b. (a -> b) -> a -> b
$ View () () -> Response
Response View () ()
vw


-- | Load the entire page when no HyperViews match
load
  :: (Hyperbole :> es)
  => Eff es (View () ())
  -> Page es ()
load :: forall (es :: [Effect]).
(Hyperbole :> es) =>
Eff es (View () ()) -> Page es ()
load Eff es (View () ())
run = Eff es () -> Page es ()
forall (es :: [Effect]) a. Eff es a -> Page es a
Page (Eff es () -> Page es ()) -> Eff es () -> Page es ()
forall a b. (a -> b) -> a -> b
$ do
  View () ()
vw <- Eff es (View () ())
run
  View () () -> Eff es ()
forall (es :: [Effect]).
(Hyperbole :> es) =>
View () () -> Eff es ()
view View () ()
vw


-- | Handle a HyperView. If the event matches our handler, respond with the fragment
hyper
  :: (Hyperbole :> es, HyperView id)
  => (id -> Action id -> Eff es (View id ()))
  -> Page es ()
hyper :: forall (es :: [Effect]) id.
(Hyperbole :> es, HyperView id) =>
(id -> Action id -> Eff es (View id ())) -> Page es ()
hyper id -> Action id -> Eff es (View id ())
run = Eff es () -> Page es ()
forall (es :: [Effect]) a. Eff es a -> Page es a
Page (Eff es () -> Page es ()) -> Eff es () -> Page es ()
forall a b. (a -> b) -> a -> b
$ do
  -- Get an event matching our type. If it doesn't match, skip to the next handler
  Maybe (Event (Action id) id)
mev <- Hyperbole (Eff es) (Maybe (Event (Action id) id))
-> Eff es (Maybe (Event (Action id) id))
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send Hyperbole (Eff es) (Maybe (Event (Action id) id))
forall id (m :: * -> *).
HyperView id =>
Hyperbole m (Maybe (Event (Action id) id))
GetEvent
  case Maybe (Event (Action id) id)
mev of
    Just Event (Action id) id
event -> do
      View id ()
vw <- id -> Action id -> Eff es (View id ())
run Event (Action id) id
event.viewId Event (Action id) id
event.action
      View () () -> Eff es ()
forall (es :: [Effect]).
(Hyperbole :> es) =>
View () () -> Eff es ()
view (View () () -> Eff es ()) -> View () () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ id -> View id () -> View () ()
forall id ctx. HyperView id => id -> View id () -> View ctx ()
viewId Event (Action id) id
event.viewId View id ()
vw
    Maybe (Event (Action id) id)
_ -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


page
  :: (Hyperbole :> es)
  => Page es ()
  -> Eff es ()
page :: forall (es :: [Effect]).
(Hyperbole :> es) =>
Page es () -> Eff es ()
page (Page Eff es ()
eff) = Eff es ()
eff