{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoFieldSelectors #-}

module Web.Hyperbole.Effect where

import Control.Monad (join)
import Data.Bifunctor (first)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.List qualified as List
import Data.String.Conversions
import Data.Text
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Effectful.State.Static.Local
import Network.HTTP.Types hiding (Query)
import Web.FormUrlEncoded (Form, urlDecodeForm)
import Web.HttpApiData (FromHttpApiData, ToHttpApiData (..), parseQueryParam)
import Web.Hyperbole.HyperView
import Web.Hyperbole.Route
import Web.Hyperbole.Session as Session
import Web.View


newtype Host = Host {Host -> ByteString
text :: BS.ByteString}
  deriving (Int -> Host -> ShowS
[Host] -> ShowS
Host -> String
(Int -> Host -> ShowS)
-> (Host -> String) -> ([Host] -> ShowS) -> Show Host
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Host -> ShowS
showsPrec :: Int -> Host -> ShowS
$cshow :: Host -> String
show :: Host -> String
$cshowList :: [Host] -> ShowS
showList :: [Host] -> ShowS
Show)


data Request = Request
  { Request -> Host
host :: Host
  , Request -> [Segment]
path :: [Segment]
  , Request -> Query
query :: Query
  , Request -> ByteString
body :: BL.ByteString
  , Request -> ByteString
method :: Method
  , Request -> [(ByteString, ByteString)]
cookies :: [(BS.ByteString, BS.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)


{- | Valid responses for a 'Hyperbole' effect. Use 'notFound', etc instead. Reminds you to use 'load' in your 'Page'

> myPage :: (Hyperbole :> es) => Page es Response
> myPage = do
>   -- compiler error: () does not equal Response
>   pure ()
-}
data Response
  = Response (View () ())
  | NotFound
  | Redirect Url
  | Err ResponseError
  | Empty


data ResponseError
  = ErrParse Text
  | ErrParam Text
  | ErrOther Text
  | ErrNotHandled (Event Text Text)
  | ErrAuth
  deriving (Int -> ResponseError -> ShowS
[ResponseError] -> ShowS
ResponseError -> String
(Int -> ResponseError -> ShowS)
-> (ResponseError -> String)
-> ([ResponseError] -> ShowS)
-> Show ResponseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseError -> ShowS
showsPrec :: Int -> ResponseError -> ShowS
$cshow :: ResponseError -> String
show :: ResponseError -> String
$cshowList :: [ResponseError] -> ShowS
showList :: [ResponseError] -> ShowS
Show)


{- | Hyperbole applications are divided into Pages. Each Page must 'load' the whole page , and 'handle' each /type/ of 'HyperView'

@
myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'
myPage = do
  'handle' messages
  'load' pageView

pageView = do
  el_ "My Page"
  'hyper' (Message 1) $ messageView "Starting Message"
@
-}
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)


-- | An action, with its corresponding id
data Event id act = Event
  { forall id act. Event id act -> id
viewId :: id
  , forall id act. Event id act -> act
action :: act
  }


instance (Show act, Show id) => Show (Event id act) where
  show :: Event id act -> String
show Event id act
e = String
"Event " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> id -> String
forall a. Show a => a -> String
show Event id act
e.viewId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> act -> String
forall a. Show a => a -> String
show Event id act
e.action


-- | Low level effect mapping request/response to either HTTP or WebSockets
data Server :: Effect where
  LoadRequest :: Server m Request
  SendResponse :: Session -> Response -> Server m ()


type instance DispatchOf Server = 'Dynamic


{- | 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
  SetSession :: (ToHttpApiData a) => Text -> a -> Hyperbole m ()
  DelSession :: Text -> Hyperbole m ()
  GetSession :: (FromHttpApiData a) => Text -> Hyperbole m (Maybe a)


type instance DispatchOf Hyperbole = 'Dynamic


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


-- | 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)))
-> (forall {a} {localEs :: [Effect]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv localEs (State HyperState : Error Response : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (State HyperState : Error Response : es) a)
-> Eff (Hyperbole : es) Response
-> Eff es (Either Response (Response, HyperState))
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 (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 ((forall {a} {localEs :: [Effect]}.
  (HasCallStack, Hyperbole :> localEs) =>
  LocalEnv localEs (State HyperState : Error Response : es)
  -> Hyperbole (Eff localEs) a
  -> Eff (State HyperState : Error Response : es) a)
 -> Eff (Hyperbole : es) Response
 -> Eff es (Either Response (Response, HyperState)))
-> (forall {a} {localEs :: [Effect]}.
    (HasCallStack, Hyperbole :> localEs) =>
    LocalEnv localEs (State HyperState : Error Response : es)
    -> Hyperbole (Eff localEs) a
    -> Eff (State HyperState : Error Response : es) a)
-> 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.
(State s :> es) =>
(s -> a) -> Eff es a
gets @HyperState (.request)
  RespondEarly Response
r -> do
    Session
s <- forall s (es :: [Effect]) a.
(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 (m :: * -> *). Session -> Response -> Server m ()
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
  SetSession Segment
k a
a -> do
    (HyperState -> HyperState)
-> Eff (State HyperState : Error Response : es) ()
forall s (es :: [Effect]). (State s :> es) => (s -> s) -> Eff es ()
modify ((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 = sessionSet k a st.session} :: HyperState
  DelSession Segment
k -> do
    (HyperState -> HyperState)
-> Eff (State HyperState : Error Response : es) ()
forall s (es :: [Effect]). (State s :> es) => (s -> s) -> Eff es ()
modify ((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 = sessionDel k st.session} :: HyperState
  GetSession Segment
k -> do
    Session
s <- forall s (es :: [Effect]) a.
(State s :> es) =>
(s -> a) -> Eff es a
gets @HyperState (.session)
    a -> Eff (State HyperState : Error Response : es) a
forall a. a -> Eff (State HyperState : Error Response : es) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Eff (State HyperState : Error Response : es) a)
-> a -> Eff (State HyperState : Error Response : es) a
forall a b. (a -> b) -> a -> b
$ Segment -> Session -> Maybe a
forall a. FromHttpApiData a => Segment -> Session -> Maybe a
sessionLookup Segment
k Session
s
 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 (m :: * -> *). Server m Request
LoadRequest
    let st :: HyperState
st = Request -> Session -> HyperState
HyperState Request
r ([(ByteString, ByteString)] -> Session
sessionFromCookies Request
r.cookies)
    forall e (es :: [Effect]) a.
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.
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 (m :: * -> *). Session -> Response -> Server m ()
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


-- | Return all information about the 'Request'
request :: (Hyperbole :> es) => Eff es Request
request :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request = 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 (m :: * -> *). Hyperbole m Request
GetRequest


{- | Return the request path

>>> reqPath
["users", "100"]
-}
reqPath :: (Hyperbole :> es) => Eff es [Segment]
reqPath :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es [Segment]
reqPath = (.path) (Request -> [Segment]) -> Eff es Request -> Eff es [Segment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es Request
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request


{- | Return the request body as a Web.FormUrlEncoded.Form

Prefer using Type-Safe 'Form's when possible
-}
formData :: (Hyperbole :> es) => Eff es Form
formData :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Form
formData = do
  ByteString
b <- (.body) (Request -> ByteString) -> Eff es Request -> Eff es ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es Request
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request
  let ef :: Either Segment Form
ef = ByteString -> Either Segment Form
urlDecodeForm ByteString
b
  -- not going to work. we need a way to `throwError` or it doesn't work...
  (Segment -> Eff es Form)
-> (Form -> Eff es Form) -> Either Segment Form -> Eff es Form
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (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 -> Eff es Form)
-> (Segment -> Hyperbole (Eff es) Form) -> Segment -> Eff es Form
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Hyperbole (Eff es) Form
forall (m :: * -> *) a. Response -> Hyperbole m a
RespondEarly (Response -> Hyperbole (Eff es) Form)
-> (Segment -> Response) -> Segment -> Hyperbole (Eff es) Form
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseError -> Response
Err (ResponseError -> Response)
-> (Segment -> ResponseError) -> Segment -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> ResponseError
ErrParse) Form -> Eff es Form
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Segment Form
ef


getEvent :: (HyperView id, Hyperbole :> es) => Eff es (Maybe (Event id (Action id)))
getEvent :: forall id (es :: [Effect]).
(HyperView id, Hyperbole :> es) =>
Eff es (Maybe (Event id (Action id)))
getEvent = do
  Query
q <- Eff es Query
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Query
reqParams
  Maybe (Event id (Action id))
-> Eff es (Maybe (Event id (Action id)))
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Event id (Action id))
 -> Eff es (Maybe (Event id (Action id))))
-> Maybe (Event id (Action id))
-> Eff es (Maybe (Event id (Action id)))
forall a b. (a -> b) -> a -> b
$ Query -> Maybe (Event id (Action id))
forall id. HyperView id => Query -> Maybe (Event id (Action id))
parseEvent Query
q


parseEvent :: (HyperView id) => Query -> Maybe (Event id (Action id))
parseEvent :: forall id. HyperView id => Query -> Maybe (Event id (Action id))
parseEvent Query
q = do
  Event Segment
ti Segment
ta <- Query -> Maybe (Event Segment Segment)
lookupEvent Query
q
  id
vid <- Segment -> Maybe id
forall a. Param a => Segment -> Maybe a
parseParam Segment
ti
  Action id
act <- Segment -> Maybe (Action id)
forall a. Param a => Segment -> Maybe a
parseParam Segment
ta
  Event id (Action id) -> Maybe (Event id (Action id))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event id (Action id) -> Maybe (Event id (Action id)))
-> Event id (Action id) -> Maybe (Event id (Action id))
forall a b. (a -> b) -> a -> b
$ id -> Action id -> Event id (Action id)
forall id act. id -> act -> Event id act
Event id
vid Action id
act


lookupEvent :: Query -> Maybe (Event Text Text)
lookupEvent :: Query -> Maybe (Event Segment Segment)
lookupEvent Query
q' =
  Segment -> Segment -> Event Segment Segment
forall id act. id -> act -> Event id act
Event
    (Segment -> Segment -> Event Segment Segment)
-> Maybe Segment -> Maybe (Segment -> Event Segment Segment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Query -> Maybe Segment
lookupParam ByteString
"id" Query
q'
    Maybe (Segment -> Event Segment Segment)
-> Maybe Segment -> Maybe (Event Segment Segment)
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 Segment
lookupParam ByteString
"action" Query
q'


{- | Lookup a session variable by keyword

> load $ do
>   tok <- session "token"
>   ...
-}
session :: (Hyperbole :> es, FromHttpApiData a) => Text -> Eff es (Maybe a)
session :: forall (es :: [Effect]) a.
(Hyperbole :> es, FromHttpApiData a) =>
Segment -> Eff es (Maybe a)
session Segment
k = Hyperbole (Eff es) (Maybe a) -> Eff es (Maybe a)
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Hyperbole (Eff es) (Maybe a) -> Eff es (Maybe a))
-> Hyperbole (Eff es) (Maybe a) -> Eff es (Maybe a)
forall a b. (a -> b) -> a -> b
$ Segment -> Hyperbole (Eff es) (Maybe a)
forall a (m :: * -> *).
FromHttpApiData a =>
Segment -> Hyperbole m (Maybe a)
GetSession Segment
k


{- | Set a session variable by keyword

> load $ do
>   t <- reqParam "token"
>   setSession "token" t
>   ...
-}
setSession :: (Hyperbole :> es, ToHttpApiData a) => Text -> a -> Eff es ()
setSession :: forall (es :: [Effect]) a.
(Hyperbole :> es, ToHttpApiData a) =>
Segment -> a -> Eff es ()
setSession Segment
k a
v = 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
$ Segment -> a -> Hyperbole (Eff es) ()
forall a (m :: * -> *).
ToHttpApiData a =>
Segment -> a -> Hyperbole m ()
SetSession Segment
k a
v


-- | Clear the user's session
clearSession :: (Hyperbole :> es) => Text -> Eff es ()
clearSession :: forall (es :: [Effect]). (Hyperbole :> es) => Segment -> Eff es ()
clearSession Segment
k = 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
$ Segment -> Hyperbole (Eff es) ()
forall (m :: * -> *). Segment -> Hyperbole m ()
DelSession Segment
k


{- | Return the entire 'Query'

@
myPage :: 'Page' es 'Response'
myPage = do
  'load' $ do
    q <- reqParams
    case 'lookupParam' "token" q of
      Nothing -> pure $ errorView "Missing Token in Query String"
      Just t -> do
        sideEffectUsingToken token
        pure myPageView
@
-}
reqParams :: (Hyperbole :> es) => Eff es Query
reqParams :: forall (es :: [Effect]). (Hyperbole :> es) => Eff es Query
reqParams = (.query) (Request -> Query) -> Eff es Request -> Eff es Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es Request
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request


-- | Lookup the query param in the 'Query'
lookupParam :: BS.ByteString -> Query -> Maybe Text
lookupParam :: ByteString -> Query -> Maybe Segment
lookupParam ByteString
p Query
q =
  (ByteString -> Segment) -> Maybe ByteString -> Maybe Segment
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Segment
forall a b. ConvertibleStrings a b => a -> b
cs (Maybe ByteString -> Maybe Segment)
-> (Maybe (Maybe ByteString) -> Maybe ByteString)
-> Maybe (Maybe ByteString)
-> Maybe Segment
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 Segment)
-> Maybe (Maybe ByteString) -> Maybe Segment
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


{- | Require a given parameter from the 'Query' arguments

@
myPage :: 'Page' es 'Response'
myPage = do
  'load' $ do
    token <- reqParam "token"
    sideEffectUsingToken token
    pure myPageView
@
-}
reqParam :: (Hyperbole :> es, FromHttpApiData a) => Text -> Eff es a
reqParam :: forall (es :: [Effect]) a.
(Hyperbole :> es, FromHttpApiData a) =>
Segment -> Eff es a
reqParam Segment
p = do
  Query
q <- Eff es Query
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Query
reqParams
  (Either Response a
er :: Either Response a) <- Either Response a -> Eff es (Either Response a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Response a -> Eff es (Either Response a))
-> Either Response a -> Eff es (Either Response a)
forall a b. (a -> b) -> a -> b
$ do
    Maybe ByteString
mv <- Maybe (Maybe ByteString) -> Either Response (Maybe ByteString)
forall x. Maybe x -> Either Response x
require (Maybe (Maybe ByteString) -> Either Response (Maybe ByteString))
-> Maybe (Maybe ByteString) -> Either Response (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Query -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup (Segment -> ByteString
encodeUtf8 Segment
p) Query
q
    ByteString
v <- Maybe ByteString -> Either Response ByteString
forall x. Maybe x -> Either Response x
require Maybe ByteString
mv
    (Segment -> Response) -> Either Segment a -> Either Response a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ResponseError -> Response
Err (ResponseError -> Response)
-> (Segment -> ResponseError) -> Segment -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> ResponseError
ErrParam) (Either Segment a -> Either Response a)
-> Either Segment a -> Either Response a
forall a b. (a -> b) -> a -> b
$ Segment -> Either Segment a
forall a. FromHttpApiData a => Segment -> Either Segment a
parseQueryParam (ByteString -> Segment
decodeUtf8 ByteString
v)
  case Either Response a
er of
    Left Response
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
RespondEarly Response
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
 where
  require :: Maybe x -> Either Response x
  require :: forall x. Maybe x -> Either Response x
require Maybe x
Nothing = Response -> Either Response x
forall a b. a -> Either a b
Left (Response -> Either Response x) -> Response -> Either Response x
forall a b. (a -> b) -> a -> b
$ ResponseError -> Response
Err (ResponseError -> Response) -> ResponseError -> Response
forall a b. (a -> b) -> a -> b
$ Segment -> ResponseError
ErrParam (Segment -> ResponseError) -> Segment -> ResponseError
forall a b. (a -> b) -> a -> b
$ Segment
"Missing: " Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment
p
  require (Just x
a) = x -> Either Response x
forall a. a -> Either Response a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
a


{- | Respond immediately with 404 Not Found

@
userLoad :: (Hyperbole :> es, Users :> es) => UserId -> Eff es User
userLoad uid = do
  mu <- send (LoadUser uid)
  maybe notFound pure mu

myPage :: (Hyperbole :> es, Users :> es) => Eff es View
myPage = do
  load $ do
    u <- userLoad 100
    -- skipped if user = Nothing
    pure $ userView u
@
-}
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
RespondEarly Response
NotFound


-- | Respond immediately with a parse error
parseError :: (Hyperbole :> es) => Text -> Eff es a
parseError :: forall (es :: [Effect]) a. (Hyperbole :> es) => Segment -> Eff es a
parseError = 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)
-> (Segment -> Hyperbole (Eff es) a) -> Segment -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Hyperbole (Eff es) a
forall (m :: * -> *) a. Response -> Hyperbole m a
RespondEarly (Response -> Hyperbole (Eff es) a)
-> (Segment -> Response) -> Segment -> Hyperbole (Eff es) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseError -> Response
Err (ResponseError -> Response)
-> (Segment -> ResponseError) -> Segment -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> ResponseError
ErrParse


