master..0be3abc · 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 roboservant --ghc-options="+RTS -N4"' --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+7−36

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

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

5+author: "Mark Wotton, Samuel Schlesinger"

6+maintainer: "mwotton@gmail.com"

6copyright: "2020 Mark Wotton, Samuel Schlesinger"

7copyright: "2020 Mark Wotton, Samuel Schlesinger"

7synopsis: Automatic session-aware servant testing

8synopsis: Automatic session-aware servant testing

8category: Web

9category: Web

@@ -17,28 +18,16 @@ dependencies:

17

18

18- bytestring

19- bytestring

19- containers

20- containers

20−- random

21+- hedgehog

21−- hashable

22−- http-types

23−- lifted-base

24−- monad-control

25- mtl

22- mtl

26- servant # >= 0.17

23- servant # >= 0.17

27- servant-client # >= 0.17

24- servant-client # >= 0.17

28- servant-flatten

25- servant-flatten

29- servant-server # >= 0.17

26- servant-server # >= 0.17

30- string-conversions

27- string-conversions

31−- vinyl

32−- dependent-sum

33−- dependent-map

34−- unordered-containers

35−- text

36−- time

37

28

38−ghc-options:

29+ghc-options: -Wall

39−- -Wall

30+

40−- -fwrite-ide-info

41−- -hiedir=.hie

42library:

31library:

43 source-dirs: src

32 source-dirs: src

44

33

@@ -55,22 +44,4 @@ tests:

55 - aeson

44 - aeson

56 - hspec

45 - hspec

57 - hspec-core

46 - hspec-core

58− - http-api-data

59− - http-client

60− - hspec-wai

47+ - hspec-hedgehog

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+13−86

@@ -1,18 +1,20 @@

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: 4f60e8b535f448b3d09b5f49b6851d27412b133b35f4381078d9693228b977cb

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

14homepage: https://github.com/mwotton/roboservant#readme

15bug-reports: https://github.com/mwotton/roboservant/issues

16+author: Mark Wotton, Samuel Schlesinger

17+maintainer: mwotton@gmail.com

16copyright: 2020 Mark Wotton, Samuel Schlesinger

18copyright: 2020 Mark Wotton, Samuel Schlesinger

17license: BSD3

19license: BSD3

18license-file: LICENSE

20license-file: LICENSE

@@ -28,131 +30,56 @@ source-repository head

28library

30library

29 exposed-modules:

31 exposed-modules:

30 Roboservant

32 Roboservant

31− Roboservant.Client

33+ Roboservant.Hedgehog

32− Roboservant.Direct

33− Roboservant.Server

34+ Roboservant.StateMachine

34 Roboservant.Types

35 Roboservant.Types

35 Roboservant.Types.Breakdown

36 Roboservant.Types.Breakdown

36− Roboservant.Types.BuildFrom

37+ Roboservant.Types.FlattenServer

37− Roboservant.Types.Config

38− Roboservant.Types.Internal

39− Roboservant.Types.Orphans

40 Roboservant.Types.ReifiedApi

38 Roboservant.Types.ReifiedApi

41− Roboservant.Types.ReifiedApi.Server

42 other-modules:

39 other-modules:

43 Paths_roboservant

40 Paths_roboservant

44 hs-source-dirs:

41 hs-source-dirs:

45 src

42 src

46− ghc-options: -Wall -fwrite-ide-info -hiedir=.hie

43+ ghc-options: -Wall

47 build-depends:

44 build-depends:

48 base >=4.7 && <5

45 base >=4.7 && <5

49 , bytestring

46 , bytestring

50 , containers

47 , containers

51− , dependent-map

48+ , hedgehog

52− , dependent-sum

53− , hashable

54− , http-types

55− , lifted-base

56− , monad-control

57 , mtl

49 , mtl

58− , random

59 , servant

50 , servant

60 , servant-client

51 , servant-client

61 , servant-flatten

52 , servant-flatten

62 , servant-server

53 , servant-server

63 , string-conversions

54 , string-conversions

64− , text

65− , time

66− , unordered-containers

67− , vinyl

68− default-language: Haskell2010

69−

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

55 default-language: Haskell2010

108

56

109test-suite roboservant-test

57test-suite roboservant-test

110 type: exitcode-stdio-1.0

58 type: exitcode-stdio-1.0

111 main-is: Spec.hs

59 main-is: Spec.hs

112 other-modules:

60 other-modules:

113− Breakdown

114 Foo

61 Foo

115 Headers

62 Headers

116− Nested

117− Post

118− Product

119− Put

120− QueryParams

121 Seeded

63 Seeded

122 UnsafeIO

64 UnsafeIO

123− Valid

124 Paths_roboservant

65 Paths_roboservant

125 hs-source-dirs:

66 hs-source-dirs:

126 test

67 test

127− ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N

68+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N

128 build-depends:

69 build-depends:

129 aeson

70 aeson

130 , base >=4.7 && <5

71 , base >=4.7 && <5

131 , bytestring

72 , bytestring

132 , containers

73 , containers

133− , dependent-map

74+ , hedgehog

134− , dependent-sum

135− , hashable

136 , hspec

75 , hspec

137 , hspec-core

76 , hspec-core

138− , hspec-wai

77+ , hspec-hedgehog

139− , http-api-data

140− , http-client

141− , http-types

142− , lifted-base

143− , monad-control

144 , mtl

78 , mtl

145− , random

146 , roboservant

79 , roboservant

147 , servant

80 , servant

148 , servant-client

81 , servant-client

149 , servant-flatten

82 , servant-flatten

150 , servant-server

83 , servant-server

151 , string-conversions

84 , string-conversions

152− , text

153− , time

154− , unordered-containers

155− , vinyl

156− , wai

157− , warp

158 default-language: Haskell2010

85 default-language: Haskell2010

src/Roboservant.hs+2−7

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

1−module Roboservant

1+module Roboservant (module Roboservant.StateMachine) where

2− ( module Roboservant.Direct,

3− module Roboservant.Types,

4− )

5−where

6

2

7−import Roboservant.Direct

3+import Roboservant.StateMachine

8−import 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.hsdeleted−311

@@ -1,311 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE LambdaCase #-}

5−{-# LANGUAGE PolyKinds #-}

6−{-# LANGUAGE RankNTypes #-}

7−{-# LANGUAGE RecordWildCards #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

10−

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−

14−module Roboservant.Direct

15− ( fuzz',

16− Config (..),

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

18− -- have some nice error-display functions

19− RoboservantException (..),

20− FuzzState (..),

21− FuzzOp (..),

22− FailureType (..),

23− Report (..),

24− )

25−where

26−

27−import Control.Exception.Lifted

28− ( Exception,

29− Handler (Handler),

30− SomeAsyncException,

31− SomeException,

32− catch,

33− catches,

34− handle,

35− throw,

36− )

37−import Control.Monad.State.Strict

38− ( MonadIO (..),

39− MonadState (get),

40− StateT (runStateT),

41− modify',

42− )

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

44−import qualified Data.Dependent.Map as DM

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

46−import qualified Data.IntSet as IntSet

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

48−import qualified Data.List.NonEmpty as NEL

49−import Data.Maybe (mapMaybe)

50−import qualified Data.Set as Set

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

52−import qualified Data.Vinyl as V

53−import qualified Data.Vinyl.Curry as V

54−import qualified Data.Vinyl.Functor as V

55−import GHC.Generics ((:*:) (..))

56−import Roboservant.Types

57− ( ApiOffset (..),

58− Argument (..),

59− InteractionError(..),

60− Provenance (..),

61− ReifiedApi,

62− ReifiedEndpoint (..),

63− Stash (..),

64− StashValue (..),

65− TypedF,

66− )

67−import Roboservant.Types.Config

68−

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

70−import qualified Type.Reflection as R

71−

72−data RoboservantException

73− = RoboservantException

74− { failureReason :: FailureType,

75− serverException :: Maybe SomeException,

76− fuzzState :: FuzzState

77− }

78− deriving (Show)

79−

80−instance Exception RoboservantException

81−

82−data FailureType

83− = ServerCrashed

84− | CheckerFailed

85− | NoPossibleMoves

86− | InsufficientCoverage Double

87− deriving (Show, Eq)

88−

89−data FuzzOp

90− = FuzzOp

91− { apiOffset :: ApiOffset,

92− provenance :: [Provenance]

93− }

94− deriving (Show, Eq)

95−

96−data FuzzState

97− = FuzzState

98− { path :: [FuzzOp],

99− stash :: Stash,

100− currentRng :: StdGen

101− }

102− deriving (Show)

103−

104−data EndpointOption

105− = forall as.

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

107− EndpointOption

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

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

110− }

111−

112−data StopReason

113− = TimedOut

114− | HitMaxIterations

115− deriving (Show, Eq)

116−

117−data Report

118− = Report

119− { textual :: String,

120− rsException :: RoboservantException

121− }

122− deriving (Show)

123−

124−

125−

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

127−-- fuzzClient = undefined

128−

129−

130−

131−fuzz' ::

132− ReifiedApi ->

133− Config ->

134− IO (Maybe Report)

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

136− let path = []

137− stash = addToStash seed mempty

138− currentRng = mkStdGen rngSeed

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

140− (stopreason, _fs) <-

141− runStateT

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

143− FuzzState {..}

144− logInfo $ show stopreason

145− pure Nothing

146− where

147− -- something less terrible later

148− formatException :: RoboservantException -> Report

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

150− Report

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 {..}

164− | coverage > coverageThreshold = pure ()

165− | otherwise = do

166− displayDiagnostics f

167− throw $ RoboservantException (InsufficientCoverage coverage) Nothing f

168− where

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

170− totalRoutes = fromIntegral routeCount

171− coverage = hitRoutes / totalRoutes

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

173− untilDone (0, _) _ = pure HitMaxIterations

174− untilDone (n, deadline) action = do

175− now <- liftIO getCurrentTime

176− if now > deadline

177− then pure TimedOut

178− else do

179− _ <- action

180− untilDone (n -1, deadline) action

181−

182− routeCount = length reifiedApi

183− elementOrFail ::

184− (MonadState FuzzState m, MonadIO m) =>

185− [a] ->

186− m a

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

188− elementOrFail l = do

189− st <- get

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

191− modify' $ \st' -> st' {currentRng = newGen}

192− pure (l !! index)

193− withOp ::

194− (MonadState FuzzState m, MonadIO m) =>

195− ( forall as.

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

197− FuzzOp ->

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

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

200− m r

201− ) ->

202− m r

203− withOp callback = do

204− -- choose a call to make, from the endpoints with fillable arguments.

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

206− r <-

207− V.rtraverse

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

209− elementOrFail $

210− zipWith

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

212− [0 ..]

213− (NEL.toList svs)

214− )

215− eoArgs

216− let pathSegment =

217− FuzzOp offset $

218− recordToList'

219− (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)

220− r

221− argValues =

222− V.rmap

223− (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)

224− r

225− modify' (\f -> f {path = path f <> [pathSegment]})

226− callback pathSegment eoCall argValues

227− where

228− options :: FuzzState -> [(ApiOffset, EndpointOption)]

229− options FuzzState {..} =

230− mapMaybe

231− ( \(offset, ReifiedEndpoint {..}) -> do

232− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments

233− pure (offset, EndpointOption reEndpointFunc args)

234− )

235− reifiedApi

236− execute ::

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

238− FuzzOp ->

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

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

241− m ()

242− execute fuzzop func args = do

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

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

245− Left (e::InteractionError) ->

246− if fatalError e

247− then throw e

248− else pure ()

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

250− modify'

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

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

253− )

