From cda8bcf17cbe5a23696fcf0e320f1d8ec99d0505 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 27 Nov 2015 02:05:34 +0100 Subject: [PATCH] Simplify verb combinators. Create a single 'Verb' combinator with parameters for status code and method. Make existing combinators type synonyms of 'Verb'. --- servant-client/src/Servant/Client.hs | 168 ++++-------- servant-client/src/Servant/Common/Req.hs | 19 +- servant-client/test/Servant/ClientSpec.hs | 4 +- servant-docs/src/Servant/Docs/Internal.hs | 63 ++--- servant-server/src/Servant/Server/Internal.hs | 249 +++--------------- .../test/Servant/Server/ErrorSpec.hs | 2 +- .../test/Servant/Server/Internal/EnterSpec.hs | 2 +- servant-server/test/Servant/ServerSpec.hs | 48 ++-- .../test/Servant/Utils/StaticFilesSpec.hs | 7 +- servant/servant.cabal | 6 +- servant/src/Servant/API.hs | 23 +- servant/src/Servant/API/ContentTypes.hs | 66 +++-- servant/src/Servant/API/Delete.hs | 24 -- servant/src/Servant/API/Get.hs | 22 -- servant/src/Servant/API/Patch.hs | 29 -- servant/src/Servant/API/Post.hs | 27 -- servant/src/Servant/API/Put.hs | 25 -- servant/src/Servant/API/Verbs.hs | 60 +++++ servant/src/Servant/Utils/Links.hs | 37 +-- 19 files changed, 279 insertions(+), 602 deletions(-) delete mode 100644 servant/src/Servant/API/Delete.hs delete mode 100644 servant/src/Servant/API/Get.hs delete mode 100644 servant/src/Servant/API/Patch.hs delete mode 100644 servant/src/Servant/API/Post.hs delete mode 100644 servant/src/Servant/API/Put.hs create mode 100644 servant/src/Servant/API/Verbs.hs diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 408850ca..4eac1b2d 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -44,7 +45,7 @@ import Servant.Common.Req -- | 'client' allows you to produce operations to query an API from a client. -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy @@ -118,62 +119,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) where p = unpack (toUrlPiece val) --- | If you have a 'Delete' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. instance OVERLAPPABLE_ - (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where - type Client (Delete cts' a) = ExceptT ServantError IO a + -- Note [Non-Empty Content Types] + (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient (Verb method status cts' a) where + type Client (Verb method status cts' a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager + snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager + where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ - HasClient (Delete cts ()) where - type Client (Delete cts ()) = ExceptT ServantError IO () + (ReflectMethod method) => HasClient (Verb method status cts ()) where + type Client (Verb method status cts ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodDelete req baseurl manager + void $ performRequestNoBody method req baseurl manager + where method = reflectMethod (Proxy :: Proxy method) --- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) - ) => HasClient (Delete cts' (Headers ls a)) where - type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) + -- Note [Non-Empty Content Types] + ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient (Verb method status cts' (Headers ls a)) where + type Client (Verb method status cts' (Headers ls a)) + = ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager + let method = reflectMethod (Proxy :: Proxy method) + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } --- | If you have a 'Get' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance OVERLAPPABLE_ - (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where - type Client (Get (ct ': cts) result) = ExceptT ServantError IO result - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager - instance OVERLAPPING_ - HasClient (Get (ct ': cts) ()) where - type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - performRequestNoBody H.methodGet req baseurl manager - --- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Get (ct ': cts) (Headers ls a)) where - type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) + ( BuildHeadersTo ls, ReflectMethod method + ) => HasClient (Verb method status cts (Headers ls ())) where + type Client (Verb method status cts (Headers ls ())) + = ExceptT ServantError IO (Headers ls ()) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager - return $ Headers { getResponse = resp + let method = reflectMethod (Proxy :: Proxy method) + hdrs <- performRequestNoBody method req baseurl manager + return $ Headers { getResponse = () , getHeadersHList = buildHeadersTo hdrs } + -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'Header', @@ -217,90 +204,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) where hname = symbolVal (Proxy :: Proxy sym) --- | If you have a 'Post' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance OVERLAPPABLE_ - (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where - type Client (Post (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager - -instance OVERLAPPING_ - HasClient (Post (ct ': cts) ()) where - type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPost req baseurl manager - --- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Post (ct ': cts) (Headers ls a)) where - type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - --- | If you have a 'Put' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance OVERLAPPABLE_ - (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where - type Client (Put (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager - -instance OVERLAPPING_ - HasClient (Put (ct ': cts) ()) where - type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPut req baseurl manager - --- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Put (ct ': cts) (Headers ls a)) where - type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager= do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - --- | If you have a 'Patch' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance OVERLAPPABLE_ - (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where - type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager - -instance OVERLAPPING_ - HasClient (Patch (ct ': cts) ()) where - type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPatch req baseurl manager - --- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Patch (ct ': cts) (Headers ls a)) where - type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'QueryParam', @@ -503,3 +406,20 @@ instance HasClient api => HasClient (IsSecure :> api) where clientWithRoute Proxy req baseurl manager = clientWithRoute (Proxy :: Proxy api) req baseurl manager + + +{- Note [Non-Empty Content Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather than have + + instance (..., cts' ~ (ct ': cts)) => ... cts' ... + +It may seem to make more sense to have: + + instance (...) => ... (ct ': cts) ... + +But this means that if another instance exists that does *not* require +non-empty lists, but is otherwise more specific, no instance will be overall +more specific. This in turns generally means adding yet another instance (one +for empty and one for non-empty lists). +-} diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 38aa39b5..32d572aa 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -142,7 +142,7 @@ performRequest reqMethod req reqHost manager = do Right response -> do let status = Client.responseStatus response body = Client.responseBody response - hrds = Client.responseHeaders response + hdrs = Client.responseHeaders response status_code = statusCode status ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" @@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ throwE $ FailureResponse status ct body - return (status_code, body, ct, hrds, response) + return (status_code, body, ct, hdrs, response) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result) + Proxy ct -> Method -> Req -> BaseUrl -> Manager + -> ExceptT ServantError IO ([HTTP.Header], result) performRequestCT ct reqMethod req reqHost manager = do let acceptCT = contentType ct - (_status, respBody, respCT, hrds, _response) <- + (_status, respBody, respCT, hdrs, _response) <- performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwE $ DecodeFailure err respCT respBody - Right val -> return (hrds, val) + Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO () -performRequestNoBody reqMethod req reqHost manager = - void $ performRequest reqMethod req reqHost manager +performRequestNoBody :: Method -> Req -> BaseUrl -> Manager + -> ExceptT ServantError IO [HTTP.Header] +performRequestNoBody reqMethod req reqHost manager = do + (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager + return hdrs catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action = diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index b1980d1a..e289873d 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type Api = "get" :> Get '[JSON] Person - :<|> "deleteEmpty" :> Delete '[] () + :<|> "deleteEmpty" :> Delete '[JSON] () :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person @@ -283,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a, + WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a, HasClient api, Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index c1d26142..41754c31 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -476,8 +476,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) -- | Synthesise a sample value of a type, encoded in the specified media types. sampleByteString - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) - => Proxy ctypes + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(M.MediaType, ByteString)] sampleByteString ctypes@Proxy Proxy = @@ -486,8 +486,8 @@ sampleByteString ctypes@Proxy Proxy = -- | Synthesise a list of sample values of a particular type, encoded in the -- specified media types. sampleByteStrings - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) - => Proxy ctypes + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = @@ -689,21 +689,21 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) instance OVERLAPPABLE_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Delete cts a) where + (ToSample a, AllMimeRender (ct ': cts) a) + => HasDocs (Delete (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' where endpoint' = endpoint & method .~ DocDELETE action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPING_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a + (ToSample a, AllMimeRender (ct ': cts) a , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Delete cts (Headers ls a)) where + => HasDocs (Delete (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -712,25 +712,26 @@ instance OVERLAPPING_ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPABLE_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Get cts a) where + (ToSample a, AllMimeRender (ct ': cts) a) + => HasDocs (Get (ct ': cts) a) where +>>>>>>> Simplify verb combinators. docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' where endpoint' = endpoint & method .~ DocGET action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPING_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a + (ToSample a, AllMimeRender (ct ': cts) a , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Get cts (Headers ls a)) where + => HasDocs (Get (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -739,7 +740,7 @@ instance OVERLAPPING_ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol sym, HasDocs sublayout) @@ -752,8 +753,8 @@ instance (KnownSymbol sym, HasDocs sublayout) headername = pack $ symbolVal (Proxy :: Proxy sym) instance OVERLAPPABLE_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Post cts a) where + (ToSample a, AllMimeRender (ct ': cts) a) + => HasDocs (Post (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -761,13 +762,13 @@ instance OVERLAPPABLE_ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t & response.respStatus .~ 201 - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPING_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a + (ToSample a, AllMimeRender (ct ': cts) a , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Post cts (Headers ls a)) where + => HasDocs (Post (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -777,12 +778,12 @@ instance OVERLAPPING_ & response.respTypes .~ allMime t & response.respStatus .~ 201 & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPABLE_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Put cts a) where + (ToSample a, AllMimeRender (ct ': cts) a) + => HasDocs (Put (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -790,13 +791,13 @@ instance OVERLAPPABLE_ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t & response.respStatus .~ 200 - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPING_ - ( ToSample a, IsNonEmpty cts, AllMimeRender cts a, + ( ToSample a, AllMimeRender (ct ': cts) a, AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Put cts (Headers ls a)) where + => HasDocs (Put (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -806,7 +807,7 @@ instance OVERLAPPING_ & response.respTypes .~ allMime t & response.respStatus .~ 200 & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) @@ -849,8 +850,8 @@ instance HasDocs Raw where -- example data. However, there's no reason to believe that the instances of -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- both are even defined) for any particular type. -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) - => HasDocs (ReqBody cts a :> sublayout) where +instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout) + => HasDocs (ReqBody (ct ': cts) a :> sublayout) where docsFor Proxy (endpoint, action) = docsFor sublayoutP (endpoint, action') @@ -858,7 +859,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) where sublayoutP = Proxy :: Proxy sublayout action' = action & rqbody .~ sampleByteString t p & rqtypes .~ allMime t - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 48aed938..5c08c4d4 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -21,26 +21,33 @@ module Servant.Server.Internal #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Except (ExceptT) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.String (fromString) -import Data.String.Conversions (ConvertibleStrings, cs, (<>)) -import Data.Text (Text) +import Control.Monad.Trans.Except (ExceptT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.String (fromString) +import Data.String.Conversions (cs, (<>)) +import Data.Text (Text) import Data.Typeable -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Socket (SockAddr) -import Network.Wai (Application, lazyRequestBody, - rawQueryString, requestHeaders, - requestMethod, responseLBS, remoteHost, - isSecure, vault, httpVersion, Response, - Request, pathInfo) +import GHC.TypeLits (KnownNat, KnownSymbol, natVal, + symbolVal) +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Socket (SockAddr) +import Network.Wai (Application, Request, Response, + httpVersion, isSecure, + lazyRequestBody, pathInfo, + rawQueryString, remoteHost, + requestHeaders, requestMethod, + responseLBS, vault) +import Web.HttpApiData (FromHttpApiData) +import Web.HttpApiData.Internal (parseHeaderMaybe, + parseQueryParamMaybe, + parseUrlPieceMaybe) + import Servant.API ((:<|>) (..), (:>), Capture, - Delete, Get, Header, - IsSecure(..), Patch, Post, Put, + Verb, ReflectMethod(reflectMethod), + IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, Vault) import Servant.API.ContentTypes (AcceptHeader (..), @@ -55,8 +62,6 @@ import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -import Web.HttpApiData (FromHttpApiData) -import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe) class HasServer layout where type ServerT layout (m :: * -> *) :: * @@ -129,12 +134,12 @@ allowedMethodHead method request = method == methodGet && requestMethod request allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || requestMethod request == method -processMethodRouter :: forall a. ConvertibleStrings a B.ByteString - => Maybe (a, BL.ByteString) -> Status -> Method +processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response processMethodRouter handleA status method headers request = case handleA of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does + Just (_, "") -> Route $ responseLBS status204 (fromMaybe [] headers) "" Just (contentT, body) -> Route $ responseLBS status hdrs bdy where bdy = if allowedMethodHead method request then "" else body @@ -160,7 +165,7 @@ methodRouter method proxy status action = LeafRouter route' | pathIsEmpty request = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH + `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request @@ -176,95 +181,34 @@ methodRouterHeaders method proxy status action = LeafRouter route' | pathIsEmpty request = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH + `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request | otherwise = respond $ Fail err404 -methodRouterEmpty :: Method - -> Delayed (ExceptT ServantErr IO ()) - -> Router -methodRouterEmpty method action = LeafRouter route' - where - route' request respond - | pathIsEmpty request = do - runAction (addMethodCheck action (methodCheck method request)) respond $ \ () -> - Route $! responseLBS noContent204 [] "" - | otherwise = respond $ Fail err404 - --- | If you have a 'Delete' endpoint in your API, --- the handler for this endpoint is meant to delete --- a resource. --- --- The code of the handler will, just like --- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and --- 'Servant.API.Put.Put', run in @ExceptT ServantErr IO ()@. --- The 'Int' represents the status code and the 'String' a message --- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to --- painlessly error out if the conditions for a successful deletion --- are not met. instance OVERLAPPABLE_ - ( AllCTRender ctypes a - ) => HasServer (Delete ctypes a) where + ( AllCTRender ctypes a, ReflectMethod method, KnownNat status + ) => HasServer (Verb method status ctypes a) where - type ServerT (Delete ctypes a) m = m a + type ServerT (Verb method status ctypes a) m = m a - route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 + route Proxy = methodRouter method (Proxy :: Proxy ctypes) status + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance OVERLAPPING_ - HasServer (Delete ctypes ()) where +instance + ( AllCTRender ctypes a, ReflectMethod method, KnownNat status + , GetHeaders (Headers h a) + ) => HasServer (Verb method status ctypes (Headers h a)) where - type ServerT (Delete ctypes ()) m = m () + type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - route Proxy = methodRouterEmpty methodDelete - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Delete ctypes (Headers h v)) where - - type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 - --- | When implementing the handler for a 'Get' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 200). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance OVERLAPPABLE_ - ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - - type ServerT (Get ctypes a) m = m a - - route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 - --- '()' ==> 204 No Content -instance OVERLAPPING_ - HasServer (Get ctypes ()) where - - type ServerT (Get ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodGet - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Get ctypes (Headers h v)) where - - type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200 + route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -297,113 +241,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) --- | When implementing the handler for a 'Post' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 201). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance OVERLAPPABLE_ - ( AllCTRender ctypes a - ) => HasServer (Post ctypes a) where - - type ServerT (Post ctypes a) m = m a - - route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 - -instance OVERLAPPING_ - HasServer (Post ctypes ()) where - - type ServerT (Post ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPost - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Post ctypes (Headers h v)) where - - type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201 - --- | When implementing the handler for a 'Put' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Post.Post', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 200). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance OVERLAPPABLE_ - ( AllCTRender ctypes a) => HasServer (Put ctypes a) where - - type ServerT (Put ctypes a) m = m a - - route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 - -instance OVERLAPPING_ - HasServer (Put ctypes ()) where - - type ServerT (Put ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPut - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Put ctypes (Headers h v)) where - - type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200 - --- | When implementing the handler for a 'Patch' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we just require that its type has --- a 'ToJSON' instance and servant takes care of encoding it for you, --- yielding status code 200 along the way. -instance OVERLAPPABLE_ - ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where - - type ServerT (Patch ctypes a) m = m a - - route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 - -instance OVERLAPPING_ - HasServer (Patch ctypes ()) where - - type ServerT (Patch ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPatch - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Patch ctypes (Headers h v)) where - - type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200 - -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 2e93cc2a..500a0069 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -162,7 +162,7 @@ errorRetrySpec = describe "Handler search" it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody - `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) } + `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 973e1f89..8b450377 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" - post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } + post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } with (return (serve combinedAPI combinedReaderServer)) $ do it "allows combnation of enters" $ do diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e017d399..ad7a3556 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -130,15 +130,21 @@ captureSpec = do type GetApi = Get '[JSON] Person - :<|> "empty" :> Get '[] () - :<|> "post" :> Post '[] () + :<|> "empty" :> Get '[JSON] () + :<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ()) + :<|> "post" :> Post '[JSON] () + getApi :: Proxy GetApi getApi = Proxy getSpec :: Spec getSpec = do describe "Servant.API.Get" $ do - let server = return alice :<|> return () :<|> return () + let server = return alice + :<|> return () + :<|> return (addHeader 5 ()) + :<|> return () + with (return $ serve getApi server) $ do it "allows to GET a Person" $ do @@ -150,8 +156,8 @@ getSpec = do post "/" "" `shouldRespondWith` 405 post "/empty" "" `shouldRespondWith` 405 - it "returns 204 if the type is '()'" $ do - get "/empty" `shouldRespondWith` ""{ matchStatus = 204 } + it "returns headers" $ do + get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] } it "returns 406 if the Accept header is not supported" $ do Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" @@ -161,7 +167,10 @@ getSpec = do headSpec :: Spec headSpec = do describe "Servant.API.Head" $ do - let server = return alice :<|> return () :<|> return () + let server = return alice + :<|> return () + :<|> return (addHeader 5 ()) + :<|> return () with (return $ serve getApi server) $ do it "allows to GET a Person" $ do @@ -177,10 +186,6 @@ headSpec = do post "/" "" `shouldRespondWith` 405 post "/empty" "" `shouldRespondWith` 405 - it "returns 204 if the type is '()'" $ do - response <- Test.Hspec.Wai.request methodHead "/empty" [] "" - return response `shouldRespondWith` ""{ matchStatus = 204 } - it "returns 406 if the Accept header is not supported" $ do Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 @@ -272,7 +277,7 @@ queryParamSpec = do type PostApi = ReqBody '[JSON] Person :> Post '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer - :<|> "empty" :> Post '[] () + :<|> "empty" :> Post '[JSON] () postApi :: Proxy PostApi postApi = Proxy @@ -287,25 +292,22 @@ postSpec = do it "allows to POST a Person" $ do post' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 + matchStatus = 200 } it "allows alternative routes if all have request bodies" $ do post' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 + matchStatus = 200 } it "handles trailing '/' gracefully" $ do post' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 + matchStatus = 200 } it "correctly rejects invalid request bodies with status 400" $ do post' "/" "some invalid body" `shouldRespondWith` 400 - it "returns 204 if the type is '()'" $ do - post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the request body media type is unsupported" $ do let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType , "application/nonsense")] @@ -314,7 +316,7 @@ postSpec = do type PutApi = ReqBody '[JSON] Person :> Put '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer - :<|> "empty" :> Put '[] () + :<|> "empty" :> Put '[JSON] () putApi :: Proxy PutApi putApi = Proxy @@ -345,9 +347,6 @@ putSpec = do it "correctly rejects invalid request bodies with status 400" $ do put' "/" "some invalid body" `shouldRespondWith` 400 - it "returns 204 if the type is '()'" $ do - put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the request body media type is unsupported" $ do let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType , "application/nonsense")] @@ -356,7 +355,7 @@ putSpec = do type PatchApi = ReqBody '[JSON] Person :> Patch '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer - :<|> "empty" :> Patch '[] () + :<|> "empty" :> Patch '[JSON] () patchApi :: Proxy PatchApi patchApi = Proxy @@ -387,9 +386,6 @@ patchSpec = do it "correctly rejects invalid request bodies with status 400" $ do patch' "/" "some invalid body" `shouldRespondWith` 400 - it "returns 204 if the type is '()'" $ do - patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the request body media type is unsupported" $ do let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType , "application/nonsense")] @@ -505,7 +501,7 @@ responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do - let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)] + let methods = [(methodGet, 200), (methodPost, 200), (methodPut, 200), (methodPatch, 200)] it "includes the headers in the response" $ forM_ methods $ \(method, expected) -> diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index 3630b313..94c63f18 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) -import Servant.API (JSON) -import Servant.API.Alternative ((:<|>) ((:<|>))) -import Servant.API.Capture (Capture) -import Servant.API.Get (Get) -import Servant.API.Raw (Raw) -import Servant.API.Sub ((:>)) +import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) import Servant.Server (Server, serve) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) diff --git a/servant/servant.cabal b/servant/servant.cabal index 895b9f32..451eb166 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -29,14 +29,9 @@ library Servant.API.Alternative Servant.API.Capture Servant.API.ContentTypes - Servant.API.Delete - Servant.API.Get Servant.API.Header Servant.API.HttpVersion Servant.API.IsSecure - Servant.API.Patch - Servant.API.Post - Servant.API.Put Servant.API.QueryParam Servant.API.Raw Servant.API.RemoteHost @@ -44,6 +39,7 @@ library Servant.API.ResponseHeaders Servant.API.Sub Servant.API.Vault + Servant.API.Verbs Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2e6abb2a..2565149f 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -25,16 +25,7 @@ module Servant.API ( -- | Access the location for arbitrary data to be shared by applications and middleware -- * Actual endpoints, distinguished by HTTP method - module Servant.API.Get, - -- | @GET@ requests - module Servant.API.Post, - -- | @POST@ requests - module Servant.API.Delete, - -- | @DELETE@ requests - module Servant.API.Put, - -- | @PUT@ requests - module Servant.API.Patch, - -- | @PATCH@ requests + module Servant.API.Verbs, -- * Content Types module Servant.API.ContentTypes, @@ -64,14 +55,9 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, MimeRender (..), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..)) -import Servant.API.Delete (Delete) -import Servant.API.Get (Get) import Servant.API.Header (Header (..)) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) -import Servant.API.Patch (Patch) -import Servant.API.Post (Post) -import Servant.API.Put (Put) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw) @@ -84,7 +70,10 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) import Servant.API.Vault (Vault) -import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) +import Servant.API.Verbs (Delete, Get, Patch, Post, Put, + ReflectMethod (reflectMethod), + Verb) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) - +import Web.HttpApiData (FromHttpApiData (..), + ToHttpApiData (..)) diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index ab857ce2..85ddbb02 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,6 +11,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif {-# OPTIONS_HADDOCK not-home #-} -- | A collection of basic Content-Types (also known as Internet Media @@ -19,7 +23,7 @@ -- -- Content-Types are used in `ReqBody` and the method combinators: -- --- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book +-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book -- -- Meaning the endpoint accepts requests of Content-Type @application/json@ -- or @text/plain;charset-utf8@, and returns data in either one of those @@ -62,7 +66,6 @@ module Servant.API.ContentTypes , AllMimeUnrender(..) , FromFormUrlEncoded(..) , ToFormUrlEncoded(..) - , IsNonEmpty , eitherDecodeLenient , canHandleAcceptH ) where @@ -91,7 +94,7 @@ import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable -import GHC.Exts (Constraint) +import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Network.URI (escapeURIString, isUnreserved, unEscapeString) @@ -137,7 +140,7 @@ instance Accept OctetStream where contentType _ = "application" M.// "octet-stream" newtype AcceptHeader = AcceptHeader BS.ByteString - deriving (Eq, Show) + deriving (Eq, Show, Read, Typeable, Generic) -- * Render (serializing) @@ -159,19 +162,22 @@ newtype AcceptHeader = AcceptHeader BS.ByteString class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString -class (AllMimeRender list a) => AllCTRender (list :: [*]) a where +class (AllMime list) => AllCTRender (list :: [*]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept - where pctyps = Proxy :: Proxy ctyps + where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs - -------------------------------------------------------------------------- -- * Unrender @@ -199,14 +205,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a -class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where +class AllCTUnrender (list :: [*]) a where handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) -instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps - ) => AllCTUnrender ctyps a where +instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body @@ -247,8 +252,7 @@ instance ( MimeRender ctyp a where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy (ctyp' ': ctyps) - -instance AllMimeRender '[] a where +instance AllMimeRender '[] () where allMimeRender _ _ = [] -------------------------------------------------------------------------- @@ -270,21 +274,25 @@ instance ( MimeUnrender ctyp a where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps -type family IsNonEmpty (list :: [*]) :: Constraint where - IsNonEmpty (x ': xs) = () - - -------------------------------------------------------------------------- -- * MimeRender Instances -- | `encode` -instance ToJSON a => MimeRender JSON a where +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) -instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ToFormUrlEncoded a => MimeRender FormUrlEncoded a where mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded -- | `TextL.encodeUtf8` @@ -307,6 +315,26 @@ instance MimeRender OctetStream ByteString where instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + MimeRender JSON () where + mimeRender _ _ = "" + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + MimeRender PlainText () where + mimeRender _ _ = "" + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + MimeRender OctetStream () where + mimeRender _ _ = "" -------------------------------------------------------------------------- -- * MimeUnrender Instances diff --git a/servant/src/Servant/API/Delete.hs b/servant/src/Servant/API/Delete.hs deleted file mode 100644 index de792a28..00000000 --- a/servant/src/Servant/API/Delete.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Delete (Delete) where - -import Data.Typeable (Typeable) - --- | Combinator for DELETE requests. --- --- Example: --- --- >>> -- DELETE /books/:isbn --- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[] () -data Delete (contentTypes :: [*]) a - deriving Typeable - - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Get.hs b/servant/src/Servant/API/Get.hs deleted file mode 100644 index 073bfda6..00000000 --- a/servant/src/Servant/API/Get.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Get (Get) where - -import Data.Typeable (Typeable) - --- | Endpoint for simple GET requests. Serves the result as JSON. --- --- Example: --- --- >>> type MyApi = "books" :> Get '[JSON] [Book] -data Get (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Patch.hs b/servant/src/Servant/API/Patch.hs deleted file mode 100644 index 715cf905..00000000 --- a/servant/src/Servant/API/Patch.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Patch (Patch) where - -import Data.Typeable (Typeable) - --- | Endpoint for PATCH requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for --- that). --- --- If the HTTP response is empty, only () is supported. --- --- Example: --- --- >>> -- PATCH /books --- >>> -- with a JSON encoded Book as the request body --- >>> -- returning the just-created Book --- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book -data Patch (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Post.hs b/servant/src/Servant/API/Post.hs deleted file mode 100644 index 72bc59cc..00000000 --- a/servant/src/Servant/API/Post.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Post (Post) where - -import Data.Typeable (Typeable) - --- | Endpoint for POST requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for --- that). --- --- Example: --- --- >>> -- POST /books --- >>> -- with a JSON encoded Book as the request body --- >>> -- returning the just-created Book --- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -data Post (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Put.hs b/servant/src/Servant/API/Put.hs deleted file mode 100644 index 0b09d961..00000000 --- a/servant/src/Servant/API/Put.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Put (Put) where - -import Data.Typeable (Typeable) - --- | Endpoint for PUT requests, usually used to update a ressource. --- The type @a@ is the type of the response body that's returned. --- --- Example: --- --- >>> -- PUT /books/:isbn --- >>> -- with a Book as request body, returning the updated Book --- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book -data Put (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs new file mode 100644 index 00000000..9ab9c74c --- /dev/null +++ b/servant/src/Servant/API/Verbs.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.Verbs where + +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import GHC.TypeLits (Nat) +import Network.HTTP.Types.Method (Method, StdMethod (..), + methodDelete, methodGet, methodHead, + methodPatch, methodPost, methodPut) + +-- | @Verb@ is a general type for representing HTTP verbs/methods. For +-- convenience, type synonyms for each verb with a 200 response code are +-- 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 + deriving (Typeable, Generic) + +-- 'GET' with 200 status code. +type Get contentTypes a = Verb 'GET 200 contentTypes a + +-- 'POST' with 200 status code. +type Post contentTypes a = Verb 'POST 200 contentTypes a + +-- 'PUT' with 200 status code. +type Put contentTypes a = Verb 'PUT 200 contentTypes a + +-- 'DELETE' with 200 status code. +type Delete contentTypes a = Verb 'DELETE 200 contentTypes a + +-- 'PATCH' with 200 status code. +type Patch contentTypes a = Verb 'PATCH 200 contentTypes a + +-- 'HEAD' with 200 status code. +type Head contentTypes a = Verb 'HEAD 200 contentTypes a + +class ReflectMethod a where + reflectMethod :: proxy a -> Method + +instance ReflectMethod 'GET where + reflectMethod _ = methodGet + +instance ReflectMethod 'POST where + reflectMethod _ = methodPost + +instance ReflectMethod 'PUT where + reflectMethod _ = methodPut + +instance ReflectMethod 'DELETE where + reflectMethod _ = methodDelete + +instance ReflectMethod 'PATCH where + reflectMethod _ = methodPatch + +instance ReflectMethod 'HEAD where + reflectMethod _ = methodHead diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index f218377f..38f791ec 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -74,7 +74,9 @@ -- >>> safeLink api bad_link -- ... -- Could not deduce (Or --- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int)) +-- (IsElem' +-- (Verb 'Network.HTTP.Types.Method.DELETE 200 '[JSON] ()) +-- (Verb 'Network.HTTP.Types.Method.GET 200 '[JSON] Int)) -- (IsElem' -- ("hello" :> Delete '[JSON] ()) -- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) @@ -119,11 +121,7 @@ import Servant.API.Capture ( Capture ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) -import Servant.API.Get ( Get ) -import Servant.API.Post ( Post ) -import Servant.API.Put ( Put ) -import Servant.API.Patch ( Patch ) -import Servant.API.Delete ( Delete ) +import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) import Servant.API.Alternative ( type (:<|>) ) @@ -177,11 +175,8 @@ type family IsElem endpoint api :: Constraint where IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb - IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' - IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' - IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct' - IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct' - IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct' + IsElem (Verb m s ct typ) (Verb m s ct' typ) + = IsSubList ct ct' IsElem e e = () IsElem e a = IsElem' e a @@ -303,24 +298,8 @@ instance HasLink sub => HasLink (Header sym a :> sub) where toLink _ = toLink (Proxy :: Proxy sub) -- Verb (terminal) instances -instance HasLink (Get y r) where - type MkLink (Get y r) = URI - toLink _ = linkURI - -instance HasLink (Post y r) where - type MkLink (Post y r) = URI - toLink _ = linkURI - -instance HasLink (Put y r) where - type MkLink (Put y r) = URI - toLink _ = linkURI - -instance HasLink (Patch y r) where - type MkLink (Patch y r) = URI - toLink _ = linkURI - -instance HasLink (Delete y r) where - type MkLink (Delete y r) = URI +instance HasLink (Verb m s ct a) where + type MkLink (Verb m s ct a) = URI toLink _ = linkURI instance HasLink Raw where