WIP

nix/nixpkgs.json

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

nix/nixpkgs.nix

@@ -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;
+  })
+  {}

nix/shell.nix

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

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 (..), Elem, foldMapUnion, inject, statusOf)
 import           Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
 import           Servant.API.ContentTypes
                  (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@@ -88,7 +96,8 @@ 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 +301,42 @@ noContentRouter method status action = leafRouter route'
                     env request respond $ \ _output ->
                       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
+  ( KnownNat statusCode, HasServer (UVerb method ctypes '[WithStatus statusCode a]) context
+  , Elem (WithStatus statusCode a) '[WithStatus statusCode a] ~ True) =>
+  HasServer (Verb method statusCode ctypes a) context where
+
+  type ServerT (Verb method statusCode ctypes a) m = m a
+  route _ pcontext denv = route
+    (Proxy :: Proxy (UVerb method ctypes '[WithStatus statusCode a]))
+    pcontext
+    ((>>= \a -> respond $ WithStatus @statusCode a) <$> denv)
+    -- ((>>= respond . WithStatus @statusCode) <$> denv)
+
+  hoistServerWithContext p1 p2 nat s = undefined
 
 instance (ReflectMethod method) =>
          HasServer (NoContentVerb method) context where
@@ -957,3 +980,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

servant-server/src/Servant/Server/UVerb.hs

@@ -22,95 +22,95 @@ module Servant.Server.UVerb
   )
 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

servant-server/test/Servant/ServerSpec.hs

@@ -76,6 +76,8 @@ import           Servant.Server.Internal.BasicAuth
 import           Servant.Server.Internal.Context
                  (NamedContext (..))
 
+import           Servant.API.Status
+
 -- * comprehensive api test
 
 -- This declaration simply checks that all instances are in place.

servant/src/Servant/API/UVerb.hs

@@ -34,17 +34,17 @@ module Servant.API.UVerb
 where
 
 import Data.Proxy (Proxy (Proxy))
-import GHC.TypeLits (Nat)
+import GHC.TypeLits (Nat, natVal, KnownNat)
 import Network.HTTP.Types (Status, StdMethod)
 import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
-import Servant.API.Status (KnownStatus, statusVal)
+import Servant.API.Status (KnownStatus, statusVal, statusFromNat)
 import Servant.API.UVerb.Union
 
-class KnownStatus (StatusOf a) => HasStatus (a :: *) where
+class KnownNat (StatusOf a) => HasStatus (a :: *) where
   type StatusOf (a :: *) :: Nat
 
 statusOf :: forall a proxy. HasStatus a => proxy a -> Status
-statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
+statusOf = const (statusFromNat (Proxy :: Proxy (StatusOf a)))
 
 -- | If an API can respond with 'NoContent' we assume that this will happen
 -- with the status code 204 No Content. If this needs to be overridden,
@@ -83,7 +83,7 @@ newtype WithStatus (k :: Nat) a = WithStatus a
 -- You can also use the convience newtype wrapper 'WithStatus' if you want to
 -- avoid writing a 'HasStatus' instance manually. It also has the benefit of
 -- showing the status code in the type; which might aid in readability.
-instance KnownStatus n => HasStatus (WithStatus n a) where
+instance KnownNat n => HasStatus (WithStatus n a) where
   type StatusOf (WithStatus n a) = n
 
 

servant/src/Servant/API/UVerb/Union.hs

@@ -52,6 +52,7 @@ module Servant.API.UVerb.Union
 ( IsMember
 , Unique
 , Union
+, Elem
 , inject
 , eject
 , foldMapUnion

servant/src/Servant/API/Verbs.hs

@@ -26,13 +26,13 @@ import           Network.HTTP.Types.Method
 -- provided, but you are free to define your own:
 --
 -- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a
-data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)
+data Verb (method :: StdMethod) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)
   deriving (Typeable, Generic)
 
 -- | @NoContentVerb@ is a specific type to represent 'NoContent' responses.
 -- It does not require either a list of content types (because there's
 -- no content) or a status code (because it should always be 204).
-data NoContentVerb  (method :: k1)
+data NoContentVerb  (method :: StdMethod)
   deriving (Typeable, Generic)
 
 -- * 200 responses