254− where

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

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

257− go ::

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

259− m ()

260− go = withOp $ \op func args -> do

261− catches

262− (execute op func args)

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

264− Handler

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

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

267− )

268− ]

269− catch

270− (liftIO healthCheck)

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

272−

273−addToStash ::

274− [(Dynamic, Int)] ->

275− Stash ->

276− Stash

277−addToStash result stash =

278− foldr

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

280− Stash $

281− DM.insertWith

282− renumber

283− tr

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

285− dict

286− )

287− stash

288− result

289− where

290− renumber ::

291− StashValue a ->

292− StashValue a ->

293− StashValue a

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

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

296− | otherwise =

297− StashValue

298− ( case NEL.toList singleDyn of

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

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

301− _ -> error "should be impossible"

302− )

303− (IntSet.union singleHash intSet)

304−

305−-- why isn't this in vinyl?

306−recordToList' ::

307− (V.RecordToList as, V.RMap as) =>

308− (forall x. f x -> a) ->

309− V.Rec f as ->

310− [a]

311−recordToList' f = V.recordToList . V.rmap (V.Const . f)

src/Roboservant/Hedgehog.hsnew file+10

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

1+{-# LANGUAGE LambdaCase #-}

2+

3+module Roboservant.Hedgehog where

4+import Hedgehog

5+import qualified Hedgehog.Gen as Gen

6+

7+elementOrFail :: MonadGen m => [a] -> m a

8+elementOrFail = \case

9+ [] -> Gen.discard

10+ x -> Gen.element x

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/StateMachine.hsnew file+150

@@ -0,0 +1,150 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DerivingStrategies #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RecordWildCards #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+{-# LANGUAGE TupleSections #-}

14+{-# LANGUAGE TypeApplications #-}

15+{-# LANGUAGE TypeFamilies #-}

16+{-# LANGUAGE TypeOperators #-}

17+{-# LANGUAGE UndecidableInstances #-}

18+

19+module Roboservant.StateMachine

20+ ( prop_sequential,

21+ prop_concurrent,

22+ )

23+where

24+

25+import Control.Monad (guard)

26+import Control.Monad.IO.Class (MonadIO, liftIO)

27+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)

28+import Data.IORef (IORef, newIORef)

29+import qualified Data.List.NonEmpty as NEL

30+import qualified Data.Map.Strict as Map

31+import Data.Maybe (mapMaybe)

32+import Data.Typeable (TypeRep)

33+import Debug.Trace

34+import GHC.IORef (readIORef)

35+import Hedgehog

36+import qualified Hedgehog.Gen as Gen

37+import qualified Hedgehog.Range as Range

38+import Roboservant.Hedgehog

39+import Roboservant.Types

40+import Servant

41+import Type.Reflection (SomeTypeRep)

42+

43+callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State

44+callEndpoint staticRoutes =

45+ let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))

46+ gen State {..} = case chewable of

47+ -- Chewable values still need to be broken down.

48+ (c : _) -> Just $ pure $ Chewable c

49+ _ -> do

50+ guard $ not $ null options

51+ pure $ uncurry Op <$> chooseOne options

52+ where

53+ chooseOne ::

54+ MonadGen n =>

55+ [ ( ApiOffset,

56+ [[Var (Opaque (IORef Dynamic)) Symbolic]]

57+ )

58+ ] ->

59+ n

60+ ( ApiOffset,

61+ [Var (Opaque (IORef Dynamic)) Symbolic]

62+ )

63+ chooseOne opts = do

64+ (offset, args) <- elementOrFail opts

65+ (offset,) <$> mapM elementOrFail args

66+ options :: [(ApiOffset, [[Var (Opaque (IORef Dynamic)) Symbolic]])]

67+ options =

68+ mapMaybe

69+ ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do

70+ mapM fillableWith argreps

71+ )

72+ staticRoutes

73+ fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]

