{-# LANGUAGE UndecidableInstances #-}

-- | To server class
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 /.

{-| Constructs server which can handle given path. Example:

> "api/v1/get/info" /. handleInfo

For captures we use wild-cards:

> "api/v1/get/info/*" /. handleInfo

And handle info has capture argument:

> handleInfo :: Capture "nameA" -> Get IO (Resp Json value)

The name for the capture is derived from the type signature of the route handler.
Note that if capture is in the last position of the path we can omit wild cards.
The proper amount of captures will be derived from the type signature of the handler.
-}
(/.) :: (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

-- | Values that can be converted to server
class ToServer a where
  -- | Convert value to server
  toServer :: a -> Server (MonadOf a)

-- identity

instance ToServer (Server m) where
  toServer :: Server m -> Server (MonadOf (Server m))
toServer = forall a. a -> a
id

-- list
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

-- routes
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)

-------------------------------------------------------------------------------------

-- | Map internal monad of the server
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 contains types which can be converted to IO-based server to run as with WAI-interface.

We can run plain IO-servers and ReaderT over IO based servers. Readers can be wrapped in newtypes.
In that case we can derive automatically @HasServer@ instance.
-}
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

-- | Render reader server to IO-based 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

-- | Render reader with expetT server to IO-based 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