-- | Redirect immediately to the 'Url'
redirect :: (Hyperbole :> es) => Url -> Eff es a
redirect :: forall (es :: [Effect]) a. (Hyperbole :> es) => Url -> Eff es a
redirect = 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)
-> (Url -> Hyperbole (Eff es) a) -> Url -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Hyperbole (Eff es) a
forall (m :: * -> *) a. Response -> Hyperbole m a
RespondEarly (Response -> Hyperbole (Eff es) a)
-> (Url -> Response) -> Url -> Hyperbole (Eff es) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Url -> Response
Redirect


-- | Respond with the given view, and stop execution
respondEarly :: (Hyperbole :> es, HyperView id) => id -> View id () -> Eff es ()
respondEarly :: forall (es :: [Effect]) id.
(Hyperbole :> es, HyperView id) =>
id -> View id () -> Eff es ()
respondEarly id
vid View id ()
vw = do
  let res :: Response
res = View () () -> Response
Response (View () () -> Response) -> View () () -> Response
forall a b. (a -> b) -> a -> b
$ id -> View id () -> View () ()
forall id ctx. HyperView id => id -> View id () -> View ctx ()
hyper id
vid View id ()
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
RespondEarly Response
res


-- | Manually set the response to the given view. Normally you return a 'View' from 'load' or 'handle' instead of using this
view :: (Hyperbole :> es) => View () () -> Eff es Response
view :: forall (es :: [Effect]).
(Hyperbole :> es) =>
View () () -> Eff es Response
view View () ()
vw = do
  Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Eff es Response) -> Response -> Eff es Response
forall a b. (a -> b) -> a -> b
$ View () () -> Response
Response View () ()
vw


{- | The load handler is run when the page is first loaded. Run any side effects needed, then return a view of the full page

@
myPage :: (Hyperbole :> es) => UserId -> Page es Response
myPage userId = do
  'load' $ do
    user <- loadUserFromDatabase userId
    pure $ userPageView user
@
-}
load
  :: (Hyperbole :> es)
  => Eff es (View () ())
  -> Page es Response
load :: forall (es :: [Effect]).
(Hyperbole :> es) =>
Eff es (View () ()) -> Page es Response
load Eff es (View () ())
run = Eff es Response -> Page es Response
forall (es :: [Effect]) a. Eff es a -> Page es a
Page (Eff es Response -> Page es Response)
-> Eff es Response -> Page es Response
forall a b. (a -> b) -> a -> b
$ do
  Request
r <- Eff es Request
forall (es :: [Effect]). (Hyperbole :> es) => Eff es Request
request
  case Query -> Maybe (Event Segment Segment)
lookupEvent Request
r.query of
    -- Are id and action set to sometjhing?
    Just Event Segment Segment
e ->
      Response -> Eff es Response
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Eff es Response) -> Response -> Eff es Response
forall a b. (a -> b) -> a -> b
$ ResponseError -> Response
Err (ResponseError -> Response) -> ResponseError -> Response
forall a b. (a -> b) -> a -> b
$ Event Segment Segment -> ResponseError
ErrNotHandled Event Segment Segment
e
    Maybe (Event Segment Segment)