74+ fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs

75+ execute ::

76+ (MonadIO m) =>

77+ Op Concrete ->

78+ m (Opaque (IORef Dynamic))

79+ -- bit subtle here - a chewable v _also_ gets a var, because chewing it should

80+ -- only give subcomponents.

81+ execute (Chewable v) = Opaque <$> liftIO (newIORef v)

82+ execute (Op (ApiOffset offset) args) = do

83+ fmap Opaque . liftIO $ do

84+ realArgs <- mapM (readIORef . opaque) args

85+ let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset

86+ -- now, magic happens: we apply some dynamic arguments to a dynamic

87+ -- function and hopefully something useful pops out the end.

88+ func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs

89+ let showable = map dynTypeRep (endpoint : realArgs)

90+ case func of

91+ Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)

92+ Just (f') -> do

93+ case fromDynamic f' of

94+ Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)

95+ Just f -> liftIO f >>= \case

96+ Left (serverError :: ServerError) -> error (show serverError)

97+ Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn

98+ in Command

99+ gen

100+ execute

101+ [ Update $ \s@State {..} op o' ->

102+ case op of

103+ Chewable v ->

104+ let (c : cs) = chewable

105+ in s

106+ { stateRefs =

107+ Map.insertWith (<>) (dynTypeRep v) (pure o') stateRefs,

108+ chewable = (breakdownDynamic c) <> cs

109+ }

110+ (Op (ApiOffset offset) _args) ->

111+ s

112+ { stateRefs =

113+ let (_, _, tr, _) = staticRoutes !! offset

114+ in Map.insertWith

115+ (<>)

116+ tr

117+ (pure o')

118+ stateRefs

119+ }

120+ ]

121+

122+-- | just a stub for now - this is where we probably have to start using ConstrainedDynamic

123+-- so we can pack them in with a Breakdown constraint. TODO.

124+breakdownDynamic :: Dynamic -> [Dynamic]

125+breakdownDynamic = const []

126+

127+prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

128+prop_sequential server seed = do

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

130+ actions <-

131+ forAll $ do

132+ Gen.sequential

133+ (Range.linear 1 100)

134+ (emptyState {chewable = seed})

135+ [callEndpoint reifiedApi]

136+ executeSequential (emptyState {chewable = seed}) actions

137+

138+prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

139+prop_concurrent server seed =

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

141+ in do

142+ actions <-

143+ forAll $

144+ Gen.parallel

145+ (Range.linear 1 50)

146+ (Range.linear 1 10)

147+ (emptyState {chewable = seed})

148+ [callEndpoint reifiedApi]

149+ test $

150+ executeParallel (emptyState {chewable = seed}) actions

src/Roboservant/Types.hs+45−12

@@ -2,25 +2,58 @@

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,

12− module Roboservant.Types.BuildFrom,

18+ FlattenServer (..),

13− module Roboservant.Types.ReifiedApi,

19+ ToReifiedApi (..),

14− module Roboservant.Types.ReifiedApi.Server,

20+ ReifiedApi,

15− module Roboservant.Types.Internal,

21+ ApiOffset (..),

16− module Roboservant.Types.Config,

17 )

22 )

18where

23where

19

24

20−import Roboservant.Types.Breakdown

25+import Data.Dynamic (Dynamic)

21−import Roboservant.Types.BuildFrom

26+import Data.IORef (IORef)

22−import Roboservant.Types.Config

27+import Data.List.NonEmpty (NonEmpty)

28+import Data.Map.Strict (Map)

29+import Data.Typeable (TypeRep)

30+import Hedgehog (HTraversable (..), Opaque, Symbolic, Var)

23−import Roboservant.Types.Internal

31+import Roboservant.Types.FlattenServer

24import Roboservant.Types.ReifiedApi

32import Roboservant.Types.ReifiedApi

25−import Roboservant.Types.ReifiedApi.Server

33+

26−import Roboservant.Types.Orphans()

34+-- | preloads are basically done, just waiting for a Var.

35+-- chewable things may have more structure in them.

36+data State v

37+ = State

38+ { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v)),

39+ chewable :: [Dynamic]

40+ }

41+

42+emptyState :: forall v. State v

43+emptyState = State mempty mempty

44+

45+-- | we need to specify an offset because it's entirely possible to have two

