From 3189902c4b0dfe4ba69bce9097550e896b4acf8a Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 23 Apr 2016 21:43:03 +0200 Subject: [PATCH] Comprehensive instances for HasGenRequest. --- servant-quickcheck.cabal | 2 + src/Servant/QuickCheck.hs | 1 + .../QuickCheck/Internal/HasGenRequest.hs | 39 +++++++++++++++++++ src/Servant/QuickCheck/Internal/Predicates.hs | 35 +++++++++++------ test/Servant/QuickCheck/InternalSpec.hs | 15 +++++++ 5 files changed, 80 insertions(+), 12 deletions(-) diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 361ccb2..996cecb 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -41,6 +41,7 @@ library , warp >= 3.2.4 && < 3.3 , process == 1.2.* , temporary == 1.2.* + , case-insensitive , hspec , text == 1.* hs-source-dirs: src @@ -74,6 +75,7 @@ test-suite spec , warp , servant-server , servant-client + , servant , transformers , QuickCheck , quickcheck-io diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index 1dadda1..ecb06e3 100644 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -36,6 +36,7 @@ module Servant.QuickCheck , (<%>) , Predicates , not500 + , onlyJsonObjects -- ** Re-exports , BaseUrl(..) diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs index 27a5f0d..b0ed6a8 100644 --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -82,6 +82,31 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b) param = cs $ symbolVal (Proxy :: Proxy x) new = arbitrary :: Gen c +instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b) + => HasGenRequest (QueryParams x c :> b) where + genRequest _ = do + new' <- new + old' <- old + return $ \burl -> let r = old' burl in r { + queryString = queryString r + <> if length new' > 0 then fold (toParam <$> new') else ""} + where + old = genRequest (Proxy :: Proxy b) + param = cs $ symbolVal (Proxy :: Proxy x) + new = arbitrary :: Gen [c] + toParam c = param <> "[]=" <> cs (toQueryParam c) + fold = foldr1 (\a b -> a <> "&" <> b) + +instance (KnownSymbol x, HasGenRequest b) + => HasGenRequest (QueryFlag x :> b) where + genRequest _ = do + old' <- old + return $ \burl -> let r = old' burl in r { + queryString = queryString r <> param <> "=" } + where + old = genRequest (Proxy :: Proxy b) + param = cs $ symbolVal (Proxy :: Proxy x) + instance (ReflectMethod method) => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where genRequest _ = return $ \burl -> def @@ -91,3 +116,17 @@ instance (ReflectMethod method) , method = reflectMethod (Proxy :: Proxy method) } +instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where + genRequest _ = genRequest (Proxy :: Proxy a) + +instance (HasGenRequest a) => HasGenRequest (IsSecure :> a) where + genRequest _ = genRequest (Proxy :: Proxy a) + +instance (HasGenRequest a) => HasGenRequest (HttpVersion :> a) where + genRequest _ = genRequest (Proxy :: Proxy a) + +instance (HasGenRequest a) => HasGenRequest (Vault :> a) where + genRequest _ = genRequest (Proxy :: Proxy a) + +instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where + genRequest _ = genRequest (Proxy :: Proxy a) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index eca2740..e8209cd 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -1,13 +1,17 @@ module Servant.QuickCheck.Internal.Predicates where -import Data.Monoid ((<>)) -import GHC.Generics (Generic) -import Control.Monad -import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs) -import Network.HTTP.Types (status500) +import Control.Monad +import Data.Aeson (Object, decode) +import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString.Lazy as LBS -import Data.Bifunctor (Bifunctor(..)) -import Data.Text (Text) +import qualified Data.ByteString as SBS +import Data.CaseInsensitive (mk) +import Data.Monoid ((<>)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.HTTP.Client (Manager, Request, Response, httpLbs, + responseBody, responseStatus, responseHeaders) +import Network.HTTP.Types (status500) -- | @500 Internal Server Error@ should be avoided - it may represent some -- issue with the application code, and it moreover gives the client little @@ -17,7 +21,6 @@ import Data.Text (Text) not500 :: ResponsePredicate Text Bool not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500) -{- -- | Returning anything other than an object when returning JSON is considered -- bad practice, as: -- @@ -30,10 +33,13 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu -- -- This function checks that any @application/json@ responses only return JSON -- objects (and not arrays, strings, numbers, or booleans) at the top level. -onlyJsonObjects :: Response b -> IO Bool +onlyJsonObjects :: ResponsePredicate Text Bool onlyJsonObjects - = ResponsePredicate "onlyJsonObjects" _ + = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of + Nothing -> False + Just (_ :: Object) -> True) +{- -- | When creating a new resource, it is good practice to provide a @Location@ -- header with a link to the created resource. -- @@ -42,9 +48,9 @@ onlyJsonObjects -- requests. -- -- References: -createContainsValidLocation :: Response b -> IO Bool +createContainsValidLocation :: ResponsePredicate Text Bool createContainsValidLocation - = ResponsePredicate "createContainsValidLocation" _ + = ResponsePredicate "createContainsValidLocation" (\resp -> getsHaveLastModifiedHeader :: Response b -> IO Bool getsHaveLastModifiedHeader @@ -221,3 +227,8 @@ finishPredicates p req mgr = do resps <- reqResps (reqPreds p) req mgr let preds = reqPred (reqPreds p) <> respPreds p return $ mconcat [respPred preds r | r <- resps ] + +-- * helpers + +hasHeader :: SBS.ByteString -> Response b -> Bool +hasHeader hdr r = mk hdr `elem` (fst <$> responseHeaders r) diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index bad7836..41ccd31 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -8,13 +8,17 @@ import Data.Proxy import Servant import Test.Hspec import Test.QuickCheck +import Servant.API.Internal.Test.ComprehensiveAPI import Servant.QuickCheck +import Servant.QuickCheck.Internal (genRequest) + spec :: Spec spec = do serversEqualSpec serverSatisfiesSpec + isComprehensiveSpec serversEqualSpec :: Spec serversEqualSpec = describe "serversEqual" $ do @@ -32,6 +36,17 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do withServantServer api server $ \burl -> serverSatisfies api burl args (not500 <%> mempty) + it "fails for false predicates" $ do + withServantServer api server $ \burl -> + serverSatisfies api burl args (onlyJsonObjects <%> mempty) + +isComprehensiveSpec :: Spec +isComprehensiveSpec = describe "HasGenRequest" $ do + + it "has instances for all 'servant' combinators" $ do + let _g = genRequest comprehensiveAPI + True `shouldBe` True -- This is a type-level check + ------------------------------------------------------------------------------ -- APIs