servant-quickcheck 0.0.10.0 → 0.1.0.0

raw patch · 9 files changed

+147/−177 lines, 9 filesdep −semigroupsdep −string-conversionsdep ~QuickCheckdep ~aesondep ~basesetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies removed: semigroups, string-conversions

Dependency ranges changed: QuickCheck, aeson, base, base-compat-batteries, bytestring, hspec, hspec-core, http-client, mtl, servant, servant-client, servant-server, text, time, warp

API changes (from Hackage documentation)

Files

• CHANGELOG.yaml +4/−11
• LICENSE +6/−27
• Setup.hs +0/−2
• servant-quickcheck.cabal +29/−32
• src/Servant/QuickCheck/Internal/Equality.hs +32/−24
• src/Servant/QuickCheck/Internal/ErrorTypes.hs +14/−16
• src/Servant/QuickCheck/Internal/HasGenRequest.hs +39/−32
• src/Servant/QuickCheck/Internal/Predicates.hs +18/−26
• src/Servant/QuickCheck/Internal/QuickCheck.hs +5/−7

@@ -1,16 +1,9 @@ releases:-  - version: "0.0.10.0"-    changes:-      - description: "Support servant-server-0.18 (#72)"-        authors: maksbotan-        date: 2020-07-31--  - version: "0.0.9.1"+  - version: "0.1.0.0"     changes:-      - description: "Fix lower version bounds for servant packages. (7926ad6b)"-        authors: fisx-        date: 2020-07-10-+      - description: "Support servant{-server,-client} up to 0.20, support base up to 4.19, drop support for some older servant and base versions, drop support for stack, drop testing for some older ghc versions"+        authors: mangoiv+        date: 2024-04-02   - version: "0.0.9.0"     changes:       - description: "Support servant-0.15 (#65)"

@@ -1,30 +1,9 @@-Copyright (c) 2016, Julian K. Arni--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.+Copyright (c) 2024 Julian K. Arni -    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -    * Neither the name of Julian K. Arni nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.+    1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,23 +1,23 @@+cabal-version:      3.4 name:               servant-quickcheck-version:            0.0.10.0+version:            0.1.0.0 synopsis:           QuickCheck entire APIs description:-  This packages provides QuickCheck properties that are tested across an entire-  API.+  This packages provides QuickCheck properties that are tested across an entire API. -license:            BSD3+license:            BSD-3-Clause license-file:       LICENSE author:             Julian K. Arni-maintainer:         jkarni@gmail.com+maintainer:         haskell-servant-maintainers@googlegroups.com category:           Web build-type:         Simple-cabal-version:      >=1.10 extra-source-files: CHANGELOG.yaml-tested-with:        GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3+tested-with:        GHC ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.1  source-repository head   type:     git-  location: https://github.com/haskell-servant/servant-quickcheck+  location: https://github.com/haskell-servant/servant.git+  subdir:   servant-quickcheck  flag long-tests   description: Run more QuickCheck tests@@ -33,38 +33,34 @@     Servant.QuickCheck.Internal.Predicates     Servant.QuickCheck.Internal.QuickCheck +  ghc-options:        -Wall -Wcompat   build-depends:-      aeson                  >=0.8    && <2-    , base                   >=4.9    && <4.15-    , base-compat-batteries  >=0.10.1 && <0.12-    , bytestring             >=0.10   && <0.11+      aeson                  >=0.8    && <2.3+    , base                   >=4.9    && <4.20+    , base-compat-batteries  >=0.10.1 && <0.15+    , bytestring             >=0.10   && <0.13     , case-insensitive       >=1.2    && <1.3     , clock                  >=0.7    && <0.9     , data-default-class     >=0.0    && <0.2-    , hspec                  >=2.5.6  && <2.8-    , http-client            >=0.4.30 && <0.8+    , hspec                  >=2.5.6  && <2.12+    , http-client            >=0.7.0  && <0.8     , http-media             >=0.6    && <0.9     , http-types             >=0.8    && <0.13-    , mtl                    >=2.1    && <2.3+    , mtl                    >=2.1    && <2.4     , pretty                 >=1.1    && <1.2     , process                >=1.2    && <1.7-    , QuickCheck             >=2.7    && <2.15-    , servant                >=0.17   && <0.19-    , servant-client         >=0.17   && <0.19-    , servant-server         >=0.17   && <0.19+    , QuickCheck             >=2.7    && <2.16+    , servant                >=0.18.2 && <0.21+    , servant-client         >=0.17   && <0.21+    , servant-server         >=0.17   && <0.21     , split                  >=0.2    && <0.3-    , string-conversions     >=0.3    && <0.5     , temporary              >=1.2    && <1.4-    , text                   >=1      && <2-    , time                   >=1.5    && <1.11-    , warp                   >=3.2.4  && <3.4--  if !impl(ghc >=8.0)-    build-depends: semigroups >=0.18.3 && <0.20+    , text                   >=1      && <2.2+    , time                   >=1.5    && <1.13+    , warp                   >=3.2.4  && <3.5    hs-source-dirs:     src   default-extensions:-    NoImplicitPrelude     ConstraintKinds     DataKinds     DeriveDataTypeable@@ -76,6 +72,7 @@     GADTs     KindSignatures     MultiParamTypeClasses+    NoImplicitPrelude     OverloadedStrings     RankNTypes     ScopedTypeVariables@@ -85,12 +82,12 @@  test-suite spec   type:               exitcode-stdio-1.0-  ghc-options:        -Wall -threaded+  ghc-options:        -Wall -Wcompat -threaded   default-language:   Haskell2010   hs-source-dirs:     test   main-is:            Spec.hs   other-modules:      Servant.QuickCheck.InternalSpec-  build-tool-depends: hspec-discover:hspec-discover -any+  build-tool-depends: hspec-discover:hspec-discover   build-depends:       aeson     , base@@ -98,7 +95,7 @@     , blaze-html     , bytestring     , hspec-    , hspec-core             >=2.5.5 && <2.8+    , hspec-core             >=2.5.5 && <2.12     , http-client     , QuickCheck     , quickcheck-io@@ -111,11 +108,11 @@     , warp    default-extensions:-    NoImplicitPrelude     DataKinds     FlexibleContexts     FlexibleInstances     GADTs+    NoImplicitPrelude     OverloadedStrings     ScopedTypeVariables     TypeOperators@@ -127,7 +124,7 @@   type:             exitcode-stdio-1.0   main-is:          Main.hs   hs-source-dirs:   example-  ghc-options:      -Wall+  ghc-options:      -Wall -Wcompat   build-depends:       base     , hspec

@@ -1,40 +1,48 @@ module Servant.QuickCheck.Internal.Equality where -import Data.Aeson          (Value, decode, decodeStrict)-import Data.ByteString     (ByteString)+import           Data.Aeson           (Value, decode, decodeStrict)+import           Data.ByteString      (ByteString) import qualified Data.ByteString.Lazy as LB-import Data.Function       (on)-import Network.HTTP.Client (Response, responseBody)-import Data.Semigroup      (Semigroup (..))-import Prelude.Compat+import           Data.Function        (on)+import           Network.HTTP.Client  (Response (..), equivCookieJar, responseBody)+import           Prelude.Compat -newtype ResponseEquality b-  = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }+newtype ResponseEquality b = ResponseEquality {getResponseEquality :: Response b -> Response b -> Bool}  instance Semigroup (ResponseEquality b) where   ResponseEquality a <> ResponseEquality b = ResponseEquality $ \x y ->-    a x y && b x y  +    a x y && b x y  instance Monoid (ResponseEquality b) where   mempty = ResponseEquality $ \_ _ -> True   mappend = (<>) --- | Use `Eq` instance for `Response`------ /Since 0.0.0.0/-allEquality :: Eq b => ResponseEquality b-allEquality = ResponseEquality (==)+{- | Use `Eq` instance for `Response` --- | ByteString `Eq` instance over the response body.------ /Since 0.0.0.0/-bodyEquality :: Eq b => ResponseEquality b+/Since 0.0.0.0/+-}+allEquality :: (Eq b) => ResponseEquality b+allEquality = ResponseEquality $ \respa respb ->+  and+    [ responseStatus respa == responseStatus respb+    , responseVersion respa == responseVersion respb+    , responseHeaders respa == responseHeaders respb+    , responseBody respa == responseBody respb+    , responseCookieJar respa `equivCookieJar` responseCookieJar respb+    ]++{- | ByteString `Eq` instance over the response body.++/Since 0.0.0.0/+-}+bodyEquality :: (Eq b) => ResponseEquality b bodyEquality = ResponseEquality ((==) `on` responseBody) --- | Equality as 'Value'. This means that if two bodies are equal as JSON--- (e.g., insignificant whitespace difference) they are considered equal.------ /Since 0.0.3.0/+{- | Equality as 'Value'. This means that if two bodies are equal as JSON+(e.g., insignificant whitespace difference) they are considered equal.++/Since 0.0.3.0/+-} jsonEquality :: (JsonEq b) => ResponseEquality b jsonEquality = ResponseEquality (jsonEq `on` responseBody) @@ -52,7 +60,7 @@ compareDecodedResponses :: Maybe Value -> Maybe Value -> Bool compareDecodedResponses resp1 resp2 =   case resp1 of-    Nothing -> False  -- if decoding fails we assume failure+    Nothing -> False -- if decoding fails we assume failure     (Just r1) -> case resp2 of-      Nothing -> False  -- another decode failure+      Nothing   -> False -- another decode failure       (Just r2) -> r1 == r2

@@ -3,7 +3,7 @@  import           Control.Exception       (Exception (..)) import qualified Data.ByteString.Lazy    as LBS-import           Data.String.Conversions (cs)+import qualified Data.ByteString.Char8   as BS8 import qualified Data.Text               as T import           Data.Typeable           (Typeable) import           GHC.Generics            (Generic)@@ -12,6 +12,7 @@ import           Text.PrettyPrint  import           Prelude.Compat hiding ((<>))+import qualified Data.ByteString.Lazy.Char8 as BSL8  data PredicateFailure   = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)@@ -42,37 +43,34 @@  prettyReq :: C.Request -> Doc prettyReq r =-  text "Request:" $$ (nest 5 $-     text "Method:"   <+> (nest 5 $ text . show $ C.method r)-  $$ text "Path:"     <+> (nest 5 $ text . cs $ C.path r)-  $$ text "Headers:"  <+> (nest 5 $ prettyHeaders $ C.requestHeaders r)-  $$ text "Body:"     <+> (nest 5 $ text . getReqBody $ C.requestBody r))+  text "Request:" $$ nest 5 (text "Method:"   <+> nest 5 (text . show $ C.method r)+  $$ text "Path:"     <+> nest 5 (text . BS8.unpack $ C.path r)+  $$ text "Headers:"  <+> nest 5 (prettyHeaders $ C.requestHeaders r)+  $$ text "Body:"     <+> nest 5 (text . getReqBody $ C.requestBody r))   where-    getReqBody (C.RequestBodyLBS lbs ) = cs lbs-    getReqBody (C.RequestBodyBS bs ) = cs bs+    getReqBody :: C.RequestBody -> String+    getReqBody (C.RequestBodyLBS lbs ) = BSL8.unpack lbs+    getReqBody (C.RequestBodyBS bs ) = BS8.unpack bs     getReqBody _ = error "expected bytestring body"  prettyResp :: C.Response LBS.ByteString -> Doc prettyResp r =-  text "Response:" $$ (nest 5 $-     text "Status code:" <+> (nest 5 $ text . show . statusCode $ C.responseStatus r)-  $$ text "Headers:"  $$ (nest 10 $ prettyHeaders $ C.responseHeaders r)-  $$ text "Body:"     <+> (nest 5 $ text . cs $ C.responseBody r))+  text "Response:" $$ nest 5 (text "Status code:" <+> nest 5 (text . show . statusCode $ C.responseStatus r)+  $$ text "Headers:"  $$ nest 10 (prettyHeaders $ C.responseHeaders r)+  $$ text "Body:"     <+> nest 5 (text . BSL8.unpack $ C.responseBody r))    prettyServerEqualityFailure :: ServerEqualityFailure -> Doc prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =-  text "Server equality failed" $$ (nest 5 $-     prettyReq req+  text "Server equality failed" $$ nest 5 (prettyReq req   $$ prettyResp resp1   $$ prettyResp resp2)   prettyPredicateFailure :: PredicateFailure -> Doc prettyPredicateFailure (PredicateFailure predicate req resp) =-  text "Predicate failed" $$ (nest 5 $-     text "Predicate:" <+> (text $ T.unpack predicate)+  text "Predicate failed" $$ nest 5 (text "Predicate:" <+> text (T.unpack predicate)   $$ r   $$ prettyResp resp)   where

@@ -1,21 +1,26 @@-{-# LANGUAGE CPP       #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE CPP        #-}+{-# LANGUAGE PolyKinds  #-}+{-# LANGUAGE StarIsType #-} module Servant.QuickCheck.Internal.HasGenRequest where -import Data.String              (fromString)-import Data.String.Conversions  (cs)-import GHC.TypeLits             (KnownSymbol, Nat, symbolVal)-import Network.HTTP.Client      (Request, RequestBody (..), host, method, path,-                                 port, queryString, requestBody, requestHeaders,-                                 secure, defaultRequest)-import Network.HTTP.Media       (renderHeader)-import Prelude.Compat-import Servant-import Servant.API.ContentTypes (AllMimeRender (..))-import Servant.Client           (BaseUrl (..), Scheme (..))-import Test.QuickCheck          (Arbitrary (..), Gen, elements, frequency)+import           Data.Kind                (Type)+import           Data.String              (fromString)+import qualified Data.Text.Encoding as Text+import qualified Data.ByteString.Char8 as BS8+import           GHC.TypeLits             (KnownSymbol, Nat, symbolVal)+import           Network.HTTP.Client      (Request, RequestBody (..),+                                           defaultRequest, host, method, path,+                                           port, queryString, requestBody,+                                           requestHeaders, secure)+import           Network.HTTP.Media       (renderHeader)+import           Prelude.Compat+import           Servant+import           Servant.API.ContentTypes (AllMimeRender (..))+import           Servant.Client           (BaseUrl (..), Scheme (..))+import           Test.QuickCheck          (Arbitrary (..), Gen, elements,+                                           frequency) -import qualified Data.ByteString as BS+import qualified Data.ByteString          as BS import qualified Data.ByteString.Internal as BS (c2w)  @@ -61,15 +66,14 @@                             in r { path = "/" <> BS.intercalate "/" paths })       where         (oldf, old) = genRequest (Proxy :: Proxy b)-        new = cs $ symbolVal (Proxy :: Proxy path)+        new = BS8.pack $ symbolVal (Proxy :: Proxy path)  instance HasGenRequest EmptyAPI where   genRequest _ = (0, error "EmptyAPIs cannot be queried.") -instance HasGenRequest api => HasGenRequest (Summary d :> api) where-  genRequest _ = genRequest (Proxy :: Proxy api)--instance HasGenRequest api => HasGenRequest (Description d :> api) where+-- | capture all path pieces that do not have semantics relevant to 'HasGenRequest'; this is to maintain backwards compatibility+--   without having to introduce CPP for every new URL piece that basically is irrelevant for this class+instance {-# OVERLAPPABLE #-} HasGenRequest api => HasGenRequest (f d :> api) where   genRequest _ = genRequest (Proxy :: Proxy api)  instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )@@ -77,7 +81,7 @@     genRequest _ = (oldf, do       old' <- old       new' <- toUrlPiece <$> new-      return $ \burl -> let r = old' burl in r { path = cs new' <> path r })+      return $ \burl -> let r = old' burl in r { path = Text.encodeUtf8 new' <> path r })       where         (oldf, old) = genRequest (Proxy :: Proxy b)         new = arbitrary :: Gen c@@ -86,7 +90,7 @@     => HasGenRequest (CaptureAll x c :> b) where     genRequest _ = (oldf, do       old' <- old-      new' <- fmap (cs . toUrlPiece) <$> new+      new' <- fmap (Text.encodeUtf8 . toUrlPiece) <$> new       let new'' = BS.intercalate "/" new'       return $ \burl -> let r = old' burl in r { path = new'' <> path r })       where@@ -99,7 +103,7 @@       old' <- old       new' <- toUrlPiece <$> new  -- TODO: generate lenient or/and optional       return $ \burl -> let r = old' burl in r {-          requestHeaders = (hdr, cs new') : requestHeaders r })+          requestHeaders = (hdr, Text.encodeUtf8 new') : requestHeaders r })       where         (oldf, old) = genRequest (Proxy :: Proxy b)         hdr = fromString $ symbolVal (Proxy :: Proxy h)@@ -125,12 +129,12 @@       new' <- new  -- TODO: generate lenient or/and optional       old' <- old       return $ \burl -> let r = old' burl-                            newExpr = param <> "=" <> cs (toQueryParam new')+                            newExpr = param <> "=" <> Text.encodeUtf8 (toQueryParam new')                             qs = queryString r in r {           queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })       where         (oldf, old) = genRequest (Proxy :: Proxy b)-        param = cs $ symbolVal (Proxy :: Proxy x)+        param = BS8.pack $ symbolVal (Proxy :: Proxy x)         new = arbitrary :: Gen c  instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)@@ -140,12 +144,12 @@       old' <- old       return $ \burl -> let r = old' burl in r {           queryString = queryString r-                     <> if length new' > 0 then fold (toParam <$> new') else ""})+                     <> if not (null new') then fold (toParam <$> new') else ""})       where         (oldf, old) = genRequest (Proxy :: Proxy b)-        param = cs $ symbolVal (Proxy :: Proxy x)+        param = BS8.pack $ symbolVal (Proxy :: Proxy x)         new = arbitrary :: Gen [c]-        toParam c = param <> "[]=" <> cs (toQueryParam c)+        toParam c = param <> "[]=" <> Text.encodeUtf8 (toQueryParam c)         fold = foldr1 (\a b -> a <> "&" <> b)  instance (KnownSymbol x, HasGenRequest b)@@ -157,12 +161,12 @@           queryString = if BS.null qs then param else param <> "&" <> qs })       where         (oldf, old) = genRequest (Proxy :: Proxy b)-        param = cs $ symbolVal (Proxy :: Proxy x)+        param = BS8.pack $ symbolVal (Proxy :: Proxy x)  instance (ReflectMethod method)-    => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where+    => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [Type]) a) where     genRequest _ = (1, return $ \burl -> defaultRequest-       { host = cs $ baseUrlHost burl+       { host = BS8.pack $ baseUrlHost burl        , port = baseUrlPort burl        , secure = baseUrlScheme burl == Https        , method = reflectMethod (Proxy :: Proxy method)@@ -171,7 +175,7 @@ instance (ReflectMethod method)     => HasGenRequest (NoContentVerb (method :: k)) where     genRequest _ = (1, return $ \burl -> defaultRequest-       { host = cs $ baseUrlHost burl+       { host = BS8.pack $ baseUrlHost burl        , port = baseUrlPort burl        , secure = baseUrlScheme burl == Https        , method = reflectMethod (Proxy :: Proxy method)@@ -194,4 +198,7 @@  -- TODO: Try logging in instance (HasGenRequest a) => HasGenRequest (BasicAuth x y :> a) where+    genRequest _ = genRequest (Proxy :: Proxy a)++instance (HasGenRequest a) => HasGenRequest (Fragment v :> a) where     genRequest _ = genRequest (Proxy :: Proxy a)

@@ -11,7 +11,6 @@ import           Data.Either           (isRight) import           Data.List.Split       (wordsBy) import           Data.Maybe            (fromMaybe, isJust)-import           Data.Semigroup        (Semigroup (..)) import qualified Data.Text             as T import           Data.Time             (UTCTime, defaultTimeLocale, parseTimeM,                                         rfc822DateFormat)@@ -155,7 +154,7 @@ getsHaveLastModifiedHeader :: RequestPredicate getsHaveLastModifiedHeader   = RequestPredicate $ \req mgr ->-     if (method req == methodGet)+     if method req == methodGet       then do         resp <- httpLbs req mgr         unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do@@ -189,7 +188,7 @@   = RequestPredicate $ \req mgr -> do       let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]                                                       , renderStdMethod m /= method req ]-      resp <- mapM (flip httpLbs mgr) reqs+      resp <- mapM (`httpLbs` mgr) reqs        case filter pred' (zip reqs resp) of         (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)@@ -197,7 +196,7 @@     where       pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)         where-          go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)+          go x = all (isRight . parseMethod . SBSC.pack)                $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)  @@ -223,11 +222,9 @@       let scode = responseStatus resp           sctype = lookup "Content-Type" $ responseHeaders resp           sacc  = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)-      if status100 < scode && scode < status300-        then if isJust $ sctype >>= \x -> matchAccept [x] sacc-          then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp-          else return [resp]-        else return [resp]+      (if (status100 < scode && scode < status300) && isJust (sctype >>= \x -> matchAccept [x] sacc)+        then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp+        else return [resp])   -- | [__Best Practice__]@@ -247,7 +244,7 @@ getsHaveCacheControlHeader :: RequestPredicate getsHaveCacheControlHeader   = RequestPredicate $ \req mgr ->-     if (method req == methodGet)+     if method req == methodGet       then do         resp <- httpLbs req mgr         unless (hasValidHeader "Cache-Control" (const True) resp) $ do@@ -263,7 +260,7 @@ headsHaveCacheControlHeader :: RequestPredicate headsHaveCacheControlHeader   = RequestPredicate $ \req mgr ->-     if (method req == methodHead)+     if method req == methodHead        then do          resp <- httpLbs req mgr          unless (hasValidHeader "Cache-Control" (const True) resp) $@@ -334,10 +331,9 @@ unauthorizedContainsWWWAuthenticate :: ResponsePredicate unauthorizedContainsWWWAuthenticate   = ResponsePredicate $ \resp ->-      if responseStatus resp == status401-        then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $+      when (responseStatus resp == status401) $+        unless (hasValidHeader "WWW-Authenticate" (const True) resp) $           throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp-        else return ()   -- | [__RFC Compliance__]@@ -354,12 +350,10 @@ htmlIncludesDoctype :: ResponsePredicate htmlIncludesDoctype   = ResponsePredicate $ \resp ->-      if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp-        then do-            let htmlContent = foldCase . LBS.take 20 $ responseBody resp-            unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $-              throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp-        else return ()+      when (hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp) $ do+          let htmlContent = foldCase . LBS.take 20 $ responseBody resp+          unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $+            throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp  -- * Predicate logic @@ -392,7 +386,7 @@  -- TODO: This isn't actually a monoid instance Monoid RequestPredicate where-  mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))+  mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return [x])   mappend = (<>)  -- TODO: This isn't actually a monoid@@ -417,10 +411,10 @@ class JoinPreds a where   joinPreds :: a -> Predicates -> Predicates -instance JoinPreds (RequestPredicate ) where+instance JoinPreds RequestPredicate where   joinPreds p (Predicates x y) = Predicates (p <> x) y -instance JoinPreds (ResponsePredicate ) where+instance JoinPreds ResponsePredicate where   joinPreds p (Predicates x y) = Predicates x (p <> y)  -- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to@@ -444,9 +438,7 @@ -- * helpers  hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bool-hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of-  Nothing -> False-  Just v  -> p v+hasValidHeader hdr p r = maybe False p (lookup (mk hdr) (responseHeaders r))  isRFC822Date :: SBS.ByteString -> Bool isRFC822Date s

@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Servant.QuickCheck.Internal.QuickCheck where @@ -21,7 +20,6 @@ import           Test.QuickCheck.Monadic  (assert, forAllM, monadicIO, monitor,                                            run) import           Test.QuickCheck.Property (counterexample)- import Servant.QuickCheck.Internal.Equality import Servant.QuickCheck.Internal.ErrorTypes import Servant.QuickCheck.Internal.HasGenRequest@@ -47,7 +45,7 @@ #endif   => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r withServantServerAndContext api ctx server t-  = withApplication (return . serveWithContext api ctx =<< server) $ \port ->+  = withApplication (serveWithContext api ctx <$> server) $ \port ->       t (BaseUrl Http "localhost" port "")  -- | Check that the two servers running under the provided @BaseUrl@s behave@@ -90,7 +88,7 @@       assert False   case r of     Success {} -> return ()-    Failure{..} -> do+    Failure {} -> do       mx <- tryReadMVar deetsMVar       case mx of         Just x ->@@ -146,7 +144,7 @@       _ -> return ()   case r of     Success {} -> return ()-    Failure {..} -> do+    Failure {} -> do       mx <- tryReadMVar deetsMVar       case mx of         Just x ->@@ -154,7 +152,7 @@         Nothing ->           expectationFailure $ "We failed to record a reason for failure: " <> show r     GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"-    NoExpectedFailure {} -> expectationFailure $ "No expected failure"+    NoExpectedFailure {} -> expectationFailure "No expected failure" #if MIN_VERSION_QuickCheck(2,12,0) #else     InsufficientCoverage {} -> expectationFailure "Insufficient coverage"@@ -175,7 +173,7 @@     Success {} -> return ()     GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"     Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m-    NoExpectedFailure {} -> expectationFailure $ "No expected failure"+    NoExpectedFailure {} -> expectationFailure "No expected failure" #if MIN_VERSION_QuickCheck(2,12,0) #else     InsufficientCoverage {} -> expectationFailure "Insufficient coverage"