Export from monorepo

.ghci

@@ -0,0 +1,8 @@
+-- This file is generated by `ninox generate`
+-- Think twice before editing it directly.
+:set -fno-show-valid-hole-fits
+:set -Wwarn
+:set -XOverloadedLabels
+:set -XOverloadedStrings
+:set -XTypeApplications
+:set -XEmptyCase

README.md

@@ -0,0 +1,13 @@
+# UnliftIO Support for `servant-server`
+
+APIs written in any `MonadUnliftIO m` can be converted to `wai`
+`Application`s without writing the natural transformation by
+hand. These functions will return `m Application` which means that either:
+
+1. You will have to serve from inside your `MonadUnliftIO m` monad, or
+2. You will have to unwrap your application monad to `IO`, bind the
+   `Application`, and then serve it in `IO`.
+
+If you choose the second option, beware `ResourceT` --- trying to use
+the returned `Application` outside of a containing `ResourceT` risks
+attempting to interact with closed resources.

src/UnliftIO/Servant/Server.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module UnliftIO.Servant.Server where
+
+import Control.Monad ((>=>))
+import Control.Monad.Except (ExceptT, runExceptT, throwError)
+import Data.Proxy (Proxy)
+import Servant.API.Generic (AsApi, GenericServant, ToServant, ToServantApi)
+import Servant.Server
+  ( Application,
+    Context,
+    HasServer,
+    ServerContext,
+    ServerError,
+    ServerT,
+  )
+import qualified Servant.Server as Servant
+import Servant.Server.Generic (AsServerT)
+import qualified Servant.Server.Generic as Servant
+import UnliftIO (MonadUnliftIO (..), liftIO)
+
+serve ::
+  (MonadUnliftIO m, HasServer api '[]) =>
+  Proxy api ->
+  ServerT api m ->
+  m Application
+serve proxy = serveWithContext proxy Servant.EmptyContext
+
+serveExceptT ::
+  (MonadUnliftIO m, HasServer api '[]) =>
+  Proxy api ->
+  (e -> Servant.ServerError) ->
+  ServerT api (ExceptT e m) ->
+  m Application
+serveExceptT proxy toServerError =
+  serveExceptTWithContext proxy toServerError Servant.EmptyContext
+
+serveWithContext ::
+  (HasServer api context, ServerContext context, MonadUnliftIO m) =>
+  Proxy api ->
+  Context context ->
+  ServerT api m ->
+  m Application
+serveWithContext proxy context api =
+  withRunInIO $ \runInIO ->
+    pure $ Servant.serveWithContextT proxy context (liftIO . runInIO) api
+
+serveExceptTWithContext ::
+  (HasServer api context, ServerContext context, MonadUnliftIO m) =>
+  Proxy api ->
+  (e -> ServerError) ->
+  Context context ->
+  ServerT api (ExceptT e m) ->
+  m Application
+serveExceptTWithContext proxy toServerError context api =
+  withRunInIO $ \runInIO ->
+    pure $
+      Servant.serveWithContextT
+        proxy
+        context
+        ( liftIO . runInIO . runExceptT
+            >=> either (throwError . toServerError) pure
+        )
+        api
+
+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 routes = withRunInIO $ \runInIO ->
+  pure $ Servant.genericServeT (liftIO . runInIO) routes
+
+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 -> ServerError) ->
+  routes (AsServerT (ExceptT e m)) ->
+  m Application
+genericServeExceptT toServerError routes =
+  genericServeExceptTWithContext toServerError routes Servant.EmptyContext
+
+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 routes context = withRunInIO $ \runInIO ->
+  pure $ Servant.genericServeTWithContext (liftIO . runInIO) routes context
+
+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 -> ServerError) ->
+  routes (AsServerT (ExceptT e m)) ->
+  Context context ->
+  m Application
+genericServeExceptTWithContext toServerError routes context =
+  withRunInIO $ \runInIO ->
+    pure $
+      Servant.genericServeTWithContext
+        ( liftIO . runInIO . runExceptT
+            >=> either (throwError . toServerError) pure
+        )
+        routes
+        context

unliftio-servant-server.cabal

@@ -0,0 +1,50 @@
+cabal-version:   3.0
+name:            unliftio-servant-server
+version:         0.1.0.0
+synopsis:        Use MonadUnliftIO on servant APIs
+description:
+  unliftio-servant-server provides convenience functions for running
+  servant APIs whose monads have a 'MonadUnliftIO' instance.
+
+category:        Servant, Server
+homepage:        https://github.com/bellroy/unliftio-servant-server
+bug-reports:     https://github.com/bellroy/unliftio-servant-server/issues
+author:          Bellroy Tech Team <[email protected]>
+maintainer:      Bellroy Tech Team <[email protected]>
+copyright:       Copyright (C) 2024 Bellroy Pty Ltd
+license:         BSD-3-Clause
+license-file:    LICENSE
+build-type:      Simple
+extra-doc-files:
+  CHANGELOG.md
+  README.md
+tested-with:     GHC ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5 || ==9.6.2
+
+source-repository head
+  type:     git
+  location: https://github.com/bellroy/haskell.git
+
+common opts
+  default-language: Haskell2010
+  ghc-options:
+    -Wall -Wcompat -Widentities -Wincomplete-record-updates
+    -Wincomplete-uni-patterns -Werror=incomplete-patterns
+    -Wredundant-constraints -Wpartial-fields -Wtabs
+    -Wmissing-local-signatures -fhelpful-errors
+    -fprint-expanded-synonyms -fwarn-unused-do-bind
+
+common opts-exe
+  ghc-options: -threaded
+
+common deps
+  build-depends:
+    , base            ^>=4.17
+    , mtl             ^>=2.2.2
+    , servant         ^>=0.20
+    , servant-server  ^>=0.20
+    , unliftio        >=0.1.0.0 && <0.3.0.0
+
+library
+  import:          deps, opts
+  hs-source-dirs:  src
+  exposed-modules: UnliftIO.Servant.Server