46+-- functions with the same arguments that do different things.

47+data Op (v :: * -> *)

48+ = -- this needs to change - need a constructor offset and a list of vars inside,

49+ -- because a single argument to the api could be a sum type with many constructors and varying

50+ -- arguments itself.

51+ Op ApiOffset [(Var (Opaque (IORef Dynamic)) v)]

52+ | Chewable Dynamic

53+

54+deriving instance Show (Op Symbolic)

55+

56+instance HTraversable Op where

57+ htraverse r = \case

58+ Op offset args -> Op offset <$> traverse (htraverse r) args

59+ Chewable v -> pure $ Chewable v

src/Roboservant/Types/Breakdown.hs+39−58

@@ -1,81 +1,62 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE DefaultSignatures #-}

4−{-# LANGUAGE DerivingVia #-}

4+{-# LANGUAGE DerivingStrategies #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE LambdaCase #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

16{-# LANGUAGE UndecidableInstances #-}

15

17

16module Roboservant.Types.Breakdown where

18module Roboservant.Types.Breakdown where

17

19

18−import Data.Dynamic (Dynamic)

20+import Data.Dynamic (Dynamic, dynTypeRep, fromDynamic, toDyn)

19−import Data.Hashable

20−import Data.Kind

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

21+import Data.List.NonEmpty (NonEmpty)

22import qualified Data.List.NonEmpty as NEL

23−import Data.Typeable (Typeable)

23+import qualified Data.Map.Strict as Map

24−import GHC.Generics

24+import Data.Map.Strict (Map)

25−import Roboservant.Types.Internal

25+import Data.Maybe (fromMaybe)

26−import Servant

26+import Data.Proxy (Proxy (..))

27−import Roboservant.Types.Orphans()

27+import Data.Typeable (TypeRep, Typeable, typeRep)

28−

28+import Hedgehog (Gen)

29−breakdown ::

29+import qualified Hedgehog.Gen as Gen

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

30+

31− x ->

31+class Typeable x => BuildFrom x where

32− NonEmpty (Dynamic, Int)

32+ buildFrom :: Map TypeRep (NonEmpty Dynamic) -> [x]

33−breakdown x = hashedDyn x :| breakdownExtras x

33+ default buildFrom :: Map TypeRep (NonEmpty Dynamic) -> [x]

34+ buildFrom = maybe [] (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))

35+

36+instance BuildFrom x => BuildFrom (Maybe x) where

37+ buildFrom dict = Nothing : fmap Just (buildFrom dict)

34

38

35class Breakdown x where

39class Breakdown x where

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

40+ breakdown :: x -> Map TypeRep (NonEmpty Dynamic)

37−

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

39− breakdownExtras _ = []

40−

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

42−

43−deriving via (Atom Int) instance Breakdown Int

44−deriving via (Atom Char) instance Breakdown Char

45−

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

47−

48−instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] 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

41

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

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

65− gBreakdownExtras (M1 f) = gBreakdownExtras f

43+newtype Chewy x = Chewy x

66

44

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

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

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

46+ breakdown x = let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]

69

47

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

48+-- instance (Typeable x, Generic x) => Breakdown x where

71− gBreakdownExtras = \case

49+-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from

72− L1 a -> gBreakdownExtras a

73− R1 a -> gBreakdownExtras a

74

50

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

51+class Create x where

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

52+ create :: Map TypeRep (NonEmpty Dynamic) -> Maybe (Gen x)

77

53

78−instance GBreakdown U1 where

54+instance Typeable x => Create x where

79− gBreakdownExtras U1 = []

55+ create mmm =

56+ (fmap Gen.element) $

57+ fmap promisedDyn . NEL.toList

58+ <$> Map.lookup (typeRep (Proxy @x)) mmm

80

59

81−deriving via (Atom NoContent) instance Breakdown NoContent

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

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

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

src/Roboservant/Types/BuildFrom.hsdeleted−107

@@ -1,107 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DerivingVia #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE PolyKinds #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE StandaloneDeriving #-}

8−{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

12−

13−module Roboservant.Types.BuildFrom where

14−

15−import Data.List(nub)

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

21−import qualified Data.List.NonEmpty as NEL

22−import Data.Typeable (Typeable)

23−import GHC.Generics

24−import Roboservant.Types.Internal

25−import qualified Type.Reflection as R

26−import Servant(NoContent)

27−import Roboservant.Types.Orphans()

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−

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

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

55−

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

57− extras _ = []

58−

59−deriving via (Atom Bool) instance BuildFrom Bool

60−

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

62−

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

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

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

66− extras stash =

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

68− where

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

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.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−

6−module Roboservant.Types.Internal where

7−

8−import qualified Data.Dependent.Map as DM

9−import 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)

18−import qualified Type.Reflection as R

19−

20−data Provenance

21− = Provenance R.SomeTypeRep Int

22− deriving (Show, Eq, Generic)

23−

24−instance Hashable Provenance

25−

26−data StashValue a

