Make Post and Put return NoContent when response is ()

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
+         ) => HasServer (Patch ctypes a) where
-         , ToJSON a) => 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
+          Right output -> do
-              Nothing -> do
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
-                  let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-                  case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of
+              Nothing -> responseLBS (mkStatus 406 "") [] ""
-                    Nothing -> responseLBS (mkStatus 406 "") [] ""
+              Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
-                    Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
+                                                             , cs contentT)] body
-                                                                   , cs contentT)] body
-              Just () -> responseLBS status204 [] ""
           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
 

test/Servant/ServerSpec.hs

@@ -1,36 +1,40 @@
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module Servant.ServerSpec where
 
 
-import Control.Monad (when)
+import           Control.Monad              (when)
-import Control.Monad.Trans.Either (EitherT, left)
+import           Control.Monad.Trans.Either (EitherT, left)
-import Data.Aeson (ToJSON, FromJSON, encode, decode')
+import           Data.Aeson                 (FromJSON, ToJSON, decode', encode)
-import Data.Char (toUpper)
+import           Data.Char                  (toUpper)
-import Data.Monoid ((<>))
+import           Data.Monoid                ((<>))
-import Data.Proxy (Proxy(Proxy))
+import           Data.Proxy                 (Proxy (Proxy))
-import Data.String (fromString)
+import           Data.String                (fromString)
-import Data.String.Conversions (cs)
+import           Data.String.Conversions    (cs)
-import GHC.Generics (Generic)
+import           GHC.Generics               (Generic)
-import Network.HTTP.Types ( parseQuery, ok200, status409, methodPost
+import           Network.HTTP.Types         (hContentType, methodDelete,
-                          , methodDelete, hContentType)
+                                             methodPatch, methodPost, methodPut,
-import Network.Wai ( Application, Request, responseLBS, pathInfo
+                                             ok200, parseQuery, status409)
-                   , queryString, rawQueryString )
+import           Network.Wai                (Application, Request, pathInfo,
-import Network.Wai.Test (runSession, defaultRequest, simpleBody, request)
+                                             queryString, rawQueryString,
-import Test.Hspec (Spec, describe, it, shouldBe)
+                                             responseLBS)
-import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith
+import           Network.Wai.Test           (defaultRequest, request,
-                      , matchStatus, 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
+import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
-                   , QueryParams, QueryFlag, MatrixParam, MatrixParams
+                                             Get, Header, JSON, MatrixFlag,
-                   , MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete )
+                                             MatrixParam, MatrixParams, Patch,
-import Servant.Server (Server, serve)
+                                             Post, Put, QueryFlag, QueryParam,
-import Servant.Server.Internal (RouteMismatch(..))
+                                             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