mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-09-11 18:37:09 +03:00
prelude-compat
This commit is contained in:
parent
b48b1e8bc1
commit
eb51069cb5
1
.gitignore
vendored
1
.gitignore
vendored
@ -1 +1,2 @@
|
||||
doc/_build/
|
||||
scripts/
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)-}
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
|
||||
--
|
||||
-- #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: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
|
||||
--
|
||||
-- #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 <%>
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user