master..e89b45f · roboservant

package.yaml+1−1

since splitsnapshots

unifiedsplit

@@ -1,6 +1,6 @@

1

2name: roboservant

3−version: 0.1.0.3

3+version: 0.1.0.2

4github: "mwotton/roboservant"

5license: BSD3

6copyright: "2020 Mark Wotton, Samuel Schlesinger"

roboservant.cabal+4−6

@@ -1,13 +1,13 @@

1cabal-version: 1.12

2

3−-- This file has been generated from package.yaml by hpack version 0.35.0.

3+-- This file has been generated from package.yaml by hpack version 0.33.0.

4--

5-- see: https://github.com/sol/hpack

6--

7−-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d

7+-- hash: 596d33d4f2e29f15b48525514def52b101c9e89b6193275bd5c0a4c253de8d5c

8

9name: roboservant

10−version: 0.1.0.3

10+version: 0.1.0.2

11synopsis: Automatic session-aware servant testing

12description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>

13category: Web

@@ -36,7 +36,6 @@ library

36 Roboservant.Types.BuildFrom

37 Roboservant.Types.Config

38 Roboservant.Types.Internal

39− Roboservant.Types.Orphans

40 Roboservant.Types.ReifiedApi

39 Roboservant.Types.ReifiedApi

41 Roboservant.Types.ReifiedApi.Server

40 Roboservant.Types.ReifiedApi.Server

42 other-modules:

41 other-modules:

@@ -73,7 +72,7 @@ test-suite example

73 other-modules:

72 other-modules:

74 Paths_roboservant

73 Paths_roboservant

75 hs-source-dirs:

74 hs-source-dirs:

76− ./

75+ ./.

77 ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit

76 ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit

78 build-tool-depends:

77 build-tool-depends:

79 markdown-unlit:markdown-unlit

78 markdown-unlit:markdown-unlit

@@ -116,7 +115,6 @@ test-suite roboservant-test

116 Nested

115 Nested

117 Post

116 Post

118 Product

117 Product

119− Put

120 QueryParams

118 QueryParams

121 Seeded

119 Seeded

122 UnsafeIO

120 UnsafeIO

src/Roboservant/Client.hs+2−2

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

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeApplications #-}

11−

11+{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE FlexibleContexts #-}

@@ -97,7 +97,7 @@ instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x)

97 where

98 renderClientError :: ClientError -> InteractionError

99 renderClientError err = case err of

100− FailureResponse _ Response{responseStatusCode} -> InteractionError textual (responseStatusCode == status500)

100+ FailureResponse _ (Response{responseStatusCode}) -> InteractionError textual (responseStatusCode == status500)

101 _ -> InteractionError textual True

102

103 where textual = T.pack $ show err

src/Roboservant/Direct.hs+12−11

@@ -7,7 +7,7 @@

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

10−

10+{-# LANGUAGE TypeApplications #-}

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

13

@@ -150,12 +150,12 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do

150 Report

151 (unlines [show failureType, show exception])

152 r

153− displayDiagnostics FuzzState {..} = liftIO $

153+ displayDiagnostics FuzzState {..} = liftIO $ do

154 logInfo $ unlines $

155− ["api endpoints covered"]

155+ ["api endpoints covered"]

156− <> (map show . Set.toList . Set.fromList $ map apiOffset path)

156+ <> (map show . Set.toList . Set.fromList $ map apiOffset path)

157− <> ["", "types in stash"]

157+ <> ["", "types in stash"]

158− <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)

158+ <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)

159 -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))

160 -- $ \_k v ->

161 -- (show . NEL.length $ getStashValue v))

@@ -246,11 +246,11 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do

246 if fatalError e

247 then throw e

248 else pure ()

249− Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->

249+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> do

250 modify'

251− ( \fs@FuzzState {..} ->

251+ ( \fs@FuzzState {..} ->

252− fs {stash = addToStash (NEL.toList dyn) stash}

252+ fs {stash = addToStash (NEL.toList dyn) stash}

253− )

253+ )

