eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

WIP

Browse source
This commit is contained in:
Gaël Deest 2022-02-03 13:45:56 +01:00
parent 6f12e38698
commit ae75b54589
5 changed files with 206 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
nix/nixpkgs.json
View file

@ -1,4 +1,4 @@
{ {
"rev" : "05f0934825c2a0750d4888c4735f9420c906b388", "rev": "0f316e4d72daed659233817ffe52bf08e081b5de",
"sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy" "sha256": "0vh0fk5is5s9l0lxpi16aabv2kk1fwklr7szy731kfcz9gdrr65l"
} }

11
nix/nixpkgs.nix
View file

@ -1,4 +1,7 @@
import (builtins.fetchTarball { let nixpkgsSnapshot =
url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz"; builtins.fromJSON (builtins.readFile ./nixpkgs.json); in
sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36"; import (builtins.fetchTarball
}) {} { url = "https://github.com/NixOS/nixpkgs/tarball/${nixpkgsSnapshot.rev}";
sha256 = nixpkgsSnapshot.sha256;
})
{}

2
nix/shell.nix
View file

@ -1,4 +1,4 @@
{ compiler ? "ghc8104" { compiler ? "ghc901"
, tutorial ? false , tutorial ? false
, pkgs ? import ./nixpkgs.nix , pkgs ? import ./nixpkgs.nix
}: }:

135
servant-server/src/Servant/Server/Internal.hs
View file

