eb51069 · servant-quickcheck

.gitignore+1

compare with master

unifiedsplit

@@ -1 +1,2 @@

1doc/_build/

2+scripts/

servant-quickcheck.cabal+3−15

@@ -1,5 +1,5 @@

1name: servant-quickcheck

2−version: 0.1.0.0

2+version: 0.0.0.0

3synopsis: QuickCheck entire APIs

4description:

5 This packages provides QuickCheck properties that are tested across an entire

@@ -20,12 +20,12 @@ flag long-tests

20library

21 exposed-modules: Servant.QuickCheck

22 , Servant.QuickCheck.Internal

23− -- , Servant.QuickCheck.Internal.Benchmarking

24 , Servant.QuickCheck.Internal.Predicates

23 , Servant.QuickCheck.Internal.Predicates

25 , Servant.QuickCheck.Internal.HasGenRequest

24 , Servant.QuickCheck.Internal.HasGenRequest

26 , Servant.QuickCheck.Internal.QuickCheck

25 , Servant.QuickCheck.Internal.QuickCheck

27 , Servant.QuickCheck.Internal.Equality

26 , Servant.QuickCheck.Internal.Equality

28 build-depends: base >=4.7 && <4.9

27 build-depends: base >=4.7 && <4.9

28+ , base-compat == 0.9.*

29 , QuickCheck == 2.8.*

30 , bytestring == 0.10.*

31 , aeson > 0.10 && < 0.12

@@ -63,6 +63,7 @@ library

63 , ScopedTypeVariables

64 , OverloadedStrings

65 , FunctionalDependencies

66+ , NoImplicitPrelude

66 default-language: Haskell2010

67 default-language: Haskell2010

67

68

68test-suite spec

69test-suite spec

@@ -89,16 +90,3 @@ test-suite spec

89 , DataKinds

90 , DataKinds

90 if flag(long-tests)

91 if flag(long-tests)

91 cpp-options: -DLONG_TESTS

92 cpp-options: -DLONG_TESTS

92−

93−-- test-suite doctests

94−-- default-language: Haskell2010

95−-- type: exitcode-stdio-1.0

96−-- ghc-options: -threaded

97−-- main-is: Doctest.hs

98−-- hs-source-dirs: test

99−-- build-depends: base >4 && <5

100−-- , doctest

101−-- , filemanip

102−-- , directory

103−-- , filepath

104−-- HS-Source-Dirs: test

src/Servant/QuickCheck/Internal.hs−1

@@ -4,4 +4,3 @@ import Servant.QuickCheck.Internal.HasGenRequest as X

4import Servant.QuickCheck.Internal.Predicates as X

5import Servant.QuickCheck.Internal.QuickCheck as X

6import Servant.QuickCheck.Internal.Equality as X

7−import Servant.QuickCheck.Internal.Benchmarking as X

src/Servant/QuickCheck/Internal/Benchmarking.hsdeleted−83

@@ -1,83 +0,0 @@

1−-- This is a WIP module that shouldn't be used.

2−module Servant.QuickCheck.Internal.Benchmarking where

3−

4−import Data.ByteString (ByteString)

5−import Data.ByteString.Lazy (toStrict)

6−import Network.HTTP.Client

7−import Network.HTTP.Types

8−import Servant.Client

9−

10−data BenchOptions = BenchOptions

11− { duration :: Int

12− , threads :: Int

13− , connections :: Int

14− , noOfTests :: Int

15− } deriving (Eq, Show, Read)

16−

17−defaultBenchOptions :: BenchOptions

18−defaultBenchOptions = BenchOptions

19− { duration = 10

20− , threads = 1

21− , connections = 10

22− , noOfTests = 10

23− }

24−

25−data WrkScript = WrkScript

26− { wrkScheme :: Scheme

27− , wrkHost :: ByteString

28− , wrkPort :: Int

29− , wrkMethod :: Method

30− , wrkPath :: ByteString

31− , wrkHeaders :: [Header]

32− , wrkBody :: ByteString

33− } deriving (Eq, Show)

34−

35−mkScript :: WrkScript -> String

36−mkScript w

37− = "wrk.scheme = \"" ++ sscheme (wrkScheme w) ++ "\""

38− ++ "\nwrk.host = " ++ show (wrkHost w)

39− ++ "\nwrk.port = " ++ show (wrkPort w)

40− ++ "\nwrk.method = " ++ show (wrkMethod w)

41− ++ "\nwrk.path = " ++ show (wrkPath w)

42− ++ foldr (\(h,v) old -> old ++ "\nwrk.headers[" ++ show h ++ "] = " ++ show v)

43− ""

44− (wrkHeaders w)

