master..0b3434a · roboservant

.github/workflows/cabal.ymldeleted−64

since splitsnapshots

unifiedsplit

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

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+3−6

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

1−name: Stack CI

1+name: CI

2

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

4on:

@@ -12,14 +12,13 @@ jobs:

12 strategy:

13 matrix:

14 stack: ["2.3.3"]

15− ghc: ["8.10.4"]

15+ ghc: ["8.8.3"]

16 os: [ubuntu-latest]

17 steps:

18 - uses: actions/checkout@v2

19 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'

20

21− - uses: actions/setup-haskell@v1.1.4

21+ - uses: actions/setup-haskell@v1.1

22− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'

23 name: Setup Haskell Stack

22 name: Setup Haskell Stack

24 with:

23 with:

25 ghc-version: ${{ matrix.ghc }}

24 ghc-version: ${{ matrix.ghc }}

@@ -27,13 +26,11 @@ jobs:

27 enable-stack: true

26 enable-stack: true

28

27

29 - uses: actions/cache@v1

28 - uses: actions/cache@v1

30− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'

31 name: Cache ~/.stack

29 name: Cache ~/.stack

32 with:

30 with:

33 path: ~/.stack

31 path: ~/.stack

34 key: ${{ runner.os }}-${{ matrix.ghc }}-stack

32 key: ${{ runner.os }}-${{ matrix.ghc }}-stack

35

33

36 - name: Test

34 - name: Test

37− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'

38 run: |

35 run: |

39 stack test

36 stack test

EXAMPLE.mddeleted−143

@@ -1,143 +0,0 @@

1−# Example

2−

3−Our api under test:

4−

5−``` haskell

6−-- Obligatory fancy-types pragma tax

7−{-# LANGUAGE DataKinds #-}

8−{-# LANGUAGE TypeOperators #-}

9−{-# LANGUAGE DerivingStrategies #-}

10−{-# LANGUAGE StandaloneDeriving #-}

11−{-# LANGUAGE DerivingVia #-}

12−{-# LANGUAGE TypeApplications #-}

13−{-# LANGUAGE DeriveGeneric #-}

14−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

15−{-# LANGUAGE RecordWildCards #-}

16−{-# LANGUAGE ScopedTypeVariables #-}

17−{-# LANGUAGE TypeApplications #-}

18−

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

24−import Test.Hspec

25−import Servant

26−import GHC.Generics

27−import Data.Typeable

28−import Data.Hashable

29−import Data.Maybe(isNothing, isJust)

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

31−import Data.Aeson(FromJSON,ToJSON)

32−

33−newtype A = A Int

34− deriving (Generic, Eq, Show, Typeable)

35− deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

36−

37−instance FromJSON A

38−instance ToJSON A

39−

40−newtype B = B Int

41− deriving (Generic, Eq, Show, Typeable)

42− deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

43−

44−instance FromJSON B

45−instance ToJSON B

46−

47−type Api =

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

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

50− :<|> "item" :> Capture "itemId" B :> Get '[JSON] ()

51−

52−server :: Handler A -> Server Api

53−server introduce = introduce :<|> combine :<|> eliminate

54− where

55− combine (B i) (B j) = pure $ B (i + j)

56− eliminate (B i)

57− | i > 10 = error "give up, eleven is way too big and probably not even real"

58− | otherwise = pure ()

59−```

60−

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

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

63−

64−``` haskell

65−goodServer, badServer :: Server Api

66−goodServer = server (pure $ A 0)

67−badServer = server (pure $ A 1)

68−```

69−

70−In the test file, we first define the tests: the faulty server should fail and the good server should pass.

71−

72−```haskell

73−main :: IO ()

74−main = hspec spec

75−

76−spec :: Spec

77−spec = describe "example" $ do

78− it "good server should not fail" $ do

79− RS.fuzz @Api goodServer config

80− >>= (`shouldSatisfy` isNothing)

81− it "bad server should fail" $ do

82− RS.fuzz @Api badServer config

83− >>= (`shouldSatisfy` isJust)

84−```

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

97−

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

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

100−per-request healthchecks, seeds, and verbose logging. Have a look at

101−Roboservant.Types.Config for details.

102−

103−``` haskell

104−config :: Config

105−config = defaultConfig

106− { coverageThreshold = 0.99

107− }

108−```

109−

110−Unless we want to ship roboservant and all its dependencies to production, we also need

111−some orphan instances: because As are the only value we can get without

112−an input, we need to be able to break them down.

113−

114−``` haskell

115−deriving via (Compound A) instance Breakdown A

116−```

117−

118−if we wanted to assemble As from parts as well, we'd derive using Compound, but in this case we don't care.

119−

120−``` haskell

121−deriving via (Atom A) instance BuildFrom A

122−

123−```

124−

125−Similarly, to generate the first B from the Ints we got from inside the A, we need to be able to

126−build it up from components.

127−

128−```haskell

129−deriving via (Compound B) instance BuildFrom B

130−deriving via (Atom B) instance Breakdown B

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

Example.lhsdeleted−1

@@ -1 +0,0 @@

1−EXAMPLE.md

Makefile+1−3

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

1testwatch:

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

3−pedanticwatch:

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

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

README.md+23−87

@@ -2,86 +2,45 @@

2

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

4

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

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

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

7

6

8−## example

9

7

10−see full example [here](EXAMPLE.md)

11−

12−## why?

8+# why?

13

9

14Servant gives us a lot of information about what a server can do. We

10Servant gives us a lot of information about what a server can do. We

15use this information to generate arbitrarily long request/response

11use this information to generate arbitrarily long request/response

16sessions and verify properties that should hold over them.

12sessions and verify properties that should hold over them.

17

13

18−## how?

14+# example

19−

20−In essence, ```fuzz @Api yourServer config``` will make a bunch of

21−calls to your API, and record the results in a type-indexed

22−dictionary. This means that they are now available for the

23−prerequisites of other calls, so as you proceed, more and more api

24−calls become possible.

25−

26−We explicitly do not try to come up with plausible values that haven't

27−somehow come back from the API. That's straying into QC/Hedgehog

28−territory: if you want that, come up with the values on that side, and

29−set them as seeds in the configuration.

30−

31−### what does it mean to be "available"?

32−

33−In a simple API, you may make a call and get back a `Foo`, which will

34−allow you to make another call that requires a `Foo`. In a more

35−complicated app, it's likely that you'll send a request body that

36−includes many subcomponents, and it's likely you'll get a response

37−that needs to be broken down into pieces before it's useful.

38

15

39−To cope with this, we have the typeclasses `BuildFrom` and

16+Our api under test:

40−`Breakdown`. You can write instances for them if you feel like it, and

41−indeed it's currently required for recursive datatypes if you don't

42−want the fuzzer to hang, but for the majority of your types it should

43−be sufficient to derive them generically. (Sensible instances are

44−provided for lists.)

45

17

46−There are two basic strategies here. In some cases, you want to regard

47−a type as indivisible: that's why we like newtypes, right? In this

48−case, we can derive using the `Atom` strategy.

49−

50−``` haskell

51−deriving via (Atom NewtypedKey) instance Breakdown NewtypedKey

52−deriving via (Atom NewtypedKey) instance BuildFrom NewtypedKey

53```

18```

54−

19+newtype Foo = Foo Int

55−This is saying "A can neither be built from components or broken down

20+ deriving (Generic, Eq, Show, Typeable)

56−for spare parts. Hands off!". This is a good strategy for key types,

21+ deriving newtype (FromHttpApiData, ToHttpApiData)

57−for instance.

22+

58−

23+type FooApi =

59−If instead it's a big complicated thing with lots of juicy

24+ "item" :> Get '[JSON] Foo

60−subcomponents, we want to rip it apart using Generics and feast on

25+ :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo

61−its succulent headmeats:

26+ :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()

62−

63−``` haskell

64−deriving via (Compound Payload) instance Breakdown Payload

65−deriving via (Compound Payload) instance BuildFrom Payload

66```

27```

67

28

68−### priming the pump

29+From the tests:

69

30

70−Sometimes there are values we'd like to smuggle into the API that are

31+```

71−not derivable from within the API itself: sometimes this is a warning

32+ assert "should find an error in Foo" . not

72−sign that your API is incomplete, but it can be quite reasonable to

33+ =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential @Foo.FooApi Foo.fooServer)])

73−require identifying credentials within an API and not provide a way to

34+```

74−get them. It might also be reasonable to have some sample values that

75−the user is expected to come up with.

76

35

77−For those cases, override the `seed` in the `Config` with a

36+We have a server that blows up if the value of the int in a `Foo` ever gets above 10. Note:

78−list of seed values, suitably hashed:

37+there is no generator for `Foo` types: larger `Foo`s can only be made only by combining existing

38+`Foo`s with `itemAdd`. This is an important distinction, because many APIs will return UUIDs or

39+similar as keys, which make it impossible to cover a useful section of the state space without

40+using the values returned by the API

79

41

80−``` haskell

81−defaultConfig { seed = [hashedDyn creds, hashedDyn userJwt]}

