staticvoid
/
4r
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
4r/nix/patches/servant-polysemy/1.patch

251 lines
8.5 KiB
Diff
Raw Blame History

From e399e9cc158bc4e846d708779b9ef283ff9ee7ca Mon Sep 17 00:00:00 2001
From: staticvoid <staticvoid@mail.i2p>
Date: Tue, 21 Jun 2022 16:05:59 +0300
Subject: [PATCH 1/2] Remove Server and examples
---
servant-polysemy.cabal | 59 -------------
src/Servant/Polysemy/Server.hs | 149 ---------------------------------
2 files changed, 208 deletions(-)
delete mode 100644 src/Servant/Polysemy/Server.hs
diff --git a/servant-polysemy.cabal b/servant-polysemy.cabal
index df6012e..1a0066a 100644
--- a/servant-polysemy.cabal
+++ b/servant-polysemy.cabal
@@ -28,14 +28,10 @@ common deps
, 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 && < 1.6
, polysemy-plugin >= 0.2.4.0 && < 0.4
, 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
@@ -64,61 +60,6 @@ library
hs-source-dirs: src
default-language: Haskell2010
exposed-modules: Servant.Polysemy.Client
- Servant.Polysemy.Server
-
-executable example-server
- import: deps
- main-is: Server.hs
- autogen-modules: Paths_servant_polysemy
- other-modules: Paths_servant_polysemy
- hs-source-dirs: example
- default-language: Haskell2010
- ghc-options: -threaded
- -rtsopts
- -with-rtsopts=-N
- build-depends: servant-polysemy
- , lens
-
-executable example-server-generic
- import: deps
- main-is: ServerGeneric.hs
- autogen-modules: Paths_servant_polysemy
- other-modules: Paths_servant_polysemy
- hs-source-dirs: example
- default-language: Haskell2010
- ghc-options: -threaded
- -rtsopts
- -with-rtsopts=-N
- build-depends: servant-polysemy
- , lens
- , servant
-
-executable example-server-with-swagger
- import: deps
- main-is: ServerWithSwagger.hs
- autogen-modules: Paths_servant_polysemy
- other-modules: Paths_servant_polysemy
- 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
diff --git a/src/Servant/Polysemy/Server.hs b/src/Servant/Polysemy/Server.hs
deleted file mode 100644
index cfa0d41..0000000
--- a/src/Servant/Polysemy/Server.hs
+++ /dev/null
@@ -1,149 +0,0 @@
-{-# 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
-
--
2.36.0
Reference in New Issue View Git Blame Copy Permalink