diff --git a/CHANGELOG.yaml b/CHANGELOG.yaml --- a/CHANGELOG.yaml +++ b/CHANGELOG.yaml @@ -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)" diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -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 diff --git a/src/Servant/QuickCheck/Internal/Equality.hs b/src/Servant/QuickCheck/Internal/Equality.hs --- a/src/Servant/QuickCheck/Internal/Equality.hs +++ b/src/Servant/QuickCheck/Internal/Equality.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal/ErrorTypes.hs b/src/Servant/QuickCheck/Internal/ErrorTypes.hs --- a/src/Servant/QuickCheck/Internal/ErrorTypes.hs +++ b/src/Servant/QuickCheck/Internal/ErrorTypes.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -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) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -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 "") 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 "") 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 diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -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"