Nothing -> do
      View () ()
vw <- Eff es (View () ())
run
      View () () -> Eff es Response
forall (es :: [Effect]).
(Hyperbole :> es) =>
View () () -> Eff es Response
view View () ()
vw


{- | A handler is run when an action for that 'HyperView' is triggered. Run any side effects needed, then return a view of the corresponding type

@
myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'
myPage = do
  'handle' messages
  'load' pageView

messages :: ('Hyperbole' :> es, MessageDatabase) => Message -> MessageAction -> 'Eff' es ('View' Message ())
messages (Message mid) ClearMessage = do
  deleteMessageSideEffect mid
  pure $ messageView ""

messages (Message mid) (Louder m) = do
  let new = m <> "!"
  saveMessageSideEffect mid new
  pure $ messageView new
@
-}
handle
  :: forall id es
   . (Hyperbole :> es, HyperView id)
  => (id -> Action id -> Eff es (View id ()))
  -> Page es ()
handle :: forall id (es :: [Effect]).
(Hyperbole :> es, HyperView id) =>
(id -> Action id -> Eff es (View id ())) -> Page es ()
handle 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 id (Action id))
mev <- forall id (es :: [Effect]).
(HyperView id, Hyperbole :> es) =>
Eff es (Maybe (Event id (Action id)))
getEvent @id
  case Maybe (Event id (Action id))
mev of
    Just Event id (Action id)
event -> do
      View id ()
vw <- id -> Action id -> Eff es (View id ())
run Event id (Action id)
event.viewId Event id (Action id)
event.action
      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
RespondEarly (Response -> Hyperbole (Eff es) ())
-> Response -> Hyperbole (Eff es) ()
forall a b. (a -> b) -> a -> b
$ View () () -> Response
Response (View () () -> Response) -> View () () -> Response
forall a b. (a -> b) -> a -> b
$ id -> View id () -> View () ()
forall id ctx. HyperView id => id -> View id () -> View ctx ()
hyper Event id (Action id)
event.viewId View id ()
vw
    Maybe (Event id (Action id))
_ -> () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Run a 'Page' in 'Hyperbole'
page
  :: (Hyperbole :> es)
  => Page es Response
  -> Eff es Response
page :: forall (es :: [Effect]).
(Hyperbole :> es) =>
Page es Response -> Eff es Response
page (Page Eff es Response
eff) = Eff es Response
eff