e89b45f..master · roboservant

package.yaml+1−1

since splitsnapshots

unifiedsplit

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

1

2name: roboservant

3−version: 0.1.0.2

3+version: 0.1.0.3

4github: "mwotton/roboservant"

5license: BSD3

6copyright: "2020 Mark Wotton, Samuel Schlesinger"

roboservant.cabal+6−4

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

1cabal-version: 1.12

2

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

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

4--

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

6--

7−-- hash: 596d33d4f2e29f15b48525514def52b101c9e89b6193275bd5c0a4c253de8d5c

7+-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d

8

9name: roboservant

10−version: 0.1.0.2

10+version: 0.1.0.3

11synopsis: Automatic session-aware servant testing

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

13category: Web

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

36 Roboservant.Types.BuildFrom

37 Roboservant.Types.Config

38 Roboservant.Types.Internal

39+ Roboservant.Types.Orphans

39 Roboservant.Types.ReifiedApi

40 Roboservant.Types.ReifiedApi

40 Roboservant.Types.ReifiedApi.Server

41 Roboservant.Types.ReifiedApi.Server

41 other-modules:

42 other-modules:

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

72 other-modules:

73 other-modules:

73 Paths_roboservant

74 Paths_roboservant

74 hs-source-dirs:

75 hs-source-dirs:

75− ./.

76+ ./

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

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

77 build-tool-depends:

78 build-tool-depends:

78 markdown-unlit:markdown-unlit

79 markdown-unlit:markdown-unlit

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

115 Nested

116 Nested

116 Post

117 Post

117 Product

118 Product

119+ Put

118 QueryParams

120 QueryParams

119 Seeded

121 Seeded

120 UnsafeIO

122 UnsafeIO

src/Roboservant/Client.hs+2−2

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

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeApplications #-}

11−{-# LANGUAGE TypeOperators #-}

11+

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+11−12

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

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

10−{-# LANGUAGE TypeApplications #-}

10+

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 $ do

153+ displayDiagnostics FuzzState {..} = liftIO $

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

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

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,8 +262,7 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do

262 (execute op func args)

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

264 Handler

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

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

266− -- displayDiagnostics =<< get

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

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

268 )

267 )

269 ]

268 ]

src/Roboservant/Server.hs+2−2

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

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE RankNTypes #-}

8+

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,3 +23,4 @@ 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+6−1

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE DerivingVia #-}

4{-# LANGUAGE DerivingVia #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

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

22import Data.Typeable (Typeable)

23import Data.Typeable (Typeable)

23import GHC.Generics

24import GHC.Generics

24import Roboservant.Types.Internal

25import Roboservant.Types.Internal

26+import Servant

27+import Roboservant.Types.Orphans()

25

28

26breakdown ::

29breakdown ::

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

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

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

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

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

47

50

48

51

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

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

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

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

51

54

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

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

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

74

77

75instance GBreakdown U1 where

78instance GBreakdown U1 where

76 gBreakdownExtras U1 = []

79 gBreakdownExtras U1 = []

80+

81+deriving via (Atom NoContent) instance Breakdown NoContent

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

@@ -23,6 +23,8 @@ 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()

26

28

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

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

28buildFrom = buildStash . buildFrom'

30buildFrom = buildStash . buildFrom'

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

75

77

76deriving via (Atom Char) instance BuildFrom Char

78deriving via (Atom Char) instance BuildFrom Char

77

79

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

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

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

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

80

82

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

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

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

101

103

102instance GBuildFrom U1 where

104instance GBuildFrom U1 where

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

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

46+ deriving newtype (Hashable, Typeable,Eq)

47

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

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

50− deriving newtype (Hashable, Typeable)

50+ deriving newtype (Hashable, Typeable, Eq)

51

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

53hashedDyn a = (toDyn a, hash a)

src/Roboservant/Types/Orphans.hsnew file+7

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

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 :: *) where

60+ ) => ToReifiedEndpoint (endpoint :: Type) 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−{-# LANGUAGE RankNTypes #-}

9+

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE TypeFamilies #-}

stack.yaml+5−5

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

1−resolver: lts-17.6

1+resolver: lts-20.4

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.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055

10+- some-1.0.3

stack.yaml.lock+9−30

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

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

21- completed:

7- completed:

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

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

23 pantry-tree:

9 pantry-tree:

24− size: 325

25 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

10 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

11+ size: 325

26 original:

12 original:

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

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

28- completed:

14- completed:

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

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

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

37 pantry-tree:

16 pantry-tree:

17+ sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

38− size: 708

18+ size: 709

39− sha256: c882b6ebe8a0616f1ab3908f1620087ad5c6d8d82d1a72b99226f6487419bfe6

40 original:

19 original:

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

20+ hackage: some-1.0.3

42snapshots:

21snapshots:

43- completed:

22- completed:

23+ sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

44− size: 565712

24+ size: 648660

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

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

46− sha256: 4e5e581a709c88e3fe26a9ce8bf331435729bead762fb5c190064c6c5bb1b835

47− original: lts-17.6

26+ original: lts-20.4

test/Breakdown.hs+1−1

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Nested.hs+2−2

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

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−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5−{-# LANGUAGE OverloadedStrings #-}

5+

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−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

test/Put.hsnew file+33

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

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−{-# LANGUAGE DeriveGeneric #-}

2+

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5−{-# LANGUAGE OverloadedStrings #-}

5+

6{-# LANGUAGE TypeOperators #-}

7

8module QueryParams where

test/Spec.hs+30−20

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

21import qualified Headers

22import qualified Nested

23import qualified Post

24+import qualified Put

24import qualified Product

25import qualified Product

25import qualified QueryParams

26import qualified QueryParams

26import qualified Roboservant as R

27import qualified Roboservant as R

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

36import Network.Wai(Application)

37import Network.Wai(Application)

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

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

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

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

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

39

41

40main :: IO ()

42main :: IO ()

41main = hspec spec

43main = hspec spec

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

46 HasClient ClientM a)

48 HasClient ClientM a)

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

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

48fuzzBoth name server config condition = do

50fuzzBoth name server config condition = do

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

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

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

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

51

53

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

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

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

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

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

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

55

57

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

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

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

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

58 where genClientEnv port = do

60 where genClientEnv port = do

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

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

60 manager <- newManager defaultManagerSettings

62 manager <- newManager defaultManagerSettings

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

73 Just (R.InsufficientCoverage _) -> True

75 Just (R.InsufficientCoverage _) -> True

74 _ -> False

76 _ -> False

75 ))

77 ))

76− describe "posted body" $ do

78+ describe "posted body" $

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

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

78− (`shouldSatisfy` isNothing)

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)

86+

79

87

80 describe "seeded" $ do

88 describe "seeded" $ do

81 let res = Seeded.Seed 1

89 let res = Seeded.Seed 1

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

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

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

84 (`shouldSatisfy` isNothing)

92 (`shouldSatisfy` isNothing)

85

93

86− describe "Foo" $ do

94+ describe "Foo" $

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

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

88

96

89− describe "QueryParams" $ do

97+ describe "QueryParams" $

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

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

91− (`shouldSatisfy` isNothing)

99+ (`shouldSatisfy` isNothing)

92

100

93 describe "BuildFrom" $ do

101 describe "BuildFrom" $ do

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

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

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

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

96− (`shouldSatisfy` serverFailure)

104+ (`shouldSatisfy` serverFailure)

97− describe "product types" $ do

105+ describe "product types" $

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

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

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

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

100− (`shouldSatisfy` serverFailure)

108+ (`shouldSatisfy` serverFailure)

101 describe "Breakdown" $ do

109 describe "Breakdown" $ do

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

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

103 (`shouldSatisfy` serverFailure)

111 (`shouldSatisfy` serverFailure)

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

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

105 (`shouldSatisfy` serverFailure)

113 (`shouldSatisfy` serverFailure)

106− describe "flattening" $ do

114+ describe "flattening" $

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.

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

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

110− (`shouldSatisfy` isNothing)

116+ (`shouldSatisfy` isNothing)

111

117

112serverFailure :: Maybe R.Report -> Bool

118serverFailure :: Maybe R.Report -> Bool

113serverFailure = \case

119serverFailure = \case

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

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

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

132

138

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

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

134−

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

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

136

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+

146+

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

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

138

148

139deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo

149deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo

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

148 ( \i ->

158 ( \i ->

149 i

159 i

150 { itemExample = \p a cb -> do

160 { itemExample = \p a cb -> do

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

161+ r <- itemExample i p a cb

152 pure

162 pure

153 r

163 r

154 { resultStatus = case resultStatus r of

164 { resultStatus = case resultStatus r of

test/UnsafeIO.hs+3−3

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

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+1−2

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

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

10import Data.Void

11import GHC.Generics

12import Servant

13−import Servant.API.Generic

14import Servant.Server.Generic

13import Servant.Server.Generic

15

14

16type Api =

15type Api =