900105a..master · roboservant

.github/workflows/cabal.ymlnew file+64

since splitsnapshots

unifiedsplit

@@ -0,0 +1,64 @@

1+# modified from https://github.com/jgm/pandoc/blob/master/.github/workflows/ci.yml

2+name: Cabal CI

3+

4+on:

5+ push:

6+ branches:

7+ - '**'

8+ paths-ignore: []

9+ pull_request:

10+ paths-ignore: []

11+

12+jobs:

13+ linux:

14+

15+ runs-on: ubuntu-20.04

16+ strategy:

17+ fail-fast: false

18+ matrix:

19+ versions:

20+ - ghc: '8.8.4'

21+ cabal: '3.4'

22+ - ghc: '8.10.4'

23+ cabal: '3.4'

24+ steps:

25+ - uses: actions/checkout@v2

26+

27+ # need to install older cabal/ghc versions from ppa repository

28+

29+ - name: Install recent cabal/ghc

30+ uses: actions/setup-haskell@v1.1.3

31+ with:

32+ ghc-version: ${{ matrix.versions.ghc }}

33+ cabal-version: ${{ matrix.versions.cabal }}

34+

35+ # declare/restore cached things

36+ # caching doesn't work for scheduled runs yet

37+ # https://github.com/actions/cache/issues/63

38+

39+ - name: Cache cabal global package db

40+ id: cabal-global

41+ uses: actions/cache@v2

42+ with:

43+ path: |

44+ ~/.cabal

45+ key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-global-${{ hashFiles('cabal.project') }}

46+

47+ - name: Cache cabal work

48+ id: cabal-local

49+ uses: actions/cache@v2

50+ with:

51+ path: |

52+ dist-newstyle

53+ key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-local

54+

55+ - name: Install dependencies

56+ run: |

57+ cabal update

58+ cabal build all --dependencies-only --enable-tests --disable-optimization

59+ - name: Build

60+ run: |

61+ cabal build all --enable-tests --disable-optimization 2>&1 | tee build.log

62+ - name: Test

63+ run: |

64+ cabal test all --disable-optimization

.github/workflows/ci.yml+2−2

@@ -1,4 +1,4 @@

1−name: CI

1+name: Stack CI

2

3# Trigger the workflow on push or pull request, but only for the master branch

4on:

@@ -12,7 +12,7 @@ jobs:

12 strategy:

13 matrix:

14 stack: ["2.3.3"]

15− ghc: ["8.8.3"]

15+ ghc: ["8.10.4"]

16 os: [ubuntu-latest]

17 steps:

18 - uses: actions/checkout@v2

EXAMPLE.md+41−4

@@ -13,23 +13,37 @@ Our api under test:

13{-# LANGUAGE DeriveGeneric #-}

14{-# LANGUAGE GeneralizedNewtypeDeriving #-}

15{-# LANGUAGE RecordWildCards #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE TypeApplications #-}

16

18

17−import Roboservant

19+import qualified Roboservant.Server as RS

20+import qualified Roboservant.Client as RC

21+import Servant.Client(ClientEnv, baseUrlPort, parseBaseUrl, mkClientEnv)

22+import Network.HTTP.Client (newManager, defaultManagerSettings)

23+import Roboservant.Types

18import Test.Hspec

24import Test.Hspec

19import Servant

25import Servant

20import GHC.Generics

26import GHC.Generics

21import Data.Typeable

27import Data.Typeable

22import Data.Hashable

28import Data.Hashable

23import Data.Maybe(isNothing, isJust)

29import Data.Maybe(isNothing, isJust)

30+import qualified Network.Wai.Handler.Warp as Warp

31+import Data.Aeson(FromJSON,ToJSON)

24

32

25newtype A = A Int

33newtype A = A Int

26 deriving (Generic, Eq, Show, Typeable)

34 deriving (Generic, Eq, Show, Typeable)

27 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

35 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

28

36

37+instance FromJSON A

38+instance ToJSON A

39+

29newtype B = B Int

40newtype B = B Int

30 deriving (Generic, Eq, Show, Typeable)

41 deriving (Generic, Eq, Show, Typeable)

31 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

42 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

32

43

44+instance FromJSON B

45+instance ToJSON B

46+

33type Api =

47type Api =

34 "item" :> Get '[JSON] A

48 "item" :> Get '[JSON] A

35 :<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B

49 :<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B

@@ -45,7 +59,7 @@ server introduce = introduce :<|> combine :<|> eliminate

45```

59```

46

60

47We have a "good" server, that never generates anything other than a 0. This means repeated application of

61We have a "good" server, that never generates anything other than a 0. This means repeated application of

48−the combination/addition rule can never bring us to the dangerous state of numbers larger than 100.

62+the combination/addition rule can never bring us to the dangerous state of numbers larger than 10.

49

63

50``` haskell

64``` haskell

51goodServer, badServer :: Server Api

65goodServer, badServer :: Server Api

@@ -62,13 +76,24 @@ main = hspec spec

62spec :: Spec

76spec :: Spec

63spec = describe "example" $ do

77spec = describe "example" $ do

64 it "good server should not fail" $ do

78 it "good server should not fail" $ do

65− fuzz @Api goodServer config

79+ RS.fuzz @Api goodServer config

66 >>= (`shouldSatisfy` isNothing)

80 >>= (`shouldSatisfy` isNothing)

67 it "bad server should fail" $ do

81 it "bad server should fail" $ do

68− fuzz @Api badServer config

82+ RS.fuzz @Api badServer config

69 >>= (`shouldSatisfy` isJust)

83 >>= (`shouldSatisfy` isJust)

70```

84```

71

85

86+The previous test just picked apart the server and ran functions manually: sometimes, we want to test via

87+an honest-to-goodness network port, like so:

88+

89+```haskell

90+ around (withServer (serve (Proxy :: Proxy Api) badServer)) $ do

91+ it "we should also be able to run the _client_ to an independent server (ignore server error messages)" $ \(clientEnv::ClientEnv) -> do

92+ RC.fuzz @Api clientEnv config >>= (`shouldSatisfy` isJust)

93+```

94+

95+(we use withApplication rather than testWithApplication because we don't primarily care what the server does here:

96+we want to check what a client does when presented with a faulty server.)

72

97

73We expect to be able to cover the whole api from our starting point, so let's set the coverage to 0.99.

98We expect to be able to cover the whole api from our starting point, so let's set the coverage to 0.99.

74There are other tweakable things in the config, like maximum runtime, reps,

99There are other tweakable things in the config, like maximum runtime, reps,

@@ -104,3 +129,15 @@ build it up from components.

104deriving via (Compound B) instance BuildFrom B

129deriving via (Compound B) instance BuildFrom B

105deriving via (Atom B) instance Breakdown B

130deriving via (Atom B) instance Breakdown B

106```

131```

132+

133+

134+test utilities:

135+

136+``` haskell

137+withServer :: Application -> ActionWith ClientEnv -> IO ()

138+withServer app action = Warp.withApplication (pure app) (\p -> genClientEnv p >>= action)

139+ where genClientEnv port = do

140+ baseUrl <- parseBaseUrl "http://localhost"

141+ manager <- newManager defaultManagerSettings

142+ pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })

143+```

Makefile+1−1

@@ -1,4 +1,4 @@

1testwatch:

2− ghcid -T main -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W

2+ ghcid -T main -c 'stack repl roboservant:lib roboservant:test:roboservant-test --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W

3pedanticwatch:

4 ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W

README.md+8−1

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

2

3Automatically fuzz your servant apis in a contextually-aware way.

4

5−![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)

5+[![Stack CI](https://github.com/mwotton/roboservant/actions/workflows/ci.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/ci.yml)

6+[![Cabal CI](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml)

6

7

7## example

8## example

8

9

@@ -102,6 +103,12 @@ we would want to show that distinction in a visible way: it's possible

102that other calls that don't have direct data dependencies were

103that other calls that don't have direct data dependencies were

103important, but we definitely know we need the direct data dependencies.

104important, but we definitely know we need the direct data dependencies.

104

105

106+The provenance stuff is a bit underbaked. It should at least pull a

107+representation of the route chosen rather than just an integer index.

108+

105It would also be nice to have a robust strategy for deriving recursive

109It would also be nice to have a robust strategy for deriving recursive

106datatypes, or at least rejecting attempts to generate them that don't

110datatypes, or at least rejecting attempts to generate them that don't

107end in an infinite loop.

111end in an infinite loop.

112+

113+Currently the `FlattenServer` instance for `:>` is quadratic. It would

114+be nice to fix this but I lack the art.

benchmarks/genFile.sh+15−2

@@ -1,9 +1,11 @@

1n=$1

2+k=$2

2

3

3cat prelude

4cat prelude

4−echo -n "type Api = \"route1\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"

5+echo -n "type SubApi = \"route1\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"

5for i in $(seq 2 $n); do

6for i in $(seq 2 $n); do

7+ echo -n " :<|> \"route${i}\" :> "

6− echo " :<|> \"route${i}\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"

8+ echo "ReqBody '[JSON] Input :> Post '[JSON] Output"

7done

9done

8

10

9echo -n "server = handler "

11echo -n "server = handler "

@@ -11,3 +13,14 @@ echo -n "server = handler "

11for i in $(seq 2 $n); do

13for i in $(seq 2 $n); do

12 echo -n ":<|> handler "

14 echo -n ":<|> handler "

13done

15done

16+echo

17+echo

18+

19+echo -n "type Api = Flatten ("

20+for i in $(seq 1 $k); do

21+ echo -n '"foo" :> '

22+done;

23+

24+echo "SubApi )"

25+

26+

benchmarks/prelude+7−16

@@ -12,6 +12,7 @@ import Servant

12import Data.Hashable

13import GHC.Generics

14import Data.Aeson

15+import Servant.API.Flatten

15

16

16data Input = Input1 { foo :: String }

17data Input = Input1 { foo :: String }

17 | Input2 { bar :: Int }

18 | Input2 { bar :: Int }

@@ -52,19 +53,9 @@ handler = pure . \case

52 Input1 foo -> Output1 foo

53 Input1 foo -> Output1 foo

53 Input2 bar -> Output2 bar

54 Input2 bar -> Output2 bar

54

55

56+main =

55−main = fuzz @Api server defaultConfig (pure ())

57+ -- fuzz @Api server defaultConfig

56−

58+ pure ()

57−defaultConfig :: Config

59+

58−defaultConfig = Config {

60+f = flatten (Proxy @Api)

59− -- you can pass extra values in using the seed argument. This can be useful

61+

60− -- for things that might not be produceable within the api, like auth tokens.

61− seed = [hashedDyn "blah"]

62− , maxRuntime = 0.5

63− -- if we get to 1000 interactions with the api, call it quits.

64− , maxReps = 1000

65− -- if you're using this inside quickcheck or hedgehog, you might want to set this

66− -- from their seed to make sure it stays deterministic

67− , rngSeed = 0

68− -- 0 to 100: fail tests if we hit less than this percentage of endpoints.

69− , coverageThreshold = 0

70− }

benchmarks/runTiming.sh+2−2

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

1lo=$1

2hi=$2

3−

3+k=$3

4for i in $(seq $lo 5 $hi); do

5− ./genFile.sh $i > main.hs;

5+ ./genFile.sh $i $k > main.hs;

6 echo "sievedn: $i,";

7 /usr/bin/time -f "%e" stack ghc main.hs 2>&1;

8# /usr/bin/time -f "%e" stack ghc -- -fomit-interface-pragmas main.hs 2>&1;

package.yaml+10−2

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

@@ -19,6 +19,7 @@ dependencies:

19- containers

20- random

21- hashable

22+- http-types

22- lifted-base

23- lifted-base

23- monad-control

24- monad-control

24- mtl

25- mtl

@@ -55,7 +56,10 @@ tests:

55 - hspec

56 - hspec

56 - hspec-core

57 - hspec-core

57 - http-api-data

58 - http-api-data

58−

59+ - http-client

60+ - hspec-wai

61+ - wai

62+ - warp

59 example:

63 example:

60 main: Example.lhs

64 main: Example.lhs

61 source-dirs: .

65 source-dirs: .

@@ -63,6 +67,10 @@ tests:

63 dependencies:

67 dependencies:

64 - roboservant

68 - roboservant

65 - hspec

69 - hspec

70+ - warp

71+ - http-client

72+ - aeson

73+ - hspec-core

66 ghc-options: -pgmL markdown-unlit

74 ghc-options: -pgmL markdown-unlit

67

75

68 build-tools: markdown-unlit

76 build-tools: markdown-unlit

roboservant.cabal+22−6

@@ -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: 48773018ec618e9eba02a126e3aeb93781a1d68ce28e2c405c35e9536bf94f70

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

@@ -28,14 +28,17 @@ source-repository head

28library

29 exposed-modules:

30 Roboservant

31+ Roboservant.Client

31 Roboservant.Direct

32 Roboservant.Direct

33+ Roboservant.Server

32 Roboservant.Types

34 Roboservant.Types

33 Roboservant.Types.Breakdown

35 Roboservant.Types.Breakdown

34 Roboservant.Types.BuildFrom

36 Roboservant.Types.BuildFrom

35 Roboservant.Types.Config

37 Roboservant.Types.Config

36− Roboservant.Types.FlattenServer

37 Roboservant.Types.Internal

38 Roboservant.Types.Internal

39+ Roboservant.Types.Orphans

38 Roboservant.Types.ReifiedApi

40 Roboservant.Types.ReifiedApi

41+ Roboservant.Types.ReifiedApi.Server

39 other-modules:

42 other-modules:

40 Paths_roboservant

43 Paths_roboservant

41 hs-source-dirs:

44 hs-source-dirs:

@@ -48,6 +51,7 @@ library

48 , dependent-map

51 , dependent-map

49 , dependent-sum

52 , dependent-sum

50 , hashable

53 , hashable

54+ , http-types

51 , lifted-base

55 , lifted-base

52 , monad-control

56 , monad-control

53 , mtl

57 , mtl

@@ -69,18 +73,22 @@ test-suite example

69 other-modules:

73 other-modules:

70 Paths_roboservant

74 Paths_roboservant

71 hs-source-dirs:

75 hs-source-dirs:

72− ./.

76+ ./

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

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

74 build-tool-depends:

78 build-tool-depends:

75 markdown-unlit:markdown-unlit

79 markdown-unlit:markdown-unlit

76 build-depends:

80 build-depends:

81+ aeson

77− base >=4.7 && <5

82+ , base >=4.7 && <5

78 , bytestring

83 , bytestring

79 , containers

84 , containers

80 , dependent-map

85 , dependent-map

81 , dependent-sum

86 , dependent-sum

82 , hashable

87 , hashable

83 , hspec

88 , hspec

89+ , hspec-core

90+ , http-client

91+ , http-types

84 , lifted-base

92 , lifted-base

85 , monad-control

93 , monad-control

86 , mtl

94 , mtl

@@ -95,6 +103,7 @@ test-suite example

95 , time

103 , time

96 , unordered-containers

104 , unordered-containers

97 , vinyl

105 , vinyl

106+ , warp

98 default-language: Haskell2010

107 default-language: Haskell2010

99

108

100test-suite roboservant-test

109test-suite roboservant-test

@@ -107,6 +116,8 @@ test-suite roboservant-test

107 Nested

116 Nested

108 Post

117 Post

109 Product

118 Product

119+ Put

120+ QueryParams

110 Seeded

121 Seeded

111 UnsafeIO

122 UnsafeIO

112 Valid

123 Valid

@@ -124,7 +135,10 @@ test-suite roboservant-test

124 , hashable

135 , hashable

125 , hspec

136 , hspec

126 , hspec-core

137 , hspec-core

138+ , hspec-wai

127 , http-api-data

139 , http-api-data

140+ , http-client

141+ , http-types

128 , lifted-base

142 , lifted-base

129 , monad-control

143 , monad-control

130 , mtl

144 , mtl

@@ -139,4 +153,6 @@ test-suite roboservant-test

139 , time

153 , time

140 , unordered-containers

154 , unordered-containers

141 , vinyl

155 , vinyl

156+ , wai

157+ , warp

142 default-language: Haskell2010

158 default-language: Haskell2010

src/Roboservant/Client.hsnew file+127

@@ -0,0 +1,127 @@

1+{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE NamedFieldPuns #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE AllowAmbiguousTypes #-}

6+{-# LANGUAGE DataKinds #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

11+

12+{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE FlexibleContexts #-}

15+-- should all the NormalizeFunction instances be in one place?

16+{-# OPTIONS_GHC -fno-warn-orphans #-}

17+module Roboservant.Client where

18+

19+import Data.Proxy

20+import Servant.Client

21+import Roboservant.Types

22+import Roboservant(Report, fuzz')

23+import Servant

24+import Data.Bifunctor

25+import Data.List.NonEmpty (NonEmpty)

26+import Data.Dynamic (Dynamic,Typeable)

27+import qualified Data.Vinyl.Curry as V

28+import qualified Data.Text as T

29+import Control.Monad.Reader

30+import Data.Hashable

31+import Network.HTTP.Types.Status

32+

33+-- fuzz :: forall api.

34+-- (FlattenServer api, ToReifiedApi (Endpoints api)) =>

35+-- Server api ->

36+-- Config ->

37+-- IO (Maybe Report)

38+-- fuzz s = fuzz' (reifyServer s)

39+-- -- todo: how do we pull reifyServer out?

40+-- where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))

41+-- => Server api -> ReifiedApi

42+-- reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

43+

44+fuzz :: forall api . (ToReifiedClientApi (Endpoints api), FlattenClient api, HasClient ClientM api)

45+ => ClientEnv -> Config -> IO (Maybe Report)

46+fuzz clientEnv

47+ = fuzz'

48+ (toReifiedClientApi

49+ (flattenClient @api apiClient) (Proxy @(Endpoints api)) clientEnv)

50+ where apiClient = client (Proxy @api)

51+

52+

53+

54+class ToReifiedClientApi api where

55+ toReifiedClientApi :: ClientBundled api -> Proxy api -> ClientEnv -> ReifiedApi

56+

57+data ClientBundled endpoints where

58+ AClientEndpoint :: Client ClientM endpoint -> ClientBundled endpoints -> ClientBundled (endpoint ': endpoints)

59+ NoClientEndpoints :: ClientBundled '[]

60+

61+

62+class FlattenClient api where

63+ flattenClient :: Client ClientM api -> ClientBundled (Endpoints api)

64+

65+instance

66+ ( NormalizeFunction (Client ClientM endpoint)

67+ , Normal (Client ClientM endpoint) ~ V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))))

68+ , ToReifiedClientApi endpoints

69+ , V.RecordCurry' (EndpointArgs endpoint)

70+ , ToReifiedEndpoint endpoint) =>

71+ ToReifiedClientApi (endpoint : endpoints) where

72+ toReifiedClientApi (endpoint `AClientEndpoint` endpoints) _ clientEnv =

73+ (0, ReifiedEndpoint

74+ { reArguments = reifiedEndpointArguments @endpoint

75+ , reEndpointFunc = foo (normalize endpoint)

76+ }

77+ )

78+ : (map . first) (+1)

79+ (toReifiedClientApi endpoints (Proxy @endpoints) clientEnv)

80+ where

81+

82+ foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType)

83+ -> V.Curried (EndpointArgs endpoint) (IO ResultType)

84+ foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv)

85+

86+mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b

87+mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g

88+

89+type ResultType = Either InteractionError (NonEmpty (Dynamic,Int))

90+-- runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)

91+

92+

93+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where

94+ type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int)))