45− ++ "\nwrk.body = " ++ show (wrkBody w)

46− ++ "\n" ++ reportFmt

47− where

48− sscheme Http = "http"

49− sscheme Https = "https"

50−

51−reqToWrk :: Request -> WrkScript

52−reqToWrk r = WrkScript

53− { wrkScheme = Http

54− , wrkHost = host r

55− , wrkPort = port r

56− , wrkMethod = method r

57− , wrkPath = path r

58− , wrkHeaders = requestHeaders r

59− , wrkBody = case requestBody r of

60− RequestBodyLBS r' -> toStrict r'

61− _ -> error "expecting RequestBodyLBS"

62− }

63−

64−reportFmt :: String

65−reportFmt

66− = "done = function(summary, latency, requests)\n"

67− ++ " for _, p in pairs({ 50, 75, 99, 99.999 }) do\n"

68− ++ " n = latency:percentile(p)\n"

69− ++ " io.write(string.format(\"%g%%, %d\\n\", p, n))\n"

70− ++ " end\n"

71− ++ "end\n"

72−

73−{-data BenchResult = BenchResult-}

74− {-{ benchReq :: Request-}

75− {-, benchLatencyDist :: [(Percentile, Microsecs)]-}

76− {-, benchLatencyAvg :: Microsecs-}

77− {-} deriving (Eq, Show, Read, Generic)-}

78−

79−{-newtype Microsecs = Microsecs { unMicroSecs :: Int }-}

80− {-deriving (Eq, Show, Read, Generic)-}

81−

82−{-newtype Percentile = Percentile { unPercentile :: Int }-}

83− {-deriving (Eq, Show, Read, Generic)-}

src/Servant/QuickCheck/Internal/Equality.hs+7−2

@@ -1,7 +1,8 @@

1module Servant.QuickCheck.Internal.Equality where

2

3−import Network.HTTP.Client

4−import Data.Function (on)

3+import Data.Function (on)

4+import Network.HTTP.Client (Response, responseBody)

5+import Prelude.Compat

5

6

6newtype ResponseEquality b

7newtype ResponseEquality b

7 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }

8 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }

@@ -12,9 +13,13 @@ instance Monoid (ResponseEquality b) where

12 a x y && b x y

13 a x y && b x y

13

14

14-- | Use `Eq` instance for `Response`

15-- | Use `Eq` instance for `Response`

16+--

17+-- #SINCE#

15allEquality :: Eq b => ResponseEquality b

18allEquality :: Eq b => ResponseEquality b

16allEquality = ResponseEquality (==)

19allEquality = ResponseEquality (==)

17

20

18-- | ByteString `Eq` instance over the response body.

21-- | ByteString `Eq` instance over the response body.

22+--

23+-- #SINCE#

19bodyEquality :: Eq b => ResponseEquality b

24bodyEquality :: Eq b => ResponseEquality b

20bodyEquality = ResponseEquality ((==) `on` responseBody)

25bodyEquality = ResponseEquality ((==) `on` responseBody)

src/Servant/QuickCheck/Internal/HasGenRequest.hs+6−5

@@ -5,15 +5,16 @@ import Data.Default.Class (def)

5import Data.Monoid ((<>))

6import Data.String (fromString)

7import Data.String.Conversions (cs)

8−import GHC.TypeLits

8+import GHC.TypeLits (KnownSymbol, Nat, symbolVal)

9import Network.HTTP.Client (Request, RequestBody (..), host,

10− method, path, port, requestBody,

10+ method, path, port, queryString,

11− requestHeaders, secure, queryString)

11+ requestBody, requestHeaders, secure)

12import Network.HTTP.Media (renderHeader)

13+import Prelude.Compat

13import Servant

14import Servant

14−import Servant.API.ContentTypes

15+import Servant.API.ContentTypes (AllMimeRender (..))

15import Servant.Client (BaseUrl (..), Scheme (..))

16import Servant.Client (BaseUrl (..), Scheme (..))

16−import Test.QuickCheck

17+import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)

17

18

19

19class HasGenRequest a where

20class HasGenRequest a where

src/Servant/QuickCheck/Internal/Predicates.hs+9

@@ -3,6 +3,7 @@ module Servant.QuickCheck.Internal.Predicates where

3import Control.Monad (liftM2)

4import Data.Aeson (Object, decode)

5import Data.Bifunctor (Bifunctor (..))

6+import Prelude.Compat

6import qualified Data.ByteString as SBS

7import qualified Data.ByteString as SBS

7import qualified Data.ByteString.Char8 as SBSC

8import qualified Data.ByteString.Char8 as SBSC

8import qualified Data.ByteString.Lazy as LBS

9import qualified Data.ByteString.Lazy as LBS

@@ -169,6 +170,8 @@ honoursAcceptHeader

169-- __References__:

170-- __References__:

170--

171--

171-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>

172-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>

173+--

174+-- #SINCE#

172getsHaveCacheControlHeader :: RequestPredicate Text Bool

175getsHaveCacheControlHeader :: RequestPredicate Text Bool

173getsHaveCacheControlHeader

176getsHaveCacheControlHeader

174 = RequestPredicate

177 = RequestPredicate

@@ -184,6 +187,8 @@ getsHaveCacheControlHeader

184-- | [__Best Practice__]

187-- | [__Best Practice__]

185--

188--

186-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.

189-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.

190+--

191+-- #SINCE#

187headsHaveCacheControlHeader :: RequestPredicate Text Bool

192headsHaveCacheControlHeader :: RequestPredicate Text Bool

188headsHaveCacheControlHeader

193headsHaveCacheControlHeader

189 = RequestPredicate

194 = RequestPredicate

@@ -254,6 +259,8 @@ linkHeadersAreValid

254-- __References__:

259-- __References__:

255--

260--

256-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>

261-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>

262+--

263+-- #SINCE#

257unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool

264unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool

258unauthorizedContainsWWWAuthenticate

265unauthorizedContainsWWWAuthenticate

259 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->

266 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->

@@ -331,6 +338,8 @@ instance JoinPreds (ResponsePredicate Text Bool) where

331-- the existing predicates.

338-- the existing predicates.

332--

339--

333-- > not500 <%> onlyJsonObjects <%> empty

340-- > not500 <%> onlyJsonObjects <%> empty

341+--

342+-- #SINCE#

334(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]

343(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]

335(<%>) = joinPreds

344(<%>) = joinPreds

336infixr 6 <%>

345infixr 6 <%>

src/Servant/QuickCheck/Internal/QuickCheck.hs+9

@@ -7,6 +7,7 @@ import Network.HTTP.Client (Manager, Request, checkStatus,

7 defaultManagerSettings, httpLbs,

8 newManager)

9import Network.Wai.Handler.Warp (withApplication)

10+import Prelude.Compat

10import Servant (Context (EmptyContext), HasServer,

11import Servant (Context (EmptyContext), HasServer,

11 Server, serveWithContext)

12 Server, serveWithContext)

12import Servant.Client (BaseUrl (..), Scheme (..))

13import Servant.Client (BaseUrl (..), Scheme (..))

@@ -23,12 +24,16 @@ import Servant.QuickCheck.Internal.Equality

23

24

24-- | Start a servant application on an open port, run the provided function,

25-- | Start a servant application on an open port, run the provided function,

25-- then stop the application.

26-- then stop the application.

27+--

28+-- #SINCE#

26withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)

29withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)

27 -> (BaseUrl -> IO r) -> IO r

30 -> (BaseUrl -> IO r) -> IO r

28withServantServer api = withServantServerAndContext api EmptyContext

31withServantServer api = withServantServerAndContext api EmptyContext

29

32

30-- | Like 'withServantServer', but allows passing in a 'Context' to the

33-- | Like 'withServantServer', but allows passing in a 'Context' to the

31-- application.

34-- application.

35+--

36+-- #SINCE#

32withServantServerAndContext :: HasServer a ctx

37withServantServerAndContext :: HasServer a ctx

33 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r

38 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r

34withServantServerAndContext api ctx server t

39withServantServerAndContext api ctx server t

@@ -46,6 +51,8 @@ withServantServerAndContext api ctx server t

46--

51--

47-- Evidently, if the behaviour of the server is expected to be

52-- Evidently, if the behaviour of the server is expected to be

48-- non-deterministic, this function may produce spurious failures

53-- non-deterministic, this function may produce spurious failures

54+--

55+-- #SINCE#

49serversEqual :: HasGenRequest a =>

56serversEqual :: HasGenRequest a =>

50 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation

57 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation

51serversEqual api burl1 burl2 args req = do

58serversEqual api burl1 burl2 args req = do

@@ -78,6 +85,8 @@ serversEqual api burl1 burl2 args req = do

78-- > <%> onlyJsonObjects

85-- > <%> onlyJsonObjects

79-- > <%> notAllowedContainsAllowHeader

86-- > <%> notAllowedContainsAllowHeader

80-- > <%> mempty)

87-- > <%> mempty)

88+--

89+-- #SINCE#

81serverSatisfies :: (HasGenRequest a) =>

90serverSatisfies :: (HasGenRequest a) =>

82 Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation

91 Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation

83serverSatisfies api burl args preds = do

92serverSatisfies api burl args preds = do