Merge pull request #72 from codedmart/deleteFix

Allow zero content types on delete. fixes #69

servant-client/CHANGELOG.md

@@ -1,3 +1,7 @@
+0.4.1
+-----
+* The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided.
+
 0.4
 ---
 * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

servant-client/src/Servant/Client.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
 #if !MIN_VERSION_base(4,8,0)
 {-# LANGUAGE OverlappingInstances #-}
 #endif
@@ -126,8 +127,9 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPABLE #-}
 #endif
-  (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where
-  type Client (Delete (ct ': cts) a) = EitherT ServantError IO a
+  -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
+  (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
+  type Client (Delete cts' a) = EitherT ServantError IO a
   clientWithRoute Proxy req baseurl =
     snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
 
@@ -137,8 +139,8 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-  HasClient (Delete (ct ': cts) ()) where
-  type Client (Delete (ct ': cts) ()) = EitherT ServantError IO ()
+  HasClient (Delete cts ()) where
+  type Client (Delete cts ()) = EitherT ServantError IO ()
   clientWithRoute Proxy req baseurl =
     void $ performRequestNoBody H.methodDelete req [204] baseurl
 
@@ -148,9 +150,10 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-  ( MimeUnrender ct a, BuildHeadersTo ls
-  ) => HasClient (Delete (ct ': cts) (Headers ls a)) where
-  type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
+  -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
+  ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
+  ) => HasClient (Delete cts' (Headers ls a)) where
+  type Client (Delete cts' (Headers ls a)) = EitherT ServantError IO (Headers ls a)
   clientWithRoute Proxy req baseurl = do
     (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
     return $ Headers { getResponse = resp

servant-client/test/Servant/ClientSpec.hs

@@ -80,7 +80,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 
 type Api =
        "get" :> Get '[JSON] Person
-  :<|> "delete" :> Delete '[JSON] ()
+  :<|> "deleteEmpty" :> Delete '[] ()
   :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
   :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
   :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@@ -98,6 +98,7 @@ type Api =
             ReqBody '[JSON] [(String, [Rational])] :>
             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
+  :<|> "deleteContentType" :> Delete '[JSON] ()
 api :: Proxy Api
 api = Proxy
 
@@ -123,6 +124,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 ()
  )
 
 withServer :: (BaseUrl -> IO a) -> IO a
@@ -148,7 +150,7 @@ withFailServer action = withWaiDaemon (return failServer) action
 spec :: IO ()
 spec = withServer $ \ baseUrl -> do
   let getGet :: EitherT ServantError IO Person
-      getDelete :: EitherT ServantError IO ()
+      getDeleteEmpty :: EitherT ServantError IO ()
       getCapture :: String -> EitherT ServantError IO Person
       getBody :: Person -> EitherT ServantError IO Person
       getQueryParam :: Maybe String -> EitherT ServantError IO Person
@@ -161,8 +163,9 @@ spec = withServer $ \ baseUrl -> do
       getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
       getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
       getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)
+      getDeleteContentType :: EitherT ServantError IO ()
       (     getGet
-       :<|> getDelete
+       :<|> getDeleteEmpty
        :<|> getCapture
        :<|> getBody
        :<|> getQueryParam
@@ -174,15 +177,20 @@ spec = withServer $ \ baseUrl -> do
        :<|> getRawSuccess
        :<|> getRawFailure
        :<|> getMultiple
-       :<|> getRespHeaders)
+       :<|> getRespHeaders
+       :<|> getDeleteContentType)
          = client api baseUrl
 
   hspec $ do
     it "Servant.API.Get" $ do
       (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice
 
-    it "Servant.API.Delete" $ do
-      (Arrow.left show <$> runEitherT getDelete) `shouldReturn` Right ()
+    describe "Servant.API.Delete" $ do
+      it "allows empty content type" $ do
+        (Arrow.left show <$> runEitherT getDeleteEmpty) `shouldReturn` Right ()
+
+      it "allows content type" $ do
+        (Arrow.left show <$> runEitherT getDeleteContentType) `shouldReturn` Right ()
 
     it "Servant.API.Capture" $ do
       (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
@@ -274,11 +282,11 @@ spec = withServer $ \ baseUrl -> do
 failSpec :: IO ()
 failSpec = withFailServer $ \ baseUrl -> do
   let getGet :: EitherT ServantError IO Person
-      getDelete :: EitherT ServantError IO ()
+      getDeleteEmpty :: EitherT ServantError IO ()
       getCapture :: String -> EitherT ServantError IO Person
       getBody :: Person -> EitherT ServantError IO Person
       (     getGet
-       :<|> getDelete
+       :<|> getDeleteEmpty
        :<|> getCapture
        :<|> getBody
        :<|> _ )
@@ -289,7 +297,7 @@ failSpec = withFailServer $ \ baseUrl -> do
   hspec $ do
     context "client returns errors appropriately" $ do
       it "reports FailureResponse" $ do
-        Left res <- runEitherT getDelete
+        Left res <- runEitherT getDeleteEmpty
         case res of
           FailureResponse (Status 404 "Not Found") _ _ -> return ()
           _ -> fail $ "expected 404 response, but got " <> show res