From ae75b5458994bcbfcab2e31dc07d0d82d1e51e5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 3 Feb 2022 13:45:56 +0100 Subject: [PATCH] WIP --- nix/nixpkgs.json | 4 +- nix/nixpkgs.nix | 11 +- nix/shell.nix | 2 +- servant-server/src/Servant/Server/Internal.hs | 135 ++++++++++++--- servant-server/src/Servant/Server/UVerb.hs | 160 +++++++++--------- 5 files changed, 206 insertions(+), 106 deletions(-) diff --git a/nix/nixpkgs.json b/nix/nixpkgs.json index b6bf5f32..295ec908 100644 --- a/nix/nixpkgs.json +++ b/nix/nixpkgs.json @@ -1,4 +1,4 @@ { - "rev" : "05f0934825c2a0750d4888c4735f9420c906b388", - "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy" + "rev": "0f316e4d72daed659233817ffe52bf08e081b5de", + "sha256": "0vh0fk5is5s9l0lxpi16aabv2kk1fwklr7szy731kfcz9gdrr65l" } diff --git a/nix/nixpkgs.nix b/nix/nixpkgs.nix index 744f982c..b5e86f5b 100644 --- a/nix/nixpkgs.nix +++ b/nix/nixpkgs.nix @@ -1,4 +1,7 @@ -import (builtins.fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz"; - sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36"; -}) {} +let nixpkgsSnapshot = + builtins.fromJSON (builtins.readFile ./nixpkgs.json); in +import (builtins.fetchTarball + { url = "https://github.com/NixOS/nixpkgs/tarball/${nixpkgsSnapshot.rev}"; + sha256 = nixpkgsSnapshot.sha256; + }) + {} diff --git a/nix/shell.nix b/nix/shell.nix index d178b60e..13e12475 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -1,4 +1,4 @@ -{ compiler ? "ghc8104" +{ compiler ? "ghc901" , tutorial ? false , pkgs ? import ./nixpkgs.nix }: diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index bb35b9c8..2d8e0c07 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -31,6 +31,12 @@ module Servant.Server.Internal , module Servant.Server.Internal.ServerError ) 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 (join, when) import Control.Monad.Trans @@ -76,7 +82,9 @@ import Servant.API QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, 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.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -88,7 +96,7 @@ import Servant.API.Modifiers import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) import Servant.API.Status - (statusFromNat) + (statusFromNat, KnownStatus) import qualified Servant.Types.SourceT as S import Servant.API.TypeErrors import Web.HttpApiData @@ -292,28 +300,36 @@ noContentRouter method status action = leafRouter route' env request respond $ \ _output -> Route $ responseLBS status [] "" -instance {-# OVERLAPPABLE #-} - ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - ) => HasServer (Verb method status ctypes a) context where +-- instance {-# OVERLAPPABLE #-} +-- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status +-- ) => HasServer (Verb method status ctypes a) context where - type ServerT (Verb method status ctypes a) m = m a - hoistServerWithContext _ _ nt s = nt s +-- type ServerT (Verb method status ctypes a) m = m a +-- hoistServerWithContext _ _ nt s = nt s - route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status - where method = reflectMethod (Proxy :: Proxy method) - status = statusFromNat (Proxy :: Proxy status) +-- route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status +-- where method = reflectMethod (Proxy :: Proxy method) +-- status = statusFromNat (Proxy :: Proxy status) -instance {-# OVERLAPPING #-} - ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - , GetHeaders (Headers h a) - ) => HasServer (Verb method status ctypes (Headers h a)) context where +-- instance {-# OVERLAPPING #-} +-- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status +-- , GetHeaders (Headers h a) +-- ) => HasServer (Verb method status ctypes (Headers h a)) context where - type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - hoistServerWithContext _ _ nt s = nt s +-- type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) +-- hoistServerWithContext _ _ nt s = nt s - route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status - where method = reflectMethod (Proxy :: Proxy method) - status = statusFromNat (Proxy :: Proxy status) +-- route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status +-- where method = reflectMethod (Proxy :: Proxy method) +-- 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) => HasServer (NoContentVerb method) context where @@ -957,3 +973,84 @@ instance toServant server servantSrvN :: ServerT (ToServantApi api) n = 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 diff --git a/servant-server/src/Servant/Server/UVerb.hs b/servant-server/src/Servant/Server/UVerb.hs index 4b934d91..9f464d0f 100644 --- a/servant-server/src/Servant/Server/UVerb.hs +++ b/servant-server/src/Servant/Server/UVerb.hs @@ -22,95 +22,95 @@ module Servant.Server.UVerb ) where -import qualified Data.ByteString as B -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 Network.Wai (responseLBS, Request) -import Servant.API (ReflectMethod, reflectMethod) -import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime) -import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..)) -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 qualified Data.ByteString as B +-- 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 Network.Wai (responseLBS, Request) +-- import Servant.API (ReflectMethod, reflectMethod) +-- import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime) +-- import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..)) +-- import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf) +import Servant.Server.Internal (respond, IsServerResource) --- | '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 +-- -- | '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)] +-- 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 {-# 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, 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 +-- 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) +-- 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 +-- 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) +-- 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 +-- 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) +-- 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 +-- 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