{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
--
-- Module      : UnliftIO.Servant.Server
-- Copyright   : (C) 2024 Bellroy Pty Ltd
-- License     : BSD-3-Clause
-- Maintainer  : Bellroy Tech Team <haskell@bellroy.com>
-- Stability   : experimental
--
-- The functions in this module make it easier to serve a Servant API,
-- when its API endpoints are implemented in a monad that has an
-- 'MonadUnliftIO' instance. Many monad transformers are morally just
-- 'ReaderT' or 'IdentityT' over some kind of base monad, and these
-- monads can be unlifted.
--
-- This isn't magic—you'll still have to unwrap the outer transformers
-- to get at the returned 'Application'—but for simpler application
-- monads it frees you from fiddling around with rank-2 functions just
-- to serve your API.
--
-- Example use:
--
-- @
-- import Network.Wai.Handler.Warp (runEnv)
--
-- -- Some kind of Servant API
-- type MyApi = ... :\<|\> ... :\<|\> ...
--
-- -- API implemented in terms of some application monad, which has a 'MonadUnliftIO' instance.
-- myApi :: ServerT MyApi SomeApplicationMonad
-- myApi = undefined -- details unimportant
--
-- main :: IO ()
-- main = runSomeApplicationMonad $ do
--   app <- 'serve' myApi
--   liftIO $ runEnv 3000 app
-- @
module UnliftIO.Servant.Server
  ( -- * Helpers for traditional-style APIs
    serve,
    serveExceptT,
    serveWithContext,
    serveExceptTWithContext,

    -- * Helpers for Generic/records-based APIs
    genericServe,
    genericServeExceptT,
    genericServeWithContext,
    genericServeExceptTWithContext,
  )
where

import Control.Monad ((>=>))
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Control.Monad.IO.Unlift (MonadUnliftIO (..), liftIO)
import Data.Proxy (Proxy)
import Servant.API.Generic (AsApi, GenericServant, ToServant, ToServantApi)
import Servant.Server
  ( Application,
    Context,
    HasServer,
    ServerContext,
    ServerT,
  )
import qualified Servant.Server as Servant
import Servant.Server.Generic (AsServerT)
import qualified Servant.Server.Generic as Servant

-- | Convert a Servant API into an 'Application', by unlifting the
-- monad in which it runs.
serve ::
  (MonadUnliftIO m, HasServer api '[]) =>
  Proxy api ->
  ServerT api m ->
  m Application
serve :: forall (m :: * -> *) api.
(MonadUnliftIO m, HasServer api '[]) =>
Proxy api -> ServerT api m -> m Application
serve Proxy api
proxy = Proxy api -> Context '[] -> ServerT api m -> m Application
forall api (context :: [*]) (m :: * -> *).
(HasServer api context, ServerContext context, MonadUnliftIO m) =>
Proxy api -> Context context -> ServerT api m -> m Application
serveWithContext Proxy api
proxy Context '[]
Servant.EmptyContext

-- | Convert a Servant API which uses 'ExceptT' above an unliftable
-- monad, by converting its errors into Servant's
-- 'Servant.ServerError' and returning them to the API caller.
serveExceptT ::
  (MonadUnliftIO m, HasServer api '[]) =>
  Proxy api ->
  (e -> Servant.ServerError) ->
  ServerT api (ExceptT e m) ->
  m Application
serveExceptT :: forall (m :: * -> *) api e.
(MonadUnliftIO m, HasServer api '[]) =>
Proxy api
-> (e -> ServerError) -> ServerT api (ExceptT e m) -> m Application
serveExceptT Proxy api
proxy e -> ServerError
toServerError =
  Proxy api
-> (e -> ServerError)
-> Context '[]
-> ServerT api (ExceptT e m)
-> m Application
forall api (context :: [*]) (m :: * -> *) e.
(HasServer api context, ServerContext context, MonadUnliftIO m) =>
Proxy api
-> (e -> ServerError)
-> Context context
-> ServerT api (ExceptT e m)
-> m Application
serveExceptTWithContext Proxy api
proxy e -> ServerError
toServerError Context '[]
Servant.EmptyContext

-- | As 'serve', with an additional 'Context' parameter.
serveWithContext ::
  (HasServer api context, ServerContext context, MonadUnliftIO m) =>
  Proxy api ->
  Context context ->
  ServerT api m ->
  m Application
serveWithContext :: forall api (context :: [*]) (m :: * -> *).
(HasServer api context, ServerContext context, MonadUnliftIO m) =>
Proxy api -> Context context -> ServerT api m -> m Application
serveWithContext Proxy api
proxy Context context
context ServerT api m
api =
  ((forall a. m a -> IO a) -> IO Application) -> m Application
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Application) -> m Application)
-> ((forall a. m a -> IO a) -> IO Application) -> m Application
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ Proxy api
-> Context context
-> (forall x. m x -> Handler x)
-> ServerT api m
-> Application
forall api (context :: [*]) (m :: * -> *).
(HasServer api context, ServerContext context) =>
Proxy api
-> Context context
-> (forall x. m x -> Handler x)
-> ServerT api m
-> Application
Servant.serveWithContextT Proxy api
proxy Context context
context (IO x -> Handler x
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO x -> Handler x) -> (m x -> IO x) -> m x -> Handler x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m x -> IO x
forall a. m a -> IO a
runInIO) ServerT api m
api

-- | As 'serveExceptT', with an additional 'Context' parameter.
serveExceptTWithContext ::
  (HasServer api context, ServerContext context, MonadUnliftIO m) =>
  Proxy api ->
  (e -> Servant.ServerError) ->
  Context context ->
  ServerT api (ExceptT e m) ->
  m Application
serveExceptTWithContext :: forall api (context :: [*]) (m :: * -> *) e.
(HasServer api context, ServerContext context, MonadUnliftIO m) =>
Proxy api
-> (e -> ServerError)
-> Context context
-> ServerT api (ExceptT e m)
-> m Application
serveExceptTWithContext Proxy api
proxy e -> ServerError
toServerError Context context
context ServerT api (ExceptT e m)
api =
  ((forall a. m a -> IO a) -> IO Application) -> m Application
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Application) -> m Application)
-> ((forall a. m a -> IO a) -> IO Application) -> m Application
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$
      Proxy api
