Skip to content

Commit b6c4ec2

Browse files
KleidukosDiamondy4
Kleidukos
and
Diamondy4
authored
Merge back Diamondy4 fork into mainline (#12)
* Support socket warp + middleware * Generic version * Expose Generic constraints * Fix lib version bounds * Add nix flake --------- Co-authored-by: Diamondy4 <diamondy4@hotmail.com>
1 parent 22af096 commit b6c4ec2

File tree

7 files changed

+248
-5
lines changed

7 files changed

+248
-5
lines changed

‎.envrc‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
use flake

‎.gitignore‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
11
dist-newstyle
22
.hie
33
.hspec-failures
4+
.direnv
5+
result

‎flake.lock‎

Lines changed: 73 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎flake.nix‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
{
2+
inputs = {
3+
nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
4+
haskell-flake.url = "github:srid/haskell-flake";
5+
};
6+
7+
outputs = inputs @ {
8+
self,
9+
flake-parts,
10+
nixpkgs,
11+
...
12+
}:
13+
flake-parts.lib.mkFlake {inherit inputs;} {
14+
systems = inputs.nixpkgs.lib.systems.flakeExposed;
15+
imports = [inputs.haskell-flake.flakeModule];
16+
perSystem = {...}: {
17+
haskellProjects.default = {};
18+
};
19+
};
20+
}

‎servant-effectful.cabal‎

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -51,13 +51,18 @@ library
5151
import: common-extensions
5252
import: common-ghc-options
5353
hs-source-dirs: src
54-
exposed-modules: Effectful.Servant
54+
exposed-modules:
55+
Effectful.Servant
56+
Effectful.Servant.Generic
57+
5558
build-depends:
5659
, base <5
57-
, effectful-core >=2.3
60+
, effectful-core >=2 && <3
5861
, mtl >=2
62+
, network >=2.3
5963
, servant-server ^>=0.20
60-
, warp >=3.3
64+
, wai ^>=3.3
65+
, warp ^>=3.5
6166

6267
test-suite servant-effectful-test
6368
import: common-extensions
@@ -67,6 +72,7 @@ test-suite servant-effectful-test
6772
main-is: Main.hs
6873
other-modules: Utils
6974
hs-source-dirs: test
75+
buildable: False
7076
build-depends:
7177
, base
7278
, effectful-core

‎src/Effectful/Servant.hs‎

Lines changed: 40 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,8 @@ module Effectful.Servant
66
( -- * main api
77
runWarpServerSettings
88
, runWarpServerSettingsContext
9+
, runWarpServerSettingsSocket
10+
, runWarpServerSettingsSocketContext
911

1012
-- * helpers
1113
, serveEff
@@ -19,6 +21,8 @@ import Effectful
1921
import Effectful.Dispatch.Static
2022
import Effectful.Dispatch.Static.Primitive (Env, cloneEnv)
2123
import Effectful.Error.Static
24+
import qualified Network.Socket as Network
25+
import qualified Network.Wai as Wai
2226
import qualified Network.Wai.Handler.Warp as Warp
2327
import Servant hiding ((:>))
2428

@@ -28,9 +32,11 @@ runWarpServerSettings
2832
. (HasServer api '[], IOE :> es)
2933
=> Warp.Settings
3034
-> ServerT api (Eff (Error ServerError : es))
35+
-> Wai.Middleware
3136
-> Eff es ()
3237
runWarpServerSettings settings =
3338
runWarpServerSettingsContext @api settings EmptyContext
39+
{-# INLINEABLE runWarpServerSettings #-}
3440

3541
-- | Deploy an effectful server with a context.
3642
runWarpServerSettingsContext
@@ -39,10 +45,40 @@ runWarpServerSettingsContext
3945
=> Warp.Settings
4046
-> Context context
4147
-> ServerT api (Eff (Error ServerError : es))
48+
-> Wai.Middleware
4249
-> Eff es ()
43-
runWarpServerSettingsContext settings ctx server = do
50+
runWarpServerSettingsContext settings ctx server middleware = do
4451
unsafeEff $ \es -> do
45-
Warp.runSettings settings (serveEff @api es ctx server)
52+
Warp.runSettings settings (middleware $ serveEff @api es ctx server)
53+
{-# INLINEABLE runWarpServerSettingsContext #-}
54+
55+
-- | Deploy an effectful server on socket.
56+
runWarpServerSettingsSocket
57+
:: forall (api :: Type) (es :: [Effect])
58+
. (HasServer api '[], IOE :> es)
59+
=> Warp.Settings
60+
-> Network.Socket
61+
-> ServerT api (Eff (Error ServerError : es))
62+
-> Wai.Middleware
63+
-> Eff es ()
64+
runWarpServerSettingsSocket settings socket =
65+
runWarpServerSettingsSocketContext @api settings socket EmptyContext
66+
{-# INLINEABLE runWarpServerSettingsSocket #-}
67+
68+
-- | Deploy an effectful server on socket with a context.
69+
runWarpServerSettingsSocketContext
70+
:: forall (api :: Type) (context :: [Type]) (es :: [Effect])
71+
. (HasServer api context, ServerContext context, IOE :> es)
72+
=> Warp.Settings
73+
-> Network.Socket
74+
-> Context context
75+
-> ServerT api (Eff (Error ServerError : es))
76+
-> Wai.Middleware
77+
-> Eff es ()
78+
runWarpServerSettingsSocketContext settings socket ctx server middleware = do
79+
unsafeEff $ \es -> do
80+
Warp.runSettingsSocket settings socket (middleware $ serveEff @api es ctx server)
81+
{-# INLINEABLE runWarpServerSettingsSocketContext #-}
4682

4783
-- | Convert an effectful server into a wai application.
4884
serveEff
@@ -53,6 +89,7 @@ serveEff
5389
-> ServerT api (Eff (Error ServerError : es))
5490
-> Application
5591
serveEff env ctx = Servant.serveWithContextT (Proxy @api) ctx (interpretServer env)
92+
{-# INLINEABLE serveEff #-}
5693

5794
-- | Transform the Eff monad into a servant Handler.
5895
interpretServer :: Env es -> Eff (Error ServerError : es) a -> Servant.Handler a
@@ -61,3 +98,4 @@ interpretServer env action = do
6198
es' <- cloneEnv env
6299
unEff (runErrorNoCallStack action) es'
63100
T.liftEither v
101+
{-# INLINEABLE interpretServer #-}

‎src/Effectful/Servant/Generic.hs‎

Lines changed: 103 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,103 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
-- Allow redendudant constraints to require IOE for runWarp helpers.
3+
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
4+
5+
module Effectful.Servant.Generic
6+
( -- * main api
7+
runWarpServerSettings
8+
, runWarpServerSettingsContext
9+
, runWarpServerSettingsSocket
10+
, runWarpServerSettingsSocketContext
11+
12+
-- * helpers
13+
, serveEff
14+
15+
-- * types
16+
, GenericServantConstraints
17+
)
18+
where
19+
20+
import Data.Kind (Type)
21+
import Effectful
22+
import Effectful.Dispatch.Static
23+
import Effectful.Dispatch.Static.Primitive (Env)
24+
import Effectful.Error.Static
25+
import Effectful.Servant (interpretServer)
26+
import qualified Network.Socket as Network
27+
import qualified Network.Wai as Wai
28+
import qualified Network.Wai.Handler.Warp as Warp
29+
import Servant hiding ((:>))
30+
import Servant.Server.Generic
31+
32+
-- | Deploy an effectful server.
33+
runWarpServerSettings
34+
:: forall routes (es :: [Effect])
35+
. (GenericServantConstraints routes '[] (Eff (Error ServerError : es)))
36+
=> Warp.Settings
37+
-> routes (AsServerT (Eff (Error ServerError : es)))
38+
-> Wai.Middleware
39+
-> Eff es ()
40+
runWarpServerSettings settings = runWarpServerSettingsContext settings EmptyContext
41+
{-# INLINEABLE runWarpServerSettings #-}
42+
43+
-- | Deploy an effectful server with a context.
44+
runWarpServerSettingsContext
45+
:: forall routes (context :: [Type]) (es :: [Effect])
46+
. (GenericServantConstraints routes context (Eff (Error ServerError : es)))
47+
=> Warp.Settings
48+
-> Context context
49+
-> routes (AsServerT (Eff (Error ServerError : es)))
50+
-> Wai.Middleware
51+
-> Eff es ()
52+
runWarpServerSettingsContext settings ctx routes middleware = do
53+
unsafeEff $ \es -> do
54+
Warp.runSettings settings (middleware $ serveEff es routes ctx)
55+
{-# INLINEABLE runWarpServerSettingsContext #-}
56+
57+
-- | Deploy an effectful server on socket.
58+
runWarpServerSettingsSocket
59+
:: forall routes (es :: [Effect])
60+
. (GenericServantConstraints routes '[] (Eff (Error ServerError : es)))
61+
=> Warp.Settings
62+
-> Network.Socket
63+
-> routes (AsServerT (Eff (Error ServerError : es)))
64+
-> Wai.Middleware
65+
-> Eff es ()
66+
runWarpServerSettingsSocket settings socket routes =
67+
runWarpServerSettingsSocketContext settings socket routes EmptyContext
68+
{-# INLINEABLE runWarpServerSettingsSocket #-}
69+
70+
-- | Deploy an effectful server on socket with a context.
71+
runWarpServerSettingsSocketContext
72+
:: forall routes (context :: [Type]) (es :: [Effect])
73+
. (GenericServantConstraints routes context (Eff (Error ServerError : es)))
74+
=> Warp.Settings
75+
-> Network.Socket
76+
-> routes (AsServerT (Eff (Error ServerError : es)))
77+
-> Context context
78+
-> Wai.Middleware
79+
-> Eff es ()
80+
runWarpServerSettingsSocketContext settings socket routes ctx middleware = do
81+
unsafeEff $ \es -> do
82+
Warp.runSettingsSocket settings socket (middleware $ serveEff es routes ctx)
83+
{-# INLINEABLE runWarpServerSettingsSocketContext #-}
84+
85+
-- | Convert an effectful server into a wai application.
86+
serveEff
87+
:: forall routes (context :: [Type]) (es :: [Effect])
88+
. (GenericServantConstraints routes context (Eff (Error ServerError : es)))
89+
=> Env es
90+
-> routes (AsServerT (Eff (Error ServerError : es)))
91+
-> Context context
92+
-- -> ServerT api ()
93+
-> Application
94+
serveEff env = genericServeTWithContext (interpretServer env)
95+
{-# INLINEABLE serveEff #-}
96+
97+
type GenericServantConstraints routes ctx m =
98+
( GenericServant routes (AsServerT m)
99+
, GenericServant routes AsApi
100+
, HasServer (ToServantApi routes) ctx
101+
, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters
102+
, ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)
103+
)

0 commit comments

Comments
 (0)