@ -31,6 +31,12 @@ module Servant.Server.Internal
, module Servant.Server.Internal.ServerError , module Servant.Server.Internal.ServerError
) where ) where
import Data.Proxy (Proxy (Proxy))
import Data.SOP (I (I))
import Data.SOP.Constraint (All, And)
import Data.String.Conversions (LBS, cs)
import Network.HTTP.Types (Status, HeaderName, hContentType)
import Control.Monad import Control.Monad
(join, when) (join, when)
import Control.Monad.Trans import Control.Monad.Trans
@ -76,7 +82,9 @@ import Servant.API
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
WithNamedContext, NamedRoutes) WithNamedContext, NamedRoutes, UVerb, WithStatus(..))
import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
import Servant.API.ContentTypes import Servant.API.ContentTypes
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@ -88,7 +96,7 @@ import Servant.API.Modifiers
import Servant.API.ResponseHeaders import Servant.API.ResponseHeaders
(GetHeaders, Headers, getHeaders, getResponse) (GetHeaders, Headers, getHeaders, getResponse)
import Servant.API.Status import Servant.API.Status
(statusFromNat) (statusFromNat, KnownStatus)
import qualified Servant.Types.SourceT as S import qualified Servant.Types.SourceT as S
import Servant.API.TypeErrors import Servant.API.TypeErrors
import Web.HttpApiData import Web.HttpApiData
@ -292,28 +300,36 @@ noContentRouter method status action = leafRouter route'
env request respond $ \ _output -> env request respond $ \ _output ->
Route $ responseLBS status [] "" Route $ responseLBS status [] ""
instance {-# OVERLAPPABLE #-} -- instance {-# OVERLAPPABLE #-}
( AllCTRender ctypes a, ReflectMethod method, KnownNat status -- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
) => HasServer (Verb method status ctypes a) context where -- ) => HasServer (Verb method status ctypes a) context where
type ServerT (Verb method status ctypes a) m = m a -- type ServerT (Verb method status ctypes a) m = m a
hoistServerWithContext _ _ nt s = nt s -- hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status -- route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) -- where method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status) -- status = statusFromNat (Proxy :: Proxy status)
instance {-# OVERLAPPING #-} -- instance {-# OVERLAPPING #-}
( AllCTRender ctypes a, ReflectMethod method, KnownNat status -- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
, GetHeaders (Headers h a) -- , GetHeaders (Headers h a)
) => HasServer (Verb method status ctypes (Headers h a)) context where -- ) => HasServer (Verb method status ctypes (Headers h a)) context where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) -- type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
hoistServerWithContext _ _ nt s = nt s -- hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status -- route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) -- where method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status) -- status = statusFromNat (Proxy :: Proxy status)
instance
(KnownStatus statusCode, HasServer (UVerb method ctypes '[WithStatus statusCode a]) context) =>
HasServer (Verb method statusCode ctypes a) context where
type ServerT (Verb method statusCode ctypes a) m = m a
route = undefined
hoistServerWithContext p1 p2 nat s = undefined
instance (ReflectMethod method) => instance (ReflectMethod method) =>
HasServer (NoContentVerb method) context where HasServer (NoContentVerb method) context where
@ -957,3 +973,84 @@ instance
toServant server toServant server
servantSrvN :: ServerT (ToServantApi api) n = servantSrvN :: ServerT (ToServantApi api) n =
hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
-- and will construct a union value in an 'Applicative' (eg. 'Server').
respond ::
forall (x :: *) (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x ->
f (Union xs)
respond = pure . inject . I
class IsServerResource (cts :: [*]) a where
resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
instance {-# OVERLAPPABLE #-} AllCTRender cts a
=> IsServerResource cts a where
resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
resourceHeaders _ _ = []
instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
=> IsServerResource cts (Headers h a) where
resourceResponse request p res = resourceResponse request p (getResponse res)
resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
instance {-# OVERLAPPING #-} IsServerResource cts a
=> IsServerResource cts (WithStatus n a) where
resourceResponse request p (WithStatus x) = resourceResponse request p x
resourceHeaders cts (WithStatus x) = resourceHeaders cts x
encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
=> Request -> Proxy cts -> a
-> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
encodeResource request cts res = (statusOf (Proxy @a),
resourceResponse request cts res,
resourceHeaders cts res)
type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
instance
( ReflectMethod method,
AllMime contentTypes,
All (IsServerResourceWithStatus contentTypes) as,
Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
-- without; client is a bit of a corner case, because it dispatches
-- the parser based on the status code. with this uniqueness
-- constraint it won't have to run more than one parser in weird
-- corner cases.
) =>
HasServer (UVerb method contentTypes as) context
where
type ServerT (UVerb method contentTypes as) m = m (Union as)
hoistServerWithContext _ _ nt s = nt s
route ::
forall env.
Proxy (UVerb method contentTypes as) ->
Context context ->
Delayed env (Server (UVerb method contentTypes as)) ->
Router env
route _proxy _ctx action = leafRouter route'
where
method = reflectMethod (Proxy @method)
route' env request cont = do
let action' :: Delayed env (Handler (Union as))
action' =
action
`addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
runAction action' env request cont $ \(output :: Union as) -> do
let cts = Proxy @contentTypes
pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
case pickResource output of
(_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
(status, Just (contentT, body), headers) ->
let bdy = if allowedMethodHead method request then "" else body
in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

160
servant-server/src/Servant/Server/UVerb.hs
View file

@ -22,95 +22,95 @@ module Servant.Server.UVerb
) )
where where
import qualified Data.ByteString as B -- import qualified Data.ByteString as B
import Data.Proxy (Proxy (Proxy)) -- import Data.Proxy (Proxy (Proxy))
import Data.SOP (I (I)) -- import Data.SOP (I (I))
import Data.SOP.Constraint (All, And) -- import Data.SOP.Constraint (All, And)
import Data.String.Conversions (LBS, cs) -- import Data.String.Conversions (LBS, cs)
import Network.HTTP.Types (Status, HeaderName, hContentType) -- import Network.HTTP.Types (Status, HeaderName, hContentType)
import Network.Wai (responseLBS, Request) -- import Network.Wai (responseLBS, Request)
import Servant.API (ReflectMethod, reflectMethod) -- import Servant.API (ReflectMethod, reflectMethod)
import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime) -- import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..)) -- import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf) -- import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction) import Servant.Server.Internal (respond, IsServerResource)
-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union, -- -- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
-- and will construct a union value in an 'Applicative' (eg. 'Server'). -- -- and will construct a union value in an 'Applicative' (eg. 'Server').
respond :: -- respond ::
forall (x :: *) (xs :: [*]) (f :: * -> *). -- forall (x :: *) (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) => -- (Applicative f, HasStatus x, IsMember x xs) =>
x -> -- x ->
f (Union xs) -- f (Union xs)
respond = pure . inject . I -- respond = pure . inject . I
class IsServerResource (cts :: [*]) a where -- class IsServerResource (cts :: [*]) a where
resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS) -- resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)] -- resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
instance {-# OVERLAPPABLE #-} AllCTRender cts a -- instance {-# OVERLAPPABLE #-} AllCTRender cts a
=> IsServerResource cts a where -- => IsServerResource cts a where
resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res -- resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
resourceHeaders _ _ = [] -- resourceHeaders _ _ = []
instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a)) -- instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
=> IsServerResource cts (Headers h a) where -- => IsServerResource cts (Headers h a) where
resourceResponse request p res = resourceResponse request p (getResponse res) -- resourceResponse request p res = resourceResponse request p (getResponse res)
resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res) -- resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
instance {-# OVERLAPPING #-} IsServerResource cts a -- instance {-# OVERLAPPING #-} IsServerResource cts a
=> IsServerResource cts (WithStatus n a) where -- => IsServerResource cts (WithStatus n a) where
resourceResponse request p (WithStatus x) = resourceResponse request p x -- resourceResponse request p (WithStatus x) = resourceResponse request p x
resourceHeaders cts (WithStatus x) = resourceHeaders cts x -- resourceHeaders cts (WithStatus x) = resourceHeaders cts x
encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a) -- encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
=> Request -> Proxy cts -> a -- => Request -> Proxy cts -> a
-> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)]) -- -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
encodeResource request cts res = (statusOf (Proxy @a), -- encodeResource request cts res = (statusOf (Proxy @a),
resourceResponse request cts res, -- resourceResponse request cts res,
resourceHeaders cts res) -- resourceHeaders cts res)
type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus -- type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
instance -- instance
( ReflectMethod method, -- ( ReflectMethod method,
AllMime contentTypes, -- AllMime contentTypes,
All (IsServerResourceWithStatus contentTypes) as, -- All (IsServerResourceWithStatus contentTypes) as,
Unique (Statuses as) -- for consistency with servant-swagger (server would work fine -- Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
-- without; client is a bit of a corner case, because it dispatches -- -- without; client is a bit of a corner case, because it dispatches
-- the parser based on the status code. with this uniqueness -- -- the parser based on the status code. with this uniqueness
-- constraint it won't have to run more than one parser in weird -- -- constraint it won't have to run more than one parser in weird
-- corner cases. -- -- corner cases.
) => -- ) =>
HasServer (UVerb method contentTypes as) context -- HasServer (UVerb method contentTypes as) context
where -- where
type ServerT (UVerb method contentTypes as) m = m (Union as) -- type ServerT (UVerb method contentTypes as) m = m (Union as)
hoistServerWithContext _ _ nt s = nt s -- hoistServerWithContext _ _ nt s = nt s
route :: -- route ::
forall env. -- forall env.
Proxy (UVerb method contentTypes as) -> -- Proxy (UVerb method contentTypes as) ->
Context context -> -- Context context ->
Delayed env (Server (UVerb method contentTypes as)) -> -- Delayed env (Server (UVerb method contentTypes as)) ->
Router env -- Router env
route _proxy _ctx action = leafRouter route' -- route _proxy _ctx action = leafRouter route'
where -- where
method = reflectMethod (Proxy @method) -- method = reflectMethod (Proxy @method)
route' env request cont = do -- route' env request cont = do
let action' :: Delayed env (Handler (Union as)) -- let action' :: Delayed env (Handler (Union as))
action' = -- action' =
action -- action
`addMethodCheck` methodCheck method request -- `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request) -- `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
runAction action' env request cont $ \(output :: Union as) -> do -- runAction action' env request cont $ \(output :: Union as) -> do
let cts = Proxy @contentTypes -- let cts = Proxy @contentTypes
pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)]) -- pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts) -- pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
case pickResource output of -- case pickResource output of
(_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does -- (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
(status, Just (contentT, body), headers) -> -- (status, Just (contentT, body), headers) ->
let bdy = if allowedMethodHead method request then "" else body -- let bdy = if allowedMethodHead method request then "" else body
in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy -- in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy