eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Make NoContent still take an arg.

Browse source 
For consistency with other combinators, and to make using headers
        easier.
This commit is contained in:
Julian K. Arni 2016-01-07 14:30:08 +01:00
parent 574e9c48cd
commit 783a849c67
6 changed files with 69 additions and 75 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
servant-client/src/Servant/Client.hs
View file

@ -129,10 +129,10 @@ instance OVERLAPPABLE_
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts ()) where (ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts ()) = ExceptT ServantError IO () type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody method req baseurl manager performRequestNoBody method req baseurl manager >> return NoContent
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
@ -150,13 +150,13 @@ instance OVERLAPPING_
instance OVERLAPPING_ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method ( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls ())) where ) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls ())) type Client (Verb method status cts (Headers ls NoContent))
= ExceptT ServantError IO (Headers ls ()) = ExceptT ServantError IO (Headers ls NoContent)
clientWithRoute Proxy req baseurl manager = do clientWithRoute Proxy req baseurl manager = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req baseurl manager hdrs <- performRequestNoBody method req baseurl manager
return $ Headers { getResponse = () return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }

12
servant-client/test/Servant/ClientSpec.hs
View file

@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api = type Api =
"get" :> Get '[JSON] Person "get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> Delete '[JSON] () :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@ -105,14 +105,14 @@ type Api =
ReqBody '[JSON] [(String, [Rational])] :> ReqBody '[JSON] [(String, [Rational])] :>
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
:<|> "deleteContentType" :> Delete '[JSON] () :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
server :: Application server :: Application
server = serve api ( server = serve api (
return alice return alice
:<|> return () :<|> return NoContent
:<|> (\ name -> return $ Person name 0) :<|> (\ name -> return $ Person name 0)
:<|> return :<|> return
:<|> (\ name -> case name of :<|> (\ name -> case name of
@ -125,7 +125,7 @@ server = serve api (
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d)) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (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 describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do it "allows empty content type" $ \(_, baseUrl) -> do
let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager 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 it "allows content type" $ \(_, baseUrl) -> do
let getDeleteContentType = getLast $ client api baseUrl manager 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 it "Servant.API.Capture" $ \(_, baseUrl) -> do
let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager

24
servant-server/test/Servant/ServerSpec.hs
View file

@ -38,8 +38,8 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
HttpVersion, IsSecure (..), JSON, HttpVersion, IsSecure (..), JSON,
Patch, PlainText, Post, Put, Patch, PlainText, Post, Put,
QueryFlag, QueryParam, QueryParams, QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Raw, RemoteHost, ReqBody, GetNoContent,
addHeader) PostNoContent, addHeader, NoContent(..))
import Servant.Server (Server, serve, ServantErr(..), err404) import Servant.Server (Server, serve, ServantErr(..), err404)
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai (get, liftIO, matchHeaders, import Test.Hspec.Wai (get, liftIO, matchHeaders,
@ -130,9 +130,9 @@ captureSpec = do
type GetApi = Get '[JSON] Person type GetApi = Get '[JSON] Person
:<|> "empty" :> Get '[JSON] () :<|> "empty" :> GetNoContent '[JSON] NoContent
:<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ()) :<|> "emptyWithHeaders" :> GetNoContent '[JSON] (Headers '[Header "H" Int] NoContent)
:<|> "post" :> Post '[JSON] () :<|> "post" :> PostNoContent '[JSON] NoContent
getApi :: Proxy GetApi getApi :: Proxy GetApi
getApi = Proxy getApi = Proxy
@ -141,9 +141,9 @@ getSpec :: Spec
getSpec = do getSpec = do
describe "Servant.API.Get" $ do describe "Servant.API.Get" $ do
let server = return alice let server = return alice
:<|> return () :<|> return NoContent
:<|> return (addHeader 5 ()) :<|> return (addHeader 5 NoContent)
:<|> return () :<|> return NoContent
with (return $ serve getApi server) $ do with (return $ serve getApi server) $ do
@ -157,7 +157,7 @@ getSpec = do
post "/empty" "" `shouldRespondWith` 405 post "/empty" "" `shouldRespondWith` 405
it "returns headers" $ do 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 it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
@ -168,9 +168,9 @@ headSpec :: Spec
headSpec = do headSpec = do
describe "Servant.API.Head" $ do describe "Servant.API.Head" $ do
let server = return alice let server = return alice
:<|> return () :<|> return NoContent
:<|> return (addHeader 5 ()) :<|> return (addHeader 5 NoContent)
:<|> return () :<|> return NoContent
with (return $ serve getApi server) $ do with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do it "allows to GET a Person" $ do

4
servant/src/Servant/API.hs
View file

@ -52,7 +52,7 @@ import Servant.API.Alternative ((:<|>) (..))
import Servant.API.Capture (Capture) import Servant.API.Capture (Capture)
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON, FromFormUrlEncoded (..), JSON,
MimeRender (..), MimeRender (..), NoContent (NoContent),
MimeUnrender (..), OctetStream, MimeUnrender (..), OctetStream,
PlainText, ToFormUrlEncoded (..)) PlainText, ToFormUrlEncoded (..))
import Servant.API.Header (Header (..)) import Servant.API.Header (Header (..))
@ -77,7 +77,7 @@ import Servant.API.Verbs (Created, Delete, DeleteAccepted,
GetNonAuthoritative, GetNonAuthoritative,
GetPartialContent, GetPartialContent,
GetResetContent, GetResetContent,
NoContent (NoContent), Patch, Patch,
PatchAccepted, PatchNoContent, PatchAccepted, PatchNoContent,
PatchNoContent, PatchNoContent,
PatchNonAuthoritative, Post, PatchNonAuthoritative, Post,

58
servant/src/Servant/API/ContentTypes.hs
View file

@ -11,11 +11,10 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_HADDOCK not-home #-}
#include "overlapping-compat.h"
-- | A collection of basic Content-Types (also known as Internet Media -- | A collection of basic Content-Types (also known as Internet Media
-- Types, or MIME types). Additionally, this module provides classes that -- Types, or MIME types). Additionally, this module provides classes that
-- encapsulate how to serialize or deserialize values to or from -- encapsulate how to serialize or deserialize values to or from
@ -57,6 +56,9 @@ module Servant.API.ContentTypes
, MimeRender(..) , MimeRender(..)
, MimeUnrender(..) , MimeUnrender(..)
-- * NoContent
, NoContent(..)
-- * Internal -- * Internal
, AcceptHeader(..) , AcceptHeader(..)
, AllCTRender(..) , AllCTRender(..)
@ -75,8 +77,7 @@ import Control.Applicative ((*>), (<*))
#endif #endif
import Control.Arrow (left) import Control.Arrow (left)
import Control.Monad import Control.Monad
import Data.Aeson (FromJSON, ToJSON, encode, import Data.Aeson (FromJSON(..), ToJSON(..), encode)
parseJSON)
import Data.Aeson.Parser (value) import Data.Aeson.Parser (value)
import Data.Aeson.Types (parseEither) import Data.Aeson.Types (parseEither)
import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,
@ -168,10 +169,7 @@ class (AllMime list) => AllCTRender (list :: [*]) a where
-- mimetype). -- mimetype).
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy (ct ': cts) where pctyps = Proxy :: Proxy (ct ': cts)
@ -275,20 +273,14 @@ instance ( MimeUnrender ctyp a
-- * MimeRender Instances -- * MimeRender Instances
-- | `encode` -- | `encode`
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
ToJSON a => MimeRender JSON a where ToJSON a => MimeRender JSON a where
mimeRender _ = encode mimeRender _ = encode
-- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- | @encodeFormUrlEncoded . toFormUrlEncoded@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@) -- holds if every element of x is non-null (i.e., not @("", "")@)
instance instance OVERLAPPABLE_
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
ToFormUrlEncoded a => MimeRender FormUrlEncoded a where ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
@ -312,25 +304,27 @@ instance MimeRender OctetStream ByteString where
instance MimeRender OctetStream BS.ByteString where instance MimeRender OctetStream BS.ByteString where
mimeRender _ = fromStrict mimeRender _ = fromStrict
instance -- | A type for responses with content-body.
#if MIN_VERSION_base(4,8,0) data NoContent = NoContent
{-# OVERLAPPING #-} deriving (Show, Eq, Read)
#endif
MimeRender JSON () where instance FromJSON NoContent where
parseJSON _ = return NoContent
instance ToJSON NoContent where
toJSON _ = ""
instance OVERLAPPING_
MimeRender JSON NoContent where
mimeRender _ _ = "" mimeRender _ _ = ""
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0) MimeRender PlainText NoContent where
{-# OVERLAPPING #-}
#endif
MimeRender PlainText () where
mimeRender _ _ = "" mimeRender _ _ = ""
instance instance OVERLAPPING_
#if MIN_VERSION_base(4,8,0) MimeRender OctetStream NoContent where
{-# OVERLAPPING #-}
#endif
MimeRender OctetStream () where
mimeRender _ _ = "" mimeRender _ _ = ""
-------------------------------------------------------------------------- --------------------------------------------------------------------------

32
servant/src/Servant/API/Verbs.hs
View file

@ -11,6 +11,7 @@ import GHC.TypeLits (Nat)
import Network.HTTP.Types.Method (Method, StdMethod (..), import Network.HTTP.Types.Method (Method, StdMethod (..),
methodDelete, methodGet, methodHead, methodDelete, methodGet, methodHead,
methodPatch, methodPost, methodPut) methodPatch, methodPost, methodPut)
import Servant.API.ContentTypes (NoContent(..))
-- | @Verb@ is a general type for representing HTTP verbs/methods. For -- | @Verb@ is a general type for representing HTTP verbs/methods. For
-- convenience, type synonyms for each verb with a 200 response code are -- 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 -- ** 204 No Content
-- --
-- Indicates that no response body is being returned. Handlers for these must -- Indicates that no response body is being returned. Handlers for these should
-- return 'NoContent'. -- return 'NoContent', possibly with headers.
-- --
-- If the document view should be reset, use @205 Reset Content@. -- If the document view should be reset, use @205 Reset Content@.
-- | 'GET' with 204 status code. -- | '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. -- | '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. -- | '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. -- | '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. -- | '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 -- ** 205 Reset Content
-- --
-- Indicates that no response body is being returned. Handlers for these must -- Indicates that no response body is being returned. Handlers for these should
-- return 'NoContent'. -- return 'NoContent', possibly with Headers.
-- --
-- If the document view should not be reset, use @204 No Content@. -- If the document view should not be reset, use @204 No Content@.
-- | 'GET' with 205 status code. -- | '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. -- | '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. -- | '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. -- | '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. -- | '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 -- ** 206 Partial Content
@ -140,9 +141,8 @@ type PutResetContent contentTypes = Verb 'PUT 205 contentTypes NoContent
-- RFC7233 Section 4.1> -- RFC7233 Section 4.1>
-- | 'GET' with 206 status code. -- | '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 class ReflectMethod a where
reflectMethod :: proxy a -> Method reflectMethod :: proxy a -> Method