254 where

255 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args

256 -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args

@@ -262,7 +262,8 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do

262 (execute op func args)

263 [ Handler (\(e :: SomeAsyncException) -> throw e),

264 Handler

265− ( \(e :: SomeException) ->

265+ ( \(e :: SomeException) -> do

266+ -- displayDiagnostics =<< get

266 throw . RoboservantException ServerCrashed (Just e) =<< get

267 throw . RoboservantException ServerCrashed (Just e) =<< get

267 )

268 )

268 ]

269 ]

src/Roboservant/Server.hs+2−2

@@ -5,7 +5,7 @@

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE PolyKinds #-}

8−

8+{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeApplications #-}

11{-# LANGUAGE TypeFamilies #-}

@@ -27,7 +27,7 @@ fuzz :: forall api.

27 Server api ->

28 Config ->

29 IO (Maybe Report)

30−fuzz s = fuzz' (reifyServer s)

30+fuzz s = fuzz' (reifyServer s)

31 -- todo: how do we pull reifyServer out?

32 where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))

33 => Server api -> ReifiedApi

src/Roboservant/Types.hs−1

@@ -23,4 +23,3 @@ import Roboservant.Types.Config

23import Roboservant.Types.Internal

24import Roboservant.Types.ReifiedApi

25import Roboservant.Types.ReifiedApi.Server

26−import Roboservant.Types.Orphans()

src/Roboservant/Types/Breakdown.hs+1−6

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE DerivingVia #-}

3{-# LANGUAGE DerivingVia #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

@@ -23,8 +22,6 @@ import qualified Data.List.NonEmpty as NEL

23import Data.Typeable (Typeable)

22import Data.Typeable (Typeable)

24import GHC.Generics

23import GHC.Generics

25import Roboservant.Types.Internal

24import Roboservant.Types.Internal

26−import Servant

27−import Roboservant.Types.Orphans()

28

25

29breakdown ::

26breakdown ::

30 (Hashable x, Typeable x, Breakdown x) =>

27 (Hashable x, Typeable x, Breakdown x) =>

@@ -49,7 +46,7 @@ instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where

49 breakdownExtras stash = concatMap (NEL.toList . breakdown) stash

46 breakdownExtras stash = concatMap (NEL.toList . breakdown) stash

50

47

51

48

52−class GBreakdown (f :: k -> Type) where

49+class GBreakdown (f :: k -> *) where

53 gBreakdownExtras :: f a -> [(Dynamic, Int)]

50 gBreakdownExtras :: f a -> [(Dynamic, Int)]

54

51

55instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where

52instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where

@@ -77,5 +74,3 @@ instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where

77

74

78instance GBreakdown U1 where

75instance GBreakdown U1 where

79 gBreakdownExtras U1 = []

76 gBreakdownExtras U1 = []

80−

81−deriving via (Atom NoContent) instance Breakdown NoContent

src/Roboservant/Types/BuildFrom.hs+1−5

@@ -23,8 +23,6 @@ import Data.Typeable (Typeable)

23import GHC.Generics

24import Roboservant.Types.Internal

25import qualified Type.Reflection as R

26−import Servant(NoContent)

27−import Roboservant.Types.Orphans()

28

26

29buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)

27buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)

30buildFrom = buildStash . buildFrom'

28buildFrom = buildStash . buildFrom'

@@ -77,7 +75,7 @@ deriving via (Atom Int) instance BuildFrom Int

77

75

78deriving via (Atom Char) instance BuildFrom Char

76deriving via (Atom Char) instance BuildFrom Char

79

77

80−class GBuildFrom (f :: k -> Type) where

78+class GBuildFrom (f :: k -> *) where

81 gExtras :: Stash -> [([Provenance], f a)]

79 gExtras :: Stash -> [([Provenance], f a)]

82

80

83instance GBuildFrom b => GBuildFrom (M1 D a b) where

81instance GBuildFrom b => GBuildFrom (M1 D a b) where

@@ -103,5 +101,3 @@ instance BuildFrom a => GBuildFrom (K1 i a) where

103

101

104instance GBuildFrom U1 where

102instance GBuildFrom U1 where

105 gExtras _ = [([], U1)]

103 gExtras _ = [([], U1)]

106−

107−deriving via (Atom NoContent) instance BuildFrom NoContent

src/Roboservant/Types/Internal.hs+2−2

@@ -43,11 +43,11 @@ instance Show Stash where

43

44-- | Can't be built up from parts, can't be broken down further.

45newtype Atom x = Atom {unAtom :: x}

46− deriving newtype (Hashable, Typeable,Eq)

46+ deriving newtype (Hashable, Typeable)

47

48-- | can be broken down and built up from generic pieces

49newtype Compound x = Compound {unCompound :: x}

50− deriving newtype (Hashable, Typeable, Eq)

50+ deriving newtype (Hashable, Typeable)

51

52hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)

53hashedDyn a = (toDyn a, hash a)

src/Roboservant/Types/Orphans.hsdeleted−7

@@ -1,7 +0,0 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2−module Roboservant.Types.Orphans where

3−

4−import Servant

5−import Data.Hashable

6−

7−instance Hashable NoContent

src/Roboservant/Types/ReifiedApi.hs+1−1

@@ -57,7 +57,7 @@ instance Show ReifiedEndpoint where

57

58class ( V.RecordToList (EndpointArgs endpoint)

59 , V.RMap (EndpointArgs endpoint)

60− ) => ToReifiedEndpoint (endpoint :: Type) where

60+ ) => ToReifiedEndpoint (endpoint :: *) where

61 type EndpointArgs endpoint :: [Type]

62 type EndpointRes endpoint :: Type

63

src/Roboservant/Types/ReifiedApi/Server.hs+1−1

@@ -6,7 +6,7 @@

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE PolyKinds #-}

9−

9+{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE TypeFamilies #-}

stack.yaml+5−5

@@ -1,10 +1,10 @@

1−resolver: lts-20.4

1+resolver: lts-17.6

2packages:

3- .

4

5extra-deps:

6−# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

6+- dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

7−# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

7+- dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

8- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

9−# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853

9+- constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853

10−- some-1.0.3

10+- some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055

stack.yaml.lock+30−9

@@ -4,23 +4,44 @@

4# https://docs.haskellstack.org/en/stable/lock_files

5

6packages:

7+- completed:

8+ hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

9+ pantry-tree:

10+ size: 551

11+ sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5

12+ original:

13+ hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

14+- completed:

15+ hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

16+ pantry-tree:

17+ size: 290

18+ sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50

19+ original:

20+ hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

7- completed:

21- completed:

8 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

22 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

9 pantry-tree:

23 pantry-tree:

10− sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

11 size: 325

24 size: 325

25+ sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

12 original:

26 original:

13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

27 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

14- completed:

28- completed:

15− hackage: some-1.0.3@sha256:938cec5fc0d3a08dde34cfc0acd5a0aa2e9fd489c9dbb64417f16588dfb47af0,2399

29+ hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853

30+ pantry-tree:

31+ size: 594

32+ sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1

33+ original:

34+ hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853

35+- completed:

36+ hackage: some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055

16 pantry-tree:

37 pantry-tree:

17− sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

38+ size: 708

18− size: 709

39+ sha256: c882b6ebe8a0616f1ab3908f1620087ad5c6d8d82d1a72b99226f6487419bfe6

19 original:

40 original:

20− hackage: some-1.0.3

41+ hackage: some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055

21snapshots:

42snapshots:

22- completed:

43- completed:

23− sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

24− size: 648660

44+ size: 565712

25− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml

45+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/6.yaml

46+ sha256: 4e5e581a709c88e3fe26a9ce8bf331435729bead762fb5c190064c6c5bb1b835

26− original: lts-20.4

47+ original: lts-17.6

test/Breakdown.hs+1−1

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Nested.hs+2−2

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

1{-# LANGUAGE DataKinds #-}

2−

2+{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Post.hs+2−2

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−

5+{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Post where

test/Product.hs+1−1

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Put.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4−

5−

6−{-# LANGUAGE TypeOperators #-}

7−

8−module Put where

9−

10−import Data.Aeson

11−import Data.Hashable

12−import GHC.Generics (Generic)

13−import Servant

14−

15−type Api =

16− Get '[JSON] Foo

17− :<|> ReqBody '[JSON] Foo :> Put '[JSON] ()

18− :<|> ReqBody '[JSON] Foo :> Put '[JSON] NoContent

19−

20−data Foo = Foo

21− deriving (Eq, Show, Generic)

22−

23−instance Hashable Foo

24−

25−instance ToJSON Foo

26−

27−instance FromJSON Foo

28−

29−server :: Server Api

30−server =

31− pure Foo

32− :<|> const (pure ())

33− :<|> const (pure NoContent)

test/QueryParams.hs+3−3

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

1{-# LANGUAGE DataKinds #-}

2−

2+{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−

5+{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module QueryParams where

test/Spec.hs+20−30

@@ -21,7 +21,6 @@ import qualified Foo

21import qualified Headers

22import qualified Nested

23import qualified Post

24−import qualified Put

25import qualified Product

24import qualified Product

26import qualified QueryParams

25import qualified QueryParams

27import qualified Roboservant as R

26import qualified Roboservant as R

@@ -37,7 +36,6 @@ import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClien

37import Network.Wai(Application)

36import Network.Wai(Application)

38import qualified Network.Wai.Handler.Warp as Warp

37import qualified Network.Wai.Handler.Warp as Warp

39import Network.HTTP.Client (newManager, defaultManagerSettings)

38import Network.HTTP.Client (newManager, defaultManagerSettings)

40−import Control.Monad((>=>))

41

39

42main :: IO ()

40main :: IO ()

43main = hspec spec

41main = hspec spec

@@ -48,15 +46,15 @@ fuzzBoth

48 HasClient ClientM a)

46 HasClient ClientM a)

49 => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec

47 => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec

50fuzzBoth name server config condition = do

48fuzzBoth name server config condition = do

51− it (name <> " via server") $

49+ it (name <> " via server") $ do

52 RS.fuzz @a server config >>= condition

50 RS.fuzz @a server config >>= condition

53

51

54− around (withServer (serve (Proxy :: Proxy a) server)) $

52+ around (withServer (serve (Proxy :: Proxy a) server)) $ do

55 it (name <> " via client") $ \(clientEnv::ClientEnv) -> do

53 it (name <> " via client") $ \(clientEnv::ClientEnv) -> do

56− RC.fuzz @a clientEnv config >>= condition

54+ RC.fuzz @a clientEnv config >>= condition

57

55

58withServer :: Application -> ActionWith ClientEnv -> IO ()

56withServer :: Application -> ActionWith ClientEnv -> IO ()

59−withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action)

57+withServer app action = Warp.testWithApplication (pure app) (\p -> genClientEnv p >>= action)

60 where genClientEnv port = do

58 where genClientEnv port = do

61 baseUrl <- parseBaseUrl "http://localhost"

59 baseUrl <- parseBaseUrl "http://localhost"

62 manager <- newManager defaultManagerSettings

60 manager <- newManager defaultManagerSettings

@@ -75,15 +73,9 @@ spec = do

75 Just (R.InsufficientCoverage _) -> True

73 Just (R.InsufficientCoverage _) -> True

76 _ -> False

74 _ -> False

77 ))

75 ))

78− describe "posted body" $

76+ describe "posted body" $ do

79 fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}

77 fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}

80− (`shouldSatisfy` isNothing)

81−

82−

83− describe "PUTted body" $

84− fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}

85− (`shouldSatisfy` isNothing)

78+ (`shouldSatisfy` isNothing)

86−

87

79

88 describe "seeded" $ do

80 describe "seeded" $ do

89 let res = Seeded.Seed 1

81 let res = Seeded.Seed 1

@@ -91,29 +83,31 @@ spec = do

91 (R.defaultConfig {R.seed = [(toDyn res, hash res)]})

83 (R.defaultConfig {R.seed = [(toDyn res, hash res)]})

92 (`shouldSatisfy` isNothing)

84 (`shouldSatisfy` isNothing)

93

85

94− describe "Foo" $

86+ describe "Foo" $ do

95 fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)

87 fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)

96

88

97− describe "QueryParams" $

89+ describe "QueryParams" $ do

98 fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }

90 fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }

99− (`shouldSatisfy` isNothing)

91+ (`shouldSatisfy` isNothing)

100

92

101 describe "BuildFrom" $ do

93 describe "BuildFrom" $ do

102− describe "headers (and sum types)" $

94+ describe "headers (and sum types)" $ do

103 fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig

95 fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig

104− (`shouldSatisfy` serverFailure)

96+ (`shouldSatisfy` serverFailure)

105− describe "product types" $

97+ describe "product types" $ do

106 fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server

98 fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server

107− R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}

99+ R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}

108− (`shouldSatisfy` serverFailure)

100+ (`shouldSatisfy` serverFailure)

109 describe "Breakdown" $ do

101 describe "Breakdown" $ do

110 fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig

102 fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig

111 (`shouldSatisfy` serverFailure)

103 (`shouldSatisfy` serverFailure)

112 fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig

104 fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig

113 (`shouldSatisfy` serverFailure)

105 (`shouldSatisfy` serverFailure)

114− describe "flattening" $

106+ describe "flattening" $ do

107+ -- we don't actually do much here, this is just here to document the appropriate response

108+ -- if you get a type error with a nested api.

115 fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}

109 fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}

116− (`shouldSatisfy` isNothing)

110+ (`shouldSatisfy` isNothing)

117

111

118serverFailure :: Maybe R.Report -> Bool

112serverFailure :: Maybe R.Report -> Bool

119serverFailure = \case

113serverFailure = \case

@@ -137,12 +131,8 @@ deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed

137deriving via (R.Atom Void) instance R.BuildFrom Void

131deriving via (R.Atom Void) instance R.BuildFrom Void

138

132

139deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost

133deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost

140−deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost

141−

142−deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo

143−deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo

144−

145

134

135+deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost

146

136

147deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo

137deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo

148

138

@@ -158,7 +148,7 @@ shouldFail =

158 ( \i ->

148 ( \i ->

159 i

149 i

160 { itemExample = \p a cb -> do

150 { itemExample = \p a cb -> do

161− r <- itemExample i p a cb

151+ r <- (itemExample i) p a cb

162 pure

152 pure

163 r

153 r

164 { resultStatus = case resultStatus r of

154 { resultStatus = case resultStatus r of

test/UnsafeIO.hs+3−3

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

1{-# LANGUAGE DataKinds #-}

2−

2+{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

@@ -22,7 +22,7 @@ healthcheck ref = do

22 t <- liftIO $ readIORef ref

23 case t of

24 0 -> pure ()

25− n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)}

25+ n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}

26

27makeServer :: IO (Server UnsafeApi)

28makeServer = do

test/Valid.hs+2−1

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

@@ -10,6 +10,7 @@ module Valid where

10import Data.Void

11import GHC.Generics

12import Servant

13+import Servant.API.Generic

13import Servant.Server.Generic

14import Servant.Server.Generic

14

15

15type Api =

16type Api =