Make onlyJsonObjects succeed in non-JSON endpoints.

CHANGELOG.yaml

@@ -1,5 +1,10 @@
 upcoming:
 
+  - description: Make onlyJsonObjects succeed in non-JSON endpoints
+    issue: 20
+    authors: jkarni
+    date: 2016-10-18
+
 releases:
 
   - version: "0.0.2.1"
@@ -15,9 +20,9 @@ releases:
         authors: jkarni
         date: 2016-10-03
 
-      - description: Raise upper bounds 
+      - description: Raise upper bounds
         notes: >
-            For Quickcheck, aeson, http-client, servant, servant-client and 
+            For Quickcheck, aeson, http-client, servant, servant-client and
             servant-server.
         pr: none
         authors: jkarni

servant-quickcheck.cabal

@@ -85,6 +85,7 @@ test-suite spec
   build-depends:       base == 4.*
                      , base-compat
                      , servant-quickcheck
+                     , bytestring
                      , hspec
                      , hspec-core
                      , http-client

src/Servant/QuickCheck/Internal/Predicates.hs

@@ -1,29 +1,32 @@
 module Servant.QuickCheck.Internal.Predicates where
 
 import           Control.Exception     (catch, throw)
-import           Control.Monad         (when, unless, liftM2)
+import           Control.Monad         (liftM2, unless, when)
 import           Data.Aeson            (Object, decode)
+import           Data.Bifunctor        (first)
 import qualified Data.ByteString       as SBS
 import qualified Data.ByteString.Char8 as SBSC
 import qualified Data.ByteString.Lazy  as LBS
-import           Data.CaseInsensitive  (mk)
+import           Data.CaseInsensitive  (mk, foldedCase)
 import           Data.Either           (isRight)
 import           Data.List.Split       (wordsBy)
 import           Data.Maybe            (fromMaybe, isJust)
 import           Data.Monoid           ((<>))
-import           Data.Time             (parseTimeM, defaultTimeLocale,
+import           Data.Time             (UTCTime, defaultTimeLocale, parseTimeM,
-                                        rfc822DateFormat, UTCTime)
+                                        rfc822DateFormat)
 import           GHC.Generics          (Generic)
 import           Network.HTTP.Client   (Manager, Request, Response, httpLbs,
-                                        method, requestHeaders, responseBody,
+                                        method, parseRequest, requestHeaders,
-                                        responseHeaders, parseRequest, responseStatus)
+                                        responseBody, responseHeaders,
+                                        responseStatus)
 import           Network.HTTP.Media    (matchAccept)
 import           Network.HTTP.Types    (methodGet, methodHead, parseMethod,
                                         renderStdMethod, status100, status200,
                                         status201, status300, status401,
                                         status405, status500)
-import           System.Clock           (toNanoSecs, Clock(Monotonic), getTime, diffTimeSpec)
 import           Prelude.Compat
+import           System.Clock          (Clock (Monotonic), diffTimeSpec,
+                                        getTime, toNanoSecs)
 
 import Servant.QuickCheck.Internal.ErrorTypes
 
@@ -80,9 +83,15 @@ notLongerThan maxAllowed
 -- /Since 0.0.0.0/
 onlyJsonObjects :: ResponsePredicate
 onlyJsonObjects
-  = ResponsePredicate (\resp -> case decode (responseBody resp) of
+  = ResponsePredicate (\resp -> case go resp of
       Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
-      Just (_ :: Object) -> return ())
+      Just () -> return ())
+    where
+      go r = do
+        ctyp <- lookup "content-type" (first foldedCase <$> responseHeaders r)
+        when ("application/json" `SBS.isPrefixOf` ctyp) $ do
+          (_ :: Object) <- decode (responseBody r)
+          return ()
 
 -- | __Optional__
 --
@@ -353,7 +362,7 @@ instance Monoid ResponsePredicate where
 --
 -- /Since 0.0.0.0/
 newtype RequestPredicate = RequestPredicate
-  { getRequestPredicate    :: Request -> Manager -> IO [Response LBS.ByteString]
+  { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
   } deriving (Generic)
 
 -- TODO: This isn't actually a monoid
@@ -364,7 +373,7 @@ instance Monoid RequestPredicate where
 
 -- | A set of predicates. Construct one with 'mempty' and '<%>'.
 data Predicates = Predicates
-  { requestPredicates :: RequestPredicate
+  { requestPredicates  :: RequestPredicate
   , responsePredicates :: ResponsePredicate
   } deriving (Generic)
 

test/Servant/QuickCheck/InternalSpec.hs

@@ -1,20 +1,22 @@
 {-# LANGUAGE CPP #-}
 module Servant.QuickCheck.InternalSpec (spec) where
 
-import Control.Concurrent.MVar                    (newMVar, readMVar, swapMVar)
+import           Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
-import Control.Monad.IO.Class                     (liftIO)
+import           Control.Monad.IO.Class  (liftIO)
-import Prelude.Compat
+import qualified Data.ByteString         as BS
-import Servant
+import           Prelude.Compat
+import           Servant
+import           Test.Hspec              (Spec, context, describe, it, shouldBe,
+                                          shouldContain)
+import           Test.Hspec.Core.Spec    (Arg, Example, Result (..),
+                                          defaultParams, evaluateExample)
+
 #if MIN_VERSION_servant(0,8,0)
 import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
 #else
-import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI, ComprehensiveAPI)
+import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
+                                                   comprehensiveAPI)
 #endif
-import Test.Hspec                                 (Spec, context, describe, it,
-                                                   shouldBe, shouldContain)
-import Test.Hspec.Core.Spec                       (Arg, Example, Result (..),
-                                                   defaultParams,
-                                                   evaluateExample)
 
 import Servant.QuickCheck
 import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
@@ -81,6 +83,10 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
         (onlyJsonObjects <%> mempty)
     err `shouldContain` "onlyJsonObjects"
 
+  it "accepts non-JSON endpoints" $ do
+    withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
+      serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
+
 notLongerThanSpec :: Spec
 notLongerThanSpec = describe "notLongerThan" $ do
 
@@ -132,6 +138,14 @@ server2 = return $ return 1
 server3 :: IO (Server API2)
 server3 = return $ return 2
 
+type OctetAPI = Get '[OctetStream] BS.ByteString
+
+octetAPI :: Proxy OctetAPI
+octetAPI = Proxy
+
+serverOctetAPI :: IO (Server OctetAPI)
+serverOctetAPI = return $ return "blah"
+
 ctx :: Context '[BasicAuthCheck ()]
 ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
 ------------------------------------------------------------------------------