27− = StashValue

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

29− stashHash :: IntSet

30− }

31− deriving (Functor, Show)

32−

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

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

36− deriving (Semigroup, Monoid)

37−

38−instance Show Stash where

39− showsPrec i (Stash x) =

40− showsPrec i

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

42− $ DM.toList x

43−

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

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

46− deriving newtype (Hashable, Typeable,Eq)

47−

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

49−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+74−151

@@ -1,217 +1,140 @@

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

8{-# LANGUAGE DerivingStrategies #-}

4{-# LANGUAGE DerivingStrategies #-}

9−{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

11−{-# LANGUAGE GADTs #-}

12{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

13{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE LambdaCase #-}

14{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

15{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE StandaloneDeriving #-}

11+{-# LANGUAGE TupleSections #-}

16{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

20−{-# LANGUAGE CPP #-}

16+

21module Roboservant.Types.ReifiedApi where

17module Roboservant.Types.ReifiedApi where

22

18

23−import Data.Dynamic (Dynamic)

19+

24−import Control.Exception(Exception)

20+import Control.Monad.Except (runExceptT)

25−import Data.List.NonEmpty (NonEmpty)

21+import Data.Dynamic (Dynamic, toDyn)

22+import Data.Function ((&))

26−import Data.Typeable (Typeable)

23+import Data.Typeable (TypeRep, Typeable, typeRep)

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

24+import GHC.TypeLits (Symbol)

28−import Roboservant.Types.Internal

29−import Roboservant.Types.Breakdown

30−import Roboservant.Types.BuildFrom

31−import Data.Kind(Type)

32import Servant

25import Servant

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

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

34−import GHC.TypeLits (Symbol)

27+import Roboservant.Types.FlattenServer

35−import qualified Data.Text as T

28+

36−import qualified Data.Vinyl as V

37−import qualified Data.Vinyl.Curry as V

38−import qualified Type.Reflection as R

39

29

40newtype ApiOffset = ApiOffset Int

30newtype ApiOffset = ApiOffset Int

41− deriving (Eq, Show, Ord)

31+ deriving (Eq, Show)

42 deriving newtype (Enum, Num)

32 deriving newtype (Enum, Num)

43

33

44−type TypedF = (:*:) R.TypeRep

34+type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)

45−

46−newtype Argument a = Argument

47− { getArgument :: Stash -> Maybe (StashValue a)

48− }

49−

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

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

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

53− }

54−

55−instance Show ReifiedEndpoint where

56− show _ = "lol"

57

35

58−class ( V.RecordToList (EndpointArgs endpoint)

36+type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]

59− , V.RMap (EndpointArgs endpoint)

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

61− type EndpointArgs endpoint :: [Type]

62− type EndpointRes endpoint :: Type

63

37

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

65

38

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

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

66

41

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

42+class ToReifiedEndpoint (endpoint :: *) where

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

43+ toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint

69−

70−data InteractionError = InteractionError

71− { errorMessage :: T.Text

72− , fatalError :: Bool

73− }

74− deriving Show

75−instance Exception InteractionError

76−

77

44

45+instance ToReifiedApi '[] where

46+ toReifiedApi NoEndpoints _ = []

78

47

79instance

48instance

80− (Typeable responseType, Breakdown responseType) =>

49+ (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>

81− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

50+ ToReifiedApi (endpoint : endpoints)

82− where

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

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

85− reifiedEndpointArguments = V.RNil

86−

87−instance ToReifiedEndpoint (NoContentVerb method)

88 where

51 where

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

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

90− type EndpointRes (NoContentVerb method) = NoContent

53+ withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))

91− reifiedEndpointArguments = V.RNil

54+ : map

55+ (\(n, x, y, z) -> (n + 1, x, y, z))

56+ (toReifiedApi endpoints (Proxy @endpoints))

57+ where

58+ withOffset (x, y, z) = (0, x, y, z)

59+

60+class NormalizeFunction m where

61+ type Normal m

62+ normalize :: m -> Normal m

63+

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

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

66+ normalize = fmap normalize

67+

68+instance Typeable x => NormalizeFunction (Handler x) where

69+ type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))

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

71+ Left serverError -> pure (Left serverError)

72+ Right x -> pure (Right (typeRep (Proxy @x), toDyn x))

92

73

93instance

74instance

94− (ToReifiedEndpoint endpoint) =>

75+ Typeable responseType =>

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

76+ ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

96 where

77 where

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

78+ toReifiedEndpoint endpoint _ =

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

79+ ([], typeRep (Proxy @responseType), endpoint)

99− reifiedEndpointArguments = reifiedEndpointArguments @endpoint

100

80

101instance

81instance

102 (ToReifiedEndpoint endpoint) =>

82 (ToReifiedEndpoint endpoint) =>

103− ToReifiedEndpoint (RemoteHost :> endpoint)

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

104 where

84 where

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

85+ toReifiedEndpoint endpoint _ =

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

86+ toReifiedEndpoint endpoint (Proxy @endpoint)

107− reifiedEndpointArguments = reifiedEndpointArguments @endpoint

108−

109−

110

87

111instance

88instance

112 (ToReifiedEndpoint endpoint) =>

89 (ToReifiedEndpoint endpoint) =>

113 ToReifiedEndpoint (Description s :> endpoint)

90 ToReifiedEndpoint (Description s :> endpoint)

114 where

91 where

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

92+ toReifiedEndpoint endpoint _ =

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

93+ toReifiedEndpoint endpoint (Proxy @endpoint)

117− reifiedEndpointArguments = reifiedEndpointArguments @endpoint

118

94

119instance

95instance

120 (ToReifiedEndpoint endpoint) =>

96 (ToReifiedEndpoint endpoint) =>

121 ToReifiedEndpoint (Summary s :> endpoint)

97 ToReifiedEndpoint (Summary s :> endpoint)

122 where

98 where

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

99+ toReifiedEndpoint endpoint _ =

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

100+ toReifiedEndpoint endpoint (Proxy @endpoint)

125− reifiedEndpointArguments = reifiedEndpointArguments @endpoint

126

101

127instance

102instance

128− (Typeable requestType

129− ,BuildFrom requestType

130− ,ToReifiedEndpoint endpoint) =>

103+ (Typeable requestType, ToReifiedEndpoint endpoint) =>

131 ToReifiedEndpoint (QueryFlag name :> endpoint)

104 ToReifiedEndpoint (QueryFlag name :> endpoint)

132 where

105 where

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

106+ toReifiedEndpoint endpoint _ =

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

107+ toReifiedEndpoint endpoint (Proxy @endpoint)

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

108+ & \(args, result, typeRepMap) -> (typeRep (Proxy @Bool) : args, result, typeRepMap)

136−

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

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

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

140

109

141instance

110instance

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

143− , ToReifiedEndpoint endpoint

111+ (Typeable (If (FoldRequired mods) paramType (Maybe paramType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>

144− ) =>

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

112 ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)

146 where

113 where

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

114+ toReifiedEndpoint endpoint _ =

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

115+ toReifiedEndpoint endpoint (Proxy @endpoint)

149− reifiedEndpointArguments =

116+ & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType))) : args, result, typeRepMap)

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

151− V.:& reifiedEndpointArguments @endpoint

152−

153

117

154instance

118instance

155− ( BuildFrom paramType

119+ (Typeable (If (FoldRequired mods) headerType (Maybe headerType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>

156− , ToReifiedEndpoint endpoint

157− , Show paramType

158− , Eq paramType

159− ) =>

160− ToReifiedEndpoint (QueryParams name paramType :> endpoint)

161− where

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

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

164− reifiedEndpointArguments =

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

166− V.:& reifiedEndpointArguments @endpoint

167−

168−

169−

170−

171−instance

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

173− , ToReifiedEndpoint endpoint

174− ) =>

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

120 ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)

176 where

121 where

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

122+ toReifiedEndpoint endpoint _ =

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

123+ toReifiedEndpoint endpoint (Proxy @endpoint)

179− reifiedEndpointArguments =

124+ & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType))) : args, result, typeRepMap)

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

