53ab47e..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+40−3

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

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

README.md+2−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

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+20−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: fa8c07f0c2fc10f18d3e925b8f702612c0c9fd81faa7942f901af388d509c231

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,15 @@ source-repository head

28library

29 exposed-modules:

30 Roboservant

31+ Roboservant.Client

31 Roboservant.Direct

32 Roboservant.Direct

32 Roboservant.Server

33 Roboservant.Server

33 Roboservant.Types

34 Roboservant.Types

34 Roboservant.Types.Breakdown

35 Roboservant.Types.Breakdown

35 Roboservant.Types.BuildFrom

36 Roboservant.Types.BuildFrom

36 Roboservant.Types.Config

37 Roboservant.Types.Config

37− Roboservant.Types.FlattenServer

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:

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

50 , dependent-map

51 , dependent-map

51 , dependent-sum

52 , dependent-sum

52 , hashable

53 , hashable

54+ , http-types

53 , lifted-base

55 , lifted-base

54 , monad-control

56 , monad-control

55 , mtl

57 , mtl

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

71 other-modules:

73 other-modules:

72 Paths_roboservant

74 Paths_roboservant

73 hs-source-dirs:

75 hs-source-dirs:

74− ./.

76+ ./

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

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

76 build-tool-depends:

78 build-tool-depends:

77 markdown-unlit:markdown-unlit

79 markdown-unlit:markdown-unlit

78 build-depends:

80 build-depends:

81+ aeson

79− base >=4.7 && <5

82+ , base >=4.7 && <5

80 , bytestring

83 , bytestring

81 , containers

84 , containers

82 , dependent-map

85 , dependent-map

83 , dependent-sum

86 , dependent-sum

84 , hashable

87 , hashable

85 , hspec

88 , hspec

89+ , hspec-core

90+ , http-client

91+ , http-types

86 , lifted-base

92 , lifted-base

87 , monad-control

93 , monad-control

88 , mtl

94 , mtl

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

97 , time

103 , time

98 , unordered-containers

104 , unordered-containers

99 , vinyl

105 , vinyl

106+ , warp

100 default-language: Haskell2010

107 default-language: Haskell2010

101

108

102test-suite roboservant-test

109test-suite roboservant-test

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

109 Nested

116 Nested

110 Post

117 Post

111 Product

118 Product

119+ Put

120+ QueryParams

112 Seeded

121 Seeded

113 UnsafeIO

122 UnsafeIO

114 Valid

123 Valid

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

126 , hashable

135 , hashable

127 , hspec

136 , hspec

128 , hspec-core

137 , hspec-core

138+ , hspec-wai

129 , http-api-data

139 , http-api-data

140+ , http-client

141+ , http-types

130 , lifted-base

142 , lifted-base

131 , monad-control

143 , monad-control

132 , mtl

144 , mtl

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

141 , time

153 , time

142 , unordered-containers

154 , unordered-containers

143 , vinyl

155 , vinyl

156+ , wai

157+ , warp

144 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+17−14

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

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

10−{-# LANGUAGE TypeApplications #-}

10+

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

13

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

56import Roboservant.Types

57 ( ApiOffset (..),

58 Argument (..),

59− InteractionError,

59+ InteractionError(..),

60 Provenance (..),

61 ReifiedApi,

62 ReifiedEndpoint (..),

@@ -65,6 +65,7 @@ import Roboservant.Types

65 TypedF,

66 )

67import Roboservant.Types.Config

68+

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

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

69import qualified Type.Reflection as R

70import qualified Type.Reflection as R

70

71

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

149 Report

150 Report

150 (unlines [show failureType, show exception])

151 (unlines [show failureType, show exception])

151 r

152 r

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

153+ displayDiagnostics FuzzState {..} = liftIO $

153 logInfo $ unlines $

154 logInfo $ unlines $

154− ["api endpoints covered"]

155+ ["api endpoints covered"]

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

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

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

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

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

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

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

159 -- $ \_k v ->

160 -- $ \_k v ->

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

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

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

241 execute fuzzop func args = do

242 execute fuzzop func args = do

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

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

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

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

244− Left (e::InteractionError) -> throw e

245+ Left (e::InteractionError) ->

246+ if fatalError e

247+ then throw e

248+ else pure ()

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

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

246 modify'

250 modify'

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

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

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

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

249− )