95+ normalize c = ReaderT $

96+ fmap (bimap renderClientError breakdown) . runClientM c

97+ where

98+ renderClientError :: ClientError -> InteractionError

99+ renderClientError err = case err of

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

101+ _ -> InteractionError textual True

102+

103+ where textual = T.pack $ show err

104+instance ToReifiedClientApi '[] where

105+ toReifiedClientApi NoClientEndpoints _ _ = []

106+

107+

108+instance

109+ ( FlattenClient api,

110+ Endpoints endpoint ~ '[endpoint]

111+ ) =>

112+ FlattenClient (endpoint :<|> api)

113+ where

114+ flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c

115+

116+instance

117+ (

118+ Endpoints api ~ '[api]

119+ ) =>

120+ FlattenClient (x :> api)

121+ where

122+ flattenClient c = c `AClientEndpoint` NoClientEndpoints

123+

124+

125+instance FlattenClient (Verb method statusCode contentTypes responseType)

126+ where

127+ flattenClient c = c `AClientEndpoint` NoClientEndpoints

src/Roboservant/Direct.hs+33−31

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

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

10−{-# LANGUAGE TypeApplications #-}

10+

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

13

14module Roboservant.Direct

15− ( fuzz,

15+ ( fuzz',

16 Config (..),

17 -- TODO come up with something smarter than exporting all this, we should

18 -- have some nice error-display functions

@@ -56,16 +56,16 @@ import GHC.Generics ((:*:) (..))

56import Roboservant.Types

57 ( ApiOffset (..),

58 Argument (..),

59− FlattenServer (..),

59+ InteractionError(..),

60 Provenance (..),

61+ ReifiedApi,

61 ReifiedEndpoint (..),

62 ReifiedEndpoint (..),

62 Stash (..),

63 Stash (..),

63 StashValue (..),

64 StashValue (..),

64− ToReifiedApi (..),

65 TypedF,

66 )

67import Roboservant.Types.Config

68−import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))

68+

69import System.Random (Random (randomR), StdGen, mkStdGen)

70import qualified Type.Reflection as R

71

@@ -105,7 +105,7 @@ data EndpointOption

105 = forall as.

106 (V.RecordToList as, V.RMap as) =>

107 EndpointOption

108− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))),

108+ { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),

109 eoArgs :: V.Rec (TypedF StashValue) as

110 }

111

@@ -121,13 +121,18 @@ data Report

121 }

122 deriving (Show)

123

124+

125+

126+-- fuzzClient :: Client api -> Config -> IO (Maybe Report)

127+-- fuzzClient = undefined

128+

129+

130+

124−fuzz ::

131+fuzz' ::

125− forall api.

132+ ReifiedApi ->

126− (FlattenServer api, ToReifiedApi (Endpoints api)) =>

127− Server api ->

128 Config ->

133 Config ->

129 IO (Maybe Report)

134 IO (Maybe Report)

130−fuzz server Config {..} = handle (pure . Just . formatException) $ do

135+fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do

131 let path = []

136 let path = []

132 stash = addToStash seed mempty

137 stash = addToStash seed mempty

133 currentRng = mkStdGen rngSeed

138 currentRng = mkStdGen rngSeed

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

145 Report

150 Report

146 (unlines [show failureType, show exception])

151 (unlines [show failureType, show exception])

147 r

152 r

148− displayDiagnostics FuzzState {..} = liftIO $ do

153+ displayDiagnostics FuzzState {..} = liftIO $

149 logInfo $ unlines $

154 logInfo $ unlines $

150− ["api endpoints covered"]

155+ ["api endpoints covered"]

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

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

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

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

153− <> 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)

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

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

155 -- $ \_k v ->

160 -- $ \_k v ->

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

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

@@ -173,7 +178,7 @@ fuzz server Config {..} = handle (pure . Just . formatException) $ do

173 else do

178 else do

174 _ <- action

179 _ <- action

175 untilDone (n -1, deadline) action

180 untilDone (n -1, deadline) action

176− reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

181+

177 routeCount = length reifiedApi

182 routeCount = length reifiedApi

178 elementOrFail ::

183 elementOrFail ::

179 (MonadState FuzzState m, MonadIO m) =>

184 (MonadState FuzzState m, MonadIO m) =>

@@ -190,7 +195,7 @@ fuzz server Config {..} = handle (pure . Just . formatException) $ do

190 ( forall as.

195 ( forall as.

191 (V.RecordToList as, V.RMap as) =>

196 (V.RecordToList as, V.RMap as) =>

192 FuzzOp ->

197 FuzzOp ->

193− V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) ->

198+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->

194 V.Rec (TypedF V.Identity) as ->

199 V.Rec (TypedF V.Identity) as ->

195 m r

200 m r

196 ) ->

201 ) ->

@@ -231,23 +236,21 @@ fuzz server Config {..} = handle (pure . Just . formatException) $ do

231 execute ::

236 execute ::

232 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>

237 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>

233 FuzzOp ->

238 FuzzOp ->

234− V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) ->

239+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->

235 V.Rec (TypedF V.Identity) as ->

240 V.Rec (TypedF V.Identity) as ->

236 m ()

241 m ()

237 execute fuzzop func args = do

242 execute fuzzop func args = do

238 (liftIO . logInfo . show . (fuzzop,) . stash) =<< get

243 (liftIO . logInfo . show . (fuzzop,) . stash) =<< get

239 liftIO (V.runcurry' func argVals) >>= \case

244 liftIO (V.runcurry' func argVals) >>= \case

240− -- parameterise this

245+ Left (e::InteractionError) ->

241− Left (serverError :: ServerError) ->

246+ if fatalError e

242− case errHTTPCode serverError of

247+ then throw e

243− 500 -> throw serverError

248+ else pure ()

244− _ ->

245− liftIO . logInfo . show $ ("ignoring non-500 error", serverError)

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

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

247 modify'

250 modify'

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

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

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

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

250− )

253+ )

251 where

254 where

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

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

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

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

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

259 (execute op func args)

262 (execute op func args)

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

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

261 Handler

264 Handler

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

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

263− -- displayDiagnostics =<< get

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

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

265 )

267 )

266 ]

268 ]

src/Roboservant/Server.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE AllowAmbiguousTypes #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE PolyKinds #-}

8+

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+

14+module Roboservant.Server (fuzz, module Roboservant.Types ) where

15+

16+import Roboservant.Direct(fuzz',Report)

17+import Roboservant.Types

18+ ( FlattenServer (..),

19+ ReifiedApi,

20+ )

21+import Roboservant.Types.ReifiedApi.Server(ToReifiedApi (..))

22+import Servant (Endpoints, Proxy (Proxy), Server)

23+import Roboservant.Types.Config

24+

25+fuzz :: forall api.

26+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>

27+ Server api ->

28+ Config ->

29+ IO (Maybe Report)

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

34+ reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

35+-- reifyServer server = toReifiedApi server (Proxy @(Endpoints api))

36+

src/Roboservant/Types.hs+3−2

@@ -10,8 +10,8 @@

10module Roboservant.Types

11 ( module Roboservant.Types.Breakdown,

12 module Roboservant.Types.BuildFrom,

13− module Roboservant.Types.FlattenServer,

14 module Roboservant.Types.ReifiedApi,

13 module Roboservant.Types.ReifiedApi,

14+ module Roboservant.Types.ReifiedApi.Server,

15 module Roboservant.Types.Internal,

16 module Roboservant.Types.Config,

17 )

@@ -20,6 +20,7 @@ where

20import Roboservant.Types.Breakdown

21import Roboservant.Types.BuildFrom

22import Roboservant.Types.Config

23−import Roboservant.Types.FlattenServer

24import Roboservant.Types.Internal

23import Roboservant.Types.Internal

25import Roboservant.Types.ReifiedApi

24import Roboservant.Types.ReifiedApi

25+import Roboservant.Types.ReifiedApi.Server

26+import Roboservant.Types.Orphans()

src/Roboservant/Types/Breakdown.hs+15−2

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

@@ -38,10 +41,15 @@ instance (Hashable x, Typeable x) => Breakdown (Atom x) where

38deriving via (Atom ()) instance Breakdown ()

41deriving via (Atom ()) instance Breakdown ()

39

42

40deriving via (Atom Int) instance Breakdown Int

43deriving via (Atom Int) instance Breakdown Int

44+deriving via (Atom Char) instance Breakdown Char

41

45

42−deriving via (Atom [Char]) instance Breakdown [Char]

46+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x)

43

47

48+instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where

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

50+

51+

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

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

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

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

46

54

47instance (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

@@ -66,3 +74,8 @@ instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where

66

74

67instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where

75instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where

68 gBreakdownExtras (K1 c) = NEL.toList $ breakdown c

76 gBreakdownExtras (K1 c) = NEL.toList $ breakdown c

77+

78+instance GBreakdown U1 where

79+ gBreakdownExtras U1 = []

80+

81+deriving via (Atom NoContent) instance Breakdown NoContent

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

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

12

13module Roboservant.Types.BuildFrom where

14

15−import Control.Monad (filterM)

15+import Data.List(nub)

16import qualified Data.Dependent.Map as DM

17import Data.Hashable

18import qualified Data.IntSet as IntSet

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

@@ -60,10 +62,13 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x)

60

62

61-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.

63-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.

62-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.

64-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.

63−instance (BuildFrom x) => BuildFrom [x] where

65+instance (Eq x, BuildFrom x) => BuildFrom [x] where

66+ extras stash =

64− extras stash = map (\xs -> (concatMap fst xs, map snd xs)) $ powerset $ extras @x stash

67+ nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash

65 where

68 where

66− powerset xs = filterM (const [True, False]) xs

69+ -- powerset creates way too much stuff. something better here eventually.

70+ notpowerset xs = []:xs:map pure xs

71+

67

72

68instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where

73instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where

69 extras stash = fmap (Compound . to) <$> gExtras stash

74 extras stash = fmap (Compound . to) <$> gExtras stash

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

72

77

73deriving via (Atom Char) instance BuildFrom Char

78deriving via (Atom Char) instance BuildFrom Char

74

79

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

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

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

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

77

82

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

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

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

98

103

99instance GBuildFrom U1 where

104instance GBuildFrom U1 where

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

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

106+

107+deriving via (Atom NoContent) instance BuildFrom NoContent

src/Roboservant/Types/FlattenServer.hsdeleted−44

@@ -1,44 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE PolyKinds #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeApplications #-}

7−{-# LANGUAGE TypeOperators #-}

8−{-# LANGUAGE UndecidableInstances #-}

9−

10−-- | terrible name, this really just pulls stuff out where we can fiddle with it.

11−module Roboservant.Types.FlattenServer where

12−

13−import Servant

14−

15−data Bundled endpoints where

16− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)

17− NoEndpoints :: Bundled '[]

18−

19−class FlattenServer api where

20− flattenServer :: Server api -> Bundled (Endpoints api)

21−

22−instance

23− ( FlattenServer api,

24− Endpoints endpoint ~ '[endpoint]

25− ) =>

26− FlattenServer (endpoint :<|> api)

27− where

28− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server

29−

30−instance

31− ( HasServer (x :> api) '[],

32− Endpoints (x :> api) ~ '[x :> api]

33− ) =>

34− FlattenServer (x :> api)

35− where

36− flattenServer server = server `AnEndpoint` NoEndpoints

37−

38−instance

39− ( Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType],

40− HasServer (Verb method statusCode contentTypes responseType) '[]

41− ) =>

42− FlattenServer (Verb method statusCode contentTypes responseType)

43− where

44− flattenServer server = server `AnEndpoint` NoEndpoints

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+56−49

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

1+-- | Description: ways to build a reified api from a servant description.

2+--

3+-- arguably this could be more general and be abstracted away from even relying on servant

4+-- but that's future work.

5+

1{-# LANGUAGE AllowAmbiguousTypes #-}

6{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

7{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DerivingStrategies #-}

8{-# LANGUAGE DerivingStrategies #-}

@@ -15,25 +20,22 @@

15{-# LANGUAGE CPP #-}

20{-# LANGUAGE CPP #-}

16module Roboservant.Types.ReifiedApi where

21module Roboservant.Types.ReifiedApi where

17

22

18−import Control.Monad.Except (runExceptT)

19−import Data.Bifunctor

20import Data.Dynamic (Dynamic)

23import Data.Dynamic (Dynamic)

21−import Data.Kind

24+import Control.Exception(Exception)

22import Data.List.NonEmpty (NonEmpty)

25import Data.List.NonEmpty (NonEmpty)

23import Data.Typeable (Typeable)

26import Data.Typeable (Typeable)

24import GHC.Generics ((:*:)(..))

27import GHC.Generics ((:*:)(..))

25−import GHC.TypeLits (Symbol)

26import Roboservant.Types.Internal

28import Roboservant.Types.Internal

27import Roboservant.Types.Breakdown

29import Roboservant.Types.Breakdown

28import Roboservant.Types.BuildFrom

30import Roboservant.Types.BuildFrom

29−import Roboservant.Types.FlattenServer

31+import Data.Kind(Type)

30import Servant

32import Servant

31import Servant.API.Modifiers(FoldRequired,FoldLenient)

33import Servant.API.Modifiers(FoldRequired,FoldLenient)

34+import GHC.TypeLits (Symbol)

32import qualified Data.Text as T

35import qualified Data.Text as T

33import qualified Data.Vinyl as V

36import qualified Data.Vinyl as V

34import qualified Data.Vinyl.Curry as V

37import qualified Data.Vinyl.Curry as V

35import qualified Type.Reflection as R

38import qualified Type.Reflection as R

36−import Data.Hashable(Hashable)

37

39

38newtype ApiOffset = ApiOffset Int

40newtype ApiOffset = ApiOffset Int

39 deriving (Eq, Show, Ord)

41 deriving (Eq, Show, Ord)

@@ -47,61 +49,32 @@ newtype Argument a = Argument

47

49

48data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint

50data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint

49 { reArguments :: V.Rec (TypedF Argument) as

51 { reArguments :: V.Rec (TypedF Argument) as

50− , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int))))

52+ , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))

51 }

53 }

52

54

53−type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]

55+instance Show ReifiedEndpoint where

54−

56+ show _ = "lol"

55−tagType :: Typeable a => f a -> TypedF f a

56−tagType = (R.typeRep :*:)

57−

58−class ToReifiedApi (endpoints ) where

59−

60− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi

61

57

62class ( V.RecordToList (EndpointArgs endpoint)

58class ( V.RecordToList (EndpointArgs endpoint)

63 , V.RMap (EndpointArgs endpoint)

59 , V.RMap (EndpointArgs endpoint)

64− ) => ToReifiedEndpoint (endpoint :: *) where

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

65 type EndpointArgs endpoint :: [Type]

61 type EndpointArgs endpoint :: [Type]

66 type EndpointRes endpoint :: Type

62 type EndpointRes endpoint :: Type

67

63

68 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)

64 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)

69

65

70−instance ToReifiedApi '[] where

71− toReifiedApi NoEndpoints _ = []

72

66

73−instance

67+tagType :: Typeable a => f a -> TypedF f a

74− ( Typeable (EndpointRes endpoint)

68+tagType = (R.typeRep :*:)

69+

70+data InteractionError = InteractionError

71+ { errorMessage :: T.Text

72+ , fatalError :: Bool

73+ }

74+ deriving Show

75+instance Exception InteractionError

76+

75

77

76− , NormalizeFunction (ServerT endpoint Handler)

77− , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int))))

78− , ToReifiedEndpoint endpoint

79− , ToReifiedApi endpoints

80− ) =>

81− ToReifiedApi (endpoint : endpoints)

82− where

83− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =

84− (0, ReifiedEndpoint

85− { reArguments = reifiedEndpointArguments @endpoint

86− , reEndpointFunc = normalize endpoint

87− }

88− )

89− : (map . first) (+1)

90− (toReifiedApi endpoints (Proxy @endpoints))

91−

92−class NormalizeFunction m where

93− type Normal m

94− normalize :: m -> Normal m

95−

96−instance NormalizeFunction x => NormalizeFunction (r -> x) where

97− type Normal (r -> x) = r -> Normal x

98− normalize = fmap normalize

99−

100−instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where

101− type Normal (Handler x) = IO (Either ServerError (NonEmpty (Dynamic,Int)))

102− normalize handler = (runExceptT . runHandler') handler >>= \case

103− Left serverError -> pure (Left serverError)

104− Right x -> pure $ Right $ breakdown x

105

78

106instance

79instance

107 (Typeable responseType, Breakdown responseType) =>

80 (Typeable responseType, Breakdown responseType) =>

@@ -111,6 +84,12 @@ instance

111 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType

84 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType

112 reifiedEndpointArguments = V.RNil

85 reifiedEndpointArguments = V.RNil

113

86

87+instance ToReifiedEndpoint (NoContentVerb method)

88+ where

89+ type EndpointArgs (NoContentVerb method) = '[]

90+ type EndpointRes (NoContentVerb method) = NoContent

91+ reifiedEndpointArguments = V.RNil

92+

114instance

93instance

115 (ToReifiedEndpoint endpoint) =>

94 (ToReifiedEndpoint endpoint) =>

116 ToReifiedEndpoint ((x :: Symbol) :> endpoint)

95 ToReifiedEndpoint ((x :: Symbol) :> endpoint)

@@ -119,6 +98,16 @@ instance

119 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint

98 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint

120 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

121

100

101+instance

102+ (ToReifiedEndpoint endpoint) =>

103+ ToReifiedEndpoint (RemoteHost :> endpoint)

104+ where

105+ type EndpointArgs (RemoteHost :> endpoint) = EndpointArgs endpoint

106+ type EndpointRes (RemoteHost :> endpoint) = EndpointRes endpoint

107+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

108+

109+

110+

122instance

111instance

123 (ToReifiedEndpoint endpoint) =>

112 (ToReifiedEndpoint endpoint) =>

124 ToReifiedEndpoint (Description s :> endpoint)

113 ToReifiedEndpoint (Description s :> endpoint)

@@ -161,6 +150,24 @@ instance

161 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))

150 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))

162 V.:& reifiedEndpointArguments @endpoint

151 V.:& reifiedEndpointArguments @endpoint

163

152

153+

154+instance

155+ ( BuildFrom paramType

156+ , ToReifiedEndpoint endpoint

157+ , Show paramType

158+ , Eq paramType

159+ ) =>

160+ ToReifiedEndpoint (QueryParams name paramType :> endpoint)

161+ where

162+ type EndpointArgs (QueryParams name paramType :> endpoint) = [paramType] ': EndpointArgs endpoint

163+ type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint

164+ reifiedEndpointArguments =

165+ tagType (Argument (buildFrom @[paramType]))

166+ V.:& reifiedEndpointArguments @endpoint

167+

168+

169+

170+

164instance

171instance

165 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

166 , ToReifiedEndpoint endpoint

173 , ToReifiedEndpoint endpoint

src/Roboservant/Types/ReifiedApi/Server.hsnew file+114

@@ -0,0 +1,114 @@

1+{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE AllowAmbiguousTypes #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE PolyKinds #-}

9+

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+{-# LANGUAGE CPP #-}

15+{-# LANGUAGE DataKinds #-}

16+{-# LANGUAGE TypeOperators #-}

17+{-# LANGUAGE FlexibleInstances #-}

18+{-# LANGUAGE MultiParamTypeClasses #-}

19+module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where

20+

21+import Servant

22+

23+import Control.Monad.Except (runExceptT)

24+import Data.Bifunctor

25+import Data.Dynamic (Dynamic)

26+import Data.List.NonEmpty (NonEmpty)

27+import Data.Typeable (Typeable)

28+import Roboservant.Types.Breakdown

29+import Roboservant.Types.ReifiedApi

30+

31+import qualified Data.Text as T

32+import qualified Data.Vinyl.Curry as V

33+import Data.Hashable(Hashable)

34+

35+type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]

36+

37+

38+class ToReifiedApi endpoints where

39+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi

40+

41+instance ToReifiedApi '[] where

42+ toReifiedApi NoEndpoints _ = []

43+

44+instance

45+ ( NormalizeFunction (ServerT endpoint Handler)

46+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))

47+ , ToReifiedEndpoint endpoint

48+ , ToReifiedApi endpoints

49+ ) =>

50+ ToReifiedApi (endpoint : endpoints)

51+ where

52+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =

53+ (0, ReifiedEndpoint

54+ { reArguments = reifiedEndpointArguments @endpoint

55+ , reEndpointFunc = normalize endpoint

56+ }

57+ )

58+ : (map . first) (+1)

59+ (toReifiedApi endpoints (Proxy @endpoints))

60+

61+

62+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where

63+ type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))

64+ normalize handler = (runExceptT . runHandler') handler >>= \case

65+ Left serverError -> pure (Left (renderServerError serverError))

66+ where

67+ -- | TODO improve this

68+ renderServerError :: ServerError -> InteractionError

69+ renderServerError s = InteractionError (T.pack $ show s) (errHTTPCode serverError == 500)

70+

71+ Right x -> pure $ Right $ breakdown x

72+

73+

74+-- case errHTTPCode serverError of

75+-- 500 -> throw serverError

76+-- _ ->

77+-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)

78+

79+

80+data Bundled endpoints where

81+ -- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)

82+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)

83+ NoEndpoints :: Bundled '[]

84+

85+class FlattenServer api where

86+ flattenServer :: Server api -> Bundled (Endpoints api)

87+

88+instance

89+ ( FlattenServer api,

90+ Endpoints endpoint ~ '[endpoint]

91+ ) =>

92+ FlattenServer (endpoint :<|> api)

93+ where

94+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server

95+

96+instance

97+ (

98+ Endpoints api ~ '[api]

99+ ) =>

100+ FlattenServer (x :> api)

101+ where

102+ flattenServer server = server `AnEndpoint` NoEndpoints

103+

104+instance FlattenServer (Verb method statusCode contentTypes responseType)

105+ where

106+ flattenServer server = server `AnEndpoint` NoEndpoints

107+

108+class NormalizeFunction m where

109+ type Normal m

110+ normalize :: m -> Normal m

111+

112+instance NormalizeFunction x => NormalizeFunction (r -> x) where

113+ type Normal (r -> x) = r -> Normal x

114+ normalize = fmap normalize

stack.yaml+5−10

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

1−resolver: lts-16.27

1+resolver: lts-20.4

2packages:

3- .

4

5extra-deps:

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

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

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

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

7−- vinyl-0.13.0

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

8−- dependent-sum-0.7.1.0

10+- some-1.0.3

9−- constraints-extras-0.3.0.2

10−- dependent-map-0.4.0.0

11−

12−- servant-0.18.2

13−- servant-client-0.18.2

14−- servant-client-core-0.18.2

15−- servant-server-0.18.2

stack.yaml.lock+9−58

@@ -7,69 +7,20 @@ packages:

7- completed:

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

9 pantry-tree:

10− size: 325

11 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

10 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

11+ size: 325

12 original:

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

14- completed:

15− hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724

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

16− pantry-tree:

17− size: 1857

18− sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01

19− original:

20− hackage: vinyl-0.13.0

21−- completed:

22− hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

23− pantry-tree:

24− size: 290

25− sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50

26− original:

27− hackage: dependent-sum-0.7.1.0

28−- completed:

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

35−- completed:

36− hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

37− pantry-tree:

38− size: 551

39− sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5

40− original:

41− hackage: dependent-map-0.4.0.0

42−- completed:

43− hackage: servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298

44− pantry-tree:

45− size: 2662

46− sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2

47− original:

48− hackage: servant-0.18.2

49−- completed:

50− hackage: servant-client-0.18.2@sha256:82578ade7468873259bb2fdc9d62290a0f998550900683e1410a237ed4b05410,4591

51− pantry-tree:

52− size: 1300

53− sha256: 6324892c77bedbce32f0d6f1612fc2cb0d82c163d3be39efb951d3cc3792ce4a

54− original:

55− hackage: servant-client-0.18.2

56−- completed:

57− hackage: servant-client-core-0.18.2@sha256:ad63ae0f227373fea7e547d4c2a7b0b69e112ff409a83cbadffc9f6ee049926f,3763

58− pantry-tree:

59− size: 1444

60− sha256: 9e37bc5f8cbb70cf1accb20bd6f83fca4c2ca42472cd0fc4b22183c2c57cbe3b

61− original:

62− hackage: servant-client-core-0.18.2

63−- completed:

64− hackage: servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482

65 pantry-tree:

16 pantry-tree:

17+ sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

66− size: 2614

18+ size: 709

67− sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c

68 original:

19 original:

69− hackage: servant-server-0.18.2

20+ hackage: some-1.0.3

70snapshots:

21snapshots:

71- completed:

22- completed:

23+ sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

72− size: 533252

24+ size: 648660

73− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/27.yaml

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

74− sha256: c2aaae52beeacf6a5727c1010f50e89d03869abfab6d2c2658ade9da8ed50c73

75− original: lts-16.27

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

@@ -11,7 +11,7 @@ import Servant

11import Servant.API.Flatten

12

13type Api =

