From 783a849c6741de37b5b09755a96f7ba5a843d8b1 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Jan 2016 14:30:08 +0100 Subject: [PATCH] Make NoContent still take an arg. For consistency with other combinators, and to make using headers easier. --- servant-client/src/Servant/Client.hs | 14 +++--- servant-client/test/Servant/ClientSpec.hs | 12 ++--- servant-server/test/Servant/ServerSpec.hs | 24 +++++----- servant/src/Servant/API.hs | 4 +- servant/src/Servant/API/ContentTypes.hs | 58 ++++++++++------------- servant/src/Servant/API/Verbs.hs | 32 ++++++------- 6 files changed, 69 insertions(+), 75 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 4eac1b2d..c7dbeb80 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -129,10 +129,10 @@ instance OVERLAPPABLE_ where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ - (ReflectMethod method) => HasClient (Verb method status cts ()) where - type Client (Verb method status cts ()) = ExceptT ServantError IO () + (ReflectMethod method) => HasClient (Verb method status cts NoContent) where + type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody method req baseurl manager + performRequestNoBody method req baseurl manager >> return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ @@ -150,13 +150,13 @@ instance OVERLAPPING_ instance OVERLAPPING_ ( 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 ()) + ) => HasClient (Verb method status cts (Headers ls NoContent)) where + type Client (Verb method status cts (Headers ls NoContent)) + = ExceptT ServantError IO (Headers ls NoContent) clientWithRoute Proxy req baseurl manager = do let method = reflectMethod (Proxy :: Proxy method) hdrs <- performRequestNoBody method req baseurl manager - return $ Headers { getResponse = () + return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index e289873d..245a7216 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 '[JSON] () + :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person @@ -105,14 +105,14 @@ type Api = ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) - :<|> "deleteContentType" :> Delete '[JSON] () + :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent api :: Proxy Api api = Proxy server :: Application server = serve api ( return alice - :<|> return () + :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> return :<|> (\ name -> case name of @@ -125,7 +125,7 @@ server = serve api ( :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) - :<|> return () + :<|> return NoContent ) @@ -157,11 +157,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager - (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right () + (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do let getDeleteContentType = getLast $ client api baseUrl manager - (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right () + (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 0a45c70a..9bb5e340 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -38,8 +38,8 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, HttpVersion, IsSecure (..), JSON, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, - addHeader) + Raw, RemoteHost, ReqBody, GetNoContent, + PostNoContent, addHeader, NoContent(..)) import Servant.Server (Server, serve, ServantErr(..), err404) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Wai (get, liftIO, matchHeaders, @@ -130,9 +130,9 @@ captureSpec = do type GetApi = Get '[JSON] Person - :<|> "empty" :> Get '[JSON] () - :<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ()) - :<|> "post" :> Post '[JSON] () + :<|> "empty" :> GetNoContent '[JSON] NoContent + :<|> "emptyWithHeaders" :> GetNoContent '[JSON] (Headers '[Header "H" Int] NoContent) + :<|> "post" :> PostNoContent '[JSON] NoContent getApi :: Proxy GetApi getApi = Proxy @@ -141,9 +141,9 @@ getSpec :: Spec getSpec = do describe "Servant.API.Get" $ do let server = return alice - :<|> return () - :<|> return (addHeader 5 ()) - :<|> return () + :<|> return NoContent + :<|> return (addHeader 5 NoContent) + :<|> return NoContent with (return $ serve getApi server) $ do @@ -157,7 +157,7 @@ getSpec = do post "/empty" "" `shouldRespondWith` 405 it "returns headers" $ do - get "/emptyWithHeaders" `shouldRespondWith` 200 { matchHeaders = [ "H" <:> "5" ] } + 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")] "" @@ -168,9 +168,9 @@ headSpec :: Spec headSpec = do describe "Servant.API.Head" $ do let server = return alice - :<|> return () - :<|> return (addHeader 5 ()) - :<|> return () + :<|> return NoContent + :<|> return (addHeader 5 NoContent) + :<|> return NoContent with (return $ serve getApi server) $ do it "allows to GET a Person" $ do diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index ff1e24ec..2afae7af 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -52,7 +52,7 @@ import Servant.API.Alternative ((:<|>) (..)) import Servant.API.Capture (Capture) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, - MimeRender (..), + MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..)) import Servant.API.Header (Header (..)) @@ -77,7 +77,7 @@ import Servant.API.Verbs (Created, Delete, DeleteAccepted, GetNonAuthoritative, GetPartialContent, GetResetContent, - NoContent (NoContent), Patch, + Patch, PatchAccepted, PatchNoContent, PatchNoContent, PatchNonAuthoritative, Post, diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 8e9c75ac..365381f7 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -11,11 +11,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# OPTIONS_HADDOCK not-home #-} +#include "overlapping-compat.h" + -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from @@ -57,6 +56,9 @@ module Servant.API.ContentTypes , MimeRender(..) , MimeUnrender(..) + -- * NoContent + , NoContent(..) + -- * Internal , AcceptHeader(..) , AllCTRender(..) @@ -75,8 +77,7 @@ import Control.Applicative ((*>), (<*)) #endif import Control.Arrow (left) import Control.Monad -import Data.Aeson (FromJSON, ToJSON, encode, - parseJSON) +import Data.Aeson (FromJSON(..), ToJSON(..), encode) import Data.Aeson.Parser (value) import Data.Aeson.Types (parseEither) import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, @@ -168,10 +169,7 @@ class (AllMime list) => AllCTRender (list :: [*]) a where -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy (ct ': cts) @@ -275,20 +273,14 @@ instance ( MimeUnrender ctyp a -- * MimeRender Instances -- | `encode` -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ 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 -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ToFormUrlEncoded a => MimeRender FormUrlEncoded a where mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded @@ -312,25 +304,27 @@ 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 +-- | A type for responses with content-body. +data NoContent = NoContent + deriving (Show, Eq, Read) + +instance FromJSON NoContent where + parseJSON _ = return NoContent + +instance ToJSON NoContent where + toJSON _ = "" + + +instance OVERLAPPING_ + MimeRender JSON NoContent where mimeRender _ _ = "" -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender PlainText () where +instance OVERLAPPING_ + MimeRender PlainText NoContent where mimeRender _ _ = "" -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender OctetStream () where +instance OVERLAPPING_ + MimeRender OctetStream NoContent where mimeRender _ _ = "" -------------------------------------------------------------------------- diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index 63232aa1..c1462503 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -11,6 +11,7 @@ import GHC.TypeLits (Nat) import Network.HTTP.Types.Method (Method, StdMethod (..), methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut) +import Servant.API.ContentTypes (NoContent(..)) -- | @Verb@ is a general type for representing HTTP verbs/methods. For -- convenience, type synonyms for each verb with a 200 response code are @@ -95,40 +96,40 @@ type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a -- ** 204 No Content -- --- Indicates that no response body is being returned. Handlers for these must --- return 'NoContent'. +-- Indicates that no response body is being returned. Handlers for these should +-- return 'NoContent', possibly with headers. -- -- If the document view should be reset, use @205 Reset Content@. -- | 'GET' with 204 status code. -type GetNoContent contentTypes = Verb 'GET 204 contentTypes NoContent +type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent -- | 'POST' with 204 status code. -type PostNoContent contentTypes = Verb 'POST 204 contentTypes NoContent +type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent -- | 'DELETE' with 204 status code. -type DeleteNoContent contentTypes = Verb 'DELETE 204 contentTypes NoContent +type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent -- | 'PATCH' with 204 status code. -type PatchNoContent contentTypes = Verb 'PATCH 204 contentTypes NoContent +type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent -- | 'PUT' with 204 status code. -type PutNoContent contentTypes = Verb 'PUT 204 contentTypes NoContent +type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent -- ** 205 Reset Content -- --- Indicates that no response body is being returned. Handlers for these must --- return 'NoContent'. +-- Indicates that no response body is being returned. Handlers for these should +-- return 'NoContent', possibly with Headers. -- -- If the document view should not be reset, use @204 No Content@. -- | 'GET' with 205 status code. -type GetResetContent contentTypes = Verb 'GET 205 contentTypes NoContent +type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent -- | 'POST' with 205 status code. -type PostResetContent contentTypes = Verb 'POST 205 contentTypes NoContent +type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent -- | 'DELETE' with 205 status code. -type DeleteResetContent contentTypes = Verb 'DELETE 205 contentTypes NoContent +type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent -- | 'PATCH' with 205 status code. -type PatchResetContent contentTypes = Verb 'PATCH 205 contentTypes NoContent +type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent -- | 'PUT' with 205 status code. -type PutResetContent contentTypes = Verb 'PUT 205 contentTypes NoContent +type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent -- ** 206 Partial Content @@ -140,9 +141,8 @@ type PutResetContent contentTypes = Verb 'PUT 205 contentTypes NoContent -- RFC7233 Section 4.1> -- | 'GET' with 206 status code. -type GetPartialContent contentTypes = Verb 'GET 205 contentTypes NoContent +type GetPartialContent contentTypes noContent = Verb 'GET 205 contentTypes noContent -data NoContent = NoContent class ReflectMethod a where reflectMethod :: proxy a -> Method