master..3deefd6 · 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+2−2

@@ -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,7 +12,7 @@ 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

EXAMPLE.md+42−71

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

2

3Our api under test:

4

5−``` haskell

5+```haskell

6-- Obligatory fancy-types pragma tax

7{-# LANGUAGE DataKinds #-}

8{-# LANGUAGE TypeOperators #-}

@@ -13,43 +13,30 @@ Our api under test:

13{-# LANGUAGE DeriveGeneric #-}

14{-# LANGUAGE GeneralizedNewtypeDeriving #-}

15{-# LANGUAGE RecordWildCards #-}

16−{-# LANGUAGE ScopedTypeVariables #-}

17−{-# LANGUAGE TypeApplications #-}

18

16

19−import qualified Roboservant.Server as RS

17+import Roboservant

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

24import Test.Hspec

18import Test.Hspec

25import Servant

19import Servant

26import GHC.Generics

20import GHC.Generics

27import Data.Typeable

21import Data.Typeable

28import Data.Hashable

22import Data.Hashable

29−import Data.Maybe(isNothing, isJust)

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

31−import Data.Aeson(FromJSON,ToJSON)

32

23

33newtype A = A Int

24newtype A = A Int

34 deriving (Generic, Eq, Show, Typeable)

25 deriving (Generic, Eq, Show, Typeable)

35 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

26 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

36

27

37−instance FromJSON A

38−instance ToJSON A

39−

40newtype B = B Int

28newtype B = B Int

41 deriving (Generic, Eq, Show, Typeable)

29 deriving (Generic, Eq, Show, Typeable)

42 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

30 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

43

31

44−instance FromJSON B

45−instance ToJSON B

46−

47type Api =

32type Api =

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

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

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

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

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

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

51

36

52−server :: Handler A -> Server Api

37+goodServer = server (pure $ A 0)

38+badServer = server (pure $ A 1)

39+

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

40server introduce = introduce :<|> combine :<|> eliminate

54 where

41 where

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

42 combine (B i) (B j) = pure $ B (i + j)

@@ -58,66 +45,45 @@ server introduce = introduce :<|> combine :<|> eliminate

58 | otherwise = pure ()

45 | otherwise = pure ()

59```

46```

60

47

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

48+In the test file, we first define the configuration:

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

49+

50+```haskell

51+defaultConfig :: Config

52+defaultConfig = Config {

53+ -- you can pass extra values in using the seed argument. This can be useful

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

55+ seed = [hashedDyn "blah"]

56+ , maxRuntime = 0.5

57+ -- if we get to 1000 interactions with the api, call it quits.

58+ , maxReps = 1000

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

60+ -- from their seed to make sure it stays deterministic

61+ , rngSeed = 0

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

63+ , coverageThreshold = 0

64+ }

63

65

64−``` haskell

65−goodServer, badServer :: Server Api

66−goodServer = server (pure $ A 0)

67−badServer = server (pure $ A 1)

68```

66```

69

67

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

68+and the tests: the faulty server should fail and the good server should pass.

71

69

72```haskell

70```haskell

73−main :: IO ()

74−main = hspec spec

75−

76−spec :: Spec

77spec = describe "example" $ do

71spec = describe "example" $ do

78 it "good server should not fail" $ do

72 it "good server should not fail" $ do

79− RS.fuzz @Api goodServer config

73+ fuzz @Api goodServer defaultConfig { coverageThreshold = 0.99 } (pure ())

80 >>= (`shouldSatisfy` isNothing)

74 >>= (`shouldSatisfy` isNothing)

81 it "bad server should fail" $ do

75 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

76+ fuzz @Api badServer defaultConfig { coverageThreshold = 0.99 } (pure ())

107− }

77+ >>= (`shouldSatisfy` serverFailure)

108```

78```

109

79

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

80+And unless we want to ship roboservant and all its dependencies to production, we also need

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

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

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

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

113

83

114−``` haskell

84+```haskell

115deriving via (Compound A) instance Breakdown A

85deriving 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.

86+-- if we wanted to assemble As from parts as well, we'd derive using Compound

119−

120−``` haskell

121deriving via (Atom A) instance BuildFrom A

87deriving via (Atom A) instance BuildFrom A

122

88

123```

89```

@@ -130,14 +96,19 @@ deriving via (Compound B) instance BuildFrom B

130deriving via (Atom B) instance Breakdown B

96deriving via (Atom B) instance Breakdown B

131```

97```

132

98

99+finally some uninteresting utilities and the entrypoint

100+

101+```haskell

102+main = hspec spec

133

103

134−test utilities:

104+serverFailure :: Maybe Report -> Bool

105+serverFailure c = case c of

106+ Just Report{..} ->

107+ let RoboservantException{..} = rsException

108+ in failureReason /= NoPossibleMoves

109+ _ -> False

135

110

136−``` haskell

111+isNothing x = case x of

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

112+ Nothing -> True

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

113+ _ -> False

139− where genClientEnv port = do

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

141− manager <- newManager defaultManagerSettings

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

143```

114```

Makefile+1−1

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

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

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

3pedanticwatch:

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

README.md+1−90

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

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

7## example

9

8

@@ -15,71 +14,6 @@ Servant gives us a lot of information about what a server can do. We

15use this information to generate arbitrarily long request/response

14use this information to generate arbitrarily long request/response

16sessions and verify properties that should hold over them.

15sessions and verify properties that should hold over them.

17

16

18−## how?

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−

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

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−

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

54−

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

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

57−for instance.

58−

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

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

61−its succulent headmeats:

62−

63−``` haskell

64−deriving via (Compound Payload) instance Breakdown Payload

65−deriving via (Compound Payload) instance BuildFrom Payload

66−```

67−

68−### priming the pump

69−

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

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

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

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

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

75−the user is expected to come up with.

76−

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

78−list of seed values, suitably hashed:

79−

80−``` haskell

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

82−```

83

17

84## why not servant-quickcheck?

18## why not servant-quickcheck?

85

19

@@ -89,26 +23,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

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

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

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

91these without context via Arbitrary.

25these 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+3−13

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

1−

2name: roboservant

1name: roboservant

3−version: 0.1.0.3

2+version: 0.1.0.2

4github: "mwotton/roboservant"

3github: "mwotton/roboservant"

5license: BSD3

4license: BSD3

6copyright: "2020 Mark Wotton, Samuel Schlesinger"

5copyright: "2020 Mark Wotton, Samuel Schlesinger"

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

19- containers

18- containers

20- random

19- random

21- hashable

20- hashable

22−- http-types

23- lifted-base

21- lifted-base

24- monad-control

22- monad-control

25- mtl

23- mtl

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

56 - hspec

54 - hspec

57 - hspec-core

55 - hspec-core

58 - http-api-data

56 - http-api-data

59− - http-client

57+

60− - hspec-wai

61− - wai

62− - warp

63 example:

58 example:

64 main: Example.lhs

59 main: Example.lhs

65 source-dirs: .

60 source-dirs: .

@@ -67,10 +62,5 @@ tests:

67 dependencies:

62 dependencies:

68 - roboservant

63 - roboservant

69 - hspec

64 - hspec

70− - warp

65+ build-depends: base, markdown-unlit

71− - http-client

72− - aeson

73− - hspec-core

74 ghc-options: -pgmL markdown-unlit

66 ghc-options: -pgmL markdown-unlit

75−

76− build-tools: markdown-unlit

roboservant.cabal+6−26

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

1cabal-version: 1.12

2

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

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

4--

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

6--

7−-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d

7+-- hash: 8de468df6e784f3723af9155bba9da9f43659b7d4e8e465fdac26eafcb0d4306

8

9name: roboservant

10−version: 0.1.0.3

10+version: 0.1.0.2

11synopsis: Automatic session-aware servant testing

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

13category: Web

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

28library

29 exposed-modules:

30 Roboservant

31− Roboservant.Client

32 Roboservant.Direct

31 Roboservant.Direct

33− Roboservant.Server

34 Roboservant.Types

32 Roboservant.Types

35 Roboservant.Types.Breakdown

33 Roboservant.Types.Breakdown

36 Roboservant.Types.BuildFrom

34 Roboservant.Types.BuildFrom

37− Roboservant.Types.Config

35+ Roboservant.Types.FlattenServer

38 Roboservant.Types.Internal

36 Roboservant.Types.Internal

39− Roboservant.Types.Orphans

40 Roboservant.Types.ReifiedApi

37 Roboservant.Types.ReifiedApi

41− Roboservant.Types.ReifiedApi.Server

42 other-modules:

38 other-modules:

43 Paths_roboservant

39 Paths_roboservant

44 hs-source-dirs:

40 hs-source-dirs:

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

51 , dependent-map

47 , dependent-map

52 , dependent-sum

48 , dependent-sum

53 , hashable

49 , hashable

54− , http-types

55 , lifted-base

50 , lifted-base

56 , monad-control

51 , monad-control

57 , mtl

52 , mtl

@@ -73,22 +68,16 @@ test-suite example

73 other-modules:

68 other-modules:

74 Paths_roboservant

69 Paths_roboservant

75 hs-source-dirs:

70 hs-source-dirs:

76− ./

71+ ./.

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

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

78− build-tool-depends:

79− markdown-unlit:markdown-unlit

80 build-depends:

73 build-depends:

81− aeson

82− , base >=4.7 && <5

74+ base >=4.7 && <5

83 , bytestring

75 , bytestring

84 , containers

76 , containers

85 , dependent-map

77 , dependent-map

86 , dependent-sum

78 , dependent-sum

87 , hashable

79 , hashable

88 , hspec

80 , hspec

89− , hspec-core

90− , http-client

91− , http-types

92 , lifted-base

81 , lifted-base

93 , monad-control

82 , monad-control

94 , mtl

83 , mtl

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

103 , time

92 , time

104 , unordered-containers

93 , unordered-containers

105 , vinyl

94 , vinyl

106− , warp

107 default-language: Haskell2010

95 default-language: Haskell2010

108

96

109test-suite roboservant-test

97test-suite roboservant-test

@@ -113,11 +101,8 @@ test-suite roboservant-test

113 Breakdown

101 Breakdown

114 Foo

102 Foo

115 Headers

103 Headers

116− Nested

117 Post

104 Post

118 Product

105 Product

119− Put

120− QueryParams

121 Seeded

106 Seeded

122 UnsafeIO

107 UnsafeIO

123 Valid

108 Valid

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

135 , hashable

120 , hashable

136 , hspec

121 , hspec

137 , hspec-core

122 , hspec-core

138− , hspec-wai

139 , http-api-data

123 , http-api-data

140− , http-client

141− , http-types

142 , lifted-base

124 , lifted-base

143 , monad-control

125 , monad-control

144 , mtl

126 , mtl

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

153 , time

135 , time

154 , unordered-containers

136 , unordered-containers

155 , vinyl

137 , vinyl

156− , wai

157− , warp

158 default-language: Haskell2010

138 default-language: Haskell2010

src/Roboservant.hs+2−5

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

1−module Roboservant

2− ( module Roboservant.Direct,

1+module Roboservant (module Roboservant.Direct

3− module Roboservant.Types,

2+ ,module Roboservant.Types) where

4− )

5−where

6

3

7import Roboservant.Direct

4import Roboservant.Direct

8import Roboservant.Types

5import Roboservant.Types

src/Roboservant/Client.hsdeleted−127

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

1−{-# LANGUAGE RankNTypes #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE NamedFieldPuns #-}

4−{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE AllowAmbiguousTypes #-}

6−{-# LANGUAGE DataKinds #-}

7−{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeApplications #-}

11−

12−{-# LANGUAGE UndecidableInstances #-}

13−{-# LANGUAGE TypeFamilies #-}

14−{-# LANGUAGE FlexibleContexts #-}

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

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

17−module Roboservant.Client where

18−

19−import Data.Proxy

20−import Servant.Client

21−import Roboservant.Types

22−import Roboservant(Report, fuzz')

23−import Servant

24−import Data.Bifunctor

25−import Data.List.NonEmpty (NonEmpty)

26−import Data.Dynamic (Dynamic,Typeable)

27−import qualified Data.Vinyl.Curry as V

28−import qualified Data.Text as T

29−import Control.Monad.Reader

30−import Data.Hashable

31−import Network.HTTP.Types.Status

32−

33−-- fuzz :: forall api.

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

35−-- Server api ->

36−-- Config ->

37−-- IO (Maybe Report)

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

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

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

41−-- => Server api -> ReifiedApi

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

43−

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

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

46−fuzz clientEnv

47− = fuzz'

48− (toReifiedClientApi

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

50− where apiClient = client (Proxy @api)

51−

52−

53−

54−class ToReifiedClientApi api where

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

56−

57−data ClientBundled endpoints where

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

59− NoClientEndpoints :: ClientBundled '[]

60−

61−

62−class FlattenClient api where

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

64−

65−instance

66− ( NormalizeFunction (Client ClientM endpoint)

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

68− , ToReifiedClientApi endpoints

69− , V.RecordCurry' (EndpointArgs endpoint)

70− , ToReifiedEndpoint endpoint) =>

71− ToReifiedClientApi (endpoint : endpoints) where

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

73− (0, ReifiedEndpoint

74− { reArguments = reifiedEndpointArguments @endpoint

75− , reEndpointFunc = foo (normalize endpoint)

76− }

77− )

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

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

80− where

81−

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

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

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

85−

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

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

88−

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

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

91−

92−

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

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

95− normalize c = ReaderT $

96− fmap (bimap renderClientError breakdown) . runClientM c

97− where

98− renderClientError :: ClientError -> InteractionError

99− renderClientError err = case err of

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

101− _ -> InteractionError textual True

102−

103− where textual = T.pack $ show err

104−instance ToReifiedClientApi '[] where

105− toReifiedClientApi NoClientEndpoints _ _ = []

106−

107−

108−instance

109− ( FlattenClient api,

110− Endpoints endpoint ~ '[endpoint]

111− ) =>

112− FlattenClient (endpoint :<|> api)

113− where

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

115−

116−instance

117− (

118− Endpoints api ~ '[api]

119− ) =>

120− FlattenClient (x :> api)

121− where

122− flattenClient c = c `AClientEndpoint` NoClientEndpoints

123−

124−

125−instance FlattenClient (Verb method statusCode contentTypes responseType)

126− where

127− flattenClient c = c `AClientEndpoint` NoClientEndpoints

src/Roboservant/Direct.hs+60−60

@@ -2,17 +2,16 @@

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE LambdaCase #-}

5−{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

8{-# LANGUAGE TupleSections #-}

10−

9+{-# LANGUAGE TypeApplications #-}

11{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE UndecidableInstances #-}

13

12

14module Roboservant.Direct

13module Roboservant.Direct

15− ( fuzz',

14+ ( fuzz,

16 Config (..),

15 Config (..),

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

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

18 -- have some nice error-display functions

17 -- have some nice error-display functions

@@ -25,30 +24,25 @@ module Roboservant.Direct

25where

24where

26

25

27import Control.Exception.Lifted

26import Control.Exception.Lifted

27+ ( SomeException,

28+ throw,

28− ( Exception,

29+ Exception,

29− Handler (Handler),

30− SomeAsyncException,

30+ SomeAsyncException,

31− SomeException,

32− catch,

31+ catch,

33− catches,

32+ catches,

34− handle,

33+ handle,

35− throw,

34+ Handler(Handler) )

36− )

37import Control.Monad.State.Strict

35import Control.Monad.State.Strict

38− ( MonadIO (..),

39− MonadState (get),

40− StateT (runStateT),

36+ ( MonadIO(..), StateT(runStateT), modify', MonadState(get) )

41− modify',

42− )

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

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

44import qualified Data.Dependent.Map as DM

38import qualified Data.Dependent.Map as DM

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

39+import Data.Dynamic ( Dynamic(..) )

46import qualified Data.IntSet as IntSet

40import qualified Data.IntSet as IntSet

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

41import Data.List.NonEmpty (NonEmpty (..))

48import qualified Data.List.NonEmpty as NEL

42import qualified Data.List.NonEmpty as NEL

49import Data.Maybe (mapMaybe)

43import Data.Maybe (mapMaybe)

50import qualified Data.Set as Set

44import qualified Data.Set as Set

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

45+import Data.Time.Clock ( addUTCTime, getCurrentTime, UTCTime )

52import qualified Data.Vinyl as V

46import qualified Data.Vinyl as V

53import qualified Data.Vinyl.Curry as V

47import qualified Data.Vinyl.Curry as V

54import qualified Data.Vinyl.Functor as V

48import qualified Data.Vinyl.Functor as V

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

56import Roboservant.Types

50import Roboservant.Types

57 ( ApiOffset (..),

51 ( ApiOffset (..),

58 Argument (..),

52 Argument (..),

59− InteractionError(..),

53+ FlattenServer (..),

60 Provenance (..),

54 Provenance (..),

61− ReifiedApi,

62 ReifiedEndpoint (..),

55 ReifiedEndpoint (..),

63 Stash (..),

56 Stash (..),

64 StashValue (..),

57 StashValue (..),

58+ ToReifiedApi (..),

65 TypedF,

59 TypedF,

66 )

60 )

67−import Roboservant.Types.Config

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

68−

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

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

70import qualified Type.Reflection as R

63import qualified Type.Reflection as R

71

64

72data RoboservantException

65data RoboservantException

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

93 }

86 }

94 deriving (Show, Eq)

87 deriving (Show, Eq)

95

88

89+data Config

90+ = Config

91+ { seed :: [(Dynamic, Int)],

92+ maxRuntime :: Double, -- seconds to test for

93+ maxReps :: Integer,

94+ rngSeed :: Int,

95+ coverageThreshold :: Double

96+ }

97+

96data FuzzState

98data FuzzState

97 = FuzzState

99 = FuzzState

98 { path :: [FuzzOp],

100 { path :: [FuzzOp],

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

105 = forall as.

107 = forall as.

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

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

107 EndpointOption

109 EndpointOption

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

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

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

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

110 }

112 }

111

113

@@ -121,18 +123,14 @@ data Report

121 }

123 }

122 deriving (Show)

124 deriving (Show)

123

125

124−

125−

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

127−-- fuzzClient = undefined

128−

129−

130−

131−fuzz' ::

126+fuzz ::

132− ReifiedApi ->

127+ forall api.

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

129+ Server api ->

133 Config ->

130 Config ->

131+ IO () ->

134 IO (Maybe Report)

132 IO (Maybe Report)

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

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

136 let path = []

134 let path = []

137 stash = addToStash seed mempty

135 stash = addToStash seed mempty

138 currentRng = mkStdGen rngSeed

136 currentRng = mkStdGen rngSeed

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

141 runStateT

139 runStateT

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

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

143 FuzzState {..}

141 FuzzState {..}

144− logInfo $ show stopreason

142+ print stopreason

145 pure Nothing

143 pure Nothing

146 where

144 where

147 -- something less terrible later

145 -- something less terrible later

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

150 Report

148 Report

151 (unlines [show failureType, show exception])

149 (unlines [show failureType, show exception])

152 r

150 r

153− displayDiagnostics FuzzState {..} = liftIO $

151+ displayDiagnostics FuzzState {..} = liftIO $ do

154− logInfo $ unlines $

155− ["api endpoints covered"]

152+ putStrLn "api endpoints covered"

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

153+ mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)

154+ putStrLn ""

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

155+ putStrLn "types in stash"

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

156+ DM.forWithKey_ (getStash stash) $ \_k v ->

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

160− -- $ \_k v ->

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

157+ print (NEL.length $ getStashValue v)

162

158

163 evaluateCoverage f@FuzzState {..}

159 evaluateCoverage f@FuzzState {..}

164 | coverage > coverageThreshold = pure ()

160 | coverage > coverageThreshold = pure ()

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

178 else do

174 else do

179 _ <- action

175 _ <- action

180 untilDone (n -1, deadline) action

176 untilDone (n -1, deadline) action

181−

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

182 routeCount = length reifiedApi

178 routeCount = length reifiedApi

183 elementOrFail ::

179 elementOrFail ::

184 (MonadState FuzzState m, MonadIO m) =>

180 (MonadState FuzzState m, MonadIO m) =>

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

195 ( forall as.

191 ( forall as.

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

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

197 FuzzOp ->

193 FuzzOp ->

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

194+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) ->

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

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

200 m r

196 m r

201 ) ->

197 ) ->

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

236 execute ::

232 execute ::

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

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

238 FuzzOp ->

234 FuzzOp ->

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

235+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) ->

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

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

241 m ()

237 m ()

242 execute fuzzop func args = do

238 execute fuzzop func args = do

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

239+ (liftIO . print . (fuzzop,) . stash) =<< get

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

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

245− Left (e::InteractionError) ->

241+ -- parameterise this

246− if fatalError e

242+ Left (serverError :: ServerError) ->

247− then throw e

243+ case errHTTPCode serverError of

248− else pure ()

244+ 500 -> throw serverError

245+ _ ->

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

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

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

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

250 modify'

249 modify'

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

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

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

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

253− )

252+ )

254 where

253 where

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

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

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

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

257 go ::

256 go ::

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

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

259 m ()

258 m ()

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

262 (execute op func args)

261 (execute op func args)

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

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

264 Handler

263 Handler

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

264+ ( \(e :: SomeException) -> do

265+ displayDiagnostics =<< get

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

267 )

268 ]

269 catch

270− (liftIO healthCheck)

270+ (liftIO checker)

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

272

273addToStash ::

src/Roboservant/Server.hsdeleted−36

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

1−{-# LANGUAGE RankNTypes #-}

2−{-# LANGUAGE TypeApplications #-}

3−{-# LANGUAGE PolyKinds #-}

4−{-# LANGUAGE AllowAmbiguousTypes #-}

5−{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE PolyKinds #-}

8−

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeApplications #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−

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

15−

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

17−import Roboservant.Types

18− ( FlattenServer (..),

19− ReifiedApi,

20− )

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

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

23−import Roboservant.Types.Config

24−

25−fuzz :: forall api.

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

27− Server api ->

28− Config ->

29− IO (Maybe Report)

30−fuzz s = fuzz' (reifyServer s)

31− -- todo: how do we pull reifyServer out?

32− where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))

33− => Server api -> ReifiedApi

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

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

36−

src/Roboservant/Types.hs+8−10

@@ -8,19 +8,17 @@

8{-# LANGUAGE UndecidableInstances #-}

9

10module Roboservant.Types

11− ( module Roboservant.Types.Breakdown,

11+ ( module Roboservant.Types.Breakdown

12− module Roboservant.Types.BuildFrom,

12+ , module Roboservant.Types.BuildFrom

13− module Roboservant.Types.ReifiedApi,

13+ , module Roboservant.Types.FlattenServer

14− module Roboservant.Types.ReifiedApi.Server,

14+ , module Roboservant.Types.ReifiedApi

15− module Roboservant.Types.Internal,

15+ , module Roboservant.Types.Internal

16− module Roboservant.Types.Config,

16+

17 )

18where

19

20import Roboservant.Types.Breakdown

21import Roboservant.Types.BuildFrom

22−import Roboservant.Types.Config

22+import Roboservant.Types.FlattenServer

23−import Roboservant.Types.Internal

24import Roboservant.Types.ReifiedApi

23import Roboservant.Types.ReifiedApi

25−import Roboservant.Types.ReifiedApi.Server

24+import Roboservant.Types.Internal

26−import Roboservant.Types.Orphans()

src/Roboservant/Types/Breakdown.hs+14−31

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE DerivingVia #-}

3{-# LANGUAGE DerivingVia #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

@@ -15,47 +14,36 @@

15

14

16module Roboservant.Types.Breakdown where

15module Roboservant.Types.Breakdown where

17

16

18−import Data.Dynamic (Dynamic)

17+import Data.Dynamic (Dynamic, toDyn)

19−import Data.Hashable

20−import Data.Kind

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

18import Data.List.NonEmpty (NonEmpty (..))

22−import qualified Data.List.NonEmpty as NEL

23−import Data.Typeable (Typeable)

24import GHC.Generics

19import GHC.Generics

20+import Data.Typeable (Typeable)

25import Roboservant.Types.Internal

21import Roboservant.Types.Internal

26−import Servant

22+import Data.Hashable

27−import Roboservant.Types.Orphans()

23+import Data.Kind

24+import qualified Data.List.NonEmpty as NEL

28

25

29−breakdown ::

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

26+breakdown :: (Hashable x, Typeable x, Breakdown x)

31− x ->

32− NonEmpty (Dynamic, Int)

27+ => x -> NonEmpty (Dynamic, Int)

33breakdown x = hashedDyn x :| breakdownExtras x

28breakdown x = hashedDyn x :| breakdownExtras x

34

29

35class Breakdown x where

30class Breakdown x where

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

31+ breakdownExtras :: x -> [(Dynamic,Int)]

37

32

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

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

39 breakdownExtras _ = []

34 breakdownExtras _ = []

40

35

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

36deriving via (Atom ()) instance Breakdown ()

42−

43deriving via (Atom Int) instance Breakdown Int

37deriving via (Atom Int) instance Breakdown Int

44−deriving via (Atom Char) instance Breakdown Char

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

39

40+class GBreakdown (f :: k -> *) where

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

51

42

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

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

56 breakdownExtras = gBreakdownExtras . from . unCompound

44 breakdownExtras = gBreakdownExtras . from . unCompound

57

45

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

46+instance GBreakdown f => GBreakdown (M1 S c f ) where

59 gBreakdownExtras (M1 f) = gBreakdownExtras f

47 gBreakdownExtras (M1 f) = gBreakdownExtras f

60

48

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

49instance GBreakdown b => GBreakdown (M1 D a b) where

@@ -72,10 +60,5 @@ instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where

72 L1 a -> gBreakdownExtras a

60 L1 a -> gBreakdownExtras a

73 R1 a -> gBreakdownExtras a

61 R1 a -> gBreakdownExtras a

74

62

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

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

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

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

77−

78−instance GBreakdown U1 where

79− gBreakdownExtras U1 = []

80−

81−deriving via (Atom NoContent) instance Breakdown NoContent

src/Roboservant/Types/BuildFrom.hs+43−49

@@ -1,54 +1,55 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DerivingVia #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE ScopedTypeVariables #-}

1{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE StandaloneDeriving #-}

3{-# LANGUAGE StandaloneDeriving #-}

4+{-# LANGUAGE DerivingVia #-}

8{-# LANGUAGE TypeApplications #-}

5{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE UndecidableInstances #-}

7{-# LANGUAGE UndecidableInstances #-}

12−

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE FlexibleInstances #-}

11+{-# LANGUAGE AllowAmbiguousTypes #-}

13module Roboservant.Types.BuildFrom where

12module Roboservant.Types.BuildFrom where

14

13

15−import Data.List(nub)

14+import Control.Monad(filterM)

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

16+import qualified Data.List.NonEmpty as NEL

17+import Data.Typeable (Typeable)

16import qualified Data.Dependent.Map as DM

18import qualified Data.Dependent.Map as DM

19+import qualified Type.Reflection as R

20+import Data.Kind

21+import Roboservant.Types.Internal

17import Data.Hashable

22import Data.Hashable

18import qualified Data.IntSet as IntSet

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

23import GHC.Generics

24import GHC.Generics

24−import Roboservant.Types.Internal

25−import qualified Type.Reflection as R

26−import Servant(NoContent)

27−import Roboservant.Types.Orphans()

28

25

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

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

30buildFrom = buildStash . buildFrom'

27buildFrom = buildStash . buildFrom'

31 where

28 where

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

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

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

30+ buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty

31+

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

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

35− promoteToStash (p, x) =

33+ promoteToStash (p,x) = StashValue (pure (p,x))

36− StashValue

37− (pure (p, x))

38− (IntSet.singleton (hash x))

34+ (IntSet.singleton (hash x))

35+

36+ -- | sorta fiddly. looks like (<>), but in general it's not safe to add arbitrary StashValues, because

37+ -- there's no guarantee that they came from the same run, which would invalidate all the provenance stuff.

38+ -- in this context it's safe because we have no access to anything else.

39+ --

40+ -- we _do_ have to check here that the new elements are not already contained, however.

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

41 addStash :: StashValue x -> StashValue x -> StashValue x

40− addStash old (StashValue newVal _) =

42+ addStash old (StashValue newVal _)

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

43+ = let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal

42− in StashValue

43− (addListToNE (getStashValue old) insertableVals)

44+ in StashValue ( addListToNE (getStashValue old) insertableVals )

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

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

46+

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

47 addListToNE :: NonEmpty a -> [a] -> NonEmpty a

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

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

47

49

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

50+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+buildFrom' stash = maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))

51− <> extras stash

52+ <> extras stash

52

53

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

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

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

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

@@ -62,22 +63,18 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x)

62

63

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

64-- 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-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.

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

66+instance (BuildFrom x) => BuildFrom [x] where

66− extras stash =

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

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

68 where

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

69+ powerset xs = filterM (const [True, False]) xs

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

71−

72

70

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

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

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

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

75

73

76deriving via (Atom Int) instance BuildFrom Int

74deriving via (Atom Int) instance BuildFrom Int

77−

78deriving via (Atom Char) instance BuildFrom Char

75deriving via (Atom Char) instance BuildFrom Char

79

76

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

77+class GBuildFrom (f :: k -> *) where

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

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

82

79

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

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

@@ -85,15 +82,14 @@ instance GBuildFrom b => GBuildFrom (M1 D a b) where

85

82

86-- not recursion safe!

83-- not recursion safe!

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

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

88− gExtras stash =

89− (fmap L1 <$> gExtras stash)

85+ gExtras stash = (fmap L1 <$> gExtras stash)

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

86+ <> (fmap R1 <$> gExtras stash)

91

87

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

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

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

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

94

90

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

91instance GBuildFrom b => GBuildFrom (M1 C a b) where

96− gExtras = fmap (fmap M1) . gExtras

92+ gExtras =fmap (fmap M1) . gExtras

97

93

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

94instance GBuildFrom b => GBuildFrom (M1 S a b) where

99 gExtras = fmap (fmap M1) . gExtras

95 gExtras = fmap (fmap M1) . gExtras

@@ -102,6 +98,4 @@ instance BuildFrom a => GBuildFrom (K1 i a) where

102 gExtras = fmap (fmap K1) . buildFrom'

98 gExtras = fmap (fmap K1) . buildFrom'

103

99

104instance GBuildFrom U1 where

100instance GBuildFrom U1 where

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

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

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

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+data Bundled endpoints where

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

16+ NoEndpoints :: Bundled '[]

17+

18+class FlattenServer api where

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

20+

21+instance

22+ ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),

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

24+ FlattenServer api

25+ ) =>

26+ FlattenServer (endpoint :<|> api)

27+ where

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

29+

30+instance

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

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

33+ ) =>

34+ FlattenServer (x :> api)

35+ where

36+ flattenServer server = server `AnEndpoint` NoEndpoints

37+

38+instance

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

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

41+ ) =>

42+ FlattenServer (Verb method statusCode contentTypes responseType)

43+ where

44+ flattenServer server = server `AnEndpoint` NoEndpoints

src/Roboservant/Types/Internal.hs+20−24

@@ -1,53 +1,49 @@

1{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5

6module Roboservant.Types.Internal where

7

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

9+import qualified Data.Map.Strict as Map

8import qualified Data.Dependent.Map as DM

10import qualified Data.Dependent.Map as DM

9import Data.Dependent.Map (DMap)

11import Data.Dependent.Map (DMap)

10−import Data.Dependent.Sum

11−import Data.Dynamic (Dynamic, toDyn)

12−import Data.Hashable (Hashable, hash)

13−import Data.IntSet (IntSet)

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

15−import qualified Data.Map.Strict as Map

16−import Data.Typeable (Typeable)

17−import GHC.Generics (Generic)

18import qualified Type.Reflection as R

12import qualified Type.Reflection as R

13+import Data.Dependent.Sum

14+import Data.IntSet(IntSet)

15+import Data.Hashable(Hashable,hash)

16+import GHC.Generics(Generic)

17+import Data.Typeable(Typeable)

18+import Data.Dynamic(Dynamic,toDyn)

19

20data Provenance

21 = Provenance R.SomeTypeRep Int

22− deriving (Show, Eq, Generic)

22+ deriving (Show,Eq,Generic)

23

24instance Hashable Provenance

25

26−data StashValue a

27− = StashValue

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

26+data StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a)

29− stashHash :: IntSet

27+ , stashHash :: IntSet

30− }

28+ }

31 deriving (Functor, Show)

29 deriving (Functor, Show)

32

30

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

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

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

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

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

36 deriving (Semigroup, Monoid)

34 deriving (Semigroup, Monoid)

37

35

38instance Show Stash where

36instance Show Stash where

39− showsPrec i (Stash x) =

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

40− showsPrec i

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

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

42− $ DM.toList x

43

39

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

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

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

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

46− deriving newtype (Hashable, Typeable,Eq)

42+ deriving newtype (Hashable,Typeable)

47

43

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

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

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

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

50− deriving newtype (Hashable, Typeable, Eq)

46+ deriving newtype (Hashable,Typeable)

51

47

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

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

53hashedDyn a = (toDyn a, hash a)

49hashedDyn 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+50−58

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

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

2−--

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

4−-- but that's future work.

5−

6{-# LANGUAGE AllowAmbiguousTypes #-}

1{-# LANGUAGE AllowAmbiguousTypes #-}

7{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

8{-# LANGUAGE DerivingStrategies #-}

3{-# LANGUAGE DerivingStrategies #-}

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

20{-# LANGUAGE CPP #-}

15{-# LANGUAGE CPP #-}

21module Roboservant.Types.ReifiedApi where

16module Roboservant.Types.ReifiedApi where

22

17

18+import Control.Monad.Except (runExceptT)

19+import Data.Bifunctor

23import Data.Dynamic (Dynamic)

20import Data.Dynamic (Dynamic)

24−import Control.Exception(Exception)

21+import Data.Kind

25import Data.List.NonEmpty (NonEmpty)

22import Data.List.NonEmpty (NonEmpty)

26import Data.Typeable (Typeable)

23import Data.Typeable (Typeable)

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

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

25+import GHC.TypeLits (Symbol)

28import Roboservant.Types.Internal

26import Roboservant.Types.Internal

29import Roboservant.Types.Breakdown

27import Roboservant.Types.Breakdown

30import Roboservant.Types.BuildFrom

28import Roboservant.Types.BuildFrom

31−import Data.Kind(Type)

29+import Roboservant.Types.FlattenServer

32import Servant

30import Servant

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

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

34−import GHC.TypeLits (Symbol)

35import qualified Data.Text as T

32import qualified Data.Text as T

36import qualified Data.Vinyl as V

33import qualified Data.Vinyl as V

37import qualified Data.Vinyl.Curry as V

34import qualified Data.Vinyl.Curry as V

38import qualified Type.Reflection as R

35import qualified Type.Reflection as R

36+import Data.Hashable(Hashable)

39

37

40newtype ApiOffset = ApiOffset Int

38newtype ApiOffset = ApiOffset Int

41 deriving (Eq, Show, Ord)

39 deriving (Eq, Show, Ord)

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

49

47

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

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

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

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

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

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

53 }

51 }

54

52

55−instance Show ReifiedEndpoint where

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

56− show _ = "lol"

54+

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

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

57+

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

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

57

60

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

58−class ( V.RecordToList (EndpointArgs endpoint)

62+ , V.RecordToList (EndpointArgs endpoint)

59 , V.RMap (EndpointArgs endpoint)

63 , V.RMap (EndpointArgs endpoint)

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

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

61 type EndpointArgs endpoint :: [Type]

65 type EndpointArgs endpoint :: [Type]

62 type EndpointRes endpoint :: Type

66 type EndpointRes endpoint :: Type

63

67

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

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

65

69

70+instance ToReifiedApi '[] where

71+ toReifiedApi NoEndpoints _ = []

66

72

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

73+instance

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

74+ ( Typeable (EndpointRes endpoint)

69−

75+ , NormalizeFunction (ServerT endpoint Handler)

70−data InteractionError = InteractionError

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

71− { errorMessage :: T.Text

77+ , ToReifiedEndpoint endpoint

72− , fatalError :: Bool

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

79+ ) =>

80+ ToReifiedApi (endpoint : endpoints)

81+ where

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

83+ (0, ReifiedEndpoint

84+ { reArguments = reifiedEndpointArguments @endpoint

85+ , reEndpointFunc = normalize endpoint

73− }

86+ }

74− deriving Show

87+ )

75−instance Exception InteractionError

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

76−

89+ (toReifiedApi endpoints (Proxy @endpoints))

77−

90+

91+class NormalizeFunction m where

92+ type Normal m

93+ normalize :: m -> Normal m

94+

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

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

97+ normalize = fmap normalize

98+

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

100+ type Normal (Handler x) = IO (Either ServerError (NonEmpty (Dynamic,Int)))

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

102+ Left serverError -> pure (Left serverError)

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

78

104

79instance

105instance

80 (Typeable responseType, Breakdown responseType) =>

106 (Typeable responseType, Breakdown responseType) =>

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

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

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

85 reifiedEndpointArguments = V.RNil

111 reifiedEndpointArguments = V.RNil

86

112

87−instance ToReifiedEndpoint (NoContentVerb method)

88− where

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

90− type EndpointRes (NoContentVerb method) = NoContent

91− reifiedEndpointArguments = V.RNil

92−

93instance

113instance

94 (ToReifiedEndpoint endpoint) =>

114 (ToReifiedEndpoint endpoint) =>

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

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

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

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

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

99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

119 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

100

120

101−instance

102− (ToReifiedEndpoint endpoint) =>

103− ToReifiedEndpoint (RemoteHost :> endpoint)

104− where

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

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

107− reifiedEndpointArguments = reifiedEndpointArguments @endpoint

108−

109−

110−

111instance

121instance

112 (ToReifiedEndpoint endpoint) =>

122 (ToReifiedEndpoint endpoint) =>

113 ToReifiedEndpoint (Description s :> endpoint)

123 ToReifiedEndpoint (Description s :> endpoint)

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

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

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

151 V.:& reifiedEndpointArguments @endpoint

161 V.:& reifiedEndpointArguments @endpoint

152

162

153−

154−instance

155− ( BuildFrom paramType

156− , ToReifiedEndpoint endpoint

157− , Show paramType

158− , Eq paramType

159− ) =>

160− ToReifiedEndpoint (QueryParams name paramType :> endpoint)

161− where

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

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

164− reifiedEndpointArguments =

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

166− V.:& reifiedEndpointArguments @endpoint

167−

168−

169−

170−

171instance

163instance

172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

164 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

173 , ToReifiedEndpoint endpoint

165 , ToReifiedEndpoint 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+11−5

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

1+# nb: 16.8 doesn't work because the version of servant is too old to have FoldLenient', fixme.

1−resolver: lts-20.4

2+resolver: lts-16.16

2packages:

3packages:

3- .

4- .

4

5

5extra-deps:

6extra-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

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

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

8+- vinyl-0.13.0

10−- some-1.0.3

9+- dependent-sum-0.7.1.0

10+- constraints-extras-0.3.0.2

11+- dependent-map-0.4.0.0

12+

13+- servant-0.18.2

14+- servant-client-0.18.2

15+- servant-client-core-0.18.2

16+- servant-server-0.18.2

stack.yaml.lock+58−9

@@ -7,20 +7,69 @@ 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: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724

16+ pantry-tree:

17+ size: 1857

18+ sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01

19+ original:

20+ hackage: vinyl-0.13.0

21+- completed:

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

23+ pantry-tree:

24+ size: 290

25+ sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50

26+ original:

27+ hackage: dependent-sum-0.7.1.0

28+- completed:

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

30+ pantry-tree:

31+ size: 594

32+ sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1

33+ original:

34+ hackage: constraints-extras-0.3.0.2

35+- completed:

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

37+ pantry-tree:

38+ size: 551

39+ sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5

40+ original:

41+ hackage: dependent-map-0.4.0.0

42+- completed:

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

44+ pantry-tree:

45+ size: 2662

46+ sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2

47+ original:

48+ hackage: servant-0.18.2

49+- completed:

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

51+ pantry-tree:

52+ size: 1300

53+ sha256: 6324892c77bedbce32f0d6f1612fc2cb0d82c163d3be39efb951d3cc3792ce4a

54+ original:

55+ hackage: servant-client-0.18.2

56+- completed:

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

58+ pantry-tree:

59+ size: 1444

60+ sha256: 9e37bc5f8cbb70cf1accb20bd6f83fca4c2ca42472cd0fc4b22183c2c57cbe3b

61+ original:

62+ hackage: servant-client-core-0.18.2

63+- completed:

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

16 pantry-tree:

65 pantry-tree:

17− sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

66+ size: 2614

18− size: 709

67+ sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c

19 original:

68 original:

20− hackage: some-1.0.3

69+ hackage: servant-server-0.18.2

21snapshots:

70snapshots:

22- completed:

71- completed:

23− sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

24− size: 648660

72+ size: 532380

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

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

74+ sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e

26− original: lts-20.4

75+ original: lts-16.16

test/Breakdown.hs+11−11

@@ -1,39 +1,36 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Breakdown 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

14+import Data.Hashable

15

16data Foo = Foo Int String

17 deriving (Generic, Eq, Show, Typeable)

18

19instance Hashable Foo

20−

21instance ToJSON Foo

20instance ToJSON Foo

22−

23instance FromJSON Foo

21instance FromJSON Foo

24

22

23+

25data SomeSum = A Int | B String

24data SomeSum = A Int | B String

26 deriving (Generic, Eq, Show, Typeable)

25 deriving (Generic, Eq, Show, Typeable)

27

26

28instance Hashable SomeSum

27instance Hashable SomeSum

29−

30instance ToJSON SomeSum

28instance ToJSON SomeSum

31−

32instance FromJSON SomeSum

29instance FromJSON SomeSum

33

30

34−type ProductApi =

31+

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

32+type ProductApi = "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()

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

33+ :<|> "getFoo" :> Get '[JSON] Foo

37

34

38eliminate :: Int -> Handler ()

35eliminate :: Int -> Handler ()

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

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

@@ -41,10 +38,13 @@ eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}

41productServer :: Server ProductApi

38productServer :: Server ProductApi

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

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

43

40

41+

44−type SumApi =

42+type SumApi

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

43+ = "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()

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

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

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

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

48

46

47+

48+

49sumServer :: Server SumApi

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

test/Foo.hs+1−3

@@ -8,19 +8,17 @@

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

14+import Data.Hashable

15

16newtype Foo = Foo Int

17 deriving (Generic, Eq, Show, Typeable)

18 deriving newtype (FromHttpApiData, ToHttpApiData)

19

20instance Hashable Foo

21−

22instance ToJSON Foo

21instance ToJSON Foo

23−

24instance FromJSON Foo

22instance FromJSON Foo

25

23

26type Api =

24type Api =

test/Headers.hs+3−4

@@ -8,19 +8,17 @@

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

14+import Data.Hashable

15

16newtype Foo = Foo Int

17 deriving (Generic, Eq, Show, Typeable)

18 deriving newtype (FromHttpApiData, ToHttpApiData)

19

20instance Hashable Foo

21−

22instance ToJSON Foo

21instance ToJSON Foo

23−

24instance FromJSON Foo

22instance FromJSON Foo

25

23

26type Api =

24type Api =

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

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

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

36combine (Just a) Nothing = pure a

34combine (Just a) Nothing = pure a

37combine Nothing (Just a) = pure a

35combine Nothing (Just a) = pure a

38−combine Nothing Nothing = pure (Foo 1)

36+combine Nothing Nothing = pure (Foo 1)

37+

39

38

40eliminate :: Foo -> Handler ()

39eliminate :: Foo -> Handler ()

41eliminate (Foo a)

40eliminate (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.hs+9−13

@@ -1,31 +1,27 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−

5+{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Post where

9

10−import Data.Aeson

11−import Data.Hashable

12import GHC.Generics (Generic)

10import GHC.Generics (Generic)

13import Servant

11import Servant

12+import Data.Aeson

13+import Data.Hashable

14

15−type Api =

16− Get '[JSON] FooPost

15+type Api = Get '[JSON] FooPost

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

16+ :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()

18

17

19data FooPost = FooPost

18data FooPost = FooPost

20− deriving (Eq, Show, Generic)

19+ deriving (Eq,Show,Generic)

21

20

22instance Hashable FooPost

21instance Hashable FooPost

23−

24instance ToJSON FooPost

22instance ToJSON FooPost

25−

26instance FromJSON FooPost

23instance FromJSON FooPost

27

24

28server :: Server Api

25server :: Server Api

29−server =

26+server = pure FooPost

30− pure FooPost

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

27+ :<|> const (pure ())

test/Product.hs+2−4

@@ -1,25 +1,23 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Product 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

14+import Data.Hashable

15

16data Foo = Foo Int String

17 deriving (Generic, Eq, Show, Typeable)

18

19instance Hashable Foo

20−

21instance ToJSON Foo

20instance ToJSON Foo

22−

23instance FromJSON Foo

21instance FromJSON Foo

24

22

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

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

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

@@ -8,26 +8,22 @@

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

14+import Data.Hashable

15

16newtype Seed = Seed Int

17 deriving (Generic, Eq, Show, Typeable)

18 deriving newtype (FromHttpApiData, ToHttpApiData)

19

20instance ToJSON Seed

21−

22instance FromJSON Seed

21instance FromJSON Seed

23−

24instance Hashable Seed

22instance Hashable Seed

25

23

26−type Api =

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

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

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

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

29

26

30server :: Server Api

27server :: Server Api

31−server =

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

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

33− :<|> pure ()

29+ :<|> pure ()

test/Spec.hs+95−130

@@ -1,170 +1,135 @@

1−{-# LANGUAGE DerivingVia #-}

2−{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE StandaloneDeriving #-}

2{-# LANGUAGE StandaloneDeriving #-}

3+{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE TypeApplications #-}

4{-# LANGUAGE TypeApplications #-}

7−{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE LambdaCase #-}

8−{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE AllowAmbiguousTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE DataKinds #-}

6+{-# LANGUAGE DerivingVia #-}

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

13−{-# LANGUAGE TypeFamilies #-}

14

7

15−import qualified Breakdown

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

16−import Data.Dynamic (toDyn)

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

18−import Data.Maybe (isNothing)

19−import Data.Void (Void)

20import qualified Foo

9import qualified Foo

10+import qualified Seeded

11+import qualified Valid

21import qualified Headers

12import qualified Headers

22−import qualified Nested

23import qualified Post

13import qualified Post

24−import qualified Put

25import qualified Product

14import qualified Product

26−import qualified QueryParams

15+import qualified Breakdown

27−import qualified Roboservant as R

28−import qualified Roboservant.Server as RS

29−import qualified Roboservant.Client as RC

30−import qualified Seeded

31−import Test.Hspec

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

33−import qualified Valid

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

35

16

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

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

37−import Network.Wai(Application)

18+import Data.Dynamic(toDyn)

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

19+import qualified Roboservant as RS

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

20+import Test.Hspec

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

21+import Data.Void ( Void )

22+import Data.Maybe ( isNothing )

23+import Data.Hashable ( Hashable(hash) )

41

24

42main :: IO ()

25main :: IO ()

43main = hspec spec

26main = hspec spec

44

27

45−fuzzBoth

28+noCheck :: IO ()

46− :: forall a .

29+noCheck = pure ()

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

30+

48− HasClient ClientM a)

31+defaultConfig :: RS.Config

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

32+defaultConfig = RS.Config

50−fuzzBoth name server config condition = do

33+ { RS.seed = []

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

34+ , RS.maxRuntime = 0.5

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

35+ , RS.maxReps = 1000

53−

36+ , RS.rngSeed = 0

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

37+ , RS.coverageThreshold = 0

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

38+ }

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

39

65spec :: Spec

40spec :: Spec

66spec = do

41spec = do

67 describe "Basic usage" $ do

42 describe "Basic usage" $ do

68 describe "noError" $ do

43 describe "noError" $ do

44+ it "finds no error in a valid app" $ do

45+ RS.fuzz @Valid.Api Valid.server defaultConfig noCheck

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

46+ >>= (`shouldSatisfy` isNothing)

47+ it "finds no error in a valid generic app" $ do

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

48+ RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck

49+ >>= (`shouldSatisfy` isNothing)

50+

51+ it "does fail coverage check" $ do

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

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

72− (\r ->

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

53+ fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`

74− `shouldSatisfy` ( \case

54+ (\case

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

55+ Just (RS.InsufficientCoverage _) -> True

76− _ -> False

56+ _ -> False)

77− ))

57+

78− describe "posted body" $

58+ describe "posted body" $ do

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

59+ it "passes a coverage check using a posted body" $ do

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}

60+ RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck

85− (`shouldSatisfy` isNothing)

61+ >>= (`shouldSatisfy` isNothing)

86−

87

62

88 describe "seeded" $ do

63 describe "seeded" $ do

89− let res = Seeded.Seed 1

64+ shouldFail $

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

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

66+ let res = Seeded.Seed 1 in

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

67+ RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [(toDyn res,hash res) ] }) noCheck

92− (`shouldSatisfy` isNothing)

68+ >>= (`shouldSatisfy` isNothing)

93−

94− describe "Foo" $

69+ describe "Foo" $ do

70+ it "finds an error in a basic app" $

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

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

72+ >>= (`shouldSatisfy` serverFailure)

96−

97− describe "QueryParams" $

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

99− (`shouldSatisfy` isNothing)

100

73

101 describe "BuildFrom" $ do

74 describe "BuildFrom" $ do

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

75+ describe "headers (and sum types)" $ do

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

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

104− (`shouldSatisfy` serverFailure)

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

105− describe "product types" $

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

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

108− (`shouldSatisfy` serverFailure)

109− describe "Breakdown" $ do

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

111− (`shouldSatisfy` serverFailure)

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

113− (`shouldSatisfy` serverFailure)

114− describe "flattening" $

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

116− (`shouldSatisfy` isNothing)

78+ >>= (`shouldSatisfy` serverFailure)

117−

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

119−serverFailure = \case

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

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

122− in failureReason /= R.NoPossibleMoves

123− _ -> False

124

79

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

80+ describe "product types" $ do

81+ it "should find a failure that's dependent on creating a product" $ do

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

83+ >>= (`shouldSatisfy` serverFailure)

126

84

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

85+ describe "Breakdown" $ do

86+ it "handles products" $ do

87+ RS.fuzz @Breakdown.ProductApi Breakdown.productServer defaultConfig noCheck

88+ >>= (`shouldSatisfy` serverFailure)

128

89

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

90+ it "handles sums" $ do

91+ RS.fuzz @Breakdown.SumApi Breakdown.sumServer defaultConfig noCheck

92+ >>= (`shouldSatisfy` serverFailure)

130

93

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

132

94

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

95+serverFailure :: Maybe RS.Report -> Bool

96+serverFailure = \case

97+ Just RS.Report{..} ->

98+ let RS.RoboservantException{..} = rsException

99+ in failureReason /= RS.NoPossibleMoves

100+ _ -> False

134

101

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

136

102

103+deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo

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

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

138

105

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

106+deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo

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

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

141

108

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

109+deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed

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

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

144

111

145

112

113+-- instance RS.BuildFrom Seeded.Seed

146

114

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

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

148

116

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

117+deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost

118+deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost

150

119

120+deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo

121+deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo

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

122+deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum

152

123

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

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

154-- this is often useful when testing tests.

125-- this is often useful when testing tests.

155shouldFail :: SpecWith a -> SpecWith a

126shouldFail :: SpecWith a -> SpecWith a

156−shouldFail =

157− mapSpecItem_

127+shouldFail = mapSpecItem_ (\i -> i {

158− ( \i ->

159− i

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

128+ itemExample = \p a cb -> do

161− r <- itemExample i p a cb

129+ r <- (itemExample i) p a cb

162− pure

163− r

164− { resultStatus = case resultStatus r of

130+ pure r {resultStatus = case resultStatus r of

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

131+ Success -> Failure Nothing (Reason "Unexpected success")

166− Failure _ _ -> Success

132+ Failure _ _ -> Success

167− x -> x

133+ x -> x

168− }

134+ }

169− }

135+ })

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.hs+14−18

@@ -1,31 +1,28 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Valid where

9

10+import Servant

10import Data.Void

11import Data.Void

11import GHC.Generics

12import GHC.Generics

12−import Servant

13+import Servant.API.Generic

13import Servant.Server.Generic

14import Servant.Server.Generic

14

15

15−type Api =

16− Get '[JSON] Int

16+type Api = Get '[JSON] Int

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

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

18

19data Routes route

20 = Routes

21− { getInt ::

21+ { getInt :: route :-

22− route

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

22+ Get '[JSON] Int

24− captureIt ::

23+ , captureIt :: route :-

25− route

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

24+ Capture "void" Void :> Get '[JSON] ()

27− }

28− deriving (Generic)

25+ } deriving Generic

29

26

30type RoutedApi = ToServantApi Routes

27type RoutedApi = ToServantApi Routes

31

28

@@ -34,11 +31,10 @@ routedServer :: Server RoutedApi

34routedServer = genericServer routes

31routedServer = genericServer routes

35

32

36routes :: Routes AsServer

33routes :: Routes AsServer

37−routes =

34+routes = Routes

38− Routes

39− { getInt = pure 7,

35+ { getInt = pure 7

40− captureIt = const (pure ())

36+ , captureIt = const (pure ())

41− }

37+ }

42

38

43server :: Server Api

39server :: Server Api

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

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