14− ( "one" :> Post '[JSON] Int

14+ ( "one" :> Summary "foo" :> Post '[JSON] Int

15 :<|> "two" :> Post '[JSON] Int

16 )

17 :<|> ( "three" :> Post '[JSON] Int

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.hsnew file+15

@@ -0,0 +1,15 @@

1+{-# LANGUAGE DataKinds #-}

2+

3+{-# LANGUAGE DerivingStrategies #-}

4+

5+

6+{-# LANGUAGE TypeOperators #-}

7+

8+module QueryParams where

9+

10+import Servant

11+

12+type Api = QueryParams "ints" Int :> Get '[JSON] [Int]

13+

14+server :: Server Api

15+server = pure

test/Spec.hs+105−65

@@ -4,7 +4,13 @@

4{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE StandaloneDeriving #-}

6{-# LANGUAGE TypeApplications #-}

7+{-# LANGUAGE RankNTypes #-}

8+{-# LANGUAGE FlexibleContexts #-}

9+{-# LANGUAGE AllowAmbiguousTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE DataKinds #-}

7{-# OPTIONS_GHC -fno-warn-orphans #-}

12{-# OPTIONS_GHC -fno-warn-orphans #-}

13+{-# LANGUAGE TypeFamilies #-}

8

14

9import qualified Breakdown

15import qualified Breakdown

10import Data.Dynamic (toDyn)

16import Data.Dynamic (toDyn)

@@ -15,100 +21,134 @@ import qualified Foo

15import qualified Headers

21import qualified Headers

16import qualified Nested

22import qualified Nested

17import qualified Post

23import qualified Post

24+import qualified Put

18import qualified Product

25import qualified Product

19−import qualified Roboservant as RS

26+import qualified QueryParams

27+import qualified Roboservant as R

28+import qualified Roboservant.Server as RS

29+import qualified Roboservant.Client as RC

20import qualified Seeded

30import qualified Seeded

21import Test.Hspec

31import Test.Hspec

22import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)

32import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)

23import qualified Valid

33import qualified Valid

34+import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )

35+

36+import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)

37+import Network.Wai(Application)

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

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

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

24

41

25main :: IO ()

42main :: IO ()

26main = hspec spec

43main = hspec spec

27

44

45+fuzzBoth

46+ :: forall a .

47+ (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,

48+ HasClient ClientM a)

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

50+fuzzBoth name server config condition = do

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

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

53+

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

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

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

57+

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

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

60+ where genClientEnv port = do

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

62+ manager <- newManager defaultManagerSettings

63+ pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })

64+

28spec :: Spec

65spec :: Spec

29spec = do

66spec = do

30 describe "Basic usage" $ do

67 describe "Basic usage" $ do

31 describe "noError" $ do

68 describe "noError" $ do

32− it "finds no error in a valid app" $ do

33− RS.fuzz @Valid.Api Valid.server RS.defaultConfig

34− >>= (`shouldSatisfy` isNothing)

69+ fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)

35− it "finds no error in a valid generic app" $ do

70+ fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)

36− RS.fuzz @Valid.RoutedApi Valid.routedServer RS.defaultConfig

37− >>= (`shouldSatisfy` isNothing)

38− it "does fail coverage check" $ do

39− r <- RS.fuzz @Valid.Api Valid.server RS.defaultConfig {RS.coverageThreshold = 0.6}

71+ fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}

72+ (\r ->

40− fmap (RS.failureReason . RS.rsException) r

73+ fmap (R.failureReason . R.rsException) r

41− `shouldSatisfy` ( \case

74+ `shouldSatisfy` ( \case

42− Just (RS.InsufficientCoverage _) -> True

75+ Just (R.InsufficientCoverage _) -> True

43− _ -> False

76+ _ -> False

44− )

77+ ))

45− describe "posted body" $ do

78+ describe "posted body" $

46− it "passes a coverage check using a posted body" $ do

79+ 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" $

47− RS.fuzz @Post.Api Post.server RS.defaultConfig {RS.coverageThreshold = 0.99}

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

48− >>= (`shouldSatisfy` isNothing)

85+ (`shouldSatisfy` isNothing)

86+

87+

49 describe "seeded" $ do

88 describe "seeded" $ do

50− shouldFail

89+ let res = Seeded.Seed 1

51− $ it "finds an error using information passed in"

90+ shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server

52− $ let res = Seeded.Seed 1

53− in RS.fuzz @Seeded.Api Seeded.server (RS.defaultConfig {RS.seed = [(toDyn res, hash res)]})

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

54− >>= (`shouldSatisfy` isNothing)

92+ (`shouldSatisfy` isNothing)

93+

55− describe "Foo" $ do

94+ describe "Foo" $

56− it "finds an error in a basic app" $

57− RS.fuzz @Foo.Api Foo.server RS.defaultConfig

58− >>= (`shouldSatisfy` serverFailure)

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

96+

97+ describe "QueryParams" $

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

99+ (`shouldSatisfy` isNothing)

100+

59 describe "BuildFrom" $ do

101 describe "BuildFrom" $ do

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

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

61− it "should find a failure that's dependent on using header info" $ do

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

62− RS.fuzz @Headers.Api Headers.server RS.defaultConfig

63− >>= (`shouldSatisfy` serverFailure)

104+ (`shouldSatisfy` serverFailure)

64− describe "product types" $ do

105+ describe "product types" $

65− it "should find a failure that's dependent on creating a product" $ do

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

66− RS.fuzz @Product.Api Product.server RS.defaultConfig {RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1 :: Int)]}

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

67− >>= (`shouldSatisfy` serverFailure)

108+ (`shouldSatisfy` serverFailure)

68 describe "Breakdown" $ do

109 describe "Breakdown" $ do

69− it "handles products" $ do

70− RS.fuzz @Breakdown.ProductApi Breakdown.productServer RS.defaultConfig

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

71− >>= (`shouldSatisfy` serverFailure)

111+ (`shouldSatisfy` serverFailure)

72− it "handles sums" $ do

73− RS.fuzz @Breakdown.SumApi Breakdown.sumServer RS.defaultConfig

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

74− >>= (`shouldSatisfy` serverFailure)

113+ (`shouldSatisfy` serverFailure)

75− describe "flattening" $ do

114+ describe "flattening" $

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

77− -- if you get a type error with a nested api.

78− it "can handle nested apis" $ do

79− RS.fuzz @(Nested.FlatApi) Nested.server RS.defaultConfig {RS.coverageThreshold = 0.99}

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

80− >>= (`shouldSatisfy` isNothing)

116+ (`shouldSatisfy` isNothing)

81−

117+

82−serverFailure :: Maybe RS.Report -> Bool

118+serverFailure :: Maybe R.Report -> Bool

83serverFailure = \case

119serverFailure = \case

84− Just RS.Report {..} ->

120+ Just R.Report {..} ->

85− let RS.RoboservantException {..} = rsException

121+ let R.RoboservantException {..} = rsException

86− in failureReason /= RS.NoPossibleMoves

122+ in failureReason /= R.NoPossibleMoves

87 _ -> False

123 _ -> False

88

124

89−deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo

125+deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo

126+

127+deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo

128+

129+deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo

90

130

91−deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo

131+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo

92

132

93−deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo

133+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed

94

134

95−deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo

135+deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed

96

136

97−deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed

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

98

138

99−deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed

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

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

100

141

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

101−deriving via (RS.Atom Void) instance RS.BuildFrom Void

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

102

144

103−deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost

104

145

105−deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost

106

146

107−deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo

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

108

148

109−deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo

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

110

150

111−deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum

151+deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum

112

152

113-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.

153-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.

114-- this is often useful when testing tests.

154-- this is often useful when testing tests.

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

118 ( \i ->

158 ( \i ->

119 i

159 i

120 { itemExample = \p a cb -> do

160 { itemExample = \p a cb -> do

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

161+ r <- itemExample i p a cb

122 pure

162 pure

123 r

163 r

124 { 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+2−3

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

@@ -21,7 +20,7 @@ data Routes route

21 = Routes

20 = Routes

22 { getInt ::

21 { getInt ::

23 route

22 route

24− :- Get '[JSON] Int,

23+ :- Summary "i'm a summary!" :> Get '[JSON] Int,

25 captureIt ::

24 captureIt ::

26 route

25 route

27 :- Capture "void" Void :> Get '[JSON] ()

26 :- Capture "void" Void :> Get '[JSON] ()