{-# 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)
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)
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 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
data Server :: Effect where
LoadRequest :: Server m Request
SendResponse :: Session -> Response -> Server m ()
type instance DispatchOf Server = 'Dynamic
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
}
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
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 ->
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
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
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
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
(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'
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
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
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
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
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
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
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
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 :: (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
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
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
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
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
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
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 ()
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