181− V.:& reifiedEndpointArguments @endpoint

182

125

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

184instance

126instance

185− ( BuildFrom (IfLenient String mods captureType)

186− , ToReifiedEndpoint endpoint) =>

127+ (Typeable captureType, ToReifiedEndpoint endpoint) =>

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

128 ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

188 where

129 where

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

130+ toReifiedEndpoint endpoint _ =

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

131+ toReifiedEndpoint endpoint (Proxy @endpoint)

191− reifiedEndpointArguments =

132+ & \(args, result, typeRepMap) -> (typeRep (Proxy @captureType) : args, result, typeRepMap)

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

193− V.:& reifiedEndpointArguments @endpoint

194−#else

195−instance

196− ( BuildFrom captureType

197− , ToReifiedEndpoint endpoint) =>

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

199− where

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

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

202− reifiedEndpointArguments =

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

204− V.:& reifiedEndpointArguments @endpoint

205−

206−#endif

207

133

208instance

134instance

209− ( BuildFrom (IfLenient String mods requestType)

135+ (Typeable (If (FoldLenient mods) (Either String requestType) requestType), ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>

210− , ToReifiedEndpoint endpoint) =>

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

136 ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)

212 where

137 where

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

138+ toReifiedEndpoint endpoint _ =

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

139+ toReifiedEndpoint endpoint (Proxy @endpoint)

215− reifiedEndpointArguments =

140+ & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldLenient mods) (Either String requestType) requestType)) : args, result, typeRepMap)

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

217− V.:& reifiedEndpointArguments @endpoint

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

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

1−resolver: lts-20.4

1+resolver: lts-16.14

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+- git: https://github.com/hedgehogqa/haskell-hedgehog.git

17+ commit: 03714682586e43b5ddf5c00391035471a6e01238

18+ subdirs:

19+ - hedgehog

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

