haskell/servant-quickcheck
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

prelude-compat

Browse Source
This commit is contained in:
Julian K. Arni 2016-05-09 17:49:29 +02:00
parent b48b1e8bc1
commit eb51069cb5
8 changed files with 35 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -1 +1,2 @@
doc/_build/
scripts/

18
servant-quickcheck.cabal
View File

@ -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

1
src/Servant/QuickCheck/Internal.hs
View File

@ -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

83
src/Servant/QuickCheck/Internal/Benchmarking.hs
View File

@ -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)-}

9
src/Servant/QuickCheck/Internal/Equality.hs
View File

@ -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)

11
src/Servant/QuickCheck/Internal/HasGenRequest.hs
View File

@ -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

9
src/Servant/QuickCheck/Internal/Predicates.hs
View File

@ -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 <%>

9
src/Servant/QuickCheck/Internal/QuickCheck.hs
View File

@ -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