WIP

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

@@ -84,7 +84,7 @@ import           Servant.API
                  Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
                  WithNamedContext, NamedRoutes, UVerb, WithStatus(..))
 
-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 (..), Elem, foldMapUnion, inject, statusOf)
 import           Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
 import           Servant.API.ContentTypes
                  (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@@ -97,6 +97,7 @@ import           Servant.API.ResponseHeaders
                  (GetHeaders, Headers, getHeaders, getResponse)
 import           Servant.API.Status
                  (statusFromNat, KnownStatus)
+
 import qualified Servant.Types.SourceT                      as S
 import           Servant.API.TypeErrors
 import           Web.HttpApiData
@@ -324,11 +325,17 @@ noContentRouter method status action = leafRouter route'
 --           status = statusFromNat (Proxy :: Proxy status)
 
 instance
-  (KnownStatus statusCode, HasServer (UVerb method ctypes '[WithStatus statusCode a]) context) =>
+  ( 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 = undefined
+  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) =>

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