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)
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
}

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 =
"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

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

@ -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

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

@ -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,

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

@ -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 _ _ = ""
--------------------------------------------------------------------------

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

@ -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