-> Context context
-> (forall x. ExceptT e m x -> Handler x)
-> ServerT api (ExceptT e m)
-> Application
forall api (context :: [*]) (m :: * -> *).
(HasServer api context, ServerContext context) =>
Proxy api
-> Context context
-> (forall x. m x -> Handler x)
-> ServerT api m
-> Application
Servant.serveWithContextT
        Proxy api
proxy
        Context context
context
        ( IO (Either e x) -> Handler (Either e x)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either e x) -> Handler (Either e x))
-> (ExceptT e m x -> IO (Either e x))
-> ExceptT e m x
-> Handler (Either e x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either e x) -> IO (Either e x)
forall a. m a -> IO a
runInIO (m (Either e x) -> IO (Either e x))
-> (ExceptT e m x -> m (Either e x))
-> ExceptT e m x
-> IO (Either e x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e m x -> m (Either e x)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
            (ExceptT e m x -> Handler (Either e x))
-> (Either e x -> Handler x) -> ExceptT e m x -> Handler x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (e -> Handler x) -> (x -> Handler x) -> Either e x -> Handler x
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ServerError -> Handler x
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler x) -> (e -> ServerError) -> e -> Handler x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ServerError
toServerError) x -> Handler x
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        )
        ServerT api (ExceptT e m)
api

-- | As 'serve', but for Servant's generic records.
--
-- /See:/ "Servant.API.Generic"
genericServe ::
  ( GenericServant routes (AsServerT m),
    GenericServant routes AsApi,
    HasServer (ToServantApi routes) '[],
    ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m),
    MonadUnliftIO m
  ) =>
  routes (AsServerT m) ->
  m Application
