servant-polysemy (empty) → 0.1.0
raw patch · 10 files changed
+561/−0 lines, 10 filesdep +basedep +deepseqdep +http-clientsetup-changed
Dependencies added: base, deepseq, http-client, http-client-tls, lens, mtl, polysemy, polysemy-plugin, polysemy-zoo, servant-client, servant-polysemy, servant-server, servant-swagger, servant-swagger-ui, swagger2, text, wai, warp
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +13/−0
- Setup.hs +2/−0
- example/Client.hs +31/−0
- example/Server.hs +27/−0
- example/ServerWithSwagger.hs +57/−0
- servant-polysemy.cabal +108/−0
- src/Servant/Polysemy/Client.hs +139/−0
- src/Servant/Polysemy/Server.hs +149/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for servant-polysemy++## 0.1.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, Alex Chapman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Alex Chapman nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,13 @@+# servant-polysemy++`servant-polysemy` is a Haskell library that makes it easier to use [Servant](https://hackage.haskell.org/package/servant) and [Polysemy](https://hackage.haskell.org/package/polysemy) together.++## Examples++Check out these examples for how to use it:++- [Server](https://github.com/AJChapman/servant-polysemy/blob/master/example/Server.hs)+- [Server with Swagger docs](https://github.com/AJChapman/servant-polysemy/blob/master/example/ServerWithSwagger.hs)+- [Client](https://github.com/AJChapman/servant-polysemy/blob/master/example/Client.hs)++The client will connect to either version of the server and interact with its endpoint, which simply serves up the package version.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Client.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+module Main (main) where++import Data.Function ((&))+import Data.Version (Version, showVersion)+import Polysemy+import Polysemy.Error+import Servant+import Servant.Client.Streaming (ClientM, client)+import Servant.Polysemy.Client (ServantClient, runClient, runServantClient)++type MyApi = "api" :> "v1" :> "version" :> Get '[JSON] Version++versionClient :: ClientM Version+versionClient = client (Proxy @MyApi)++program :: Members '[ServantClient, Embed IO] r => Sem r ()+program = do+ ev <- runClient versionClient & runError+ case ev of+ Left err ->+ embed $ putStrLn $ "Client failed: " <> show err+ Right v ->+ embed $ putStrLn $ "Received version: " <> showVersion v++main :: IO ()+main = program+ & runServantClient "localhost:8080"+ & runM
+ example/Server.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Main (main) where++import Control.Lens.Operators+import Data.Version (Version, showVersion)+import Paths_servant_polysemy as Paths+import Polysemy+import Polysemy.Error+import Servant+import Servant.Polysemy.Server++type MyApi = "api" :> "v1" :> "version" :> Get '[JSON] Version++myServer :: Member (Embed IO) r => ServerT MyApi (Sem (Error ServerError ': r))+myServer = do+ embed $ putStrLn $ "Returning version " <> showVersion Paths.version+ pure Paths.version++main :: IO ()+main =+ runWarpServer @MyApi 8080 True myServer+ & runM+
+ example/ServerWithSwagger.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Main (main) where++import Control.Lens.Operators+import Data.Swagger (Swagger, description, host, info, license, title, version)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Version (Version, showVersion)+import qualified Paths_servant_polysemy as Paths+import Polysemy+import Polysemy.Error+import Servant+import Servant.Polysemy.Server+import Servant.Swagger (toSwagger)+import Servant.Swagger.UI (SwaggerSchemaUI, swaggerSchemaUIServer)++type MyApi = "api" :> "v1" :> "version" :> Get '[JSON] Version++type SwaggerDocs = "api" :> "v1" :> SwaggerSchemaUI "swagger-ui" "swagger.json"++type MyApiWithSwagger =+ MyApi+ :<|> SwaggerDocs+ :<|> "api" :> "v1" :> Redirect 302 Text -- Redirect /api/v1 to the swagger docs+ :<|> "api" :> Redirect 302 Text -- Redirect /api to the swagger docs+ :<|> Redirect 302 Text -- Redirect / to the swagger docs++myServer :: Member (Embed IO) r => ServerT MyApi (Sem (Error ServerError ': r))+myServer = do+ embed $ putStrLn $ "Returning version " <> showVersion Paths.version+ pure Paths.version++mySwagger :: Swagger+mySwagger = toSwagger (Proxy @MyApi)+ & info.title .~ "My API"+ & info.version .~ (T.pack . showVersion) Paths.version+ & info.description ?~ "This is just an example API."+ & info.license ?~ "Public Domain"+ & host ?~ "localhost:8080"++mySwaggerServer :: Member (Embed IO) r => ServerT MyApiWithSwagger (Sem (Error ServerError ': r))+mySwaggerServer =+ myServer+ :<|> hoistServerIntoSem @SwaggerDocs (swaggerSchemaUIServer mySwagger)+ :<|> redirect "/api/v1/swagger-ui"+ :<|> redirect "/api/v1/swagger-ui"+ :<|> redirect "/api/v1/swagger-ui"++main :: IO ()+main =+ runWarpServer @MyApiWithSwagger 8080 True mySwaggerServer+ & runM
+ servant-polysemy.cabal view
@@ -0,0 +1,108 @@+cabal-version: 2.4+name: servant-polysemy+version: 0.1.0+synopsis: Utilities for using servant in a polysemy stack +description: It's possible to use servant and polysemy together without this library, but it's not easy. This library makes it easy.+homepage: https://github.com/AJChapman/servant-polysemy#readme+bug-reports: https://github.com/AJChapman/servant-polysemy/issues+license: BSD-3-Clause+license-file: LICENSE+author: Alex Chapman+maintainer: alex@farfromthere.net+copyright: 2020 Alex Chapman+category: Servant, Web+build-type: Simple+extra-source-files: CHANGELOG.md+ README.md+extra-doc-files: example/Server.hs+ example/ServerWithSwagger.hs+ example/Client.hs+tested-with: GHC == 8.8.4+ , GHC == 8.10.1+ -- GHC == 8.4.4 -- Not working due to missing extension BlockArguments+ --, GHC == 8.6.5 -- Not working due to Polysemy.Plugin not found when generating haddocks++common deps+ build-depends: base >= 4.11.0.0 && < 5+ , deepseq >= 1.4.3.0 && < 1.5+ , http-client ^>= 0.6.4.1+ , http-client-tls ^>= 0.3.5.3+ , mtl ^>= 2.2.2+ , polysemy ^>= 1.3.0.0+ , polysemy-plugin ^>= 0.2.4.0+ , polysemy-zoo ^>= 0.7.0.1+ , servant-server >= 0.16 && < 0.19+ , servant-client >= 0.16 && < 0.19+ , wai ^>= 3.2.1.2+ , warp >= 3.2.22 && < 3.4++-- Warnings list list taken from+-- https://medium.com/mercury-bank/enable-all-the-warnings-a0517bc081c3+-- Enable all warnings with -Weverything, then disable the ones we+-- don’t care about+ default-language: Haskell2010+ ghc-options: -Weverything+ -Wno-all-missed-specialisations+ -Wno-implicit-prelude+ -Wno-missed-specialisations+ -Wno-missing-exported-signatures+ -Wno-missing-import-lists+ -Wno-missing-local-signatures+ -Wno-monomorphism-restriction+ -Wno-missing-deriving-strategies+ -Wno-safe+ -Wno-unsafe+ -fprint-potential-instances+ -fplugin=Polysemy.Plugin+ if impl(ghc >= 8.10)+ ghc-options: -Wno-prepositive-qualified-module+ -Wno-missing-safe-haskell-mode++library+ import: deps+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules: Servant.Polysemy.Client+ Servant.Polysemy.Server+ Paths_servant_polysemy+ autogen-modules: Paths_servant_polysemy++executable example-server+ import: deps+ main-is: Server.hs+ hs-source-dirs: example+ default-language: Haskell2010+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ build-depends: servant-polysemy+ , lens++executable example-server-with-swagger+ import: deps+ main-is: ServerWithSwagger.hs+ hs-source-dirs: example+ default-language: Haskell2010+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ build-depends: servant-polysemy+ , lens+ , servant-swagger ^>= 1.1+ , servant-swagger-ui ^>= 0.3+ , swagger2 >= 2.4 && < 2.7+ , text ^>= 1.2.3.1++executable example-client+ import: deps+ main-is: Client.hs+ hs-source-dirs: example+ default-language: Haskell2010+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ build-depends: servant-polysemy++source-repository head+ type: git+ location: https://github.com/AJChapman/servant-polysemy
+ src/Servant/Polysemy/Client.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-|+Module : Servant.Polysemy.Client+Copyright : (c) 2020 Alex Chapman+License : BSD3+Maintainer : alex@farfromthere.net+Stability : experimental+Portability : GHC+Description : A Polysemy effect for running Servant commands (ClientM).++This module allows you to act as a client of a Servant API, within a Polysemy 'Sem'.+Use the servant-client package to generate your clients, which return in the 'ClientM' monad.+You can then use 'runClient' (or 'runClientStreaming') to run your client in 'Sem', and 'runServantClient' (or 'runServantClientStreaming') to interpret the effect.++See <example/Client.hs> for a simple example that can interact with the example servers in the same directory.+-}+module Servant.Polysemy.Client+ (+ -- * Effects+ -- ** Non-Streaming+ ServantClient+ , runClient'+ , runClient++ -- ** Streaming+ , ServantClientStreaming+ , runClientStreaming++ -- * Interpreters+ -- ** Non-Streaming+ , runServantClientUrl+ , runServantClient++ -- ** Streaming+ , runServantClientStreamingUrl+ , runServantClientStreaming++ -- * Re-exported from Servant+ , ClientError+ ) where++import Control.DeepSeq (NFData)+import Control.Monad ((>=>))+import Network.HTTP.Client (newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Polysemy+import Polysemy.Cont+import Polysemy.Error+import Servant.Client.Streaming+ ( BaseUrl+ , ClientError+ , ClientM+ , mkClientEnv+ , parseBaseUrl+ , runClientM+ , withClientM+ )++-- | The 'ServantClient' effect allows you to run a 'ClientM' as automatically generated for your API by the servant-client package.+data ServantClient m a where+ RunClient' :: NFData o => ClientM o -> ServantClient m (Either ClientError o)++makeSem ''ServantClient++-- | Run this 'ClientM' in the 'Sem' monad.+runClient+ :: (Members '[ServantClient, Error ClientError] r, NFData o)+ => ClientM o -> Sem r o+runClient = runClient' >=> fromEither++-- | Interpret the 'ServantClient' effect by running any calls to 'RunClient'' against the given 'BaseUrl'.+runServantClientUrl+ :: Member (Embed IO) r+ => BaseUrl -> Sem (ServantClient ': r) a -> Sem r a+runServantClientUrl server m = do+ manager <- embed $ newManager tlsManagerSettings+ let env = mkClientEnv manager server+ interpret (\case+ RunClient' client ->+ embed $ runClientM client env+ ) m++-- | Parse the given string as a URL and then behave as 'runServantClientUrl' does.+runServantClient+ :: Member (Embed IO) r+ => String -> Sem (ServantClient ': r) a -> Sem r a+runServantClient server m = do+ server' <- embed $ parseBaseUrl server+ runServantClientUrl server' m++-- | The 'ServantClientStreaming' effect is just like the 'ServantClient' effect,+-- but allows streaming connections.+data ServantClientStreaming m a where+ RunClientStreaming :: ClientM o -> ServantClientStreaming m o++makeSem ''ServantClientStreaming++-- | Interpret the 'ServantClientStreaming' effect by running any calls to 'RunClientStreaming' against the given URL.+-- Note that this adds a 'Cont' effect, which you can interpret using 'runContM', probably just before your call to 'runM'.+runServantClientStreamingUrl+ :: Members+ '[ Cont ref+ , Embed IO+ , Error ClientError+ ] r+ => BaseUrl -> Sem (ServantClientStreaming ': r) a -> Sem r a+runServantClientStreamingUrl server m = do+ manager <- embed $ newManager tlsManagerSettings+ let env = mkClientEnv manager server+ interpret (\case+ RunClientStreaming client ->+ subst (\continue ->+ withLowerToIO $ \unliftIO _ ->+ withClientM client env (unliftIO . jump continue)+ ) fromEither+ ) m++-- | Parse the given string as a URL and then behave as 'runServantClientStreamingUrl'.+runServantClientStreaming+ :: Members+ '[ Cont ref+ , Embed IO+ , Error ClientError+ ] r+ => String -> Sem (ServantClientStreaming ': r) a -> Sem r a+runServantClientStreaming server m = do+ server' <- embed $ parseBaseUrl server+ runServantClientStreamingUrl server' m
+ src/Servant/Polysemy/Server.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-|+Module : Servant.Polysemy.Server+Copyright : (c) 2020 Alex Chapman+License : BSD3+Maintainer : alex@farfromthere.net+Stability : experimental+Portability : GHC+Description : Utilities for running a Servant server in a polysemy stack using Warp.++A simple usage scenario is that you create your API,+then implement a server for it in a 'ServerT api (Sem (Error ServerError ': r))' monad (where 'api' is your API type),+then run it with 'runWarpServer'.+See <example/Server.hs> for a trivial example of this.++If you need to take your Servant-Polysemy server and run it in an ordinary Servant server then you can use 'hoistServerIntoSem'.+This can be used to e.g. add Swagger docs to your server, as in <example/ServerWithSwagger.hs>.+-}+module Servant.Polysemy.Server+ (+ -- * Use ordinary Servant code in a Polysemy 'Sem'+ hoistServerIntoSem+ , liftHandler++ -- * Use Servant-Polysemy code in an ordinary Servant/WAI system+ , serveSem+ , semHandler++ -- * Use Warp to serve a Servant-Polysemy API in a 'Sem' stack.+ , runWarpServer+ , runWarpServerSettings++ -- * Redirect paths in a Servant-Polysemy API+ , Redirect+ , redirect+ ) where++import Control.Monad.Except (ExceptT(..))+import Data.Function ((&))+import Data.Proxy (Proxy(..))+import GHC.TypeLits (Nat)+import qualified Network.Wai.Handler.Warp as Warp+import Polysemy+import Polysemy.Error+import Servant+ ( Application+ , Handler(..)+ , HasServer+ , Header+ , Headers+ , JSON+ , NoContent(..)+ , Server+ , ServerError+ , ServerT+ , StdMethod(GET)+ , ToHttpApiData+ , Verb+ , addHeader+ , hoistServer+ , runHandler+ , serve+ )++-- | Make a Servant 'Handler' run in a Polysemy 'Sem' instead.+liftHandler :: Members '[Error ServerError, Embed IO] r => Handler a -> Sem r a+liftHandler handler =+ embed (runHandler handler) >>= fromEither++-- | Hoist an ordinary Servant 'Server' into a 'ServerT' whose monad is 'Sem',+-- so that it can be used with 'serveSem'.+hoistServerIntoSem+ :: forall api r+ . ( HasServer api '[]+ , Members '[Error ServerError, Embed IO] r+ )+ => Server api -> ServerT api (Sem r)+hoistServerIntoSem =+ hoistServer (Proxy @api) (liftHandler @r)++-- | Turn a 'Sem' that can throw 'ServerError's into a Servant 'Handler'.+semHandler+ :: (forall x. Sem r x -> IO x)+ -> Sem (Error ServerError ': r) a+ -> Handler a+semHandler lowerToIO =+ Handler . ExceptT . lowerToIO . runError++-- | Turn a 'ServerT' that contains a 'Sem' (as returned by 'hoistServerIntoSem') into a WAI 'Application'.+serveSem+ :: forall api r+ . HasServer api '[]+ => (forall x. Sem r x -> IO x)+ -> ServerT api (Sem (Error ServerError ': r))+ -> Application+serveSem lowerToIO m = let api = Proxy @api+ in serve api (hoistServer api (semHandler lowerToIO) m)++-- | Run the given server on the given port, possibly showing exceptions in the responses.+runWarpServer+ :: forall api r+ . ( HasServer api '[]+ , Member (Embed IO) r+ )+ => Warp.Port -- ^ The port to listen on, e.g. '8080'+ -> Bool -- ^ Whether to show exceptions in the http response (good for debugging but potentially a security risk)+ -> ServerT api (Sem (Error ServerError ': r)) -- ^ The server to run. You can create one of these with 'hoistServerIntoSem'.+ -> Sem r ()+runWarpServer port showExceptionResponse server =+ let warpSettings = Warp.defaultSettings+ & Warp.setPort port+ & if showExceptionResponse+ then Warp.setOnExceptionResponse Warp.exceptionResponseForDebug+ else id+ in+ runWarpServerSettings @api warpSettings server++-- | Run the given server with these Warp settings.+runWarpServerSettings+ :: forall api r+ . ( HasServer api '[]+ , Member (Embed IO) r+ )+ => Warp.Settings+ -> ServerT api (Sem (Error ServerError ': r))+ -> Sem r ()+runWarpServerSettings settings server = withLowerToIO $ \lowerToIO finished -> do+ Warp.runSettings settings (serveSem @api lowerToIO server)+ finished++-- | A redirect response with the given code, the new location given in the given type, e.g:+-- > Redirect 302 Text+-- This will return a '302 Found' response, and we will use 'Text' in the server to say where it will redirect to.+type Redirect (code :: Nat) loc+ = Verb 'GET code '[JSON] (Headers '[Header "Location" loc] NoContent)++-- | Serve a redirect response to the given location, e.g:+-- > redirect "/api/v1"+redirect :: ToHttpApiData a => a -> Sem r (Headers '[Header "Location" a] NoContent)+redirect a = pure $ addHeader a NoContent+