21+ commit: cd9012414a93cf08f86e409544d4d3a8f282b507

22+ subdirs:

23+ - hspec-core

stack.yaml.lock+84−9

@@ -7,20 +7,95 @@ 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+ subdir: hedgehog

72+ name: hedgehog

73+ version: 1.0.3

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

75+ pantry-tree:

76+ size: 2575

77+ sha256: 7e69930fef281dfeb47b2f7c745c26234768e56ffb5490065f607c57146ffbab

78+ commit: 03714682586e43b5ddf5c00391035471a6e01238

79+ original:

80+ subdir: hedgehog

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

82+ commit: 03714682586e43b5ddf5c00391035471a6e01238

83+- completed:

84+ subdir: hspec-core

85+ name: hspec-core

86+ version: 2.7.4

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

16 pantry-tree:

88 pantry-tree:

17− sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

89+ size: 3899

18− size: 709

90+ sha256: 6ece11ad28a7f122a502e766eb1b3ef950815c2d16babb0ea8744646f1c1bd70

91+ commit: cd9012414a93cf08f86e409544d4d3a8f282b507

19 original:

92 original:

20− hackage: some-1.0.3

93+ subdir: hspec-core

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

95+ commit: cd9012414a93cf08f86e409544d4d3a8f282b507

21snapshots:

96snapshots:

22- completed:

97- completed:

23− sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

24− size: 648660

98+ size: 532382

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

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

100+ sha256: 1ef27e36f38824abafc43224ca612211b3828fa9ffd31ba0fc2867ae2e19ba90

26− original: lts-20.4

101+ original: lts-16.14

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+38−155

@@ -1,170 +1,53 @@

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

8−{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE AllowAmbiguousTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE DataKinds #-}

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

13−{-# LANGUAGE TypeFamilies #-}

14

4

15−import qualified Breakdown

16−import Data.Dynamic (toDyn)

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

18−import Data.Maybe (isNothing)

19−import Data.Void (Void)

20import qualified Foo

5import 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

6import qualified Seeded

7+import qualified Headers

8+import qualified UnsafeIO

9+import qualified Roboservant as RS

10+

11+import Test.Hspec.Hedgehog

31import Test.Hspec

12import Test.Hspec

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

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

33−import qualified Valid

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

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

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

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

41

16

42main :: IO ()

17main :: IO ()

43main = hspec spec

18main = hspec spec

44

19

45−fuzzBoth

46− :: forall a .

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

48− HasClient ClientM a)

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

50−fuzzBoth name server config condition = do

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

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

53−

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

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

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

57−

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

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

60− where genClientEnv port = do

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

62− manager <- newManager defaultManagerSettings

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

64−

65spec :: Spec

20spec :: Spec

66spec = do

21spec = do

67 describe "Basic usage" $ do

22 describe "Basic usage" $ do

68− describe "noError" $ do

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

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

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

72− (\r ->

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

74− `shouldSatisfy` ( \case

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

23 describe "seeded" $ do

89− let res = Seeded.Seed 1

24+ modifyMaxSuccess (const 10000) $

25+ shouldFail $

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

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

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

27+ hedgehog $ RS.prop_sequential @Seeded.Api Seeded.server [toDyn $ Seeded.Seed 1]

92− (`shouldSatisfy` isNothing)

28+

93−

29+ modifyMaxSuccess (const 10000) $

94− describe "Foo" $

30+

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

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

96−

32+ hedgehog $ RS.prop_sequential @Foo.Api Foo.server []

97− describe "QueryParams" $

33+

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

34+ describe "Headers" $ do

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

35+ modifyMaxSuccess (const 10000) $

36+

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

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

104− (`shouldSatisfy` serverFailure)

38+ hedgehog $ RS.prop_sequential @Headers.Api Headers.server []

105− describe "product types" $

39+ -- pending

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

40+

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

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

108− (`shouldSatisfy` serverFailure)

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

109− describe "Breakdown" $ do

43+ describe "concurrency bugs" $ do

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

44+ before UnsafeIO.makeServer $ do

111− (`shouldSatisfy` serverFailure)

45+ describe "sequential checking" $ do

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

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

113− (`shouldSatisfy` serverFailure)

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

114− describe "flattening" $

48+

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

49+ modifyMaxSuccess (const 10000) $

116− (`shouldSatisfy` isNothing)

50+ shouldFail $

117−

51+ describe "concurrent" $ do

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

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

119−serverFailure = \case

53+ RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []

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 =

157− mapSpecItem_

158− ( \i ->

159− i

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

161− r <- itemExample i p a cb

162− pure

163− r

164− { resultStatus = case resultStatus r of

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

166− Failure _ _ -> Success

167− x -> x

168− }

169− }

170− )

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.hsdeleted−44

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4−

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE TypeOperators #-}

7−

8−module Valid where

9−

10−import Data.Void

11−import GHC.Generics

12−import Servant

13−import Servant.Server.Generic

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−

43−server :: Server Api

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