{-# LANGUAGE UndecidableInstances #-}
module Mig.Core.Class.Server (
(/.),
ToServer (..),
HasServer (..),
hoistServer,
fromReader,
fromReaderExcept,
) where
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.Reader
import Data.Kind
import Data.Text (Text)
import Mig.Core.Api qualified as Api
import Mig.Core.Class.Monad
import Mig.Core.Class.Route
import Mig.Core.Server (Server (..), mapServerFun)
import Mig.Core.ServerFun (ServerFun)
import Mig.Core.Types
infixr 4 /.
(/.) :: (ToServer a) => Api.Path -> a -> Server (MonadOf a)
/. :: forall a. ToServer a => Path -> a -> Server (MonadOf a)
(/.) Path
path a
api
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null Path
path.unPath = forall a. ToServer a => a -> Server (MonadOf a)
toServer a
api
| Bool
otherwise =
case forall (m :: * -> *). Server m -> Api (Route m)
unServer (forall a. ToServer a => a -> Server (MonadOf a)
toServer a
api) of
Api.WithPath Path
rest Api (Route (MonadOf a))
a -> Path -> Api (Route (MonadOf a)) -> Server (MonadOf a)
go Path
rest Api (Route (MonadOf a))
a
Api (Route (MonadOf a))
other -> Path -> Api (Route (MonadOf a)) -> Server (MonadOf a)
go forall a. Monoid a => a
mempty Api (Route (MonadOf a))
other
where
go :: Path -> Api (Route (MonadOf a)) -> Server (MonadOf a)
go Path
rest Api (Route (MonadOf a))
a = forall (m :: * -> *). Api (Route m) -> Server m
Server forall a b. (a -> b) -> a -> b
$ forall a. Path -> Api a -> Api a
Api.WithPath (Path
path forall a. Semigroup a => a -> a -> a
<> Path
rest) Api (Route (MonadOf a))
a
class ToServer a where
toServer :: a -> Server (MonadOf a)
instance ToServer (Server m) where
toServer :: Server m -> Server (MonadOf (Server m))
toServer = forall a. a -> a
id
instance (ToServer a) => ToServer [a] where
toServer :: [a] -> Server (MonadOf [a])
toServer = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. ToServer a => a -> Server (MonadOf a)
toServer
instance {-# OVERLAPPABLE #-} (ToRoute a) => ToServer a where
toServer :: a -> Server (MonadOf a)
toServer a
a = forall (m :: * -> *). Api (Route m) -> Server m
Server forall a b. (a -> b) -> a -> b
$ forall a. a -> Api a
Api.HandleRoute (forall a. ToRoute a => a -> Route (MonadOf a)
toRoute a
a)
hoistServer :: (forall a. m a -> n a) -> Server m -> Server n
hoistServer :: forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> Server m -> Server n
hoistServer forall a. m a -> n a
f (Server Api (Route m)
server) =
forall (m :: * -> *). Api (Route m) -> Server m
Server forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Route m
x -> forall (m :: * -> *). RouteInfo -> ServerFun m -> Route m
Route Route m
x.info (forall a. m a -> n a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Route m
x.run)) Api (Route m)
server
class (Monad m) => HasServer m where
type ServerResult m :: Type
renderServer :: Server m -> ServerResult m
instance HasServer IO where
type ServerResult IO = Server IO
renderServer :: Server IO -> ServerResult IO
renderServer = forall a. a -> a
id
instance HasServer (ReaderT env IO) where
type ServerResult (ReaderT env IO) = env -> Server IO
renderServer :: Server (ReaderT env IO) -> ServerResult (ReaderT env IO)
renderServer Server (ReaderT env IO)
server env
initEnv = forall env. env -> Server (ReaderT env IO) -> Server IO
fromReader env
initEnv Server (ReaderT env IO)
server
fromReader :: env -> Server (ReaderT env IO) -> Server IO
fromReader :: forall env. env -> Server (ReaderT env IO) -> Server IO
fromReader env
env = forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> Server m -> Server n
hoistServer (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT env
env)
instance HasServer (ReaderT env (ExceptT Text IO)) where
type
ServerResult (ReaderT env (ExceptT Text IO)) =
env -> Server IO
renderServer :: Server (ReaderT env (ExceptT Text IO))
-> ServerResult (ReaderT env (ExceptT Text IO))
renderServer Server (ReaderT env (ExceptT Text IO))
server env
initEnv = forall env.
env -> Server (ReaderT env (ExceptT Text IO)) -> Server IO
fromReaderExcept env
initEnv Server (ReaderT env (ExceptT Text IO))
server
fromReaderExcept ::
forall env.
env ->
Server (ReaderT env (ExceptT Text IO)) ->
Server IO
fromReaderExcept :: forall env.
env -> Server (ReaderT env (ExceptT Text IO)) -> Server IO
fromReaderExcept env
env = forall (m :: * -> *) (n :: * -> *).
(ServerFun m -> ServerFun n) -> Server m -> Server n
mapServerFun (env -> ServerFun (ReaderT env (ExceptT Text IO)) -> ServerFun IO
handle env
env)
where
handle :: env -> ServerFun (ReaderT env (ExceptT Text IO)) -> ServerFun IO
handle :: env -> ServerFun (ReaderT env (ExceptT Text IO)) -> ServerFun IO
handle env
e ServerFun (ReaderT env (ExceptT Text IO))
f = \Request
req ->
Either Text (Maybe Response) -> Maybe Response
handleError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ServerFun (ReaderT env (ExceptT Text IO))
f Request
req) env
e)
handleError :: Either Text (Maybe Response) -> Maybe Response
handleError :: Either Text (Maybe Response) -> Maybe Response
handleError = \case
Right Maybe Response
mResp -> Maybe Response
mResp
Left Text
err -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {k} (media :: k) a. ToRespBody media a => a -> Response
badRequest @Text Text
err