diff --git a/.gitignore b/.gitignore index 9638ef2..6b712bf 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ doc/_build/ +scripts/ diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index df0141c..182c61f 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -1,5 +1,5 @@ name: servant-quickcheck -version: 0.1.0.0 +version: 0.0.0.0 synopsis: QuickCheck entire APIs description: This packages provides QuickCheck properties that are tested across an entire @@ -20,12 +20,12 @@ flag long-tests library exposed-modules: Servant.QuickCheck , Servant.QuickCheck.Internal - -- , Servant.QuickCheck.Internal.Benchmarking , Servant.QuickCheck.Internal.Predicates , Servant.QuickCheck.Internal.HasGenRequest , Servant.QuickCheck.Internal.QuickCheck , Servant.QuickCheck.Internal.Equality build-depends: base >=4.7 && <4.9 + , base-compat == 0.9.* , QuickCheck == 2.8.* , bytestring == 0.10.* , aeson > 0.10 && < 0.12 @@ -63,6 +63,7 @@ library , ScopedTypeVariables , OverloadedStrings , FunctionalDependencies + , NoImplicitPrelude default-language: Haskell2010 test-suite spec @@ -89,16 +90,3 @@ test-suite spec , DataKinds if flag(long-tests) cpp-options: -DLONG_TESTS - --- test-suite doctests --- default-language: Haskell2010 --- type: exitcode-stdio-1.0 --- ghc-options: -threaded --- main-is: Doctest.hs --- hs-source-dirs: test --- build-depends: base >4 && <5 --- , doctest --- , filemanip --- , directory --- , filepath --- HS-Source-Dirs: test diff --git a/src/Servant/QuickCheck/Internal.hs b/src/Servant/QuickCheck/Internal.hs index 3663748..8e52dd4 100644 --- a/src/Servant/QuickCheck/Internal.hs +++ b/src/Servant/QuickCheck/Internal.hs @@ -4,4 +4,3 @@ import Servant.QuickCheck.Internal.HasGenRequest as X import Servant.QuickCheck.Internal.Predicates as X import Servant.QuickCheck.Internal.QuickCheck as X import Servant.QuickCheck.Internal.Equality as X -import Servant.QuickCheck.Internal.Benchmarking as X diff --git a/src/Servant/QuickCheck/Internal/Benchmarking.hs b/src/Servant/QuickCheck/Internal/Benchmarking.hs deleted file mode 100644 index 38b8300..0000000 --- a/src/Servant/QuickCheck/Internal/Benchmarking.hs +++ /dev/null @@ -1,83 +0,0 @@ --- This is a WIP module that shouldn't be used. -module Servant.QuickCheck.Internal.Benchmarking where - -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (toStrict) -import Network.HTTP.Client -import Network.HTTP.Types -import Servant.Client - -data BenchOptions = BenchOptions - { duration :: Int - , threads :: Int - , connections :: Int - , noOfTests :: Int - } deriving (Eq, Show, Read) - -defaultBenchOptions :: BenchOptions -defaultBenchOptions = BenchOptions - { duration = 10 - , threads = 1 - , connections = 10 - , noOfTests = 10 - } - -data WrkScript = WrkScript - { wrkScheme :: Scheme - , wrkHost :: ByteString - , wrkPort :: Int - , wrkMethod :: Method - , wrkPath :: ByteString - , wrkHeaders :: [Header] - , wrkBody :: ByteString - } deriving (Eq, Show) - -mkScript :: WrkScript -> String -mkScript w - = "wrk.scheme = \"" ++ sscheme (wrkScheme w) ++ "\"" - ++ "\nwrk.host = " ++ show (wrkHost w) - ++ "\nwrk.port = " ++ show (wrkPort w) - ++ "\nwrk.method = " ++ show (wrkMethod w) - ++ "\nwrk.path = " ++ show (wrkPath w) - ++ foldr (\(h,v) old -> old ++ "\nwrk.headers[" ++ show h ++ "] = " ++ show v) - "" - (wrkHeaders w) - ++ "\nwrk.body = " ++ show (wrkBody w) - ++ "\n" ++ reportFmt - where - sscheme Http = "http" - sscheme Https = "https" - -reqToWrk :: Request -> WrkScript -reqToWrk r = WrkScript - { wrkScheme = Http - , wrkHost = host r - , wrkPort = port r - , wrkMethod = method r - , wrkPath = path r - , wrkHeaders = requestHeaders r - , wrkBody = case requestBody r of - RequestBodyLBS r' -> toStrict r' - _ -> error "expecting RequestBodyLBS" - } - -reportFmt :: String -reportFmt - = "done = function(summary, latency, requests)\n" - ++ " for _, p in pairs({ 50, 75, 99, 99.999 }) do\n" - ++ " n = latency:percentile(p)\n" - ++ " io.write(string.format(\"%g%%, %d\\n\", p, n))\n" - ++ " end\n" - ++ "end\n" - -{-data BenchResult = BenchResult-} - {-{ benchReq :: Request-} - {-, benchLatencyDist :: [(Percentile, Microsecs)]-} - {-, benchLatencyAvg :: Microsecs-} - {-} deriving (Eq, Show, Read, Generic)-} - -{-newtype Microsecs = Microsecs { unMicroSecs :: Int }-} - {-deriving (Eq, Show, Read, Generic)-} - -{-newtype Percentile = Percentile { unPercentile :: Int }-} - {-deriving (Eq, Show, Read, Generic)-} diff --git a/src/Servant/QuickCheck/Internal/Equality.hs b/src/Servant/QuickCheck/Internal/Equality.hs index f1b9e61..1195dae 100644 --- a/src/Servant/QuickCheck/Internal/Equality.hs +++ b/src/Servant/QuickCheck/Internal/Equality.hs @@ -1,7 +1,8 @@ module Servant.QuickCheck.Internal.Equality where -import Network.HTTP.Client -import Data.Function (on) +import Data.Function (on) +import Network.HTTP.Client (Response, responseBody) +import Prelude.Compat newtype ResponseEquality b = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool } @@ -12,9 +13,13 @@ instance Monoid (ResponseEquality b) where a x y && b x y -- | Use `Eq` instance for `Response` +-- +-- #SINCE# allEquality :: Eq b => ResponseEquality b allEquality = ResponseEquality (==) -- | ByteString `Eq` instance over the response body. +-- +-- #SINCE# bodyEquality :: Eq b => ResponseEquality b bodyEquality = ResponseEquality ((==) `on` responseBody) diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs index 078f953..84e466e 100644 --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -5,15 +5,16 @@ import Data.Default.Class (def) import Data.Monoid ((<>)) import Data.String (fromString) import Data.String.Conversions (cs) -import GHC.TypeLits +import GHC.TypeLits (KnownSymbol, Nat, symbolVal) import Network.HTTP.Client (Request, RequestBody (..), host, - method, path, port, requestBody, - requestHeaders, secure, queryString) + method, path, port, queryString, + requestBody, requestHeaders, secure) import Network.HTTP.Media (renderHeader) +import Prelude.Compat import Servant -import Servant.API.ContentTypes +import Servant.API.ContentTypes (AllMimeRender (..)) import Servant.Client (BaseUrl (..), Scheme (..)) -import Test.QuickCheck +import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof) class HasGenRequest a where diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 786df66..e213e81 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -3,6 +3,7 @@ module Servant.QuickCheck.Internal.Predicates where import Control.Monad (liftM2) import Data.Aeson (Object, decode) import Data.Bifunctor (Bifunctor (..)) +import Prelude.Compat import qualified Data.ByteString as SBS import qualified Data.ByteString.Char8 as SBSC import qualified Data.ByteString.Lazy as LBS @@ -169,6 +170,8 @@ honoursAcceptHeader -- __References__: -- -- * @Cache-Control@ header: +-- +-- #SINCE# getsHaveCacheControlHeader :: RequestPredicate Text Bool getsHaveCacheControlHeader = RequestPredicate @@ -184,6 +187,8 @@ getsHaveCacheControlHeader -- | [__Best Practice__] -- -- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests. +-- +-- #SINCE# headsHaveCacheControlHeader :: RequestPredicate Text Bool headsHaveCacheControlHeader = RequestPredicate @@ -254,6 +259,8 @@ linkHeadersAreValid -- __References__: -- -- * @WWW-Authenticate@ header: +-- +-- #SINCE# unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool unauthorizedContainsWWWAuthenticate = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp -> @@ -331,6 +338,8 @@ instance JoinPreds (ResponsePredicate Text Bool) where -- the existing predicates. -- -- > not500 <%> onlyJsonObjects <%> empty +-- +-- #SINCE# (<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text] (<%>) = joinPreds infixr 6 <%> diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 51b6cb6..e47f4cf 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -7,6 +7,7 @@ import Network.HTTP.Client (Manager, Request, checkStatus, defaultManagerSettings, httpLbs, newManager) import Network.Wai.Handler.Warp (withApplication) +import Prelude.Compat import Servant (Context (EmptyContext), HasServer, Server, serveWithContext) import Servant.Client (BaseUrl (..), Scheme (..)) @@ -23,12 +24,16 @@ import Servant.QuickCheck.Internal.Equality -- | Start a servant application on an open port, run the provided function, -- then stop the application. +-- +-- #SINCE# withServantServer :: HasServer a '[] => Proxy a -> IO (Server a) -> (BaseUrl -> IO r) -> IO r withServantServer api = withServantServerAndContext api EmptyContext -- | Like 'withServantServer', but allows passing in a 'Context' to the -- application. +-- +-- #SINCE# withServantServerAndContext :: HasServer a ctx => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r withServantServerAndContext api ctx server t @@ -46,6 +51,8 @@ withServantServerAndContext api ctx server t -- -- Evidently, if the behaviour of the server is expected to be -- non-deterministic, this function may produce spurious failures +-- +-- #SINCE# serversEqual :: HasGenRequest a => Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation serversEqual api burl1 burl2 args req = do @@ -78,6 +85,8 @@ serversEqual api burl1 burl2 args req = do -- > <%> onlyJsonObjects -- > <%> notAllowedContainsAllowHeader -- > <%> mempty) +-- +-- #SINCE# serverSatisfies :: (HasGenRequest a) => Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation serverSatisfies api burl args preds = do