253+ )

250 where

254 where

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

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

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

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

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

258 (execute op func args)

262 (execute op func args)

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

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

260 Handler

264 Handler

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

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

262− -- displayDiagnostics =<< get

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

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

264 )

267 )

265 ]

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−4

@@ -10,18 +10,17 @@

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− Atom, Compound

18−

19 )

17 )

20where

18where

21

19

22import Roboservant.Types.Breakdown

20import Roboservant.Types.Breakdown

23import Roboservant.Types.BuildFrom

21import Roboservant.Types.BuildFrom

24import Roboservant.Types.Config

22import Roboservant.Types.Config

25−import Roboservant.Types.FlattenServer

26import Roboservant.Types.Internal

23import Roboservant.Types.Internal

27import Roboservant.Types.ReifiedApi

24import Roboservant.Types.ReifiedApi

25+import 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+10−4

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

12

13module Roboservant.Types.BuildFrom where

14

15+import Data.List(nub)

15import qualified Data.Dependent.Map as DM

16import qualified Data.Dependent.Map as DM

16import Data.Hashable

17import Data.Hashable

17import qualified Data.IntSet as IntSet

18import qualified Data.IntSet as IntSet

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

22import GHC.Generics

23import GHC.Generics

23import Roboservant.Types.Internal

24import Roboservant.Types.Internal

24import qualified Type.Reflection as R

25import qualified Type.Reflection as R

26+import Servant(NoContent)

27+import Roboservant.Types.Orphans()

25

28

26buildFrom :: 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)

27buildFrom = buildStash . buildFrom'

30buildFrom = buildStash . buildFrom'

@@ -59,11 +62,12 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x)

59

62

60-- 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.

61-- 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.

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

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

66+ extras stash =

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

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

64 where

68 where

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

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

66− notpowerset xs = xs:map pure xs

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

67

71

68

72

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

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

73

77

74deriving via (Atom Char) instance BuildFrom Char

78deriving via (Atom Char) instance BuildFrom Char

75

79

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

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

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

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

78

82

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

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

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

99

103

100instance GBuildFrom U1 where

104instance GBuildFrom U1 where

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

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

106+

107+deriving via (Atom NoContent) instance BuildFrom NoContent

src/Roboservant/Types/FlattenServer.hsdeleted−40

@@ -1,40 +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− (

32− Endpoints api ~ '[api]

33− ) =>

34− FlattenServer (x :> api)

35− where

36− flattenServer server = server `AnEndpoint` NoEndpoints

37−

38−instance FlattenServer (Verb method statusCode contentTypes responseType)

39− where

40− 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+168−3

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

@@ -21,7 +26,12 @@ import Data.List.NonEmpty (NonEmpty)

21import Data.Typeable (Typeable)

26import Data.Typeable (Typeable)

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

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

23import Roboservant.Types.Internal

28import Roboservant.Types.Internal

24−

29+import Roboservant.Types.Breakdown

30+import Roboservant.Types.BuildFrom

31+import Data.Kind(Type)

32+import Servant

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

34+import GHC.TypeLits (Symbol)

25import qualified Data.Text as T

35import qualified Data.Text as T

26import qualified Data.Vinyl as V

36import qualified Data.Vinyl as V

27import qualified Data.Vinyl.Curry as V

37import qualified Data.Vinyl.Curry as V

@@ -42,11 +52,166 @@ data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpo

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

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

43 }

53 }

44

54

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

55+instance Show ReifiedEndpoint where

56+ show _ = "lol"

57+

58+class ( V.RecordToList (EndpointArgs endpoint)

59+ , V.RMap (EndpointArgs endpoint)

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

61+ type EndpointArgs endpoint :: [Type]

62+ type EndpointRes endpoint :: Type

63+

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

65+

46

66

47tagType :: Typeable a => f a -> TypedF f a

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

48tagType = (R.typeRep :*:)

68tagType = (R.typeRep :*:)

49

69

50−newtype InteractionError = InteractionError T.Text

70+data InteractionError = InteractionError

71+ { errorMessage :: T.Text

72+ , fatalError :: Bool

73+ }

51 deriving Show

74 deriving Show

52instance Exception InteractionError

75instance Exception InteractionError

76+

77+

78+

79+instance

80+ (Typeable responseType, Breakdown responseType) =>

81+ ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

82+ where

83+ type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]

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

85+ reifiedEndpointArguments = V.RNil

86+

87+instance ToReifiedEndpoint (NoContentVerb method)

88+ where

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

90+ type EndpointRes (NoContentVerb method) = NoContent

91+ reifiedEndpointArguments = V.RNil

92+

93+instance

94+ (ToReifiedEndpoint endpoint) =>

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

96+ where

97+ type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint

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

99+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

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+

111+instance

112+ (ToReifiedEndpoint endpoint) =>

113+ ToReifiedEndpoint (Description s :> endpoint)

114+ where

115+ type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint

116+ type EndpointRes (Description s :> endpoint) = EndpointRes endpoint

117+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

118+

119+instance

120+ (ToReifiedEndpoint endpoint) =>

121+ ToReifiedEndpoint (Summary s :> endpoint)

122+ where

123+ type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint

124+ type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint

125+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

126+

127+instance

128+ (Typeable requestType

129+ ,BuildFrom requestType

130+ ,ToReifiedEndpoint endpoint) =>

131+ ToReifiedEndpoint (QueryFlag name :> endpoint)

132+ where

133+ type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint

134+ type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint

135+ reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint

136+

137+type IfLenient s mods t = If (FoldLenient mods) (Either s t) t

138+type IfRequired mods t = If (FoldRequired mods) t (Maybe t)

139+type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)

140+

141+instance

142+ ( BuildFrom (IfRequiredLenient T.Text mods paramType)

143+ , ToReifiedEndpoint endpoint

144+ ) =>

145+ ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)

146+ where

147+ type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint

148+ type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint

149+ reifiedEndpointArguments =

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

151+ V.:& reifiedEndpointArguments @endpoint

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+

171+instance

172+ ( BuildFrom (IfRequiredLenient T.Text mods headerType)

173+ , ToReifiedEndpoint endpoint

174+ ) =>

175+ ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)

176+ where

177+ type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint

178+ type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint

179+ reifiedEndpointArguments =

180+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))

181+ V.:& reifiedEndpointArguments @endpoint

182+

183+#if MIN_VERSION_servant(0,17,0)

184+instance

185+ ( BuildFrom (IfLenient String mods captureType)

186+ , ToReifiedEndpoint endpoint) =>

187+ ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

188+ where

189+ type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint

190+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint

191+ reifiedEndpointArguments =

192+ tagType (Argument (buildFrom @(IfLenient String mods captureType)))

193+ V.:& reifiedEndpointArguments @endpoint

194+#else

195+instance

196+ ( BuildFrom captureType

197+ , ToReifiedEndpoint endpoint) =>

198+ ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

199+ where

200+ type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint

201+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint

202+ reifiedEndpointArguments =

203+ tagType (Argument (buildFrom @(captureType)))

204+ V.:& reifiedEndpointArguments @endpoint

205+

206+#endif

207+

208+instance

209+ ( BuildFrom (IfLenient String mods requestType)

210+ , ToReifiedEndpoint endpoint) =>

211+ ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)

212+ where

213+ type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint

214+ type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint

215+ reifiedEndpointArguments =

216+ tagType (Argument (buildFrom @(IfLenient String mods requestType)))

217+ V.:& reifiedEndpointArguments @endpoint

src/Roboservant/Types/ReifiedApi/Server.hs+36−126

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

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE RankNTypes #-}

9+

10−{-# LANGUAGE RecordWildCards #-}

11{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TypeApplications #-}

11{-# LANGUAGE TypeApplications #-}

14{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

@@ -17,47 +15,34 @@

17{-# LANGUAGE DataKinds #-}

15{-# LANGUAGE DataKinds #-}

18{-# LANGUAGE TypeOperators #-}

16{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE FlexibleInstances #-}

17{-# LANGUAGE FlexibleInstances #-}

18+{-# LANGUAGE MultiParamTypeClasses #-}

20−module Roboservant.Types.ReifiedApi.Server where

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

21

20

22import Servant

21import Servant

23−import Servant.API.Modifiers(FoldRequired,FoldLenient)

24

22

25import Control.Monad.Except (runExceptT)

23import Control.Monad.Except (runExceptT)

26import Data.Bifunctor

24import Data.Bifunctor

27import Data.Dynamic (Dynamic)

25import Data.Dynamic (Dynamic)

28−import Data.Kind

29import Data.List.NonEmpty (NonEmpty)

26import Data.List.NonEmpty (NonEmpty)

30import Data.Typeable (Typeable)

27import Data.Typeable (Typeable)

31−import GHC.TypeLits (Symbol)

32import Roboservant.Types.Breakdown

28import Roboservant.Types.Breakdown

33−import Roboservant.Types.BuildFrom

34−import Roboservant.Types.FlattenServer

35import Roboservant.Types.ReifiedApi

29import Roboservant.Types.ReifiedApi

36

30

37import qualified Data.Text as T

31import qualified Data.Text as T

38−import qualified Data.Vinyl as V

39import qualified Data.Vinyl.Curry as V

32import qualified Data.Vinyl.Curry as V

40import Data.Hashable(Hashable)

33import Data.Hashable(Hashable)

41

34

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

42

36

43−class ToReifiedApi (endpoints ) where

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

45−

46−class ( V.RecordToList (EndpointArgs endpoint)

47− , V.RMap (EndpointArgs endpoint)

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

49− type EndpointArgs endpoint :: [Type]

50− type EndpointRes endpoint :: Type

51

37

52− reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)

38+class ToReifiedApi endpoints where

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

53

40

54instance ToReifiedApi '[] where

41instance ToReifiedApi '[] where

55 toReifiedApi NoEndpoints _ = []

42 toReifiedApi NoEndpoints _ = []

56

43

57instance

44instance

58− ( Typeable (EndpointRes endpoint)

59−

60− , NormalizeFunction (ServerT endpoint Handler)

45+ ( NormalizeFunction (ServerT endpoint Handler)

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

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

62 , ToReifiedEndpoint endpoint

47 , ToReifiedEndpoint endpoint

63 , ToReifiedApi endpoints

48 , ToReifiedApi endpoints

@@ -73,13 +58,6 @@ instance

73 : (map . first) (+1)

58 : (map . first) (+1)

74 (toReifiedApi endpoints (Proxy @endpoints))

59 (toReifiedApi endpoints (Proxy @endpoints))

75

60

76−class NormalizeFunction m where

77− type Normal m

78− normalize :: m -> Normal m

79−

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

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

82− normalize = fmap normalize

83

61

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

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

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

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

@@ -88,117 +66,49 @@ instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x)

88 where

66 where

89 -- | TODO improve this

67 -- | TODO improve this

90 renderServerError :: ServerError -> InteractionError

68 renderServerError :: ServerError -> InteractionError

91− renderServerError = InteractionError . T.pack . show

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

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

93−

94−instance

95− (Typeable responseType, Breakdown responseType) =>

96− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

97− where

98− type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]

99− type EndpointRes (Verb method statusCode contentTypes responseType) = responseType

100− reifiedEndpointArguments = V.RNil

101

70

102−instance

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

103− (ToReifiedEndpoint endpoint) =>

104− ToReifiedEndpoint ((x :: Symbol) :> endpoint)

105− where

106− type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint

107− type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint

108− reifiedEndpointArguments = reifiedEndpointArguments @endpoint

109

72

110−instance

111− (ToReifiedEndpoint endpoint) =>

112− ToReifiedEndpoint (Description s :> endpoint)

113− where

114− type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint

115− type EndpointRes (Description s :> endpoint) = EndpointRes endpoint

116− reifiedEndpointArguments = reifiedEndpointArguments @endpoint

117

73

118−instance

74+-- case errHTTPCode serverError of

119− (ToReifiedEndpoint endpoint) =>

75+-- 500 -> throw serverError

120− ToReifiedEndpoint (Summary s :> endpoint)

76+-- _ ->

121− where

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

122− type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint

123− type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint

124− reifiedEndpointArguments = reifiedEndpointArguments @endpoint

125

78

126−instance

127− (Typeable requestType

128− ,BuildFrom requestType

129− ,ToReifiedEndpoint endpoint) =>

130− ToReifiedEndpoint (QueryFlag name :> endpoint)

131− where

132− type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint

133− type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint

134− reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint

135

79

136−type IfLenient s mods t = If (FoldLenient mods) (Either s t) t

80+data Bundled endpoints where

137−type IfRequired mods t = If (FoldRequired mods) t (Maybe t)

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

138−type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)

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

83+ NoEndpoints :: Bundled '[]

139

84

140−instance

85+class FlattenServer api where

141− ( BuildFrom (IfRequiredLenient T.Text mods paramType)

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

142− , ToReifiedEndpoint endpoint

143− ) =>

144− ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)

145− where

146− type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint

147− type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint

148− reifiedEndpointArguments =

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

150− V.:& reifiedEndpointArguments @endpoint

151

87

152instance

88instance

153− ( BuildFrom (IfRequiredLenient T.Text mods headerType)

89+ ( FlattenServer api,

154− , ToReifiedEndpoint endpoint

90+ Endpoints endpoint ~ '[endpoint]

155 ) =>

91 ) =>

156− ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)

92+ FlattenServer (endpoint :<|> api)

157 where

93 where

158− type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint

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

159− type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint

160− reifiedEndpointArguments =

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

162− V.:& reifiedEndpointArguments @endpoint

163

95

164−#if MIN_VERSION_servant(0,17,0)

165−instance

166− ( BuildFrom (IfLenient String mods captureType)

167− , ToReifiedEndpoint endpoint) =>

168− ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

169− where

170− type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint

171− type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint

172− reifiedEndpointArguments =

173− tagType (Argument (buildFrom @(IfLenient String mods captureType)))

174− V.:& reifiedEndpointArguments @endpoint

175−#else

176instance

96instance

177− ( BuildFrom captureType

97+ (

178− , ToReifiedEndpoint endpoint) =>

98+ Endpoints api ~ '[api]

179− ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

99+ ) =>

100+ FlattenServer (x :> api)

180 where

101 where

181− type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint

102+ flattenServer server = server `AnEndpoint` NoEndpoints

182− type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint

183− reifiedEndpointArguments =

184− tagType (Argument (buildFrom @(captureType)))

185− V.:& reifiedEndpointArguments @endpoint

186

103

187−#endif

104+instance FlattenServer (Verb method statusCode contentTypes responseType)

188−

189−instance

190− ( BuildFrom (IfLenient String mods requestType)

191− , ToReifiedEndpoint endpoint) =>

192− ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)

193 where

105 where

194− type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint

106+ flattenServer server = server `AnEndpoint` NoEndpoints

195− type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint

196− reifiedEndpointArguments =

197− tagType (Argument (buildFrom @(IfLenient String mods requestType)))

198− V.:& reifiedEndpointArguments @endpoint

199

107

108+class NormalizeFunction m where

109+ type Normal m

110+ normalize :: m -> Normal m

200

111

201−-- case errHTTPCode serverError of

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

202−-- 500 -> throw serverError

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

203−-- _ ->

114+ normalize = fmap normalize

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

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+104−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,101 +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

20import qualified Roboservant.Server as RS

28import qualified Roboservant.Server as RS

29+import qualified Roboservant.Client as RC

21import qualified Seeded

30import qualified Seeded

22import Test.Hspec

31import Test.Hspec

23import 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)

24import 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((>=>))

25

41

26main :: IO ()

42main :: IO ()

27main = hspec spec

43main = hspec spec

28

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+

29spec :: Spec

65spec :: Spec

30spec = do

66spec = do

31 describe "Basic usage" $ do

67 describe "Basic usage" $ do

32 describe "noError" $ do

68 describe "noError" $ do

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

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

35− >>= (`shouldSatisfy` isNothing)

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

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

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

38− >>= (`shouldSatisfy` isNothing)

39− it "does fail coverage check" $ do

40− 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 ->

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

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

42− `shouldSatisfy` ( \case

74+ `shouldSatisfy` ( \case

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

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

44− _ -> False

76+ _ -> False

45− )

77+ ))

46− describe "posted body" $ do

78+ describe "posted body" $

47− 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" $

48− 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}

49− >>= (`shouldSatisfy` isNothing)

85+ (`shouldSatisfy` isNothing)

86+

87+

50 describe "seeded" $ do

88 describe "seeded" $ do

51− shouldFail

89+ let res = Seeded.Seed 1

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

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

53− $ let res = Seeded.Seed 1

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

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

55− >>= (`shouldSatisfy` isNothing)

92+ (`shouldSatisfy` isNothing)

93+

56− describe "Foo" $ do

94+ describe "Foo" $

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

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

59− >>= (`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+

60 describe "BuildFrom" $ do

101 describe "BuildFrom" $ do

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

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

62− 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

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

64− >>= (`shouldSatisfy` serverFailure)

104+ (`shouldSatisfy` serverFailure)

65− describe "product types" $ do

105+ describe "product types" $

66− 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

67− 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)]}

68− >>= (`shouldSatisfy` serverFailure)

108+ (`shouldSatisfy` serverFailure)

69 describe "Breakdown" $ do

109 describe "Breakdown" $ do

70− it "handles products" $ do

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

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

72− >>= (`shouldSatisfy` serverFailure)

111+ (`shouldSatisfy` serverFailure)

73− it "handles sums" $ do

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

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

75− >>= (`shouldSatisfy` serverFailure)

113+ (`shouldSatisfy` serverFailure)

76− describe "flattening" $ do

114+ describe "flattening" $

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

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

79− it "can handle nested apis" $ do

80− 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}

81− >>= (`shouldSatisfy` isNothing)

116+ (`shouldSatisfy` isNothing)

82−

117+

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

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

84serverFailure = \case

119serverFailure = \case

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

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

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

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

87− in failureReason /= RS.NoPossibleMoves

122+ in failureReason /= R.NoPossibleMoves

88 _ -> False

123 _ -> False

89

124

90−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

91

130

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

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

93

132

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

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

95

134

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

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

97

136

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

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

99

138

100−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

101

141

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

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

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

103

144

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

105

145

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

107

146

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

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

109

148

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

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

111

150

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

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

113

152

114-- | `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.

115-- this is often useful when testing tests.

154-- this is often useful when testing tests.

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

119 ( \i ->

158 ( \i ->

120 i

159 i

121 { itemExample = \p a cb -> do

160 { itemExample = \p a cb -> do

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

161+ r <- itemExample i p a cb

123 pure

162 pure

124 r

163 r

125 { 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] ()