genericServe :: forall (routes :: * -> *) (m :: * -> *).
(GenericServant routes (AsServerT m), GenericServant routes AsApi,
 HasServer (ToServantApi routes) '[],
 ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m),
 MonadUnliftIO m) =>
routes (AsServerT m) -> m Application
genericServe routes (AsServerT m)
routes = ((forall a. m a -> IO a) -> IO Application) -> m Application
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Application) -> m Application)
-> ((forall a. m a -> IO a) -> IO Application) -> m Application
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
  Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> Handler a) -> routes (AsServerT m) -> Application
forall (routes :: * -> *) (m :: * -> *).
(GenericServant routes (AsServerT m), GenericServant routes AsApi,
 HasServer (ToServantApi routes) '[],
 ServerT (ToServantApi routes) m
 ~ ToServant routes (AsServerT m)) =>
(forall a. m a -> Handler a) -> routes (AsServerT m) -> Application
Servant.genericServeT (IO a -> Handler a
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Handler a) -> (m a -> IO a) -> m a -> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IO a
forall a. m a -> IO a
runInIO) routes (AsServerT m)
routes

-- | As 'genericServe', but for when you have an 'ExceptT' above the
-- unliftable monad. As with 'serveExceptT', errors are returned to
-- the API caller.
genericServeExceptT ::
  ( GenericServant routes (AsServerT (ExceptT e m)),
    GenericServant routes AsApi,
    HasServer (ToServantApi routes) '[],
    ServerT (ToServantApi routes) (ExceptT e m)
      ~ ToServant routes (AsServerT (ExceptT e m)),
    MonadUnliftIO m
  ) =>
  (e -> Servant.ServerError) ->
  routes (AsServerT (ExceptT e m)) ->
  m Application
genericServeExceptT :: forall (routes :: * -> *) e (m :: * -> *).
(GenericServant routes (AsServerT (ExceptT e m)),
 GenericServant routes AsApi, HasServer (ToServantApi routes) '[],
 ServerT (ToServantApi routes) (ExceptT e m)
 ~ ToServant routes (AsServerT (ExceptT e m)),
 MonadUnliftIO m) =>
(e -> ServerError)
-> routes (AsServerT (ExceptT e m)) -> m Application
genericServeExceptT e -> ServerError
toServerError routes (AsServerT (ExceptT e m))
routes =
  (e -> ServerError)
-> routes (AsServerT (ExceptT e m)) -> Context '[] -> m Application
forall (routes :: * -> *) e (m :: * -> *) (context :: [*]).
(GenericServant routes (AsServerT (ExceptT e m)),
 GenericServant routes AsApi,
 HasServer (ToServantApi routes) context, ServerContext context,
 ServerT (ToServantApi routes) (ExceptT e m)
 ~ ToServant routes (AsServerT (ExceptT e m)),
 MonadUnliftIO m) =>
(e -> ServerError)
-> routes (AsServerT (ExceptT e m))
-> Context context
-> m Application
genericServeExceptTWithContext e -> ServerError
toServerError routes (AsServerT (ExceptT e m))
routes Context '[]
Servant.EmptyContext

-- | As 'genericServe', but with an additional 'Context' parameter.
genericServeWithContext ::
  ( GenericServant routes (AsServerT m),
    GenericServant routes AsApi,
    HasServer (ToServantApi routes) context,
    ServerContext context,
    ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m),
    MonadUnliftIO m
  ) =>
  routes (AsServerT m) ->
  Context context ->
  m Application
genericServeWithContext :: forall (routes :: * -> *) (m :: * -> *) (context :: [*]).
(GenericServant routes (AsServerT m), GenericServant routes AsApi,
 HasServer (ToServantApi routes) context, ServerContext context,
 ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m),
 MonadUnliftIO m) =>
routes (AsServerT m) -> Context context -> m Application
genericServeWithContext routes (AsServerT m)
routes Context context
context = ((forall a. m a -> IO a) -> IO Application) -> m Application
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Application) -> m Application)
-> ((forall a. m a -> IO a) -> IO Application) -> m Application
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
  Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> Handler a)
-> routes (AsServerT m) -> Context context -> Application
forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]).
(GenericServant routes (AsServerT m), GenericServant routes AsApi,
 HasServer (ToServantApi routes) ctx,
 HasContextEntry (ctx .++ '[ErrorFormatters]) ErrorFormatters,
 ServerT (ToServantApi routes) m
 ~ ToServant routes (AsServerT m)) =>
(forall a. m a -> Handler a)
-> routes (AsServerT m) -> Context ctx -> Application
Servant.genericServeTWithContext (IO a -> Handler a
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Handler a) -> (m a -> IO a) -> m a -> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IO a
forall a. m a -> IO a
runInIO) routes (AsServerT m)
routes Context context
context

-- | As 'genericServeExceptT', but with an additional 'Context' parameter.
genericServeExceptTWithContext ::
  ( GenericServant routes (AsServerT (ExceptT e m)),
    GenericServant routes AsApi,
    HasServer (ToServantApi routes) context,
    ServerContext context,
    ServerT (ToServantApi routes) (ExceptT e m)
      ~ ToServant routes (AsServerT (ExceptT e m)),
    MonadUnliftIO m
  ) =>
  (e -> Servant.ServerError) ->
  routes (AsServerT (ExceptT e m)) ->
  Context context ->
  m Application
genericServeExceptTWithContext :: forall (routes :: * -> *) e (m :: * -> *) (context :: [*]).
(GenericServant routes (AsServerT (ExceptT e m)),
 GenericServant routes AsApi,
 HasServer (ToServantApi routes) context, ServerContext context,
 ServerT (ToServantApi routes) (ExceptT e m)
 ~ ToServant routes (AsServerT (ExceptT e m)),
 MonadUnliftIO m) =>
(e -> ServerError)
-> routes (AsServerT (ExceptT e m))
-> Context context
-> m Application
genericServeExceptTWithContext e -> ServerError
toServerError routes (AsServerT (ExceptT e m))
routes Context context
context =
  ((forall a. m a -> IO a) -> IO Application) -> m Application
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Application) -> m Application)
-> ((forall a. m a -> IO a) -> IO Application) -> m Application
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$
      (forall a. ExceptT e m a -> Handler a)
-> routes (AsServerT (ExceptT e m))
-> Context context
-> Application
forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]).
(GenericServant routes (AsServerT m), GenericServant routes AsApi,
 HasServer (ToServantApi routes) ctx,
 HasContextEntry (ctx .++ '[ErrorFormatters]) ErrorFormatters,
 ServerT (ToServantApi routes) m
 ~ ToServant routes (AsServerT m)) =>
(forall a. m a -> Handler a)
-> routes (AsServerT m) -> Context ctx -> Application
Servant.genericServeTWithContext
        ( IO (Either e a) -> Handler (Either e a)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either e a) -> Handler (Either e a))
-> (ExceptT e m a -> IO (Either e a))
-> ExceptT e m a
-> Handler (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either e a) -> IO (Either e a)
forall a. m a -> IO a
runInIO (m (Either e a) -> IO (Either e a))
-> (ExceptT e m a -> m (Either e a))
-> ExceptT e m a
-> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
            (ExceptT e m a -> Handler (Either e a))
-> (Either e a -> Handler a) -> ExceptT e m a -> Handler a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (e -> Handler a) -> (a -> Handler a) -> Either e a -> Handler a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ServerError -> Handler a
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler a) -> (e -> ServerError) -> e -> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ServerError
toServerError) a -> Handler a
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        )
        routes (AsServerT (ExceptT e m))
routes
        Context context
context