82−```

83

42

84−## why not servant-quickcheck?

43+# why not servant-quickcheck?

85

44

86[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)

45[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)

87is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,

46is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,

@@ -89,26 +48,3 @@ there's a lot of the state space you just can't explore without context: modern

89full of pointer-like structures, whether they're URLs or database

48full of pointer-like structures, whether they're URLs or database

90keys/uuids, and servant-quickcheck requires that you be able to generate

49keys/uuids, and servant-quickcheck requires that you be able to generate

91these without context via Arbitrary.

50these without context via Arbitrary.

92−

93−## limitations and future work

94−

95−Currently, the display of failing traces is pretty tragic, both in the

96−formatting and in its non-minimality. This is pretty ticklish:

97−arguably the right way to do this is to return a trace that we can

98−also rerun, and let quickcheck or hedgehog a level up shrink it until

99−it's satisfactorily short. In the interest of being useful earlier

100−rather than later, I'm releasing v1.0 before I crack this particular

101−nut. We do know which calls we made that led to the failing case, so

102−we would want to show that distinction in a visible way: it's possible

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

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

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−

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

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

111−end 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/README.mddeleted−30

@@ -1,30 +0,0 @@

1−# Benchmarks

2−

3−I've noticed compilation can be a little slow on realistic apps so I set up a test.

4−

5−## components

6−

7−1. codegen

8−

9− given an integer input n, create an api with n endpoints. they should take a reasonably

10− complicated input and return a reasonably complicated output

11−

12−2. runner

13−

14− build dependencies

15− for i from 1 to 100

16− generate api with i endpoints

17− compile it, but timed

18− print (i,time)

19−

20−3. plot to see linearity/quadraticity?

21−

22−## possible gotchas

23−

24−- we usually compile these in different modules rather than together: if we don't get slow

25− compilation in one file, try out multiple files.

26−

27−## notes

28−

29−- flat profile if you don't have the call to `fuzz`

30−- no difference between deriving via Atom vs Compound, so not a Generics thing.

benchmarks/genFile.shdeleted−26

@@ -1,26 +0,0 @@

1−n=$1

2−k=$2

3−

4−cat prelude

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

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

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

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

9−done

10−

11−echo -n "server = handler "

12−

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

14− echo -n ":<|> handler "

15−done

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/preludedeleted−61

@@ -1,61 +0,0 @@

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE TypeApplications #-}

5−{-# LANGUAGE DerivingVia #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7−{-# LANGUAGE DeriveGeneric #-}

8−

9−

10−import Roboservant

11−import Servant

12−import Data.Hashable

13−import GHC.Generics

14−import Data.Aeson

15−import Servant.API.Flatten

16−

17−data Input = Input1 { foo :: String }

18− | Input2 { bar :: Int }

19− deriving (Generic, Eq)

20−

21−instance FromJSON Input

22−instance ToJSON Input

23−

24−

25−deriving via (Compound Input) instance Breakdown Input

26−deriving via (Compound Input) instance BuildFrom Input

27−

28−

29−-- deriving via (Atom Input) instance Breakdown Input

30−-- deriving via (Atom Input) instance BuildFrom Input

31−

32−instance Hashable Input

33−

34−

35−data Output = Output1 { ofoo :: String }

36− | Output2 { obar :: Int }

37− deriving (Generic, Eq)

38−

39−instance FromJSON Output

40−instance ToJSON Output

41−

42−instance Hashable Output

43−

44−deriving via (Compound Output) instance Breakdown Output

45−deriving via (Compound Output) instance BuildFrom Output

46−

47−-- deriving via (Atom Output) instance Breakdown Output

48−-- deriving via (Atom Output) instance BuildFrom Output

49−

50−

51−handler :: Input -> Handler Output

52−handler = pure . \case

53− Input1 foo -> Output1 foo

54− Input2 bar -> Output2 bar

55−

56−main =

57− -- fuzz @Api server defaultConfig

58− pure ()

59−

60−f = flatten (Proxy @Api)

61−

benchmarks/runTiming.shdeleted−10

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

1−lo=$1

2−hi=$2

3−k=$3

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

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;

9−

10−done | grep -v Compiling | grep -v Linking | awk '/,$/ { printf("%s", $0); next } 1' | sed 's/sievedn: //'

benchmarks/runTimingNoisy.shdeleted−10

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

1−lo=$1

2−hi=$2

3−

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

5− ./genFile.sh $i > 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;

9−

10−done

package.yaml+1−24

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

1−

2name: roboservant

1name: roboservant

3−version: 0.1.0.3

2+version: 0.1.0.2

4github: "mwotton/roboservant"

3github: "mwotton/roboservant"

5license: BSD3

4license: BSD3

6copyright: "2020 Mark Wotton, Samuel Schlesinger"

5copyright: "2020 Mark Wotton, Samuel Schlesinger"

@@ -18,8 +17,6 @@ dependencies:

18- bytestring

17- bytestring

19- containers

18- containers

20- random

19- random

21−- hashable

22−- http-types

23- lifted-base

20- lifted-base

24- monad-control

21- monad-control

25- mtl

22- mtl

@@ -31,7 +28,6 @@ dependencies:

31- vinyl

28- vinyl

32- dependent-sum

29- dependent-sum

33- dependent-map

30- dependent-map

34−- unordered-containers

35- text

31- text

36- time

32- time

37

33

@@ -55,22 +51,3 @@ tests:

55 - aeson

51 - aeson

56 - hspec

52 - hspec

57 - hspec-core

53 - hspec-core

58− - http-api-data

59− - http-client

60− - hspec-wai

61− - wai

62− - warp

63− example:

64− main: Example.lhs

65− source-dirs: .

66−

67− dependencies:

68− - roboservant

69− - hspec

70− - warp

71− - http-client

72− - aeson

73− - hspec-core

74− ghc-options: -pgmL markdown-unlit

75−

76− build-tools: markdown-unlit

roboservant.cabal+5−64

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

1cabal-version: 1.12

2

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

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

4--

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

6--

7−-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d

7+-- hash: a0f650472f077eb44b9eefc36c90786ca0e371f2dc596f9a5d4e0e808ddc0396

8

9name: roboservant

10−version: 0.1.0.3

10+version: 0.1.0.2

11synopsis: Automatic session-aware servant testing

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

13category: Web

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

28library

29 exposed-modules:

30 Roboservant

31− Roboservant.Client

32 Roboservant.Direct

31 Roboservant.Direct

33− Roboservant.Server

34 Roboservant.Types

32 Roboservant.Types

35 Roboservant.Types.Breakdown

33 Roboservant.Types.Breakdown

36 Roboservant.Types.BuildFrom

34 Roboservant.Types.BuildFrom

37− Roboservant.Types.Config

35+ Roboservant.Types.FlattenServer

38 Roboservant.Types.Internal

36 Roboservant.Types.Internal

39− Roboservant.Types.Orphans

40 Roboservant.Types.ReifiedApi

37 Roboservant.Types.ReifiedApi

41− Roboservant.Types.ReifiedApi.Server

42 other-modules:

38 other-modules:

43 Paths_roboservant

39 Paths_roboservant

44 hs-source-dirs:

40 hs-source-dirs:

@@ -50,8 +46,6 @@ library

50 , containers

46 , containers

51 , dependent-map

47 , dependent-map

52 , dependent-sum

48 , dependent-sum

53− , hashable

54− , http-types

55 , lifted-base

49 , lifted-base

56 , monad-control

50 , monad-control

57 , mtl

51 , mtl

@@ -63,61 +57,16 @@ library

63 , string-conversions

57 , string-conversions

64 , text

58 , text

65 , time

59 , time

66− , unordered-containers

67 , vinyl

60 , vinyl

68 default-language: Haskell2010

61 default-language: Haskell2010

69

62

70−test-suite example

71− type: exitcode-stdio-1.0

72− main-is: Example.lhs

73− other-modules:

74− Paths_roboservant

75− hs-source-dirs:

76− ./

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

78− build-tool-depends:

79− markdown-unlit:markdown-unlit

80− build-depends:

81− aeson

82− , base >=4.7 && <5

83− , bytestring

84− , containers

85− , dependent-map

86− , dependent-sum

87− , hashable

88− , hspec

89− , hspec-core

90− , http-client

91− , http-types

92− , lifted-base

93− , monad-control

94− , mtl

95− , random

96− , roboservant

97− , servant

98− , servant-client

99− , servant-flatten

100− , servant-server

101− , string-conversions

102− , text

103− , time

104− , unordered-containers

105− , vinyl

106− , warp

107− default-language: Haskell2010

108−

109test-suite roboservant-test

63test-suite roboservant-test

110 type: exitcode-stdio-1.0

64 type: exitcode-stdio-1.0

111 main-is: Spec.hs

65 main-is: Spec.hs

112 other-modules:

66 other-modules:

113− Breakdown

67+ BuildFrom

114 Foo

68 Foo

115 Headers

69 Headers

116− Nested

117− Post

118− Product

119− Put

120− QueryParams

121 Seeded

70 Seeded

122 UnsafeIO

71 UnsafeIO

123 Valid

72 Valid

@@ -132,13 +81,8 @@ test-suite roboservant-test

132 , containers

81 , containers

133 , dependent-map

82 , dependent-map

134 , dependent-sum

83 , dependent-sum

135− , hashable

136 , hspec

84 , hspec

137 , hspec-core

85 , hspec-core

138− , hspec-wai

139− , http-api-data

140− , http-client

141− , http-types

142 , lifted-base

86 , lifted-base

143 , monad-control

87 , monad-control

144 , mtl

88 , mtl

@@ -151,8 +95,5 @@ test-suite roboservant-test

151 , string-conversions

95 , string-conversions

152 , text

96 , text

153 , time

97 , time

154− , unordered-containers

155 , vinyl

98 , vinyl

156− , wai

157− , warp

158 default-language: Haskell2010

99 default-language: Haskell2010

src/Roboservant.hs+2−5

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

1−module Roboservant

2− ( module Roboservant.Direct,

1+module Roboservant (module Roboservant.Direct

3− module Roboservant.Types,

2+ ,module Roboservant.Types) where

4− )

5−where

6

3

7import Roboservant.Direct

4import Roboservant.Direct

8import Roboservant.Types

5import Roboservant.Types

src/Roboservant/Client.hsdeleted−127

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

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+82−113

@@ -2,53 +2,33 @@

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE LambdaCase #-}

5−{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

8{-# LANGUAGE TupleSections #-}

10−

9+{-# LANGUAGE TypeApplications #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE UndecidableInstances #-}

13

10

14module Roboservant.Direct

11module Roboservant.Direct

15− ( fuzz',

12+ ( fuzz,

16 Config (..),

13 Config (..),

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

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

18 -- have some nice error-display functions

15 -- have some nice error-display functions

19 RoboservantException (..),

16 RoboservantException (..),

20 FuzzState (..),

17 FuzzState (..),

21 FuzzOp (..),

18 FuzzOp (..),

22− FailureType (..),

23− Report (..),

24 )

19 )

25where

20where

26

21

27−import Control.Exception.Lifted

22+import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)

28− ( Exception,

29− Handler (Handler),

30− SomeAsyncException,

31− SomeException,

32− catch,

33− catches,

34− handle,

35− throw,

36− )

37−import Control.Monad.State.Strict

23+import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)

38− ( MonadIO (..),

39− MonadState (get),

40− StateT (runStateT),

41− modify',

42− )

43import Control.Monad.Trans.Control (MonadBaseControl)

24import Control.Monad.Trans.Control (MonadBaseControl)

44import qualified Data.Dependent.Map as DM

25import qualified Data.Dependent.Map as DM

45−import Data.Dynamic (Dynamic (..))

26+import Data.Dynamic (Dynamic (..), dynTypeRep)

46−import qualified Data.IntSet as IntSet

47import Data.List.NonEmpty (NonEmpty (..))

27import Data.List.NonEmpty (NonEmpty (..))

48import qualified Data.List.NonEmpty as NEL

28import qualified Data.List.NonEmpty as NEL

49import Data.Maybe (mapMaybe)

29import Data.Maybe (mapMaybe)

50import qualified Data.Set as Set

30import qualified Data.Set as Set

51−import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)

31+import Data.Time.Clock

52import qualified Data.Vinyl as V

32import qualified Data.Vinyl as V

53import qualified Data.Vinyl.Curry as V

33import qualified Data.Vinyl.Curry as V

54import qualified Data.Vinyl.Functor as V

34import qualified Data.Vinyl.Functor as V

@@ -56,34 +36,30 @@ import GHC.Generics ((:*:) (..))

56import Roboservant.Types

36import Roboservant.Types

57 ( ApiOffset (..),

37 ( ApiOffset (..),

58 Argument (..),

38 Argument (..),

59− InteractionError(..),

39+ FlattenServer (..),

60 Provenance (..),

40 Provenance (..),

61− ReifiedApi,

62 ReifiedEndpoint (..),

41 ReifiedEndpoint (..),

63 Stash (..),

42 Stash (..),

64 StashValue (..),

43 StashValue (..),

44+ ToReifiedApi (..),

65 TypedF,

45 TypedF,

66 )

46 )

67−import Roboservant.Types.Config

47+import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))

68−

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

48+import System.Random (StdGen, mkStdGen, randomR)

70import qualified Type.Reflection as R

49import qualified Type.Reflection as R

71

50

72data RoboservantException

51data RoboservantException

73− = RoboservantException

52+ = RoboservantException FailureType (Maybe SomeException) Int FuzzState

74− { failureReason :: FailureType,

75− serverException :: Maybe SomeException,

76− fuzzState :: FuzzState

77− }

78 deriving (Show)

53 deriving (Show)

79

54

55+-- we believe in nussink, lebowski

80instance Exception RoboservantException

56instance Exception RoboservantException

81

57

82data FailureType

58data FailureType

83 = ServerCrashed

59 = ServerCrashed

84 | CheckerFailed

60 | CheckerFailed

85 | NoPossibleMoves

61 | NoPossibleMoves

86− | InsufficientCoverage Double

62+ | InsufficientCoverage

87 deriving (Show, Eq)

63 deriving (Show, Eq)

88

64

89data FuzzOp

65data FuzzOp

@@ -93,6 +69,15 @@ data FuzzOp

93 }

69 }

94 deriving (Show, Eq)

70 deriving (Show, Eq)

95

71

72+data Config

73+ = Config

74+ { seed :: [Dynamic],

75+ maxRuntime :: Integer, -- seconds to test for

76+ maxReps :: Integer,

77+ rngSeed :: Int,

78+ coverageThreshold :: Double

79+ }

80+

96data FuzzState

81data FuzzState

97 = FuzzState

82 = FuzzState

98 { path :: [FuzzOp],

83 { path :: [FuzzOp],

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

105 = forall as.

90 = forall as.

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

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

107 EndpointOption

92 EndpointOption

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

93+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic))),

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

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

110 }

95 }

111

96

@@ -116,59 +101,40 @@ data StopReason

116

101

117data Report

102data Report

118 = Report

103 = Report

119− { textual :: String,

104+ {textual :: String}

120− rsException :: RoboservantException

121− }

122− deriving (Show)

105+ deriving (Show, Eq)

123−

124−

125−

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

127−-- fuzzClient = undefined

128−

129−

130

106

131−fuzz' ::

107+fuzz ::

132− ReifiedApi ->

108+ forall api.

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

110+ Server api ->

133 Config ->

111 Config ->

112+ IO () ->

134 IO (Maybe Report)

113 IO (Maybe Report)

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

114+fuzz server Config {..} checker = handle (pure . Just . formatException) $ do

136 let path = []

115 let path = []

137 stash = addToStash seed mempty

116 stash = addToStash seed mempty

138 currentRng = mkStdGen rngSeed

117 currentRng = mkStdGen rngSeed

139− deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime

118+ deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime

140 (stopreason, _fs) <-

119 (stopreason, _fs) <-

141 runStateT

120 runStateT

142 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))

121 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))

143 FuzzState {..}

122 FuzzState {..}

144− logInfo $ show stopreason

123+ print stopreason

145 pure Nothing

124 pure Nothing

146 where

125 where

147 -- something less terrible later

126 -- something less terrible later

148 formatException :: RoboservantException -> Report

127 formatException :: RoboservantException -> Report

149− formatException r@(RoboservantException failureType exception _state) =

128+ formatException = Report . show

150− Report

129+ -- evaluateCoverage :: FuzzState -> m ()

151− (unlines [show failureType, show exception])

152− r

153− displayDiagnostics FuzzState {..} = liftIO $

154− logInfo $ unlines $

155− ["api endpoints covered"]

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

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

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

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

160− -- $ \_k v ->

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

162−

163 evaluateCoverage f@FuzzState {..}

130 evaluateCoverage f@FuzzState {..}

164− | coverage > coverageThreshold = pure ()

131+ | hitRoutes / totalRoutes > coverageThreshold = do

165− | otherwise = do

132+ liftIO $ print ("passed coverage", hitRoutes, totalRoutes)

166− displayDiagnostics f

133+ pure ()

167− throw $ RoboservantException (InsufficientCoverage coverage) Nothing f

134+ | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f

168 where

135 where

169− hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path

136+ hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)

170− totalRoutes = fromIntegral routeCount

137+ totalRoutes = (fromIntegral routeCount)

171− coverage = hitRoutes / totalRoutes

172 untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason

138 untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason

173 untilDone (0, _) _ = pure HitMaxIterations

139 untilDone (0, _) _ = pure HitMaxIterations

174 untilDone (n, deadline) action = do

140 untilDone (n, deadline) action = do

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

178 else do

144 else do

179 _ <- action

145 _ <- action

180 untilDone (n -1, deadline) action

146 untilDone (n -1, deadline) action

181−

147+ reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

182 routeCount = length reifiedApi

148 routeCount = length reifiedApi

183 elementOrFail ::

149 elementOrFail ::

184 (MonadState FuzzState m, MonadIO m) =>

150 (MonadState FuzzState m, MonadIO m) =>

185 [a] ->

151 [a] ->

186 m a

152 m a

187− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get

153+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get

188 elementOrFail l = do

154 elementOrFail l = do

189 st <- get

155 st <- get

190 let (index, newGen) = randomR (0, length l - 1) (currentRng st)

156 let (index, newGen) = randomR (0, length l - 1) (currentRng st)

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

195 ( forall as.

161 ( forall as.

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

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

197 FuzzOp ->

163 FuzzOp ->

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

164+ V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->

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

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

200 m r

166 m r

201 ) ->

167 ) ->

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

205 (offset, EndpointOption {..}) <- elementOrFail . options =<< get

171 (offset, EndpointOption {..}) <- elementOrFail . options =<< get

206 r <-

172 r <-

207 V.rtraverse

173 V.rtraverse

208− ( \(tr :*: StashValue svs _) ->

174+ ( \(tr :*: StashValue svs) ->

209 elementOrFail $

175 elementOrFail $

210 zipWith

176 zipWith

211 (\i xy -> V.Const i :*: tr :*: xy)

177 (\i xy -> V.Const i :*: tr :*: xy)

@@ -236,24 +202,39 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do

236 execute ::

202 execute ::

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

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

238 FuzzOp ->

204 FuzzOp ->

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

205+ V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->

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

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

241 m ()

207 m ()

242 execute fuzzop func args = do

208 execute fuzzop func args = do

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

209+ liftIO $ print fuzzop

210+ st <- get

211+ let showable =

212+ unlines $

213+ ("args" : map show argTypes)

214+ <> [ "fuzzop",

215+ show fuzzop,

216+ -- ,"dyncall"

217+ -- ,show (dynTypeRep dyncall)

218+ "state",

219+ show st

220+ ]

221+ liftIO $ putStrLn showable

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

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

245− Left (e::InteractionError) ->

223+ -- parameterise this

246− if fatalError e

224+ Left (serverError :: ServerError) ->

247− then throw e

225+ case errHTTPCode serverError of

248− else pure ()

226+ 500 -> throw serverError

227+ _ -> do

228+ liftIO $ print ("ignoring non-500 error", serverError)

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

229+ Right (dyn :: NEL.NonEmpty Dynamic) -> do

230+ liftIO $ print ("storing", fmap dynTypeRep dyn)

250 modify'

231 modify'

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

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

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

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

253− )

234+ )

254 where

235 where

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

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

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

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

257 go ::

238 go ::

258 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>

239 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>

259 m ()

240 m ()

@@ -261,28 +242,21 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do

261 catches

242 catches

262 (execute op func args)

243 (execute op func args)

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

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

264− Handler

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

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

245+ Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)

267− )

268 ]

246 ]

269 catch

247 catch

270− (liftIO healthCheck)

248+ (liftIO checker)

271− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)

249+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)

272

250

273addToStash ::

251addToStash ::

274− [(Dynamic, Int)] ->

252+ [Dynamic] ->

275 Stash ->

253 Stash ->

276 Stash

254 Stash

277addToStash result stash =

255addToStash result stash =

278 foldr

256 foldr

279− ( \(Dynamic tr x, hashed) (Stash dict) ->

257+ ( \(Dynamic tr x) (Stash dict) ->

280 Stash $

258 Stash $

281− DM.insertWith

282− renumber

283− tr

284− (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))

259+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| [])) dict

285− dict

286 )

260 )

287 stash

261 stash

288 result

262 result

@@ -291,16 +265,11 @@ addToStash result stash =

291 StashValue a ->

265 StashValue a ->

292 StashValue a ->

266 StashValue a ->

293 StashValue a

267 StashValue a

294− renumber (StashValue singleDyn singleHash) orig@(StashValue l intSet)

268+ renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of

295− | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig

296− | otherwise =

297− StashValue

298− ( case NEL.toList singleDyn of

299− [([Provenance tr _], dyn)] ->

269+ [([Provenance tr _], dyn)] ->

270+ l

300− l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)

271+ <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)

301− _ -> error "should be impossible"

272+ _ -> error "should be impossible"

302− )

303− (IntSet.union singleHash intSet)

304

273

305-- why isn't this in vinyl?

274-- why isn't this in vinyl?

306recordToList' ::

275recordToList' ::

src/Roboservant/Server.hsdeleted−36

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

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+14−10

@@ -2,25 +2,29 @@

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DerivingStrategies #-}

4{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE StandaloneDeriving #-}

10+{-# LANGUAGE TupleSections #-}

11+{-# LANGUAGE TypeApplications #-}

7{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

9

15

10module Roboservant.Types

16module Roboservant.Types

11− ( module Roboservant.Types.Breakdown,

17+ ( module Roboservant.Types.Breakdown

12− module Roboservant.Types.BuildFrom,

18+ , module Roboservant.Types.BuildFrom

13− module Roboservant.Types.ReifiedApi,

19+ , module Roboservant.Types.FlattenServer

14− module Roboservant.Types.ReifiedApi.Server,

20+ , module Roboservant.Types.ReifiedApi

15− module Roboservant.Types.Internal,

21+ , module Roboservant.Types.Internal

16− module Roboservant.Types.Config,

22+

17 )

23 )

18where

24where

19

25

20import Roboservant.Types.Breakdown

26import Roboservant.Types.Breakdown

21import Roboservant.Types.BuildFrom

27import Roboservant.Types.BuildFrom

22−import Roboservant.Types.Config

28+import Roboservant.Types.FlattenServer

23−import Roboservant.Types.Internal

24import Roboservant.Types.ReifiedApi

29import Roboservant.Types.ReifiedApi

25−import Roboservant.Types.ReifiedApi.Server

30+import Roboservant.Types.Internal

26−import Roboservant.Types.Orphans()

src/Roboservant/Types/Breakdown.hs+20−67

@@ -1,81 +1,34 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE DefaultSignatures #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DerivingStrategies #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE DerivingVia #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE LambdaCase #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE StandaloneDeriving #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE UndecidableInstances #-}

15

3

16module Roboservant.Types.Breakdown where

4module Roboservant.Types.Breakdown where

17

5

18−import Data.Dynamic (Dynamic)

6+import Data.Dynamic (Dynamic, fromDynamic, toDyn)

19−import Data.Hashable

20−import Data.Kind

21import Data.List.NonEmpty (NonEmpty (..))

7import Data.List.NonEmpty (NonEmpty (..))

22import qualified Data.List.NonEmpty as NEL

8import qualified Data.List.NonEmpty as NEL

9+import Data.Maybe (fromMaybe)

23import Data.Typeable (Typeable)

10import Data.Typeable (Typeable)

24−import GHC.Generics

25−import Roboservant.Types.Internal

26−import Servant

27−import Roboservant.Types.Orphans()

28

11

29−breakdown ::

12+-- | only use this when we are using the internal typerep map.

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

13+promisedDyn :: Typeable a => Dynamic -> a

31− x ->

14+promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic

32− NonEmpty (Dynamic, Int)

33−breakdown x = hashedDyn x :| breakdownExtras x

34

15

35class Breakdown x where

16class Breakdown x where

36− breakdownExtras :: x -> [(Dynamic, Int)]

17+ breakdown :: x -> NonEmpty Dynamic

18+ default breakdown :: Typeable x => x -> NonEmpty Dynamic

19+ breakdown = pure . toDyn

37

20

38−instance (Hashable x, Typeable x) => Breakdown (Atom x) where

21+-- | Can't break it down any further -- stuck in your teeth, maybe.

39− breakdownExtras _ = []

22+newtype Chewy x = Chewy {unChew :: x}

40

23

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

24+instance Breakdown () where

25+ breakdown = pure . toDyn

42

26

43−deriving via (Atom Int) instance Breakdown Int

27+instance Breakdown Int where

44−deriving via (Atom Char) instance Breakdown Char

28+ breakdown = pure . toDyn

45

29

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

30+instance Typeable x => Breakdown (Chewy x) where

31+ breakdown x = pure (toDyn x)

47

32

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

33+instance (Typeable a, Breakdown a) => Breakdown [a] where

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

50−

51−

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

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

54−

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

56− breakdownExtras = gBreakdownExtras . from . unCompound

57−

58−instance GBreakdown f => GBreakdown (M1 S c f) where

59− gBreakdownExtras (M1 f) = gBreakdownExtras f

60−

61−instance GBreakdown b => GBreakdown (M1 D a b) where

62− gBreakdownExtras (M1 f) = gBreakdownExtras f

63−

64−instance GBreakdown b => GBreakdown (M1 C a b) where

65− gBreakdownExtras (M1 f) = gBreakdownExtras f

66−

67−instance (GBreakdown a, GBreakdown b) => GBreakdown (a :*: b) where

68− gBreakdownExtras (a :*: b) = gBreakdownExtras a <> gBreakdownExtras b

69−

70−instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where

71− gBreakdownExtras = \case

72− L1 a -> gBreakdownExtras a

73− R1 a -> gBreakdownExtras a

74−

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

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

34+ breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)

77−

78−instance GBreakdown U1 where

79− gBreakdownExtras U1 = []

80−

81−deriving via (Atom NoContent) instance Breakdown NoContent

src/Roboservant/Types/BuildFrom.hs+25−93

@@ -1,107 +1,39 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE DefaultSignatures #-}

2−{-# LANGUAGE DerivingVia #-}

2+{-# LANGUAGE DerivingStrategies #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE StandaloneDeriving #-}

8{-# LANGUAGE TypeApplications #-}

4{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE StandaloneDeriving #-}

11−{-# LANGUAGE UndecidableInstances #-}

7+{-# LANGUAGE DerivingVia #-}

8+

9+

12

10

13module Roboservant.Types.BuildFrom where

11module Roboservant.Types.BuildFrom where

14

12

15−import Data.List(nub)

13+import Data.List.NonEmpty (NonEmpty(..))

16−import qualified Data.Dependent.Map as DM

17−import Data.Hashable

18−import qualified Data.IntSet as IntSet

19−import Data.Kind

20−import Data.List.NonEmpty (NonEmpty (..))

21import qualified Data.List.NonEmpty as NEL

14import qualified Data.List.NonEmpty as NEL

22import Data.Typeable (Typeable)

15import Data.Typeable (Typeable)

23−import GHC.Generics

16+import qualified Data.Dependent.Map as DM

24−import Roboservant.Types.Internal

25import qualified Type.Reflection as R

17import qualified Type.Reflection as R

26−import Servant(NoContent)

18+import Data.Kind

27−import Roboservant.Types.Orphans()

19+import Roboservant.Types.Internal

28−

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

30−buildFrom = buildStash . buildFrom'

31− where

32− buildStash :: [([Provenance], x)] -> Maybe (StashValue x)

33− buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty

34− promoteToStash :: ([Provenance], x) -> StashValue x

35− promoteToStash (p, x) =

36− StashValue

37− (pure (p, x))

38− (IntSet.singleton (hash x))

39− addStash :: StashValue x -> StashValue x -> StashValue x

40− addStash old (StashValue newVal _) =

41− let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal

42− in StashValue

43− (addListToNE (getStashValue old) insertableVals)

44− (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))

45− addListToNE :: NonEmpty a -> [a] -> NonEmpty a

46− addListToNE ne l = NEL.fromList (NEL.toList ne <> l)

47−

48−buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]

49−buildFrom' stash =

50− maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))

51− <> extras stash

52

20

53−class (Hashable x, Typeable x) => BuildFrom (x :: Type) where

21+class Typeable x => BuildFrom (x :: Type) where

54− extras :: Stash -> [([Provenance], x)]

22+ buildFrom :: Stash -> Maybe (StashValue x)

55

23

24+-- | this is a little esoteric: basically, we're always going to use this with

25+-- deriving-via, so we need to look up the underlying `x` and then wrap it in Atom.

56−instance (Hashable x, Typeable x) => BuildFrom (Atom x) where

26+instance Typeable x => BuildFrom (Atom x) where

57− extras _ = []

27+ buildFrom = fmap (fmap Atom) <$> DM.lookup R.typeRep . getStash

58

28

59deriving via (Atom Bool) instance BuildFrom Bool

29deriving via (Atom Bool) instance BuildFrom Bool

60

30

61−deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)

31+instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where

62−

32+ buildFrom dict = Just options

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

33+ where options :: StashValue (Maybe x)

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

34+ options = StashValue $

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

35+ ([],Nothing) :|

66− extras stash =

36+ (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict

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

37+ )

68− where

38+-- instance (BuildFrom a) => BuildFrom [a] -- where

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

39+ --breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)

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

71−

72−

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

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

75−

76−deriving via (Atom Int) instance BuildFrom Int

77−

78−deriving via (Atom Char) instance BuildFrom Char

79−

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

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

82−

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

84− gExtras = fmap (fmap M1) . gExtras

85−

86−-- not recursion safe!

87−instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where

88− gExtras stash =

89− (fmap L1 <$> gExtras stash)

90− <> (fmap R1 <$> gExtras stash)

91−

92−instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where

93− gExtras stash = [(pa <> pb, a' :*: b') | (pa, a') <- gExtras stash, (pb, b') <- gExtras stash]

94−

95−instance GBuildFrom b => GBuildFrom (M1 C a b) where

96− gExtras = fmap (fmap M1) . gExtras

97−

98−instance GBuildFrom b => GBuildFrom (M1 S a b) where

99− gExtras = fmap (fmap M1) . gExtras

100−

101−instance BuildFrom a => GBuildFrom (K1 i a) where

102− gExtras = fmap (fmap K1) . buildFrom'

103−

104−instance GBuildFrom U1 where

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

106−

107−deriving via (Atom NoContent) instance BuildFrom NoContent

src/Roboservant/Types/Config.hsdeleted−29

@@ -1,29 +0,0 @@

1−module Roboservant.Types.Config where

2−

3−import Data.Dynamic

4−

5−data Config

6− = Config

7− { seed :: [(Dynamic, Int)],

8− maxRuntime :: Double, -- seconds to test for

9− maxReps :: Integer,

10− rngSeed :: Int,

11− coverageThreshold :: Double,

12− logInfo :: String -> IO (),

13− healthCheck :: IO ()

14− }

15−

16−defaultConfig :: Config

17−defaultConfig =

18− Config

19− { seed = [],

20− maxRuntime = 0.5,

21− maxReps = 1000,

22− rngSeed = 0,

23− coverageThreshold = 0,

24− logInfo = const (pure ()),

25− healthCheck = pure ()

26− }

27−

28−noisyConfig :: Config

29−noisyConfig = defaultConfig {logInfo = print}

src/Roboservant/Types/FlattenServer.hsnew file+45

@@ -0,0 +1,45 @@

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+module Roboservant.Types.FlattenServer where

11+

12+import Servant

13+

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+ ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),

24+ Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),

25+ FlattenServer api

26+ ) =>

27+ FlattenServer (endpoint :<|> api)

28+ where

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

30+

31+instance

32+ ( HasServer (x :> api) '[],

33+ Endpoints (x :> api) ~ '[x :> api]

34+ ) =>

35+ FlattenServer (x :> api)

36+ where

37+ flattenServer server = server `AnEndpoint` NoEndpoints

38+

39+instance

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

41+ Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]

42+ ) =>

43+ FlattenServer (Verb method statusCode contentTypes responseType)

44+ where

45+ flattenServer server = server `AnEndpoint` NoEndpoints

src/Roboservant/Types/Internal.hs+10−30

@@ -1,53 +1,33 @@

1{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5

3

6module Roboservant.Types.Internal where

4module Roboservant.Types.Internal where

7

5

6+import Data.List.NonEmpty (NonEmpty(..))

7+import qualified Data.Map.Strict as Map

8import qualified Data.Dependent.Map as DM

9import Data.Dependent.Map (DMap)

10−import Data.Dependent.Sum

11−import Data.Dynamic (Dynamic, toDyn)

12−import Data.Hashable (Hashable, hash)

13−import Data.IntSet (IntSet)

14−import Data.List.NonEmpty (NonEmpty (..))

15−import qualified Data.Map.Strict as Map

16−import Data.Typeable (Typeable)

17−import GHC.Generics (Generic)

18import qualified Type.Reflection as R

10import qualified Type.Reflection as R

11+import Data.Dependent.Sum

19

12

20data Provenance

13data Provenance

21 = Provenance R.SomeTypeRep Int

14 = Provenance R.SomeTypeRep Int

22− deriving (Show, Eq, Generic)

15+ deriving (Show,Eq)

23−

24−instance Hashable Provenance

25

16

26−data StashValue a

27− = StashValue

28− { getStashValue :: NonEmpty ([Provenance], a),

17+newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }

29− stashHash :: IntSet

30− }

31 deriving (Functor, Show)

18 deriving (Functor, Show)

32

19

33-- wrap in newtype to give a custom Show instance, since the normal

20-- wrap in newtype to give a custom Show instance, since the normal

34-- instance for DMap is not happy since StashValue needs Show a to show

21-- instance for DMap is not happy since StashValue needs Show a to show

35−newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}

22+newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }

36 deriving (Semigroup, Monoid)

23 deriving (Semigroup, Monoid)

37

24

38instance Show Stash where

25instance Show Stash where

39− showsPrec i (Stash x) =

26+ showsPrec i (Stash x) = showsPrec i $

40− showsPrec i

41− $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))

27+ Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x

42− $ DM.toList x

43

28

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

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

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

30+newtype Atom x = Atom { unAtom :: x }

46− deriving newtype (Hashable, Typeable,Eq)

47

31

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

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

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

33+newtype Compound x = Compound { unCompound :: x }

50− deriving newtype (Hashable, Typeable, Eq)

51−

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

53−hashedDyn a = (toDyn a, hash a)

src/Roboservant/Types/Orphans.hsdeleted−7

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

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

2−module Roboservant.Types.Orphans where

3−

4−import Servant

5−import Data.Hashable

6−

7−instance Hashable NoContent

src/Roboservant/Types/ReifiedApi.hs+56−71

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

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

6{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE AllowAmbiguousTypes #-}

7{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

@@ -12,31 +8,39 @@

12{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

13{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE LambdaCase #-}

14{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE RecordWildCards #-}

15{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE StandaloneDeriving #-}

14+{-# LANGUAGE TupleSections #-}

16{-# LANGUAGE TypeApplications #-}

15{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

20−{-# LANGUAGE CPP #-}

19+

21module Roboservant.Types.ReifiedApi where

20module Roboservant.Types.ReifiedApi where

22

21

22+

23+import Control.Monad.Except (runExceptT)

24+import Data.Bifunctor

25+-- import Data.Dependent.Sum

23import Data.Dynamic (Dynamic)

26import Data.Dynamic (Dynamic)

24−import Control.Exception(Exception)

27+import Data.Kind

25import Data.List.NonEmpty (NonEmpty)

28import Data.List.NonEmpty (NonEmpty)

26import Data.Typeable (Typeable)

29import Data.Typeable (Typeable)

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

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

31+import GHC.TypeLits (Symbol)

28import Roboservant.Types.Internal

32import Roboservant.Types.Internal

29import Roboservant.Types.Breakdown

33import Roboservant.Types.Breakdown

30import Roboservant.Types.BuildFrom

34import Roboservant.Types.BuildFrom

31−import Data.Kind(Type)

35+import Roboservant.Types.FlattenServer

32import Servant

36import Servant

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

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

34−import GHC.TypeLits (Symbol)

35import qualified Data.Text as T

38import qualified Data.Text as T

36import qualified Data.Vinyl as V

39import qualified Data.Vinyl as V

37import qualified Data.Vinyl.Curry as V

40import qualified Data.Vinyl.Curry as V

38import qualified Type.Reflection as R

41import qualified Type.Reflection as R

39

42

43+

40newtype ApiOffset = ApiOffset Int

44newtype ApiOffset = ApiOffset Int

41 deriving (Eq, Show, Ord)

45 deriving (Eq, Show, Ord)

42 deriving newtype (Enum, Num)

46 deriving newtype (Enum, Num)

@@ -49,32 +53,60 @@ newtype Argument a = Argument

49

53

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

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

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

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

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

56+ , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

53 }

57 }

54

58

55−instance Show ReifiedEndpoint where

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

56− show _ = "lol"

60+

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

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

63+

64+class ToReifiedApi (endpoints :: [*]) where

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

57

66

67+class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint

58−class ( V.RecordToList (EndpointArgs endpoint)

68+ , V.RecordToList (EndpointArgs endpoint)

59 , V.RMap (EndpointArgs endpoint)

69 , V.RMap (EndpointArgs endpoint)

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

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

61 type EndpointArgs endpoint :: [Type]

71 type EndpointArgs endpoint :: [Type]

62 type EndpointRes endpoint :: Type

72 type EndpointRes endpoint :: Type

63

73

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

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

65

75

76+instance ToReifiedApi '[] where

77+ toReifiedApi NoEndpoints _ = []

66

78

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

79+instance

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

80+ ( Typeable (EndpointRes endpoint)

69−

81+ , NormalizeFunction (ServerT endpoint Handler)

70−data InteractionError = InteractionError

82+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty Dynamic)))

71− { errorMessage :: T.Text

83+ , ToReifiedEndpoint endpoint

72− , fatalError :: Bool

84+ , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)

85+ ) =>

86+ ToReifiedApi (endpoint : endpoints)

87+ where

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

89+ (0, ReifiedEndpoint

90+ { reArguments = reifiedEndpointArguments @endpoint

91+ , reEndpointFunc = normalize endpoint

73− }

92+ }

74− deriving Show

93+ )

75−instance Exception InteractionError

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

76−

95+ (toReifiedApi endpoints (Proxy @endpoints))

77−

96+

97+class NormalizeFunction m where

98+ type Normal m

99+ normalize :: m -> Normal m

100+

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

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

103+ normalize = fmap normalize

104+

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

106+ type Normal (Handler x) = IO (Either ServerError (NonEmpty Dynamic))

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

108+ Left serverError -> pure (Left serverError)

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

78

110

79instance

111instance

80 (Typeable responseType, Breakdown responseType) =>

112 (Typeable responseType, Breakdown responseType) =>

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

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

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

85 reifiedEndpointArguments = V.RNil

117 reifiedEndpointArguments = V.RNil

86

118

87−instance ToReifiedEndpoint (NoContentVerb method)

88− where

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

90− type EndpointRes (NoContentVerb method) = NoContent

91− reifiedEndpointArguments = V.RNil

92−

93instance

119instance

94 (ToReifiedEndpoint endpoint) =>

120 (ToReifiedEndpoint endpoint) =>

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

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

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

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

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

99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

125 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

100

126

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−

111instance

127instance

112 (ToReifiedEndpoint endpoint) =>

128 (ToReifiedEndpoint endpoint) =>

113 ToReifiedEndpoint (Description s :> endpoint)

129 ToReifiedEndpoint (Description s :> endpoint)

@@ -151,23 +167,6 @@ instance

151 V.:& reifiedEndpointArguments @endpoint

167 V.:& reifiedEndpointArguments @endpoint

152

168

153

169

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−

171instance

170instance

172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

171 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

173 , ToReifiedEndpoint endpoint

172 , ToReifiedEndpoint endpoint

@@ -180,7 +179,6 @@ instance

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

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

181 V.:& reifiedEndpointArguments @endpoint

180 V.:& reifiedEndpointArguments @endpoint

182

181

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

184instance

182instance

185 ( BuildFrom (IfLenient String mods captureType)

183 ( BuildFrom (IfLenient String mods captureType)

186 , ToReifiedEndpoint endpoint) =>

184 , ToReifiedEndpoint endpoint) =>

@@ -191,19 +189,6 @@ instance

191 reifiedEndpointArguments =

189 reifiedEndpointArguments =

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

190 tagType (Argument (buildFrom @(IfLenient String mods captureType)))

193 V.:& reifiedEndpointArguments @endpoint

191 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

192

208instance

193instance

209 ( BuildFrom (IfLenient String mods requestType)

194 ( BuildFrom (IfLenient String mods requestType)

src/Roboservant/Types/ReifiedApi/Server.hsdeleted−114

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

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+22−5

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

1−resolver: lts-20.4

1+resolver: lts-16.16

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

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

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

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

7+- markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112

10−- some-1.0.3

8+- servant-0.18

9+- servant-client-0.18

10+- servant-client-core-0.18

11+- servant-server-0.18

12+# - hspec-hedgehog-0.0.1.2@sha256:aaeeb50a43d2bce8a1850baa3ddf934a964bfe38c64efd59306b0c1421e55b45,1405

13+- QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736

14+- random-1.2.0

15+- splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253

16+- vinyl-0.13.0

17+- dependent-sum-0.7.1.0

18+- constraints-extras-0.3.0.2

19+- dependent-map-0.4.0.0

20+- git: https://github.com/hedgehogqa/haskell-hedgehog.git

21+ commit: 03714682586e43b5ddf5c00391035471a6e01238

22+ subdirs:

23+ - hedgehog

24+- git: https://github.com/mwotton/hspec

25+ commit: cd9012414a93cf08f86e409544d4d3a8f282b507

26+ subdirs:

27+ - hspec-core

stack.yaml.lock+112−9

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

7- completed:

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

9 pantry-tree:

10− sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

11 size: 325

10 size: 325

11+ sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

12 original:

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

14- completed:

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

15+ hackage: markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112

16+ pantry-tree:

17+ size: 432

18+ sha256: 6871bd9281acf589296d0998a3d62892b036040ab10e74e8a0f356f68c194f4f

19+ original:

20+ hackage: markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112

21+- completed:

22+ hackage: servant-0.18@sha256:2b5c81089540c208b1945b5ca0c3551c862138d71b224a39fa275a62852a5c75,5068

23+ pantry-tree:

24+ size: 2458

25+ sha256: 701b6443e486601dd127b92a28ca052278dea8dc528f013781c1304826e117d8

26+ original:

27+ hackage: servant-0.18

28+- completed:

29+ hackage: servant-client-0.18@sha256:3e3b8d145cf811e19849744ad305aa0bd42301d01ff75e1dac169bc9f5d18221,4589

30+ pantry-tree:

31+ size: 1299

32+ sha256: 445c610d83a6e356ed2a7808af8deac84708be3e44d38cbf76e60fd6105f9715

33+ original:

34+ hackage: servant-client-0.18

35+- completed:

36+ hackage: servant-client-core-0.18@sha256:6702f04f3e5ac47abace5b26ab1948480437334747895407f0697502a403b96a,3593

37+ pantry-tree:

38+ size: 1444

39+ sha256: 20f538ae12091696073a2ac5f3301a4a56686f5e2889b2a9e539c0d61a332cd1

40+ original:

41+ hackage: servant-client-core-0.18

42+- completed:

43+ hackage: servant-server-0.18@sha256:ec7f361bc9848968b1fff8091fa2213b721d3f47549421945c6a7ca1702e22e6,5424

44+ pantry-tree:

45+ size: 2546

46+ sha256: c2470cd8665742cee13faae1db7e3d49d70b027d57c4578e3f7ba66ffc8dc7b4

47+ original:

48+ hackage: servant-server-0.18

49+- completed:

50+ hackage: QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736

51+ pantry-tree:

52+ size: 2315

53+ sha256: 21961d0875fc156cdd97110a6fb277f37aa31faa3c7910895f84c82630e7ba46

54+ original:

55+ hackage: QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736

56+- completed:

57+ hackage: random-1.2.0@sha256:4321209c8faedc034810ea8ed0dbc4a36f1a1df97b75af024219f2f533da57de,6094

58+ pantry-tree:

59+ size: 1259

60+ sha256: 29ff0a7ec5bf123e2c40f849b7af163950854a6c08c68b4a1b4364ce7a515af0

61+ original:

62+ hackage: random-1.2.0

63+- completed:

64+ hackage: splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253

65+ pantry-tree:

66+ size: 1149

67+ sha256: b9a0c60e2d4786bbb276ce6606027a99615bf703fa3e0f01911e8c6a656c5161

68+ original:

69+ hackage: splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253

70+- completed:

71+ hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724

72+ pantry-tree:

73+ size: 1857

74+ sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01

75+ original:

76+ hackage: vinyl-0.13.0

77+- completed:

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

79+ pantry-tree:

80+ size: 290

81+ sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50

82+ original:

83+ hackage: dependent-sum-0.7.1.0

84+- completed:

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

86+ pantry-tree:

87+ size: 594

88+ sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1

89+ original:

90+ hackage: constraints-extras-0.3.0.2

91+- completed:

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

93+ pantry-tree:

94+ size: 551

95+ sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5

96+ original:

97+ hackage: dependent-map-0.4.0.0

98+- completed:

99+ subdir: hedgehog

100+ name: hedgehog

101+ version: 1.0.3

102+ git: https://github.com/hedgehogqa/haskell-hedgehog.git

103+ pantry-tree:

104+ size: 2575

105+ sha256: 7e69930fef281dfeb47b2f7c745c26234768e56ffb5490065f607c57146ffbab

106+ commit: 03714682586e43b5ddf5c00391035471a6e01238

107+ original:

108+ subdir: hedgehog

109+ git: https://github.com/hedgehogqa/haskell-hedgehog.git

110+ commit: 03714682586e43b5ddf5c00391035471a6e01238

111+- completed:

112+ subdir: hspec-core

113+ name: hspec-core

114+ version: 2.7.4

115+ git: https://github.com/mwotton/hspec

16 pantry-tree:

116 pantry-tree:

17− sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

117+ size: 3899

18− size: 709

118+ sha256: 6ece11ad28a7f122a502e766eb1b3ef950815c2d16babb0ea8744646f1c1bd70

119+ commit: cd9012414a93cf08f86e409544d4d3a8f282b507

19 original:

120 original:

20− hackage: some-1.0.3

121+ subdir: hspec-core

122+ git: https://github.com/mwotton/hspec

123+ commit: cd9012414a93cf08f86e409544d4d3a8f282b507

21snapshots:

124snapshots:

22- completed:

125- completed:

23− sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

24− size: 648660

126+ size: 532380

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

127+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml

128+ sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e

26− original: lts-20.4

129+ original: lts-16.16

test/Breakdown.hsdeleted−50

@@ -1,50 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4−

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE TypeOperators #-}

7−

8−module Breakdown where

9−

10−import Data.Aeson

11−import Data.Hashable

12−import Data.Typeable (Typeable)

13−import GHC.Generics (Generic)

14−import Servant

15−

16−data Foo = Foo Int String

17− deriving (Generic, Eq, Show, Typeable)

18−

19−instance Hashable Foo

20−

21−instance ToJSON Foo

22−

23−instance FromJSON Foo

24−

25−data SomeSum = A Int | B String

26− deriving (Generic, Eq, Show, Typeable)

27−

28−instance Hashable SomeSum

29−

30−instance ToJSON SomeSum

31−

32−instance FromJSON SomeSum

33−

34−type ProductApi =

35− "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()

36− :<|> "getFoo" :> Get '[JSON] Foo

37−

38−eliminate :: Int -> Handler ()

39−eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}

40−

41−productServer :: Server ProductApi

42−productServer = eliminate :<|> pure (Foo 12 "abc")

43−

44−type SumApi =

45− "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()

46− :<|> "getFoo1" :> Get '[JSON] SomeSum

47− :<|> "getFoo2" :> Get '[JSON] SomeSum

48−

49−sumServer :: Server SumApi

50−sumServer = eliminate :<|> pure (B "hi") :<|> pure (A 3)

test/Foo.hs−3

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

8module Foo where

9

10import Data.Aeson

11−import Data.Hashable

12import Data.Typeable (Typeable)

11import Data.Typeable (Typeable)

13import GHC.Generics (Generic)

12import GHC.Generics (Generic)

14import Servant

13import Servant

@@ -17,8 +16,6 @@ newtype Foo = Foo Int

17 deriving (Generic, Eq, Show, Typeable)

16 deriving (Generic, Eq, Show, Typeable)

18 deriving newtype (FromHttpApiData, ToHttpApiData)

17 deriving newtype (FromHttpApiData, ToHttpApiData)

19

18

20−instance Hashable Foo

21−

22instance ToJSON Foo

19instance ToJSON Foo

23

20

24instance FromJSON Foo

21instance FromJSON Foo

test/Headers.hs+2−4

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

8module Headers where

9

10import Data.Aeson

11−import Data.Hashable

12import Data.Typeable (Typeable)

11import Data.Typeable (Typeable)

13import GHC.Generics (Generic)

12import GHC.Generics (Generic)

14import Servant

13import Servant

@@ -17,8 +16,6 @@ newtype Foo = Foo Int

17 deriving (Generic, Eq, Show, Typeable)

16 deriving (Generic, Eq, Show, Typeable)

18 deriving newtype (FromHttpApiData, ToHttpApiData)

17 deriving newtype (FromHttpApiData, ToHttpApiData)

19

18

20−instance Hashable Foo

21−

22instance ToJSON Foo

19instance ToJSON Foo

23

20

24instance FromJSON Foo

21instance FromJSON Foo

@@ -35,7 +32,8 @@ combine :: Maybe Foo -> Maybe Foo -> Handler Foo

35combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))

32combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))

36combine (Just a) Nothing = pure a

33combine (Just a) Nothing = pure a

37combine Nothing (Just a) = pure a

34combine Nothing (Just a) = pure a

38−combine Nothing Nothing = pure (Foo 1)

35+combine Nothing Nothing = pure (Foo 1)

36+

39

37

40eliminate :: Foo -> Handler ()

38eliminate :: Foo -> Handler ()

41eliminate (Foo a)

39eliminate (Foo a)

test/Nested.hsdeleted−23

@@ -1,23 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−

3−{-# LANGUAGE DerivingStrategies #-}

4−

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE TypeOperators #-}

7−

8−module Nested where

9−

10−import Servant

11−import Servant.API.Flatten

12−

13−type Api =

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

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

16− )

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

18− )

19−

20−type FlatApi = Flat Api

21−

22−server :: Server FlatApi

23−server = pure 1 :<|> pure 2 :<|> pure 3

test/Post.hsdeleted−31

@@ -1,31 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4−

5−

6−{-# LANGUAGE TypeOperators #-}

7−

8−module Post 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] FooPost

17− :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()

18−

19−data FooPost = FooPost

20− deriving (Eq, Show, Generic)

21−

22−instance Hashable FooPost

23−

24−instance ToJSON FooPost

25−

26−instance FromJSON FooPost

27−

28−server :: Server Api

29−server =

30− pure FooPost

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

test/Product.hsdeleted−31

@@ -1,31 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4−

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE TypeOperators #-}

7−

8−module Product where

9−

10−import Data.Aeson

11−import Data.Hashable

12−import Data.Typeable (Typeable)

13−import GHC.Generics (Generic)

14−import Servant

15−

16−data Foo = Foo Int String

17− deriving (Generic, Eq, Show, Typeable)

18−

19−instance Hashable Foo

20−

21−instance ToJSON Foo

22−

23−instance FromJSON Foo

24−

25−type Api = "item" :> ReqBody '[JSON] Foo :> Post '[JSON] ()

26−

27−eliminate :: Foo -> Handler ()

28−eliminate (Foo _a _b) = throwError $ err500 {errBody = "eliminate blew up, oh no!"}

29−

30−server :: Server Api

31−server = eliminate

test/Put.hsdeleted−33

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4−

5−

6−{-# LANGUAGE TypeOperators #-}

7−

8−module Put where

9−

10−import Data.Aeson

11−import Data.Hashable

12−import GHC.Generics (Generic)

13−import Servant

14−

15−type Api =

16− Get '[JSON] Foo

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

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

19−

20−data Foo = Foo

21− deriving (Eq, Show, Generic)

22−

23−instance Hashable Foo

24−

25−instance ToJSON Foo

26−

27−instance FromJSON Foo

28−

29−server :: Server Api

30−server =

31− pure Foo

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

33− :<|> const (pure NoContent)

test/QueryParams.hsdeleted−15

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

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/Seeded.hs+4−10

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

8module Seeded where

9

10import Data.Aeson

11−import Data.Hashable

12import Data.Typeable (Typeable)

11import Data.Typeable (Typeable)

13import GHC.Generics (Generic)

12import GHC.Generics (Generic)

14import Servant

13import Servant

@@ -18,16 +17,11 @@ newtype Seed = Seed Int

18 deriving newtype (FromHttpApiData, ToHttpApiData)

17 deriving newtype (FromHttpApiData, ToHttpApiData)

19

18

20instance ToJSON Seed

19instance ToJSON Seed

21−

22instance FromJSON Seed

20instance FromJSON Seed

23

21

24−instance Hashable Seed

25−

26−type Api =

27− Capture "seed" Seed :> Get '[JSON] ()

22+type Api = Capture "seed" Seed :> Get '[JSON] ()

28− :<|> Get '[JSON] ()

23+ :<|> Get '[JSON] ()

29

24

30server :: Server Api

25server :: Server Api

31−server =

32− (\(Seed _) -> error "we blow up if we get here")

26+server = (\(Seed _) -> error "we blow up if we get here")

33− :<|> pure ()

27+ :<|> pure ()

test/Spec.hs+61−153

@@ -1,170 +1,78 @@

1−{-# LANGUAGE DerivingVia #-}

1+

2−{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE StandaloneDeriving #-}

6{-# LANGUAGE TypeApplications #-}

3{-# LANGUAGE TypeApplications #-}

7−{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE DerivingVia #-}

8−{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE StandaloneDeriving #-}

9−{-# LANGUAGE AllowAmbiguousTypes #-}

6+

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE DataKinds #-}

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

13−{-# LANGUAGE TypeFamilies #-}

14

7

15−import qualified Breakdown

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

16−import Data.Dynamic (toDyn)

17−import Data.Hashable (Hashable (hash))

18−import Data.Maybe (isNothing)

19−import Data.Void (Void)

20import qualified Foo

9import qualified Foo

21−import qualified Headers

22−import qualified Nested

23−import qualified Post

24−import qualified Put

25−import qualified Product

26−import qualified QueryParams

27−import qualified Roboservant as R

28−import qualified Roboservant.Server as RS

29−import qualified Roboservant.Client as RC

30import qualified Seeded

10import qualified Seeded

31−import Test.Hspec

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

33import qualified Valid

11import qualified Valid

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

12+import qualified Headers

13+-- import qualified UnsafeIO

35

14

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

15+import Data.Dynamic(toDyn)

37−import Network.Wai(Application)

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

16+import qualified Roboservant as RS

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

17+

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

18+import Test.Hspec

19+import Test.Hspec.Core.Spec(shouldFail)

20+import Data.Void

21+import Data.Maybe

41

22

42main :: IO ()

23main :: IO ()

43main = hspec spec

24main = hspec spec

44

25

45−fuzzBoth

26+noCheck :: IO ()

46− :: forall a .

27+noCheck = pure ()

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

28+

48− HasClient ClientM a)

29+defaultConfig :: RS.Config

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

30+defaultConfig = RS.Config [] 1 1000 1 0

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

31

65spec :: Spec

32spec :: Spec

66spec = do

33spec = do

67 describe "Basic usage" $ do

34 describe "Basic usage" $ do

68 describe "noError" $ do

35 describe "noError" $ do

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

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

37+ RS.fuzz @Valid.Api Valid.server defaultConfig noCheck `shouldReturn` Nothing

38+ it "does fail coverage check" $ do

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

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

72− (\r ->

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

74− `shouldSatisfy` ( \case

40+ r `shouldSatisfy` isJust

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

76− _ -> False

77− ))

78− describe "posted body" $

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

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

85− (`shouldSatisfy` isNothing)

86−

87−

88 describe "seeded" $ do

41 describe "seeded" $ do

89− let res = Seeded.Seed 1

42+ shouldFail $

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

43+ it "finds an error using information passed in" $

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

44+ RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck

92− (`shouldSatisfy` isNothing)

45+ `shouldReturn` Nothing

93−

46+ shouldFail $ it "finds an error in a basic app" $

94− describe "Foo" $

47+ RS.fuzz @Foo.Api Foo.server defaultConfig noCheck

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

48+ `shouldReturn` Nothing

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−

101− describe "BuildFrom" $ do

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

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

49+ shouldFail $ it "should find a failure that's dependent on using header info" $ do

104− (`shouldSatisfy` serverFailure)

50+ RS.fuzz @Headers.Api Headers.server defaultConfig noCheck

105− describe "product types" $

51+ `shouldReturn` Nothing

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

52+ -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it

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

53+ -- -- -- could: it's mostly here to show how to test for concurrency problems.

108− (`shouldSatisfy` serverFailure)

54+ -- describe "concurrency bugs" $ do

109− describe "Breakdown" $ do

55+ -- before UnsafeIO.makeServer $ do

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

56+ -- describe "sequential checking" $ do

111− (`shouldSatisfy` serverFailure)

57+ -- it "safe use" $ \unsafeServer -> do

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

58+ -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []

113− (`shouldSatisfy` serverFailure)

59+

114− describe "flattening" $

60+ -- modifyMaxSuccess (const 10000) $

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

116− (`shouldSatisfy` isNothing)

117−

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

119−serverFailure = \case

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

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

122− in failureReason /= R.NoPossibleMoves

123− _ -> False

124−

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

130−

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

132−

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

134−

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

136−

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

138−

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

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

141−

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

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

144−

145−

146−

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

148−

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

150−

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

152−

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

154−-- this is often useful when testing tests.

155−shouldFail :: SpecWith a -> SpecWith a

156−shouldFail =

61+ -- shouldFail $

157− mapSpecItem_

62+ -- describe "concurrent" $ do

158− ( \i ->

63+ -- it "concurrent, dangerous use" $ \unsafeServer -> do

159− i

64+ -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []

160− { itemExample = \p a cb -> do

65+

161− r <- itemExample i p a cb

66+

162− pure

67+instance RS.Breakdown Foo.Foo where

163− r

68+ breakdown = pure . toDyn

164− { resultStatus = case resultStatus r of

69+

165− Success -> Failure Nothing (Reason "Unexpected success")

70+

166− Failure _ _ -> Success

71+instance RS.Breakdown Headers.Foo where

167− x -> x

72+ breakdown = pure . toDyn

168− }

73+

169− }

74+

170− )

75+deriving via (RS.Atom Void) instance RS.BuildFrom Void

76+deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo

77+deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo

78+deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed

test/UnsafeIO.hs+15−13

@@ -1,39 +1,41 @@

1{-# LANGUAGE DataKinds #-}

2−

2+{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module UnsafeIO where

9

10−import Control.Monad.Trans (MonadIO (liftIO))

11−import Data.Aeson ()

10+import Data.Aeson()

12−import qualified Data.ByteString.Lazy.Char8 as BL8

13−import Data.IORef (IORef, newIORef, readIORef, writeIORef)

14import Servant

11import Servant

12+import Data.IORef (writeIORef, IORef, readIORef, newIORef)

13+import Control.Monad.Trans (MonadIO(liftIO))

14+import qualified Data.ByteString.Lazy.Char8 as BL8

15+

15

16

16type UnsafeApi =

17type UnsafeApi =

17 "add" :> Get '[JSON] ()

18 "add" :> Get '[JSON] ()

18− :<|> "healthcheck" :> Get '[JSON] ()

19+ :<|> "healthcheck" :> Get '[JSON] ()

19

20

20healthcheck :: IORef Int -> Handler ()

21healthcheck :: IORef Int -> Handler ()

21healthcheck ref = do

22healthcheck ref = do

22 t <- liftIO $ readIORef ref

23 t <- liftIO $ readIORef ref

23 case t of

24 case t of

24 0 -> pure ()

25 0 -> pure ()

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

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

27+

28+

26

29

27makeServer :: IO (Server UnsafeApi)

30makeServer :: IO (Server UnsafeApi)

28makeServer = do

31makeServer = do

29 ref <- newIORef 0

32 ref <- newIORef 0

30− pure $

33+ pure $ unsafeMunge ref

31− unsafeMunge ref

32− :<|> healthcheck ref

34+ :<|> healthcheck ref

33

35

34unsafeMunge :: IORef Int -> Handler ()

36unsafeMunge :: IORef Int -> Handler ()

35unsafeMunge ref = liftIO $ do

37unsafeMunge ref = liftIO $ do

36 t <- readIORef ref

38 t <- readIORef ref

37− writeIORef ref (t + 1)

39+ writeIORef ref (t+1)

38 t2 <- readIORef ref

40 t2 <- readIORef ref

39− writeIORef ref (t2 -1)

41+ writeIORef ref (t2-1)

test/Valid.hs+5−32

@@ -1,44 +1,17 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Valid where

9

10−import Data.Void

11−import GHC.Generics

12import Servant

10import Servant

13−import Servant.Server.Generic

11+import Data.Void

14−

15−type Api =

16− Get '[JSON] Int

17− :<|> Capture "void" Void :> Get '[JSON] ()

18−

19−data Routes route

20− = Routes

21− { getInt ::

22− route

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

24− captureIt ::

25− route

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

27− }

28− deriving (Generic)

29−

30−type RoutedApi = ToServantApi Routes

31−

32−-- routedApi = genericApi (Proxy :: Proxy Routes)

33−routedServer :: Server RoutedApi

34−routedServer = genericServer routes

35−

36−routes :: Routes AsServer

37−routes =

38− Routes

39− { getInt = pure 7,

40− captureIt = const (pure ())

41− }

42

12

13+type Api = Get '[JSON] Int

14+ :<|> Capture "void" Void :> Get '[JSON] ()

15+

43server :: Server Api

16server :: Server Api

44server = pure 7 :<|> const (pure ())

17server = pure 7 :<|> const (pure ())