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

Make Post and Put return NoContent when response is ()

Browse Source
This commit is contained in:
Julian K. Arni 2015-03-12 18:29:57 +01:00
parent bd98844357
commit 5eddb318a2
2 changed files with 193 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
src/Servant/Server/Internal.hs
View File

@ -4,12 +4,12 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Server.Internal where
import Control.Applicative ((<$>))
import Control.Monad.Trans.Either (EitherT, runEitherT)
import Data.Aeson (ToJSON)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef)
@ -286,6 +286,19 @@ instance ( AllCTRender ctypes a
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance HasServer (Get ctypes ()) where
type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'Header'.
@ -351,6 +364,19 @@ instance ( AllCTRender ctypes a
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance HasServer (Post ctypes ()) where
type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | 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
@ -382,7 +408,19 @@ instance ( AllCTRender ctypes a
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance HasServer (Put ctypes ()) where
type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | When implementing the handler for a 'Patch' endpoint,
@ -397,25 +435,35 @@ instance ( AllCTRender ctypes a
-- a 'ToJSON' instance and servant takes care of encoding it for you,
-- yielding status code 201 along the way.
instance ( AllCTRender ctypes a
, Typeable a
, ToJSON a) => HasServer (Patch ctypes a) where
) => HasServer (Patch ctypes a) where
type ServerT (Patch ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond . succeedWith $ case e of
Right out -> case cast out of
Nothing -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of
Nothing -> responseLBS (mkStatus 406 "") [] ""
Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
, cs contentT)] body
Just () -> responseLBS status204 [] ""
Right output -> do
let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> responseLBS (mkStatus 406 "") [] ""
Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
, cs contentT)] body
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPost =
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance HasServer (Patch ctypes ()) where
type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| pathIsEmpty request && requestMethod request /= methodPatch =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound

162
test/Servant/ServerSpec.hs
View File

@ -1,36 +1,40 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-}
module Servant.ServerSpec where
import Control.Monad (when)
import Control.Monad.Trans.Either (EitherT, left)
import Data.Aeson (ToJSON, FromJSON, encode, decode')
import Data.Char (toUpper)
import Data.Monoid ((<>))
import Data.Proxy (Proxy(Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
import GHC.Generics (Generic)
import Network.HTTP.Types ( parseQuery, ok200, status409, methodPost
, methodDelete, hContentType)
import Network.Wai ( Application, Request, responseLBS, pathInfo
, queryString, rawQueryString )
import Network.Wai.Test (runSession, defaultRequest, simpleBody, request)
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith
, matchStatus, request )
import Control.Monad (when)
import Control.Monad.Trans.Either (EitherT, left)
import Data.Aeson (FromJSON, ToJSON, decode', encode)
import Data.Char (toUpper)
import Data.Monoid ((<>))
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
import GHC.Generics (Generic)
import Network.HTTP.Types (hContentType, methodDelete,
methodPatch, methodPost, methodPut,
ok200, parseQuery, status409)
import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString,
responseLBS)
import Network.Wai.Test (defaultRequest, request,
runSession, simpleBody)
import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai (get, liftIO, matchStatus, post,
request, shouldRespondWith, with)
import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam
, QueryParams, QueryFlag, MatrixParam, MatrixParams
, MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete )
import Servant.Server (Server, serve)
import Servant.Server.Internal (RouteMismatch(..))
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
Get, Header, JSON, MatrixFlag,
MatrixParam, MatrixParams, Patch,
Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody)
import Servant.Server (Server, serve)
import Servant.Server.Internal (RouteMismatch (..))
-- * test data types
@ -69,9 +73,11 @@ spec :: Spec
spec = do
captureSpec
getSpec
postSpec
putSpec
patchSpec
queryParamSpec
matrixParamSpec
postSpec
headerSpec
rawSpec
unionSpec
@ -105,13 +111,15 @@ captureSpec = do
type GetApi = Get '[JSON] Person
:<|> "empty" :> Get '[] ()
getApi :: Proxy GetApi
getApi = Proxy
getSpec :: Spec
getSpec = do
describe "Servant.API.Get" $ do
with (return (serve getApi (return alice))) $ do
let server = return alice :<|> return ()
with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do
response <- get "/"
return response `shouldRespondWith` 200
@ -121,6 +129,10 @@ getSpec = do
it "throws 405 (wrong method) on POSTs" $ do
post "/" "" `shouldRespondWith` 405
it "returns 204 if the type is '()'" $ do
get "empty" `shouldRespondWith` ""{ matchStatus = 204 }
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
@ -291,13 +303,16 @@ matrixParamSpec = do
type PostApi =
ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "empty" :> Post '[] ()
postApi :: Proxy PostApi
postApi = Proxy
postSpec :: Spec
postSpec = do
describe "Servant.API.Post and .ReqBody" $ do
with (return (serve postApi (return . age :<|> return . age))) $ do
let server = return . age :<|> return . age :<|> return ()
with (return $ serve postApi server) $ do
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/json;charset=utf-8")]
@ -319,11 +334,98 @@ postSpec = do
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 requested media type is unsupported" $ do
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/nonsense")]
post'' "/" "anything at all" `shouldRespondWith` 415
type PutApi =
ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "empty" :> Put '[] ()
putApi :: Proxy PutApi
putApi = Proxy
putSpec :: Spec
putSpec = do
describe "Servant.API.Put and .ReqBody" $ do
let server = return . age :<|> return . age :<|> return ()
with (return $ serve putApi server) $ do
let put' x = Test.Hspec.Wai.request methodPut x [(hContentType
, "application/json;charset=utf-8")]
it "allows to put a Person" $ do
put' "/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "allows alternative routes if all have request bodies" $ do
put' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "handles trailing '/' gracefully" $ do
put' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
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 requested media type is unsupported" $ do
let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
, "application/nonsense")]
put'' "/" "anything at all" `shouldRespondWith` 415
type PatchApi =
ReqBody '[JSON] Person :> Patch '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
:<|> "empty" :> Patch '[] ()
patchApi :: Proxy PatchApi
patchApi = Proxy
patchSpec :: Spec
patchSpec = do
describe "Servant.API.Patch and .ReqBody" $ do
let server = return . age :<|> return . age :<|> return ()
with (return $ serve patchApi server) $ do
let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/json;charset=utf-8")]
it "allows to patch a Person" $ do
patch' "/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "allows alternative routes if all have request bodies" $ do
patch' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
it "handles trailing '/' gracefully" $ do
patch' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 200
}
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 requested media type is unsupported" $ do
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/nonsense")]
patch'' "/" "anything at all" `shouldRespondWith` 415
type HeaderApi a = Header "MyHeader" a :> Delete
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy