a96a0ff...master · roboservant

.github/workflows/cabal.ymlnew file+64

since splitsnapshots

unifiedsplit

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

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

2+name: Cabal CI

3+

4+on:

5+ push:

6+ branches:

7+ - '**'

8+ paths-ignore: []

9+ pull_request:

10+ paths-ignore: []

11+

12+jobs:

13+ linux:

14+

15+ runs-on: ubuntu-20.04

16+ strategy:

17+ fail-fast: false

18+ matrix:

19+ versions:

20+ - ghc: '8.8.4'

21+ cabal: '3.4'

22+ - ghc: '8.10.4'

23+ cabal: '3.4'

24+ steps:

25+ - uses: actions/checkout@v2

26+

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

28+

29+ - name: Install recent cabal/ghc

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

31+ with:

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

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

34+

35+ # declare/restore cached things

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

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

38+

39+ - name: Cache cabal global package db

40+ id: cabal-global

41+ uses: actions/cache@v2

42+ with:

43+ path: |

44+ ~/.cabal

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

46+

47+ - name: Cache cabal work

48+ id: cabal-local

49+ uses: actions/cache@v2

50+ with:

51+ path: |

52+ dist-newstyle

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

54+

55+ - name: Install dependencies

56+ run: |

57+ cabal update

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

59+ - name: Build

60+ run: |

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

62+ - name: Test

63+ run: |

64+ cabal test all --disable-optimization

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

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

1−name: CI

1+name: Stack CI

2

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

4on:

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

12 strategy:

13 matrix:

14 stack: ["2.3.3"]

15− ghc: ["8.8.3"]

15+ ghc: ["8.10.4"]

16 os: [ubuntu-latest]

17 steps:

18 - uses: actions/checkout@v2

EXAMPLE.md+71−42

@@ -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,30 +13,43 @@ Our api under test:

13{-# LANGUAGE DeriveGeneric #-}

14{-# LANGUAGE GeneralizedNewtypeDeriving #-}

15{-# LANGUAGE RecordWildCards #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE TypeApplications #-}

16

18

17−import Roboservant

19+import qualified Roboservant.Server as RS

20+import qualified Roboservant.Client as RC

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

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

23+import Roboservant.Types

18import Test.Hspec

24import Test.Hspec

19import Servant

25import Servant

20import GHC.Generics

26import GHC.Generics

21import Data.Typeable

27import Data.Typeable

22import Data.Hashable

28import Data.Hashable

29+import Data.Maybe(isNothing, isJust)

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

31+import Data.Aeson(FromJSON,ToJSON)

23

32

24newtype A = A Int

33newtype A = A Int

25 deriving (Generic, Eq, Show, Typeable)

34 deriving (Generic, Eq, Show, Typeable)

26 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

35 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

27

36

37+instance FromJSON A

38+instance ToJSON A

39+

28newtype B = B Int

40newtype B = B Int

29 deriving (Generic, Eq, Show, Typeable)

41 deriving (Generic, Eq, Show, Typeable)

30 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

42 deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)

31

43

44+instance FromJSON B

45+instance ToJSON B

46+

32type Api =

47type Api =

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

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

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

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

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

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

36

51

37−goodServer = server (pure $ A 0)

52+server :: Handler A -> Server Api

38−badServer = server (pure $ A 1)

39−

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

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

41 where

54 where

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

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

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

45 | otherwise = pure ()

58 | otherwise = pure ()

46```

59```

47

60

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

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

49−

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

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

65

63

64+``` haskell

65+goodServer, badServer :: Server Api

66+goodServer = server (pure $ A 0)

67+badServer = server (pure $ A 1)

66```

68```

67

69

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

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

69

71

70```haskell

72```haskell

73+main :: IO ()

74+main = hspec spec

75+

76+spec :: Spec

71spec = describe "example" $ do

77spec = describe "example" $ do

72 it "good server should not fail" $ do

78 it "good server should not fail" $ do

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

79+ RS.fuzz @Api goodServer config

74 >>= (`shouldSatisfy` isNothing)

80 >>= (`shouldSatisfy` isNothing)

75 it "bad server should fail" $ do

81 it "bad server should fail" $ do

82+ RS.fuzz @Api badServer config

83+ >>= (`shouldSatisfy` isJust)

84+```

85+

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

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

88+

89+```haskell

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

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

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

93+```

94+

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

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

97+

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

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

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

101+Roboservant.Types.Config for details.

102+

103+``` haskell

104+config :: Config

105+config = defaultConfig

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

106+ { coverageThreshold = 0.99

77− >>= (`shouldSatisfy` serverFailure)

107+ }

78```

108```

79

109

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

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

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

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

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

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

83

113

84−```haskell

114+``` haskell

85deriving via (Compound A) instance Breakdown A

115deriving via (Compound A) instance Breakdown A

116+```

117+

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

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

119+

120+``` haskell

87deriving via (Atom A) instance BuildFrom A

121deriving via (Atom A) instance BuildFrom A

88

122

89```

123```

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

96deriving via (Atom B) instance Breakdown B

130deriving via (Atom B) instance Breakdown B

97```

131```

98

132

99−finally some uninteresting utilities and the entrypoint

100−

101−```haskell

102−main = hspec spec

103

133

104−serverFailure :: Maybe Report -> Bool

134+test utilities:

105−serverFailure c = case c of

106− Just Report{..} ->

107− let RoboservantException{..} = rsException

108− in failureReason /= NoPossibleMoves

109− _ -> False

110

135

111−isNothing x = case x of

136+``` haskell

112− Nothing -> True

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

113− _ -> False

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

139+ where genClientEnv port = do

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

141+ manager <- newManager defaultManagerSettings

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

114```

143```

Makefile+1−1

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

1testwatch:

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

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

3pedanticwatch:

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

README.md+90−1

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

2

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

4

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

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

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

6

7

7## example

8## example

8

9

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

14use this information to generate arbitrarily long request/response

15use this information to generate arbitrarily long request/response

15sessions and verify properties that should hold over them.

16sessions and verify properties that should hold over them.

16

17

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

17

83

18## why not servant-quickcheck?

84## why not servant-quickcheck?

19

85

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

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

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

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

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

25these without context via Arbitrary.

91these 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/genFile.sh+15−2

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

1n=$1

2+k=$2

2

3

3cat prelude

4cat prelude

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

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

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

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

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

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

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

7done

9done

8

10

9echo -n "server = handler "

11echo -n "server = handler "

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

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

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

12 echo -n ":<|> handler "

14 echo -n ":<|> handler "

13done

15done

16+echo

17+echo

18+

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

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

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

22+done;

23+

24+echo "SubApi )"

25+

26+

benchmarks/prelude+7−16

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

12import Data.Hashable

13import GHC.Generics

14import Data.Aeson

15+import Servant.API.Flatten

15

16

16data Input = Input1 { foo :: String }

17data Input = Input1 { foo :: String }

17 | Input2 { bar :: Int }

18 | Input2 { bar :: Int }

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

52 Input1 foo -> Output1 foo

53 Input1 foo -> Output1 foo

53 Input2 bar -> Output2 bar

54 Input2 bar -> Output2 bar

54

55

56+main =

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

57+ -- fuzz @Api server defaultConfig

56−

58+ pure ()

57−defaultConfig :: Config

59+

58−defaultConfig = Config {

60+f = flatten (Proxy @Api)

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

61+

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

61− seed = [hashedDyn "blah"]

62− , maxRuntime = 0.5

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

64− , maxReps = 1000

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

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

67− , rngSeed = 0

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

69− , coverageThreshold = 0

70− }

benchmarks/runTiming.sh+2−2

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

1lo=$1

2hi=$2

3−

3+k=$3

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

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

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

6 echo "sievedn: $i,";

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

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

package.yaml+12−3

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

1

2name: roboservant

3−version: 0.1.0.2

3+version: 0.1.0.3

4github: "mwotton/roboservant"

5license: BSD3

6copyright: "2020 Mark Wotton, Samuel Schlesinger"

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

19- containers

20- random

21- hashable

22+- http-types

22- lifted-base

23- lifted-base

23- monad-control

24- monad-control

24- mtl

25- mtl

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

55 - hspec

56 - hspec

56 - hspec-core

57 - hspec-core

57 - http-api-data

58 - http-api-data

58−

59+ - http-client

60+ - hspec-wai

61+ - wai

62+ - warp

59 example:

63 example:

60 main: Example.lhs

64 main: Example.lhs

61 source-dirs: .

65 source-dirs: .

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

63 dependencies:

67 dependencies:

64 - roboservant

68 - roboservant

65 - hspec

69 - hspec

66− # build-depends: base, markdown-unlit

70+ - warp

71+ - http-client

72+ - aeson

73+ - hspec-core

67 ghc-options: -pgmL markdown-unlit

74 ghc-options: -pgmL markdown-unlit

75+

76+ build-tools: markdown-unlit

roboservant.cabal+25−6

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

1cabal-version: 1.12

2

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

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

4--

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

6--

7−-- hash: 1a4c7ba230ea0cde1208ffe68cfb5433046265dea94f292c81d73644caa87cd6

7+-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d

8

9name: roboservant

10−version: 0.1.0.2

10+version: 0.1.0.3

11synopsis: Automatic session-aware servant testing

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

13category: Web

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

28library

29 exposed-modules:

30 Roboservant

31+ Roboservant.Client

31 Roboservant.Direct

32 Roboservant.Direct

33+ Roboservant.Server

32 Roboservant.Types

34 Roboservant.Types

33 Roboservant.Types.Breakdown

35 Roboservant.Types.Breakdown

34 Roboservant.Types.BuildFrom

36 Roboservant.Types.BuildFrom

35− Roboservant.Types.FlattenServer

37+ Roboservant.Types.Config

36 Roboservant.Types.Internal

38 Roboservant.Types.Internal

39+ Roboservant.Types.Orphans

37 Roboservant.Types.ReifiedApi

40 Roboservant.Types.ReifiedApi

41+ Roboservant.Types.ReifiedApi.Server

38 other-modules:

42 other-modules:

39 Paths_roboservant

43 Paths_roboservant

40 hs-source-dirs:

44 hs-source-dirs:

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

47 , dependent-map

51 , dependent-map

48 , dependent-sum

52 , dependent-sum

49 , hashable

53 , hashable

54+ , http-types

50 , lifted-base

55 , lifted-base

51 , monad-control

56 , monad-control

52 , mtl

57 , mtl

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

68 other-modules:

73 other-modules:

69 Paths_roboservant

74 Paths_roboservant

70 hs-source-dirs:

75 hs-source-dirs:

71− ./.

76+ ./

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

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

78+ build-tool-depends:

79+ markdown-unlit:markdown-unlit

73 build-depends:

80 build-depends:

81+ aeson

74− base >=4.7 && <5

82+ , base >=4.7 && <5

75 , bytestring

83 , bytestring

76 , containers

84 , containers

77 , dependent-map

85 , dependent-map

78 , dependent-sum

86 , dependent-sum

79 , hashable

87 , hashable

80 , hspec

88 , hspec

89+ , hspec-core

90+ , http-client

91+ , http-types

81 , lifted-base

92 , lifted-base

82 , monad-control

93 , monad-control

83 , mtl

94 , mtl

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

92 , time

103 , time

93 , unordered-containers

104 , unordered-containers

94 , vinyl

105 , vinyl

106+ , warp

95 default-language: Haskell2010

107 default-language: Haskell2010

96

108

97test-suite roboservant-test

109test-suite roboservant-test

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

104 Nested

116 Nested

105 Post

117 Post

106 Product

118 Product

119+ Put

120+ QueryParams

107 Seeded

121 Seeded

108 UnsafeIO

122 UnsafeIO

109 Valid

123 Valid

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

121 , hashable

135 , hashable

122 , hspec

136 , hspec

123 , hspec-core

137 , hspec-core

138+ , hspec-wai

124 , http-api-data

139 , http-api-data

140+ , http-client

141+ , http-types

125 , lifted-base

142 , lifted-base

126 , monad-control

143 , monad-control

127 , mtl

144 , mtl

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

136 , time

153 , time

137 , unordered-containers

154 , unordered-containers

138 , vinyl

155 , vinyl

156+ , wai

157+ , warp

139 default-language: Haskell2010

158 default-language: Haskell2010

src/Roboservant.hs+5−2

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

1+module Roboservant

1−module Roboservant (module Roboservant.Direct

2+ ( module Roboservant.Direct,

2− ,module Roboservant.Types) where

3+ module Roboservant.Types,

4+ )

5+where

3

6

4import Roboservant.Direct

7import Roboservant.Direct

5import Roboservant.Types

8import Roboservant.Types

src/Roboservant/Client.hsnew file+127

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

1+{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE NamedFieldPuns #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE AllowAmbiguousTypes #-}

6+{-# LANGUAGE DataKinds #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

11+

12+{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE FlexibleContexts #-}

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

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

17+module Roboservant.Client where

18+

19+import Data.Proxy

20+import Servant.Client

21+import Roboservant.Types

22+import Roboservant(Report, fuzz')

23+import Servant

24+import Data.Bifunctor

25+import Data.List.NonEmpty (NonEmpty)

26+import Data.Dynamic (Dynamic,Typeable)

27+import qualified Data.Vinyl.Curry as V

28+import qualified Data.Text as T

29+import Control.Monad.Reader

30+import Data.Hashable

31+import Network.HTTP.Types.Status

32+

33+-- fuzz :: forall api.

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

35+-- Server api ->

36+-- Config ->

37+-- IO (Maybe Report)

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

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

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

41+-- => Server api -> ReifiedApi

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

43+

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

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

46+fuzz clientEnv

47+ = fuzz'

48+ (toReifiedClientApi

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

50+ where apiClient = client (Proxy @api)

51+

52+

53+

54+class ToReifiedClientApi api where

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

56+

57+data ClientBundled endpoints where

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

59+ NoClientEndpoints :: ClientBundled '[]

60+

61+

62+class FlattenClient api where

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

64+

65+instance

66+ ( NormalizeFunction (Client ClientM endpoint)

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

68+ , ToReifiedClientApi endpoints

69+ , V.RecordCurry' (EndpointArgs endpoint)

70+ , ToReifiedEndpoint endpoint) =>

71+ ToReifiedClientApi (endpoint : endpoints) where

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

73+ (0, ReifiedEndpoint

74+ { reArguments = reifiedEndpointArguments @endpoint

75+ , reEndpointFunc = foo (normalize endpoint)

76+ }

77+ )

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

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

80+ where

81+

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

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

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

85+

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

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

88+

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

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

91+

92+

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

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

95+ normalize c = ReaderT $

96+ fmap (bimap renderClientError breakdown) . runClientM c

97+ where

98+ renderClientError :: ClientError -> InteractionError

99+ renderClientError err = case err of

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

101+ _ -> InteractionError textual True

102+

103+ where textual = T.pack $ show err

104+instance ToReifiedClientApi '[] where

105+ toReifiedClientApi NoClientEndpoints _ _ = []

106+

107+

108+instance

109+ ( FlattenClient api,

110+ Endpoints endpoint ~ '[endpoint]

111+ ) =>

112+ FlattenClient (endpoint :<|> api)

113+ where

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

115+

116+instance

117+ (

118+ Endpoints api ~ '[api]

119+ ) =>

120+ FlattenClient (x :> api)

121+ where

122+ flattenClient c = c `AClientEndpoint` NoClientEndpoints

123+

124+

125+instance FlattenClient (Verb method statusCode contentTypes responseType)

126+ where

127+ flattenClient c = c `AClientEndpoint` NoClientEndpoints

src/Roboservant/Direct.hs+60−61

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

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE LambdaCase #-}

5+{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RecordWildCards #-}

7{-# LANGUAGE RecordWildCards #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

9{-# LANGUAGE TupleSections #-}

9−{-# LANGUAGE TypeApplications #-}

10+

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

12−{-# LANGUAGE PolyKinds #-}

13

14module Roboservant.Direct

15− ( fuzz,

15+ ( fuzz',

16 Config (..),

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

18 -- have some nice error-display functions

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

25where

26

27import Control.Exception.Lifted

28− ( SomeException,

29− throw,

30− Exception,

28+ ( Exception,

29+ Handler (Handler),

31− SomeAsyncException,

30+ SomeAsyncException,

31+ SomeException,

32− catch,

32+ catch,

33− catches,

33+ catches,

34− handle,

34+ handle,

35− Handler(Handler) )

35+ throw,

36+ )

36import Control.Monad.State.Strict

37import Control.Monad.State.Strict

38+ ( MonadIO (..),

39+ MonadState (get),

37− ( MonadIO(..), StateT(runStateT), modify', MonadState(get) )

40+ StateT (runStateT),

41+ modify',

42+ )

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

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

39import qualified Data.Dependent.Map as DM

44import qualified Data.Dependent.Map as DM

40−import Data.Dynamic ( Dynamic(..) )

45+import Data.Dynamic (Dynamic (..))

41import qualified Data.IntSet as IntSet

46import qualified Data.IntSet as IntSet

42import Data.List.NonEmpty (NonEmpty (..))

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

43import qualified Data.List.NonEmpty as NEL

48import qualified Data.List.NonEmpty as NEL

44import Data.Maybe (mapMaybe)

49import Data.Maybe (mapMaybe)

45import qualified Data.Set as Set

50import qualified Data.Set as Set

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

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

47import qualified Data.Vinyl as V

52import qualified Data.Vinyl as V

48import qualified Data.Vinyl.Curry as V

53import qualified Data.Vinyl.Curry as V

49import qualified Data.Vinyl.Functor as V

54import qualified Data.Vinyl.Functor as V

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

51import Roboservant.Types

56import Roboservant.Types

52 ( ApiOffset (..),

57 ( ApiOffset (..),

53 Argument (..),

58 Argument (..),

54− FlattenServer (..),

59+ InteractionError(..),

55 Provenance (..),

60 Provenance (..),

61+ ReifiedApi,

56 ReifiedEndpoint (..),

62 ReifiedEndpoint (..),

57 Stash (..),

63 Stash (..),

58 StashValue (..),

64 StashValue (..),

59− ToReifiedApi (..),

60 TypedF,

65 TypedF,

61 )

66 )

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

67+import Roboservant.Types.Config

68+

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

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

64import qualified Type.Reflection as R

70import qualified Type.Reflection as R

65

71

66data RoboservantException

72data RoboservantException

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

87 }

93 }

88 deriving (Show, Eq)

94 deriving (Show, Eq)

89

95

90−data Config

91− = Config

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

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

94− maxReps :: Integer,

95− rngSeed :: Int,

96− coverageThreshold :: Double

97− }

98−

99data FuzzState

96data FuzzState

100 = FuzzState

97 = FuzzState

101 { path :: [FuzzOp],

98 { path :: [FuzzOp],

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

108 = forall as.

105 = forall as.

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

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

110 EndpointOption

107 EndpointOption

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

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

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

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

113 }

110 }

114

111

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

124 }

121 }

125 deriving (Show)

122 deriving (Show)

126

123

124+

125+

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

127+-- fuzzClient = undefined

128+

129+

130+

127−fuzz ::

131+fuzz' ::

128− forall api.

132+ ReifiedApi ->

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

130− Server api ->

131 Config ->

133 Config ->

132− IO () ->

133 IO (Maybe Report)

134 IO (Maybe Report)

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

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

135 let path = []

136 let path = []

136 stash = addToStash seed mempty

137 stash = addToStash seed mempty

137 currentRng = mkStdGen rngSeed

138 currentRng = mkStdGen rngSeed

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

140 runStateT

141 runStateT

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

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

142 FuzzState {..}

143 FuzzState {..}

143− print stopreason

144+ logInfo $ show stopreason

144 pure Nothing

145 pure Nothing

145 where

146 where

146 -- something less terrible later

147 -- something less terrible later

@@ -149,13 +150,15 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do

149 Report

150 Report

150 (unlines [show failureType, show exception])

151 (unlines [show failureType, show exception])

151 r

152 r

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

153+ displayDiagnostics FuzzState {..} = liftIO $

154+ logInfo $ unlines $

153− putStrLn "api endpoints covered"

155+ ["api endpoints covered"]

154− mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)

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

155− putStrLn ""

156− putStrLn "types in stash"

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

157− DM.forWithKey_ (getStash stash) $ \_k v ->

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

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

160+ -- $ \_k v ->

158− print (NEL.length $ getStashValue v)

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

159

162

160 evaluateCoverage f@FuzzState {..}

163 evaluateCoverage f@FuzzState {..}

161 | coverage > coverageThreshold = pure ()

164 | coverage > coverageThreshold = pure ()

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

175 else do

178 else do

176 _ <- action

179 _ <- action

177 untilDone (n -1, deadline) action

180 untilDone (n -1, deadline) action

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

181+

179 routeCount = length reifiedApi

182 routeCount = length reifiedApi

180 elementOrFail ::

183 elementOrFail ::

181 (MonadState FuzzState m, MonadIO m) =>

184 (MonadState FuzzState m, MonadIO m) =>

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

192 ( forall as.

195 ( forall as.

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

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

194 FuzzOp ->

197 FuzzOp ->

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

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

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

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

197 m r

200 m r

198 ) ->

201 ) ->

@@ -233,27 +236,24 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do

233 execute ::

236 execute ::

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

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

235 FuzzOp ->

238 FuzzOp ->

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

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

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

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

238 m ()

241 m ()

239 execute fuzzop func args = do

242 execute fuzzop func args = do

240− (liftIO . print . (fuzzop,) . stash) =<< get

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

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

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

242− -- parameterise this

245+ Left (e::InteractionError) ->

243− Left (serverError :: ServerError) ->

246+ if fatalError e

244− case errHTTPCode serverError of

247+ then throw e

245− 500 -> throw serverError

248+ else pure ()

246− _ ->

247− liftIO $ print ("ignoring non-500 error", serverError)

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

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

249− -- liftIO $ print ("storing", fmap dynTypeRep dyn)

250 modify'

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

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

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

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

253− )

253+ )

254 where

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

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

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

257 go ::

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

259 m ()

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

262 (execute op func args)

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

264 Handler

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

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

266− displayDiagnostics =<< get

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

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

268 )

267 )

269 ]

268 ]

270 catch

269 catch

271− (liftIO checker)

270+ (liftIO healthCheck)

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

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

273

272

274addToStash ::

273addToStash ::

src/Roboservant/Server.hsnew file+36

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

1+{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE AllowAmbiguousTypes #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE PolyKinds #-}

8+

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+

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

15+

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

17+import Roboservant.Types

18+ ( FlattenServer (..),

19+ ReifiedApi,

20+ )

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

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

23+import Roboservant.Types.Config

24+

25+fuzz :: forall api.

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

27+ Server api ->

28+ Config ->

29+ IO (Maybe Report)

30+fuzz s = fuzz' (reifyServer s)

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

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

33+ => Server api -> ReifiedApi

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

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

36+

src/Roboservant/Types.hs+10−8

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

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

13+ module Roboservant.Types.ReifiedApi,

14− , module Roboservant.Types.ReifiedApi

14+ module Roboservant.Types.ReifiedApi.Server,

15− , module Roboservant.Types.Internal

15+ module Roboservant.Types.Internal,

16−

16+ module Roboservant.Types.Config,

17 )

18where

19

20import Roboservant.Types.Breakdown

21import Roboservant.Types.BuildFrom

22−import Roboservant.Types.FlattenServer

22+import Roboservant.Types.Config

23−import Roboservant.Types.ReifiedApi

24import Roboservant.Types.Internal

23import Roboservant.Types.Internal

24+import Roboservant.Types.ReifiedApi

25+import Roboservant.Types.ReifiedApi.Server

26+import Roboservant.Types.Orphans()

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

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE DerivingVia #-}

4{-# LANGUAGE DerivingVia #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

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

14

15

15module Roboservant.Types.Breakdown where

16module Roboservant.Types.Breakdown where

16

17

17−import Data.Dynamic (Dynamic, toDyn)

18+import Data.Dynamic (Dynamic)

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

19−import GHC.Generics

20−import Data.Typeable (Typeable)

21−import Roboservant.Types.Internal

22import Data.Hashable

19import Data.Hashable

23import Data.Kind

20import Data.Kind

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

24import qualified Data.List.NonEmpty as NEL

22import qualified Data.List.NonEmpty as NEL

23+import Data.Typeable (Typeable)

24+import GHC.Generics

25+import Roboservant.Types.Internal

26+import Servant

27+import Roboservant.Types.Orphans()

25

28

29+breakdown ::

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

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

31+ x ->

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

32+ NonEmpty (Dynamic, Int)

28breakdown x = hashedDyn x :| breakdownExtras x

33breakdown x = hashedDyn x :| breakdownExtras x

29

34

30class Breakdown x where

35class Breakdown x where

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

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

32

37

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

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

34 breakdownExtras _ = []

39 breakdownExtras _ = []

35

40

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

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

42+

37deriving via (Atom Int) instance Breakdown Int

43deriving via (Atom Int) instance Breakdown Int

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

44+deriving via (Atom Char) instance Breakdown Char

45+

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

47+

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

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

39

50

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

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

42

51

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

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

54+

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

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

44 breakdownExtras = gBreakdownExtras . from . unCompound

56 breakdownExtras = gBreakdownExtras . from . unCompound

45

57

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

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

47 gBreakdownExtras (M1 f) = gBreakdownExtras f

59 gBreakdownExtras (M1 f) = gBreakdownExtras f

48

60

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

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

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

60 L1 a -> gBreakdownExtras a

72 L1 a -> gBreakdownExtras a

61 R1 a -> gBreakdownExtras a

73 R1 a -> gBreakdownExtras a

62

74

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

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

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

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

77+

78+instance GBreakdown U1 where

79+ gBreakdownExtras U1 = []

80+

81+deriving via (Atom NoContent) instance Breakdown NoContent

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

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

1−{-# LANGUAGE ScopedTypeVariables #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE TypeFamilies #-}

3−{-# LANGUAGE StandaloneDeriving #-}

4{-# LANGUAGE DerivingVia #-}

2{-# LANGUAGE DerivingVia #-}

5−{-# LANGUAGE TypeApplications #-}

6{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

7−{-# LANGUAGE UndecidableInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE StandaloneDeriving #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE TypeOperators #-}

10−{-# LANGUAGE FlexibleInstances #-}

11+{-# LANGUAGE UndecidableInstances #-}

11−{-# LANGUAGE AllowAmbiguousTypes #-}

12+

12module Roboservant.Types.BuildFrom where

13module Roboservant.Types.BuildFrom where

13

14

14−import Control.Monad(filterM)

15+import Data.List(nub)

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

16−import qualified Data.List.NonEmpty as NEL

17−import Data.Typeable (Typeable)

18import qualified Data.Dependent.Map as DM

16import qualified Data.Dependent.Map as DM

19−import qualified Type.Reflection as R

20−import Data.Kind

21−import Roboservant.Types.Internal

22import Data.Hashable

17import Data.Hashable

23import qualified Data.IntSet as IntSet

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

24import GHC.Generics

23import GHC.Generics

24+import Roboservant.Types.Internal

25+import qualified Type.Reflection as R

26+import Servant(NoContent)

27+import Roboservant.Types.Orphans()

25

28

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

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

27buildFrom = buildStash . buildFrom'

30buildFrom = buildStash . buildFrom'

28 where

31 where

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

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

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

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

31−

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

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

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

35+ promoteToStash (p, x) =

36+ StashValue

37+ (pure (p, x))

34− (IntSet.singleton (hash x))

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

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

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

42− addStash old (StashValue newVal _)

40+ addStash old (StashValue newVal _) =

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

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

42+ in StashValue

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

43+ (addListToNE (getStashValue old) insertableVals)

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

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

46−

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

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

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

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

49

47

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

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

49+buildFrom' stash =

51−buildFrom' stash = maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))

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

52− <> extras stash

51+ <> extras stash

53

52

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

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

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

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

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

63

62

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

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

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

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

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

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

66+ extras stash =

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

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

68 where

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

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

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

71+

70

72

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

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

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

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

73

75

74deriving via (Atom Int) instance BuildFrom Int

76deriving via (Atom Int) instance BuildFrom Int

77+

75deriving via (Atom Char) instance BuildFrom Char

78deriving via (Atom Char) instance BuildFrom Char

76

79

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

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

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

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

79

82

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

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

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

82

85

83-- not recursion safe!

86-- not recursion safe!

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

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

88+ gExtras stash =

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

89+ (fmap L1 <$> gExtras stash)

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

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

87

91

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

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

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

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

90

94

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

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

92− gExtras =fmap (fmap M1) . gExtras

96+ gExtras = fmap (fmap M1) . gExtras

93

97

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

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

95 gExtras = fmap (fmap M1) . gExtras

99 gExtras = fmap (fmap M1) . gExtras

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

98 gExtras = fmap (fmap K1) . buildFrom'

102 gExtras = fmap (fmap K1) . buildFrom'

99

103

100instance GBuildFrom U1 where

104instance GBuildFrom U1 where

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

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

106+

107+deriving via (Atom NoContent) instance BuildFrom NoContent

src/Roboservant/Types/Config.hsnew file+29

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

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

@@ -1,46 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE PolyKinds #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeApplications #-}

7−{-# LANGUAGE TypeOperators #-}

8−{-# LANGUAGE UndecidableInstances #-}

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

10−

11−module Roboservant.Types.FlattenServer where

12−

13−import Servant

14−

15−data Bundled endpoints where

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

17− NoEndpoints :: Bundled '[]

18−

19−class FlattenServer api where

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

21−

22−

23−instance

24− ( FlattenServer api

25− , Endpoints endpoint ~ '[endpoint]

26− ) =>

27− FlattenServer (endpoint :<|> api)

28− where

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

30−

31−instance

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

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

34− ) =>

35− FlattenServer (x :> api)

36− where

37− flattenServer server = server `AnEndpoint` NoEndpoints

38−

39−instance

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

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

42−

43− ) =>

44− FlattenServer (Verb method statusCode contentTypes responseType)

45− where

46− flattenServer server = server `AnEndpoint` NoEndpoints

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

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

1{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DerivingStrategies #-}

3{-# 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

10import qualified Data.Dependent.Map as DM

8import qualified Data.Dependent.Map as DM

11import Data.Dependent.Map (DMap)

9import Data.Dependent.Map (DMap)

12−import qualified Type.Reflection as R

13import Data.Dependent.Sum

10import Data.Dependent.Sum

14−import Data.IntSet(IntSet)

11+import Data.Dynamic (Dynamic, toDyn)

15−import Data.Hashable(Hashable,hash)

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)

16−import GHC.Generics(Generic)

17+import GHC.Generics (Generic)

17−import Data.Typeable(Typeable)

18+import qualified Type.Reflection as R

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

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

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

27− , stashHash :: IntSet

29+ stashHash :: IntSet

28− }

30+ }

29 deriving (Functor, Show)

31 deriving (Functor, Show)

30

32

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

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

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

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

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

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

34 deriving (Semigroup, Monoid)

36 deriving (Semigroup, Monoid)

35

37

36instance Show Stash where

38instance Show Stash where

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

39+ showsPrec i (Stash x) =

40+ showsPrec i

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

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

42+ $ DM.toList x

39

43

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

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

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

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

42− deriving newtype (Hashable,Typeable)

46+ deriving newtype (Hashable, Typeable,Eq)

43

47

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

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

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

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

46− deriving newtype (Hashable,Typeable)

50+ deriving newtype (Hashable, Typeable, Eq)

47

51

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

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

49hashedDyn a = (toDyn a, hash a)

53hashedDyn a = (toDyn a, hash a)

src/Roboservant/Types/Orphans.hsnew file+7

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

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

2+module Roboservant.Types.Orphans where

3+

4+import Servant

5+import Data.Hashable

6+

7+instance Hashable NoContent

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

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

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

2+--

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

4+-- but that's future work.

5+

1{-# LANGUAGE AllowAmbiguousTypes #-}

6{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

7{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DerivingStrategies #-}

8{-# LANGUAGE DerivingStrategies #-}

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

15{-# LANGUAGE CPP #-}

20{-# LANGUAGE CPP #-}

16module Roboservant.Types.ReifiedApi where

21module Roboservant.Types.ReifiedApi where

17

22

18−import Control.Monad.Except (runExceptT)

19−import Data.Bifunctor

20import Data.Dynamic (Dynamic)

23import Data.Dynamic (Dynamic)

21−import Data.Kind

24+import Control.Exception(Exception)

22import Data.List.NonEmpty (NonEmpty)

25import Data.List.NonEmpty (NonEmpty)

23import Data.Typeable (Typeable)

26import Data.Typeable (Typeable)

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

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

25−import GHC.TypeLits (Symbol)

26import Roboservant.Types.Internal

28import Roboservant.Types.Internal

27import Roboservant.Types.Breakdown

29import Roboservant.Types.Breakdown

28import Roboservant.Types.BuildFrom

30import Roboservant.Types.BuildFrom

29−import Roboservant.Types.FlattenServer

31+import Data.Kind(Type)

30import Servant

32import Servant

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

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

34+import GHC.TypeLits (Symbol)

32import qualified Data.Text as T

35import qualified Data.Text as T

33import qualified Data.Vinyl as V

36import qualified Data.Vinyl as V

34import qualified Data.Vinyl.Curry as V

37import qualified Data.Vinyl.Curry as V

35import qualified Type.Reflection as R

38import qualified Type.Reflection as R

36−import Data.Hashable(Hashable)

37

39

38newtype ApiOffset = ApiOffset Int

40newtype ApiOffset = ApiOffset Int

39 deriving (Eq, Show, Ord)

41 deriving (Eq, Show, Ord)

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

47

49

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

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

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

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

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

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

51 }

53 }

52

54

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

55+instance Show ReifiedEndpoint where

54−

56+ show _ = "lol"

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

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

57−

58−class ToReifiedApi (endpoints ) where

59−

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

61

57

62class ( V.RecordToList (EndpointArgs endpoint)

58class ( V.RecordToList (EndpointArgs endpoint)

63 , V.RMap (EndpointArgs endpoint)

59 , V.RMap (EndpointArgs endpoint)

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

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

65 type EndpointArgs endpoint :: [Type]

61 type EndpointArgs endpoint :: [Type]

66 type EndpointRes endpoint :: Type

62 type EndpointRes endpoint :: Type

67

63

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

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

69

65

70−instance ToReifiedApi '[] where

71− toReifiedApi NoEndpoints _ = []

72

66

73−instance

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

74− ( Typeable (EndpointRes endpoint)

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

69+

70+data InteractionError = InteractionError

71+ { errorMessage :: T.Text

72+ , fatalError :: Bool

73+ }

74+ deriving Show

75+instance Exception InteractionError

76+

75

77

76− , NormalizeFunction (ServerT endpoint Handler)

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

78− , ToReifiedEndpoint endpoint

79− , ToReifiedApi endpoints

80− ) =>

81− ToReifiedApi (endpoint : endpoints)

82− where

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

84− (0, ReifiedEndpoint

85− { reArguments = reifiedEndpointArguments @endpoint

86− , reEndpointFunc = normalize endpoint

87− }

88− )

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

90− (toReifiedApi endpoints (Proxy @endpoints))

91−

92−class NormalizeFunction m where

93− type Normal m

94− normalize :: m -> Normal m

95−

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

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

98− normalize = fmap normalize

99−

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

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

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

103− Left serverError -> pure (Left serverError)

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

105

78

106instance

79instance

107 (Typeable responseType, Breakdown responseType) =>

80 (Typeable responseType, Breakdown responseType) =>

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

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

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

112 reifiedEndpointArguments = V.RNil

85 reifiedEndpointArguments = V.RNil

113

86

87+instance ToReifiedEndpoint (NoContentVerb method)

88+ where

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

90+ type EndpointRes (NoContentVerb method) = NoContent

91+ reifiedEndpointArguments = V.RNil

92+

114instance

93instance

115 (ToReifiedEndpoint endpoint) =>

94 (ToReifiedEndpoint endpoint) =>

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

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

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

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

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

120 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint

121

100

101+instance

102+ (ToReifiedEndpoint endpoint) =>

103+ ToReifiedEndpoint (RemoteHost :> endpoint)

104+ where

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

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

107+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

108+

109+

110+

122instance

111instance

123 (ToReifiedEndpoint endpoint) =>

112 (ToReifiedEndpoint endpoint) =>

124 ToReifiedEndpoint (Description s :> endpoint)

113 ToReifiedEndpoint (Description s :> endpoint)

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

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

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

162 V.:& reifiedEndpointArguments @endpoint

151 V.:& reifiedEndpointArguments @endpoint

163

152

153+

154+instance

155+ ( BuildFrom paramType

156+ , ToReifiedEndpoint endpoint

157+ , Show paramType

158+ , Eq paramType

159+ ) =>

160+ ToReifiedEndpoint (QueryParams name paramType :> endpoint)

161+ where

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

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

164+ reifiedEndpointArguments =

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

166+ V.:& reifiedEndpointArguments @endpoint

167+

168+

169+

170+

164instance

171instance

165 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)

166 , ToReifiedEndpoint endpoint

173 , ToReifiedEndpoint endpoint

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

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

1+{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE AllowAmbiguousTypes #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE PolyKinds #-}

9+

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+{-# LANGUAGE CPP #-}

15+{-# LANGUAGE DataKinds #-}

16+{-# LANGUAGE TypeOperators #-}

17+{-# LANGUAGE FlexibleInstances #-}

18+{-# LANGUAGE MultiParamTypeClasses #-}

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

20+

21+import Servant

22+

23+import Control.Monad.Except (runExceptT)

24+import Data.Bifunctor

25+import Data.Dynamic (Dynamic)

26+import Data.List.NonEmpty (NonEmpty)

27+import Data.Typeable (Typeable)

28+import Roboservant.Types.Breakdown

29+import Roboservant.Types.ReifiedApi

30+

31+import qualified Data.Text as T

32+import qualified Data.Vinyl.Curry as V

33+import Data.Hashable(Hashable)

34+

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

36+

37+

38+class ToReifiedApi endpoints where

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

40+

41+instance ToReifiedApi '[] where

42+ toReifiedApi NoEndpoints _ = []

43+

44+instance

45+ ( NormalizeFunction (ServerT endpoint Handler)

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

47+ , ToReifiedEndpoint endpoint

48+ , ToReifiedApi endpoints

49+ ) =>

50+ ToReifiedApi (endpoint : endpoints)

51+ where

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

53+ (0, ReifiedEndpoint

54+ { reArguments = reifiedEndpointArguments @endpoint

55+ , reEndpointFunc = normalize endpoint

56+ }

57+ )

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

59+ (toReifiedApi endpoints (Proxy @endpoints))

60+

61+

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

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

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

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

66+ where

67+ -- | TODO improve this

68+ renderServerError :: ServerError -> InteractionError

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

70+

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

72+

73+

74+-- case errHTTPCode serverError of

75+-- 500 -> throw serverError

76+-- _ ->

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

78+

79+

80+data Bundled endpoints where

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

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

83+ NoEndpoints :: Bundled '[]

84+

85+class FlattenServer api where

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

87+

88+instance

89+ ( FlattenServer api,

90+ Endpoints endpoint ~ '[endpoint]

91+ ) =>

92+ FlattenServer (endpoint :<|> api)

93+ where

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

95+

96+instance

97+ (

98+ Endpoints api ~ '[api]

99+ ) =>

100+ FlattenServer (x :> api)

101+ where

102+ flattenServer server = server `AnEndpoint` NoEndpoints

103+

104+instance FlattenServer (Verb method statusCode contentTypes responseType)

105+ where

106+ flattenServer server = server `AnEndpoint` NoEndpoints

107+

108+class NormalizeFunction m where

109+ type Normal m

110+ normalize :: m -> Normal m

111+

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

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

114+ normalize = fmap normalize

stack.yaml+5−12

@@ -1,17 +1,10 @@

1−resolver: lts-16.27

1+resolver: lts-20.4

2−# bit faster on ReifiedApi stuff which is unfortunately terribly slow.

3−compiler: ghc-8.10.3

4packages:

2packages:

5- .

3- .

6

4

7extra-deps:

5extra-deps:

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

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

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

9−- vinyl-0.13.0

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

10−- dependent-sum-0.7.1.0

10+- some-1.0.3

11−- constraints-extras-0.3.0.2

12−- dependent-map-0.4.0.0

13−

14−- servant-0.18.2

15−- servant-client-0.18.2

16−- servant-client-core-0.18.2

17−- servant-server-0.18.2

stack.yaml.lock+9−58

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

7- completed:

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

9 pantry-tree:

10− size: 325

11 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

10 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

11+ size: 325

12 original:

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

14- completed:

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

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

16− pantry-tree:

17− size: 1857

18− sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01

19− original:

20− hackage: vinyl-0.13.0

21−- completed:

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

23− pantry-tree:

24− size: 290

25− sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50

26− original:

27− hackage: dependent-sum-0.7.1.0

28−- completed:

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

30− pantry-tree:

31− size: 594

32− sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1

33− original:

34− hackage: constraints-extras-0.3.0.2

35−- completed:

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

37− pantry-tree:

38− size: 551

39− sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5

40− original:

41− hackage: dependent-map-0.4.0.0

42−- completed:

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

44− pantry-tree:

45− size: 2662

46− sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2

47− original:

48− hackage: servant-0.18.2

49−- completed:

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

51− pantry-tree:

52− size: 1300

53− sha256: 6324892c77bedbce32f0d6f1612fc2cb0d82c163d3be39efb951d3cc3792ce4a

54− original:

55− hackage: servant-client-0.18.2

56−- completed:

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

58− pantry-tree:

59− size: 1444

60− sha256: 9e37bc5f8cbb70cf1accb20bd6f83fca4c2ca42472cd0fc4b22183c2c57cbe3b

61− original:

62− hackage: servant-client-core-0.18.2

63−- completed:

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

65 pantry-tree:

16 pantry-tree:

17+ sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8

66− size: 2614

18+ size: 709

67− sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c

68 original:

19 original:

69− hackage: servant-server-0.18.2

20+ hackage: some-1.0.3

70snapshots:

21snapshots:

71- completed:

22- completed:

23+ sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94

72− size: 533252

24+ size: 648660

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

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

74− sha256: c2aaae52beeacf6a5727c1010f50e89d03869abfab6d2c2658ade9da8ed50c73

75− original: lts-16.27

26+ original: lts-20.4

test/Breakdown.hs+11−11

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Breakdown where

9

10import Data.Aeson

11+import Data.Hashable

11import Data.Typeable (Typeable)

12import Data.Typeable (Typeable)

12import GHC.Generics (Generic)

13import GHC.Generics (Generic)

13import Servant

14import Servant

14−import Data.Hashable

15

16data Foo = Foo Int String

17 deriving (Generic, Eq, Show, Typeable)

18

19instance Hashable Foo

20+

20instance ToJSON Foo

21instance ToJSON Foo

21−instance FromJSON Foo

22

23+instance FromJSON Foo

23

24

24data SomeSum = A Int | B String

25data SomeSum = A Int | B String

25 deriving (Generic, Eq, Show, Typeable)

26 deriving (Generic, Eq, Show, Typeable)

26

27

27instance Hashable SomeSum

28instance Hashable SomeSum

29+

28instance ToJSON SomeSum

30instance ToJSON SomeSum

29−instance FromJSON SomeSum

30

31

32+instance FromJSON SomeSum

31

33

34+type ProductApi =

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

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

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

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

34

37

35eliminate :: Int -> Handler ()

38eliminate :: Int -> Handler ()

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

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

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

38productServer :: Server ProductApi

41productServer :: Server ProductApi

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

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

40

43

41−

42−type SumApi

44+type SumApi =

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

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

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

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

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

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

46

48

47−

48−

49sumServer :: Server SumApi

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

test/Foo.hs+3−1

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

8module Foo where

9

10import Data.Aeson

11+import Data.Hashable

11import Data.Typeable (Typeable)

12import Data.Typeable (Typeable)

12import GHC.Generics (Generic)

13import GHC.Generics (Generic)

13import Servant

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

21instance ToJSON Foo

22instance ToJSON Foo

23+

22instance FromJSON Foo

24instance FromJSON Foo

23

25

24type Api =

26type Api =

test/Headers.hs+4−3

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

8module Headers where

9

10import Data.Aeson

11+import Data.Hashable

11import Data.Typeable (Typeable)

12import Data.Typeable (Typeable)

12import GHC.Generics (Generic)

13import GHC.Generics (Generic)

13import Servant

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

21instance ToJSON Foo

22instance ToJSON Foo

23+

22instance FromJSON Foo

24instance FromJSON Foo

23

25

24type Api =

26type Api =

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

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

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

34combine (Just a) Nothing = pure a

36combine (Just a) Nothing = pure a

35combine Nothing (Just a) = pure a

37combine Nothing (Just a) = pure a

36−combine Nothing Nothing = pure (Foo 1)

38+combine Nothing Nothing = pure (Foo 1)

37−

38

39

39eliminate :: Foo -> Handler ()

40eliminate :: Foo -> Handler ()

40eliminate (Foo a)

41eliminate (Foo a)

test/Nested.hs+6−8

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

@@ -10,14 +10,12 @@ module Nested where

10import Servant

11import Servant.API.Flatten

12

13−

14type Api =

13type Api =

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

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

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

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

17− )

18− :<|> (

19− "three" :> Post '[JSON] Int

20 )

16 )

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

18+ )

21

19

22type FlatApi = Flat Api

20type FlatApi = Flat Api

23

21

test/Post.hs+13−9

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5−{-# LANGUAGE OverloadedStrings #-}

5+

6{-# LANGUAGE TypeOperators #-}

7

8module Post where

9

10−import GHC.Generics (Generic)

11−import Servant

12import Data.Aeson

10import Data.Aeson

13import Data.Hashable

11import Data.Hashable

12+import GHC.Generics (Generic)

13+import Servant

14

15+type Api =

15−type Api = Get '[JSON] FooPost

16+ Get '[JSON] FooPost

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

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

17

18

18data FooPost = FooPost

19data FooPost = FooPost

19− deriving (Eq,Show,Generic)

20+ deriving (Eq, Show, Generic)

20

21

21instance Hashable FooPost

22instance Hashable FooPost

23+

22instance ToJSON FooPost

24instance ToJSON FooPost

25+

23instance FromJSON FooPost

26instance FromJSON FooPost

24

27

25server :: Server Api

28server :: Server Api

29+server =

26−server = pure FooPost

30+ pure FooPost

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

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

test/Product.hs+4−2

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Product where

9

10import Data.Aeson

11+import Data.Hashable

11import Data.Typeable (Typeable)

12import Data.Typeable (Typeable)

12import GHC.Generics (Generic)

13import GHC.Generics (Generic)

13import Servant

14import Servant

14−import Data.Hashable

15

16data Foo = Foo Int String

17 deriving (Generic, Eq, Show, Typeable)

18

19instance Hashable Foo

20+

20instance ToJSON Foo

21instance ToJSON Foo

22+

21instance FromJSON Foo

23instance FromJSON Foo

22

24

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

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

test/Put.hsnew file+33

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DerivingStrategies #-}

4+

5+

6+{-# LANGUAGE TypeOperators #-}

7+

8+module Put where

9+

10+import Data.Aeson

11+import Data.Hashable

12+import GHC.Generics (Generic)

13+import Servant

14+

15+type Api =

16+ Get '[JSON] Foo

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

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

19+

20+data Foo = Foo

21+ deriving (Eq, Show, Generic)

22+

23+instance Hashable Foo

24+

25+instance ToJSON Foo

26+

27+instance FromJSON Foo

28+

29+server :: Server Api

30+server =

31+ pure Foo

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

33+ :<|> const (pure NoContent)

test/QueryParams.hsnew file+15

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

1+{-# LANGUAGE DataKinds #-}

2+

3+{-# LANGUAGE DerivingStrategies #-}

4+

5+

6+{-# LANGUAGE TypeOperators #-}

7+

8+module QueryParams where

9+

10+import Servant

11+

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

13+

14+server :: Server Api

15+server = pure

test/Seeded.hs+9−5

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

8module Seeded where

9

10import Data.Aeson

11+import Data.Hashable

11import Data.Typeable (Typeable)

12import Data.Typeable (Typeable)

12import GHC.Generics (Generic)

13import GHC.Generics (Generic)

13import Servant

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

21instance FromJSON Seed

22instance FromJSON Seed

23+

22instance Hashable Seed

24instance Hashable Seed

23

25

26+type Api =

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

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

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

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

26

29

27server :: Server Api

30server :: Server Api

31+server =

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

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

29− :<|> pure ()

33+ :<|> pure ()

test/Spec.hs+128−102

@@ -1,144 +1,170 @@

1+{-# LANGUAGE DerivingVia #-}

2+{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE StandaloneDeriving #-}

3{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE StandaloneDeriving #-}

4{-# LANGUAGE TypeApplications #-}

6{-# LANGUAGE TypeApplications #-}

5−{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE DerivingVia #-}

8+{-# LANGUAGE FlexibleContexts #-}

7−

9+{-# LANGUAGE AllowAmbiguousTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE DataKinds #-}

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

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

13+{-# LANGUAGE TypeFamilies #-}

14+

15+import qualified Breakdown

16+import Data.Dynamic (toDyn)

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

18+import Data.Maybe (isNothing)

19+import Data.Void (Void)

9import qualified Foo

20import qualified Foo

10−import qualified Seeded

11−import qualified Valid

12import qualified Headers

21import qualified Headers

22+import qualified Nested

13import qualified Post

23import qualified Post

24+import qualified Put

14import qualified Product

25import qualified Product

15−import qualified Breakdown

26+import qualified QueryParams

16−import qualified Nested

27+import qualified Roboservant as R

17−

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

19−import Data.Dynamic(toDyn)

20−import qualified Roboservant as RS

28+import qualified Roboservant.Server as RS

29+import qualified Roboservant.Client as RC

30+import qualified Seeded

21import Test.Hspec

31import Test.Hspec

22−import Data.Void ( Void )

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

23−import Data.Maybe ( isNothing )

33+import qualified Valid

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

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

35+

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

37+import Network.Wai(Application)

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

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

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

25

41

26main :: IO ()

42main :: IO ()

27main = hspec spec

43main = hspec spec

28

44

29−noCheck :: IO ()

45+fuzzBoth

30−noCheck = pure ()

46+ :: forall a .

31−

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

32−defaultConfig :: RS.Config

48+ HasClient ClientM a)

33−defaultConfig = RS.Config

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

34− { RS.seed = []

50+fuzzBoth name server config condition = do

35− , RS.maxRuntime = 0.5

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

36− , RS.maxReps = 1000

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

37− , RS.rngSeed = 0

53+

38− , RS.coverageThreshold = 0

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

39− }

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

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

57+

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

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

60+ where genClientEnv port = do

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

62+ manager <- newManager defaultManagerSettings

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

40

64

41spec :: Spec

65spec :: Spec

42spec = do

66spec = do

43 describe "Basic usage" $ do

67 describe "Basic usage" $ do

44 describe "noError" $ do

68 describe "noError" $ do

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

46− RS.fuzz @Valid.Api Valid.server defaultConfig noCheck

47− >>= (`shouldSatisfy` isNothing)

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

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

49− RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck

50− >>= (`shouldSatisfy` isNothing)

51−

52− it "does fail coverage check" $ do

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

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

72+ (\r ->

54− fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`

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

55− (\case

74+ `shouldSatisfy` ( \case

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

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

57− _ -> False)

76+ _ -> False

58−

77+ ))

59− describe "posted body" $ do

78+ describe "posted body" $

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

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

80+ (`shouldSatisfy` isNothing)

81+

82+

83+ describe "PUTted body" $

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

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

62− >>= (`shouldSatisfy` isNothing)

85+ (`shouldSatisfy` isNothing)

86+

63

87

64 describe "seeded" $ do

88 describe "seeded" $ do

65− shouldFail $

89+ let res = Seeded.Seed 1

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

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

67− let res = Seeded.Seed 1 in

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

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

69− >>= (`shouldSatisfy` isNothing)

92+ (`shouldSatisfy` isNothing)

70− describe "Foo" $ do

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

72− RS.fuzz @Foo.Api Foo.server defaultConfig noCheck

73− >>= (`shouldSatisfy` serverFailure)

74

93

75− describe "BuildFrom" $ do

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

94+ describe "Foo" $

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

78− RS.fuzz @Headers.Api Headers.server defaultConfig noCheck

79− >>= (`shouldSatisfy` serverFailure)

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

80

96

81− describe "product types" $ do

97+ describe "QueryParams" $

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

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

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

84− >>= (`shouldSatisfy` serverFailure)

99+ (`shouldSatisfy` isNothing)

85

100

101+ describe "BuildFrom" $ do

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

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

104+ (`shouldSatisfy` serverFailure)

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)

86 describe "Breakdown" $ do

109 describe "Breakdown" $ do

87− it "handles products" $ do

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

88− RS.fuzz @Breakdown.ProductApi Breakdown.productServer defaultConfig noCheck

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)

117+

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

89− >>= (`shouldSatisfy` serverFailure)

119+serverFailure = \case

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

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

122+ in failureReason /= R.NoPossibleMoves

123+ _ -> False

90

124

91− it "handles sums" $ do

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

92− RS.fuzz @Breakdown.SumApi Breakdown.sumServer defaultConfig noCheck

93− >>= (`shouldSatisfy` serverFailure)

94

126

95− describe "flattening" $ do

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

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

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

98− it "can handle nested apis" $ do

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

100− >>= (`shouldSatisfy` isNothing)

101

128

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

102

130

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

103

132

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

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

105−serverFailure = \case

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

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

108− in failureReason /= RS.NoPossibleMoves

109− _ -> False

110

134

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

111

136

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

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

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

114

138

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

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

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

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

117

141

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

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

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

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

120

144

121

145

122−-- instance RS.BuildFrom Seeded.Seed

123

146

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

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

125

148

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

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

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

128

150

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

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

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

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

132

152

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

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

134-- this is often useful when testing tests.

154-- this is often useful when testing tests.

135shouldFail :: SpecWith a -> SpecWith a

155shouldFail :: SpecWith a -> SpecWith a

156+shouldFail =

136−shouldFail = mapSpecItem_ (\i -> i {

157+ mapSpecItem_

158+ ( \i ->

159+ i

137− itemExample = \p a cb -> do

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

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

161+ r <- itemExample i p a cb

162+ pure

163+ r

139− pure r {resultStatus = case resultStatus r of

164+ { resultStatus = case resultStatus r of

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

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

141− Failure _ _ -> Success

166+ Failure _ _ -> Success

142− x -> x

167+ x -> x

143− }

168+ }

144− })

169+ }

170+ )

test/UnsafeIO.hs+13−15

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module UnsafeIO where

9

10−import Data.Aeson()

11−import Servant

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

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

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

11+import Data.Aeson ()

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

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

15−

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

14+import Servant

16

15

17type UnsafeApi =

16type UnsafeApi =

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

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

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

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

20

19

21healthcheck :: IORef Int -> Handler ()

20healthcheck :: IORef Int -> Handler ()

22healthcheck ref = do

21healthcheck ref = do

23 t <- liftIO $ readIORef ref

22 t <- liftIO $ readIORef ref

24 case t of

23 case t of

25 0 -> pure ()

24 0 -> pure ()

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

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

27−

28−

29

26

30makeServer :: IO (Server UnsafeApi)

27makeServer :: IO (Server UnsafeApi)

31makeServer = do

28makeServer = do

32 ref <- newIORef 0

29 ref <- newIORef 0

30+ pure $

33− pure $ unsafeMunge ref

31+ unsafeMunge ref

34− :<|> healthcheck ref

32+ :<|> healthcheck ref

35

33

36unsafeMunge :: IORef Int -> Handler ()

34unsafeMunge :: IORef Int -> Handler ()

37unsafeMunge ref = liftIO $ do

35unsafeMunge ref = liftIO $ do

38 t <- readIORef ref

36 t <- readIORef ref

39− writeIORef ref (t+1)

37+ writeIORef ref (t + 1)

40 t2 <- readIORef ref

38 t2 <- readIORef ref

41− writeIORef ref (t2-1)

39+ writeIORef ref (t2 -1)

test/Valid.hs+18−14

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE TypeOperators #-}

7

8module Valid where

9

10−import Servant

11import Data.Void

10import Data.Void

12import GHC.Generics

11import GHC.Generics

13−import Servant.API.Generic

12+import Servant

14import Servant.Server.Generic

13import Servant.Server.Generic

15

14

15+type Api =

16−type Api = Get '[JSON] Int

16+ Get '[JSON] Int

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

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

18

19data Routes route

20 = Routes

21− { getInt :: route :-

21+ { getInt ::

22+ route

22− Get '[JSON] Int

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

23− , captureIt :: route :-

24+ captureIt ::

25+ route

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

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

27+ }

25− } deriving Generic

28+ deriving (Generic)

26

29

27type RoutedApi = ToServantApi Routes

30type RoutedApi = ToServantApi Routes

28

31

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

31routedServer = genericServer routes

34routedServer = genericServer routes

32

35

33routes :: Routes AsServer

36routes :: Routes AsServer

34−routes = Routes

37+routes =

38+ Routes

35− { getInt = pure 7

39+ { getInt = pure 7,

36− , captureIt = const (pure ())

40+ captureIt = const (pure ())

37− }

41+ }

38

42

39server :: Server Api

43server :: Server Api

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

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