git.iko.soy/typeable/servant
on master help sign in
WIP
ae75b54Gaël Deest
nix/nixpkgs.json+2−2
compare with master
unifiedsplit
@@ -1,4 +1,4 @@
1{
1{
2− "rev" : "05f0934825c2a0750d4888c4735f9420c906b388",
2+ "rev": "0f316e4d72daed659233817ffe52bf08e081b5de",
3− "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy"
3+ "sha256": "0vh0fk5is5s9l0lxpi16aabv2kk1fwklr7szy731kfcz9gdrr65l"
4}
4}
nix/nixpkgs.nix+7−4
@@ -1,4 +1,7 @@
1+let nixpkgsSnapshot =
2+ builtins.fromJSON (builtins.readFile ./nixpkgs.json); in
1−import (builtins.fetchTarball {
3+import (builtins.fetchTarball
2− url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz";
4+ { url = "https://github.com/NixOS/nixpkgs/tarball/${nixpkgsSnapshot.rev}";
3− sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36";
5+ sha256 = nixpkgsSnapshot.sha256;
4−}) {}
6+ })
7+ {}
nix/shell.nix+1−1
@@ -1,4 +1,4 @@
1−{ compiler ? "ghc8104"
1+{ compiler ? "ghc901"
2, tutorial ? false
2, tutorial ? false
3, pkgs ? import ./nixpkgs.nix
3, pkgs ? import ./nixpkgs.nix
4}:
4}:
servant-server/src/Servant/Server/Internal.hs+116−19
@@ -31,6 +31,12 @@ module Servant.Server.Internal
31 , module Servant.Server.Internal.ServerError
31 , module Servant.Server.Internal.ServerError
32 ) where
32 ) where
33
33
34+import Data.Proxy (Proxy (Proxy))
35+import Data.SOP (I (I))
36+import Data.SOP.Constraint (All, And)
37+import Data.String.Conversions (LBS, cs)
38+import Network.HTTP.Types (Status, HeaderName, hContentType)
39+
34import Control.Monad
40import Control.Monad
35 (join, when)
41 (join, when)
36import Control.Monad.Trans
42import Control.Monad.Trans
@@ -76,7 +82,9 @@ import Servant.API
76 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
82 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
77 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
83 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
78 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
84 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
79− WithNamedContext, NamedRoutes)
85+ WithNamedContext, NamedRoutes, UVerb, WithStatus(..))
86+
87+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
80import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
88import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
81import Servant.API.ContentTypes
89import Servant.API.ContentTypes
82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
90 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@@ -88,7 +96,7 @@ import Servant.API.Modifiers
88import Servant.API.ResponseHeaders
96import Servant.API.ResponseHeaders
89 (GetHeaders, Headers, getHeaders, getResponse)
97 (GetHeaders, Headers, getHeaders, getResponse)
90import Servant.API.Status
98import Servant.API.Status
91− (statusFromNat)
99+ (statusFromNat, KnownStatus)
92import qualified Servant.Types.SourceT as S
100import qualified Servant.Types.SourceT as S
93import Servant.API.TypeErrors
101import Servant.API.TypeErrors
94import Web.HttpApiData
102import Web.HttpApiData
@@ -292,28 +300,36 @@ noContentRouter method status action = leafRouter route'
292 env request respond $ \ _output ->
300 env request respond $ \ _output ->
293 Route $ responseLBS status [] ""
301 Route $ responseLBS status [] ""
294
302
295−instance {-# OVERLAPPABLE #-}
303+-- instance {-# OVERLAPPABLE #-}
296− ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
304+-- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
297− ) => HasServer (Verb method status ctypes a) context where
305+-- ) => HasServer (Verb method status ctypes a) context where
298
306
299− type ServerT (Verb method status ctypes a) m = m a
307+-- type ServerT (Verb method status ctypes a) m = m a
300− hoistServerWithContext _ _ nt s = nt s
308+-- hoistServerWithContext _ _ nt s = nt s
301
309
302− route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
310+-- route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
303− where method = reflectMethod (Proxy :: Proxy method)
311+-- where method = reflectMethod (Proxy :: Proxy method)
304− status = statusFromNat (Proxy :: Proxy status)
312+-- status = statusFromNat (Proxy :: Proxy status)
305
313
306−instance {-# OVERLAPPING #-}
314+-- instance {-# OVERLAPPING #-}
307− ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
315+-- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
308− , GetHeaders (Headers h a)
316+-- , GetHeaders (Headers h a)
309− ) => HasServer (Verb method status ctypes (Headers h a)) context where
317+-- ) => HasServer (Verb method status ctypes (Headers h a)) context where
310
318
311− type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
319+-- type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
312− hoistServerWithContext _ _ nt s = nt s
320+-- hoistServerWithContext _ _ nt s = nt s
313
321
314− route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
322+-- route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
315− where method = reflectMethod (Proxy :: Proxy method)
323+-- where method = reflectMethod (Proxy :: Proxy method)
316− status = statusFromNat (Proxy :: Proxy status)
324+-- status = statusFromNat (Proxy :: Proxy status)
325+
326+instance
327+ (KnownStatus statusCode, HasServer (UVerb method ctypes '[WithStatus statusCode a]) context) =>
328+ HasServer (Verb method statusCode ctypes a) context where
329+
330+ type ServerT (Verb method statusCode ctypes a) m = m a
331+ route = undefined
332+ hoistServerWithContext p1 p2 nat s = undefined
317
333
318instance (ReflectMethod method) =>
334instance (ReflectMethod method) =>
319 HasServer (NoContentVerb method) context where
335 HasServer (NoContentVerb method) context where
@@ -957,3 +973,84 @@ instance
957 toServant server
973 toServant server
958 servantSrvN :: ServerT (ToServantApi api) n =
974 servantSrvN :: ServerT (ToServantApi api) n =
959 hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
975 hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
976+
977+
978+
979+-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
980+-- and will construct a union value in an 'Applicative' (eg. 'Server').
981+respond ::
982+ forall (x :: *) (xs :: [*]) (f :: * -> *).
983+ (Applicative f, HasStatus x, IsMember x xs) =>
984+ x ->
985+ f (Union xs)
986+respond = pure . inject . I
987+
988+class IsServerResource (cts :: [*]) a where
989+ resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
990+ resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
991+
992+instance {-# OVERLAPPABLE #-} AllCTRender cts a
993+ => IsServerResource cts a where
994+ resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
995+ resourceHeaders _ _ = []
996+
997+instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
998+ => IsServerResource cts (Headers h a) where
999+ resourceResponse request p res = resourceResponse request p (getResponse res)
1000+ resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
1001+
1002+instance {-# OVERLAPPING #-} IsServerResource cts a
1003+ => IsServerResource cts (WithStatus n a) where
1004+ resourceResponse request p (WithStatus x) = resourceResponse request p x
1005+ resourceHeaders cts (WithStatus x) = resourceHeaders cts x
1006+
1007+encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
1008+ => Request -> Proxy cts -> a
1009+ -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
1010+encodeResource request cts res = (statusOf (Proxy @a),
1011+ resourceResponse request cts res,
1012+ resourceHeaders cts res)
1013+
1014+type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
1015+
1016+instance
1017+ ( ReflectMethod method,
1018+ AllMime contentTypes,
1019+ All (IsServerResourceWithStatus contentTypes) as,
1020+ Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
1021+ -- without; client is a bit of a corner case, because it dispatches
1022+ -- the parser based on the status code. with this uniqueness
1023+ -- constraint it won't have to run more than one parser in weird
1024+ -- corner cases.
1025+ ) =>
1026+ HasServer (UVerb method contentTypes as) context
1027+ where
1028+ type ServerT (UVerb method contentTypes as) m = m (Union as)
1029+
1030+ hoistServerWithContext _ _ nt s = nt s
1031+
1032+ route ::
1033+ forall env.
1034+ Proxy (UVerb method contentTypes as) ->
1035+ Context context ->
1036+ Delayed env (Server (UVerb method contentTypes as)) ->
1037+ Router env
1038+ route _proxy _ctx action = leafRouter route'
1039+ where
1040+ method = reflectMethod (Proxy @method)
1041+ route' env request cont = do
1042+ let action' :: Delayed env (Handler (Union as))
1043+ action' =
1044+ action
1045+ `addMethodCheck` methodCheck method request
1046+ `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
1047+
1048+ runAction action' env request cont $ \(output :: Union as) -> do
1049+ let cts = Proxy @contentTypes
1050+ pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
1051+ pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
1052+ case pickResource output of
1053+ (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
1054+ (status, Just (contentT, body), headers) ->
1055+ let bdy = if allowedMethodHead method request then "" else body
1056+ in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
servant-server/src/Servant/Server/UVerb.hs+80−80
@@ -22,95 +22,95 @@ module Servant.Server.UVerb
22 )
22 )
23where
23where
24
24
25−import qualified Data.ByteString as B
25+-- import qualified Data.ByteString as B
26−import Data.Proxy (Proxy (Proxy))
26+-- import Data.Proxy (Proxy (Proxy))
27−import Data.SOP (I (I))
27+-- import Data.SOP (I (I))
28−import Data.SOP.Constraint (All, And)
28+-- import Data.SOP.Constraint (All, And)
29−import Data.String.Conversions (LBS, cs)
29+-- import Data.String.Conversions (LBS, cs)
30−import Network.HTTP.Types (Status, HeaderName, hContentType)
30+-- import Network.HTTP.Types (Status, HeaderName, hContentType)
31−import Network.Wai (responseLBS, Request)
31+-- import Network.Wai (responseLBS, Request)
32−import Servant.API (ReflectMethod, reflectMethod)
32+-- import Servant.API (ReflectMethod, reflectMethod)
33−import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
33+-- import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
34−import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
34+-- import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
35−import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
35+-- import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
36−import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)
36+import Servant.Server.Internal (respond, IsServerResource)
37
37
38
38
39−-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
39+-- -- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
40−-- and will construct a union value in an 'Applicative' (eg. 'Server').
40+-- -- and will construct a union value in an 'Applicative' (eg. 'Server').
41−respond ::
41+-- respond ::
42− forall (x :: *) (xs :: [*]) (f :: * -> *).
42+-- forall (x :: *) (xs :: [*]) (f :: * -> *).
43− (Applicative f, HasStatus x, IsMember x xs) =>
43+-- (Applicative f, HasStatus x, IsMember x xs) =>
44− x ->
44+-- x ->
45− f (Union xs)
45+-- f (Union xs)
46−respond = pure . inject . I
46+-- respond = pure . inject . I
47
47
48−class IsServerResource (cts :: [*]) a where
48+-- class IsServerResource (cts :: [*]) a where
49− resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
49+-- resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
50− resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
50+-- resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
51
51
52−instance {-# OVERLAPPABLE #-} AllCTRender cts a
52+-- instance {-# OVERLAPPABLE #-} AllCTRender cts a
53− => IsServerResource cts a where
53+-- => IsServerResource cts a where
54− resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
54+-- resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
55− resourceHeaders _ _ = []
55+-- resourceHeaders _ _ = []
56
56
57−instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
57+-- instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
58− => IsServerResource cts (Headers h a) where
58+-- => IsServerResource cts (Headers h a) where
59− resourceResponse request p res = resourceResponse request p (getResponse res)
59+-- resourceResponse request p res = resourceResponse request p (getResponse res)
60− resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
60+-- resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
61
61
62−instance {-# OVERLAPPING #-} IsServerResource cts a
62+-- instance {-# OVERLAPPING #-} IsServerResource cts a
63− => IsServerResource cts (WithStatus n a) where
63+-- => IsServerResource cts (WithStatus n a) where
64− resourceResponse request p (WithStatus x) = resourceResponse request p x
64+-- resourceResponse request p (WithStatus x) = resourceResponse request p x
65− resourceHeaders cts (WithStatus x) = resourceHeaders cts x
65+-- resourceHeaders cts (WithStatus x) = resourceHeaders cts x
66
66
67−encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
67+-- encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
68− => Request -> Proxy cts -> a
68+-- => Request -> Proxy cts -> a
69− -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
69+-- -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
70−encodeResource request cts res = (statusOf (Proxy @a),
70+-- encodeResource request cts res = (statusOf (Proxy @a),
71− resourceResponse request cts res,
71+-- resourceResponse request cts res,
72− resourceHeaders cts res)
72+-- resourceHeaders cts res)
73
73
74−type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
74+-- type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
75
75
76−instance
76+-- instance
77− ( ReflectMethod method,
77+-- ( ReflectMethod method,
78− AllMime contentTypes,
78+-- AllMime contentTypes,
79− All (IsServerResourceWithStatus contentTypes) as,
79+-- All (IsServerResourceWithStatus contentTypes) as,
80− Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
80+-- Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
81− -- without; client is a bit of a corner case, because it dispatches
81+-- -- without; client is a bit of a corner case, because it dispatches
82− -- the parser based on the status code. with this uniqueness
82+-- -- the parser based on the status code. with this uniqueness
83− -- constraint it won't have to run more than one parser in weird
83+-- -- constraint it won't have to run more than one parser in weird
84− -- corner cases.
84+-- -- corner cases.
85− ) =>
85+-- ) =>
86− HasServer (UVerb method contentTypes as) context
86+-- HasServer (UVerb method contentTypes as) context
87− where
87+-- where
88− type ServerT (UVerb method contentTypes as) m = m (Union as)
88+-- type ServerT (UVerb method contentTypes as) m = m (Union as)
89
89
90− hoistServerWithContext _ _ nt s = nt s
90+-- hoistServerWithContext _ _ nt s = nt s
91
91
92− route ::
92+-- route ::
93− forall env.
93+-- forall env.
94− Proxy (UVerb method contentTypes as) ->
94+-- Proxy (UVerb method contentTypes as) ->
95− Context context ->
95+-- Context context ->
96− Delayed env (Server (UVerb method contentTypes as)) ->
96+-- Delayed env (Server (UVerb method contentTypes as)) ->
97− Router env
97+-- Router env
98− route _proxy _ctx action = leafRouter route'
98+-- route _proxy _ctx action = leafRouter route'
99− where
99+-- where
100− method = reflectMethod (Proxy @method)
100+-- method = reflectMethod (Proxy @method)
101− route' env request cont = do
101+-- route' env request cont = do
102− let action' :: Delayed env (Handler (Union as))
102+-- let action' :: Delayed env (Handler (Union as))
103− action' =
103+-- action' =
104− action
104+-- action
105− `addMethodCheck` methodCheck method request
105+-- `addMethodCheck` methodCheck method request
106− `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
106+-- `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
107
107
108− runAction action' env request cont $ \(output :: Union as) -> do
108+-- runAction action' env request cont $ \(output :: Union as) -> do
109− let cts = Proxy @contentTypes
109+-- let cts = Proxy @contentTypes
110− pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
110+-- pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
111− pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
111+-- pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
112− case pickResource output of
112+-- case pickResource output of
113− (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
113+-- (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
114− (status, Just (contentT, body), headers) ->
114+-- (status, Just (contentT, body), headers) ->
115− let bdy = if allowedMethodHead method request then "" else body
115+-- let bdy = if allowedMethodHead method request then "" else body
116− in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
116+-- in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy