diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 2d8e0c07..648acb60 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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) => diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 39e75cd4..f4d6a7e9 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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. diff --git a/servant/src/Servant/API/UVerb.hs b/servant/src/Servant/API/UVerb.hs index ed59eded..b304a7f6 100644 --- a/servant/src/Servant/API/UVerb.hs +++ b/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 diff --git a/servant/src/Servant/API/UVerb/Union.hs b/servant/src/Servant/API/UVerb/Union.hs index 11d93e74..f2c26c03 100644 --- a/servant/src/Servant/API/UVerb/Union.hs +++ b/servant/src/Servant/API/UVerb/Union.hs @@ -52,6 +52,7 @@ module Servant.API.UVerb.Union ( IsMember , Unique , Union +, Elem , inject , eject , foldMapUnion