diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index df930374..b92036c6 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -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 diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index e73c565e..6b44e409 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -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