Server.hs

{-# 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)
(/.) path api
  | null path.unPath = toServer api
  | otherwise =
      case unServer (toServer api) of
        Api.WithPath rest a -> go rest a
        other -> go mempty other
  where
    go rest a = Server $ Api.WithPath (path <> rest) 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 = id

-- list
instance (ToServer a) => ToServer [a] where
  toServer = foldMap toServer

-- routes
instance {-# OVERLAPPABLE #-} (ToRoute a) => ToServer a where
  toServer a = Server $ Api.HandleRoute (toRoute a)

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

-- | Map internal monad of the server
hoistServer :: (forall a. m a -> n a) -> Server m -> Server n
hoistServer f (Server server) =
  Server $ fmap (\x -> Route x.info (f . x.run)) 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 = id

instance HasServer (ReaderT env IO) where
  type ServerResult (ReaderT env IO) = env -> Server IO
  renderServer server initEnv = fromReader initEnv server

-- | Render reader server to IO-based server
fromReader :: env -> Server (ReaderT env IO) -> Server IO
fromReader env = hoistServer (flip runReaderT env)

instance HasServer (ReaderT env (ExceptT Text IO)) where
  type
    ServerResult (ReaderT env (ExceptT Text IO)) =
      env -> Server IO

  renderServer server initEnv = fromReaderExcept initEnv server

-- | Render reader with expetT server to IO-based server
fromReaderExcept ::
  forall env.
  env ->
  Server (ReaderT env (ExceptT Text IO)) ->
  Server IO
fromReaderExcept env = mapServerFun (handle env)
  where
    handle :: env -> ServerFun (ReaderT env (ExceptT Text IO)) -> ServerFun IO
    handle e f = \req ->
      handleError <$> runExceptT (runReaderT (f req) e)

    handleError :: Either Text (Maybe Response) -> Maybe Response
    handleError = \case
      Right mResp -> mResp
      Left err -> Just $ badRequest @Text err