diff --git a/.ghci b/.ghci new file mode 100644 index 0000000..d391637 --- /dev/null +++ b/.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 diff --git a/README.md b/README.md new file mode 100644 index 0000000..89b7183 --- /dev/null +++ b/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. diff --git a/src/UnliftIO/Servant/Server.hs b/src/UnliftIO/Servant/Server.hs new file mode 100644 index 0000000..849dbd3 --- /dev/null +++ b/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 diff --git a/unliftio-servant-server.cabal b/unliftio-servant-server.cabal new file mode 100644 index 0000000..a3664d6 --- /dev/null +++ b/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 +maintainer: Bellroy Tech Team +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