git.iko.soy/roboservant
on b32a660 help sign in
8ade8f3
swap
0 ahead, 31 behind
40 files changed+557−1347
since splitsnapshots
unifiedsplit
.github/workflows/cabal.yml−64 .github/workflows/ci.yml+2−2 EXAMPLE.md−143 Example.lhs−1 Makefile+1−1 README.md+23−87 benchmarks/README.md−30 benchmarks/genFile.sh−26 benchmarks/prelude−61 benchmarks/runTiming.sh−10 benchmarks/runTimingNoisy.sh−10 package.yaml+1−21 roboservant.cabal+4−56 src/Roboservant.hs+2−5 src/Roboservant/Client.hs−127 src/Roboservant/Direct.hs+60−60 src/Roboservant/Server.hs−36 src/Roboservant/Types.hs+14−10 src/Roboservant/Types/Breakdown.hs+16−32 src/Roboservant/Types/BuildFrom.hs+56−49 src/Roboservant/Types/Config.hs−29 src/Roboservant/Types/FlattenServer.hs+45 src/Roboservant/Types/Internal.hs+20−24 src/Roboservant/Types/Orphans.hs−7 src/Roboservant/Types/ReifiedApi.hs+58−57 src/Roboservant/Types/ReifiedApi/Server.hs−114 stack.yaml+11−5 stack.yaml.lock+58−9 test/Breakdown.hs+11−11 test/Foo.hs+1−3 test/Headers.hs+3−4 test/Nested.hs−23 test/Post.hs+9−13 test/Product.hs+2−4 test/Put.hs−33 test/QueryParams.hs−15 test/Seeded.hs+5−9 test/Spec.hs+126−125 test/UnsafeIO.hs+15−13 test/Valid.hs+14−18
.github/workflows/cabal.ymldeleted−64
@@ -1,64 +0,0 @@
1−# modified from https://github.com/jgm/pandoc/blob/master/.github/workflows/ci.yml
2−name: Cabal CI
3−
4−on:
5− push:
6− branches:
7− - '**'
8− paths-ignore: []
9− pull_request:
10− paths-ignore: []
11−
12−jobs:
13− linux:
14−
15− runs-on: ubuntu-20.04
16− strategy:
17− fail-fast: false
18− matrix:
19− versions:
20− - ghc: '8.8.4'
21− cabal: '3.4'
22− - ghc: '8.10.4'
23− cabal: '3.4'
24− steps:
25− - uses: actions/checkout@v2
26−
27− # need to install older cabal/ghc versions from ppa repository
28−
29− - name: Install recent cabal/ghc
30− uses: actions/setup-haskell@v1.1.3
31− with:
32− ghc-version: ${{ matrix.versions.ghc }}
33− cabal-version: ${{ matrix.versions.cabal }}
34−
35− # declare/restore cached things
36− # caching doesn't work for scheduled runs yet
37− # https://github.com/actions/cache/issues/63
38−
39− - name: Cache cabal global package db
40− id: cabal-global
41− uses: actions/cache@v2
42− with:
43− path: |
44− ~/.cabal
45− key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-global-${{ hashFiles('cabal.project') }}
46−
47− - name: Cache cabal work
48− id: cabal-local
49− uses: actions/cache@v2
50− with:
51− path: |
52− dist-newstyle
53− key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-local
54−
55− - name: Install dependencies
56− run: |
57− cabal update
58− cabal build all --dependencies-only --enable-tests --disable-optimization
59− - name: Build
60− run: |
61− cabal build all --enable-tests --disable-optimization 2>&1 | tee build.log
62− - name: Test
63− run: |
64− cabal test all --disable-optimization
.github/workflows/ci.yml+2−2
@@ -1,4 +1,4 @@
1−name: Stack CI
1+name: CI
22
33# Trigger the workflow on push or pull request, but only for the master branch
44on:
@@ -12,7 +12,7 @@ jobs:
1212 strategy:
1313 matrix:
1414 stack: ["2.3.3"]
15− ghc: ["8.10.4"]
15+ ghc: ["8.8.3"]
1616 os: [ubuntu-latest]
1717 steps:
1818 - uses: actions/checkout@v2
EXAMPLE.mddeleted−143
@@ -1,143 +0,0 @@
1−# Example
2−
3−Our api under test:
4−
5−``` haskell
6−-- Obligatory fancy-types pragma tax
7−{-# LANGUAGE DataKinds #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE DerivingStrategies #-}
10−{-# LANGUAGE StandaloneDeriving #-}
11−{-# LANGUAGE DerivingVia #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE DeriveGeneric #-}
14−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
15−{-# LANGUAGE RecordWildCards #-}
16−{-# LANGUAGE ScopedTypeVariables #-}
17−{-# LANGUAGE TypeApplications #-}
18−
19−import qualified Roboservant.Server as RS
20−import qualified Roboservant.Client as RC
21−import Servant.Client(ClientEnv, baseUrlPort, parseBaseUrl, mkClientEnv)
22−import Network.HTTP.Client (newManager, defaultManagerSettings)
23−import Roboservant.Types
24−import Test.Hspec
25−import Servant
26−import GHC.Generics
27−import Data.Typeable
28−import Data.Hashable
29−import Data.Maybe(isNothing, isJust)
30−import qualified Network.Wai.Handler.Warp as Warp
31−import Data.Aeson(FromJSON,ToJSON)
32−
33−newtype A = A Int
34− deriving (Generic, Eq, Show, Typeable)
35− deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
36−
37−instance FromJSON A
38−instance ToJSON A
39−
40−newtype B = B Int
41− deriving (Generic, Eq, Show, Typeable)
42− deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
43−
44−instance FromJSON B
45−instance ToJSON B
46−
47−type Api =
48− "item" :> Get '[JSON] A
49− :<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B
50− :<|> "item" :> Capture "itemId" B :> Get '[JSON] ()
51−
52−server :: Handler A -> Server Api
53−server introduce = introduce :<|> combine :<|> eliminate
54− where
55− combine (B i) (B j) = pure $ B (i + j)
56− eliminate (B i)
57− | i > 10 = error "give up, eleven is way too big and probably not even real"
58− | otherwise = pure ()
59−```
60−
61−We have a "good" server, that never generates anything other than a 0. This means repeated application of
62−the combination/addition rule can never bring us to the dangerous state of numbers larger than 10.
63−
64−``` haskell
65−goodServer, badServer :: Server Api
66−goodServer = server (pure $ A 0)
67−badServer = server (pure $ A 1)
68−```
69−
70−In the test file, we first define the tests: the faulty server should fail and the good server should pass.
71−
72−```haskell
73−main :: IO ()
74−main = hspec spec
75−
76−spec :: Spec
77−spec = describe "example" $ do
78− it "good server should not fail" $ do
79− RS.fuzz @Api goodServer config
80− >>= (`shouldSatisfy` isNothing)
81− it "bad server should fail" $ do
82− RS.fuzz @Api badServer config
83− >>= (`shouldSatisfy` isJust)
84−```
85−
86−The previous test just picked apart the server and ran functions manually: sometimes, we want to test via
87−an honest-to-goodness network port, like so:
88−
89−```haskell
90− around (withServer (serve (Proxy :: Proxy Api) badServer)) $ do
91− it "we should also be able to run the _client_ to an independent server (ignore server error messages)" $ \(clientEnv::ClientEnv) -> do
92− RC.fuzz @Api clientEnv config >>= (`shouldSatisfy` isJust)
93−```
94−
95−(we use withApplication rather than testWithApplication because we don't primarily care what the server does here:
96−we want to check what a client does when presented with a faulty server.)
97−
98−We expect to be able to cover the whole api from our starting point, so let's set the coverage to 0.99.
99−There are other tweakable things in the config, like maximum runtime, reps,
100−per-request healthchecks, seeds, and verbose logging. Have a look at
101−Roboservant.Types.Config for details.
102−
103−``` haskell
104−config :: Config
105−config = defaultConfig
106− { coverageThreshold = 0.99
107− }
108−```
109−
110−Unless we want to ship roboservant and all its dependencies to production, we also need
111−some orphan instances: because As are the only value we can get without
112−an input, we need to be able to break them down.
113−
114−``` haskell
115−deriving via (Compound A) instance Breakdown A
116−```
117−
118−if we wanted to assemble As from parts as well, we'd derive using Compound, but in this case we don't care.
119−
120−``` haskell
121−deriving via (Atom A) instance BuildFrom A
122−
123−```
124−
125−Similarly, to generate the first B from the Ints we got from inside the A, we need to be able to
126−build it up from components.
127−
128−```haskell
129−deriving via (Compound B) instance BuildFrom B
130−deriving via (Atom B) instance Breakdown B
131−```
132−
133−
134−test utilities:
135−
136−``` haskell
137−withServer :: Application -> ActionWith ClientEnv -> IO ()
138−withServer app action = Warp.withApplication (pure app) (\p -> genClientEnv p >>= action)
139− where genClientEnv port = do
140− baseUrl <- parseBaseUrl "http://localhost"
141− manager <- newManager defaultManagerSettings
142− pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
143−```
Example.lhsdeleted−1
@@ -1 +0,0 @@
1−EXAMPLE.md
Makefile+1−1
@@ -1,4 +1,4 @@
11testwatch:
2− ghcid -T main -c 'stack repl roboservant:lib roboservant:test:roboservant-test --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
2+ ghcid -T main -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
33pedanticwatch:
44 ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
README.md+23−87
@@ -2,86 +2,45 @@
22
33Automatically fuzz your servant apis in a contextually-aware way.
44
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)
5+![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)
76
8−## example
97
10−see full example [here](EXAMPLE.md)
11−
12−## why?
8+# why?
139
1410Servant gives us a lot of information about what a server can do. We
1511use this information to generate arbitrarily long request/response
1612sessions and verify properties that should hold over them.
1713
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.
14+# example
3815
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.)
16+Our api under test:
4517
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
5318```
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
19+newtype Foo = Foo Int
20+ deriving (Generic, Eq, Show, Typeable)
21+ deriving newtype (FromHttpApiData, ToHttpApiData)
22+
23+type FooApi =
24+ "item" :> Get '[JSON] Foo
25+ :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
26+ :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
6627```
6728
68−### priming the pump
29+From the tests:
6930
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.
31+```
32+ assert "should find an error in Foo" . not
33+ =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential @Foo.FooApi Foo.fooServer)])
34+```
7635
77−For those cases, override the `seed` in the `Config` with a
78−list of seed values, suitably hashed:
36+We have a server that blows up if the value of the int in a `Foo` ever gets above 10. Note:
37+there is no generator for `Foo` types: larger `Foo`s can only be made only by combining existing
38+`Foo`s with `itemAdd`. This is an important distinction, because many APIs will return UUIDs or
39+similar as keys, which make it impossible to cover a useful section of the state space without
40+using the values returned by the API
7941
80−``` haskell
81−defaultConfig { seed = [hashedDyn creds, hashedDyn userJwt]}
82−```
8342
84−## why not servant-quickcheck?
43+# why not servant-quickcheck?
8544
8645[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
8746is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
@@ -89,26 +48,3 @@ there's a lot of the state space you just can't explore without context: modern
8948full of pointer-like structures, whether they're URLs or database
9049keys/uuids, and servant-quickcheck requires that you be able to generate
9150these without context via Arbitrary.
92−
93−## limitations and future work
94−
95−Currently, the display of failing traces is pretty tragic, both in the
96−formatting and in its non-minimality. This is pretty ticklish:
97−arguably the right way to do this is to return a trace that we can
98−also rerun, and let quickcheck or hedgehog a level up shrink it until
99−it's satisfactorily short. In the interest of being useful earlier
100−rather than later, I'm releasing v1.0 before I crack this particular
101−nut. We do know which calls we made that led to the failing case, so
102−we would want to show that distinction in a visible way: it's possible
103−that other calls that don't have direct data dependencies were
104−important, but we definitely know we need the direct data dependencies.
105−
106−The provenance stuff is a bit underbaked. It should at least pull a
107−representation of the route chosen rather than just an integer index.
108−
109−It would also be nice to have a robust strategy for deriving recursive
110−datatypes, or at least rejecting attempts to generate them that don't
111−end in an infinite loop.
112−
113−Currently the `FlattenServer` instance for `:>` is quadratic. It would
114−be nice to fix this but I lack the art.
benchmarks/README.mddeleted−30
@@ -1,30 +0,0 @@
1−# Benchmarks
2−
3−I've noticed compilation can be a little slow on realistic apps so I set up a test.
4−
5−## components
6−
7−1. codegen
8−
9− given an integer input n, create an api with n endpoints. they should take a reasonably
10− complicated input and return a reasonably complicated output
11−
12−2. runner
13−
14− build dependencies
15− for i from 1 to 100
16− generate api with i endpoints
17− compile it, but timed
18− print (i,time)
19−
20−3. plot to see linearity/quadraticity?
21−
22−## possible gotchas
23−
24−- we usually compile these in different modules rather than together: if we don't get slow
25− compilation in one file, try out multiple files.
26−
27−## notes
28−
29−- flat profile if you don't have the call to `fuzz`
30−- no difference between deriving via Atom vs Compound, so not a Generics thing.
benchmarks/genFile.shdeleted−26
@@ -1,26 +0,0 @@
1−n=$1
2−k=$2
3−
4−cat prelude
5−echo -n "type SubApi = \"route1\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"
6−for i in $(seq 2 $n); do
7− echo -n " :<|> \"route${i}\" :> "
8− echo "ReqBody '[JSON] Input :> Post '[JSON] Output"
9−done
10−
11−echo -n "server = handler "
12−
13−for i in $(seq 2 $n); do
14− echo -n ":<|> handler "
15−done
16−echo
17−echo
18−
19−echo -n "type Api = Flatten ("
20−for i in $(seq 1 $k); do
21− echo -n '"foo" :> '
22−done;
23−
24−echo "SubApi )"
25−
26−
benchmarks/preludedeleted−61
@@ -1,61 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE TypeApplications #-}
5−{-# LANGUAGE DerivingVia #-}
6−{-# LANGUAGE StandaloneDeriving #-}
7−{-# LANGUAGE DeriveGeneric #-}
8−
9−
10−import Roboservant
11−import Servant
12−import Data.Hashable
13−import GHC.Generics
14−import Data.Aeson
15−import Servant.API.Flatten
16−
17−data Input = Input1 { foo :: String }
18− | Input2 { bar :: Int }
19− deriving (Generic, Eq)
20−
21−instance FromJSON Input
22−instance ToJSON Input
23−
24−
25−deriving via (Compound Input) instance Breakdown Input
26−deriving via (Compound Input) instance BuildFrom Input
27−
28−
29−-- deriving via (Atom Input) instance Breakdown Input
30−-- deriving via (Atom Input) instance BuildFrom Input
31−
32−instance Hashable Input
33−
34−
35−data Output = Output1 { ofoo :: String }
36− | Output2 { obar :: Int }
37− deriving (Generic, Eq)
38−
39−instance FromJSON Output
40−instance ToJSON Output
41−
42−instance Hashable Output
43−
44−deriving via (Compound Output) instance Breakdown Output
45−deriving via (Compound Output) instance BuildFrom Output
46−
47−-- deriving via (Atom Output) instance Breakdown Output
48−-- deriving via (Atom Output) instance BuildFrom Output
49−
50−
51−handler :: Input -> Handler Output
52−handler = pure . \case
53− Input1 foo -> Output1 foo
54− Input2 bar -> Output2 bar
55−
56−main =
57− -- fuzz @Api server defaultConfig
58− pure ()
59−
60−f = flatten (Proxy @Api)
61−
benchmarks/runTiming.shdeleted−10
@@ -1,10 +0,0 @@
1−lo=$1
2−hi=$2
3−k=$3
4−for i in $(seq $lo 5 $hi); do
5− ./genFile.sh $i $k > main.hs;
6− echo "sievedn: $i,";
7− /usr/bin/time -f "%e" stack ghc main.hs 2>&1;
8−# /usr/bin/time -f "%e" stack ghc -- -fomit-interface-pragmas main.hs 2>&1;
9−
10−done | grep -v Compiling | grep -v Linking | awk '/,$/ { printf("%s", $0); next } 1' | sed 's/sievedn: //'
benchmarks/runTimingNoisy.shdeleted−10
@@ -1,10 +0,0 @@
1−lo=$1
2−hi=$2
3−
4−for i in $(seq $lo 5 $hi); do
5− ./genFile.sh $i > main.hs;
6− echo "sievedn: $i,";
7− /usr/bin/time -f "%e" stack ghc main.hs 2>&1;
8−# /usr/bin/time -f "%e" stack ghc -- -fomit-interface-pragmas main.hs 2>&1;
9−
10−done
package.yaml+1−21
@@ -1,6 +1,5 @@
1−
21name: roboservant
3−version: 0.1.0.3
2+version: 0.1.0.2
43github: "mwotton/roboservant"
54license: BSD3
65copyright: "2020 Mark Wotton, Samuel Schlesinger"
@@ -19,7 +18,6 @@ dependencies:
1918- containers
2019- random
2120- hashable
22−- http-types
2321- lifted-base
2422- monad-control
2523- mtl
@@ -56,21 +54,3 @@ tests:
5654 - hspec
5755 - hspec-core
5856 - http-api-data
59− - http-client
60− - hspec-wai
61− - wai
62− - warp
63− example:
64− main: Example.lhs
65− source-dirs: .
66−
67− dependencies:
68− - roboservant
69− - hspec
70− - warp
71− - http-client
72− - aeson
73− - hspec-core
74− ghc-options: -pgmL markdown-unlit
75−
76− build-tools: markdown-unlit
roboservant.cabal+4−56
@@ -1,13 +1,13 @@
11cabal-version: 1.12
22
3−-- This file has been generated from package.yaml by hpack version 0.35.0.
3+-- This file has been generated from package.yaml by hpack version 0.33.0.
44--
55-- see: https://github.com/sol/hpack
66--
7−-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d
7+-- hash: 3b8eaf26233853cd94e20de7f84c25d6124cd919072681c3287a761526f82b9e
88
99name: roboservant
10−version: 0.1.0.3
10+version: 0.1.0.2
1111synopsis: Automatic session-aware servant testing
1212description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
1313category: Web
@@ -28,17 +28,13 @@ source-repository head
2828library
2929 exposed-modules:
3030 Roboservant
31− Roboservant.Client
3231 Roboservant.Direct
33− Roboservant.Server
3432 Roboservant.Types
3533 Roboservant.Types.Breakdown
3634 Roboservant.Types.BuildFrom
37− Roboservant.Types.Config
35+ Roboservant.Types.FlattenServer
3836 Roboservant.Types.Internal
39− Roboservant.Types.Orphans
4037 Roboservant.Types.ReifiedApi
41− Roboservant.Types.ReifiedApi.Server
4238 other-modules:
4339 Paths_roboservant
4440 hs-source-dirs:
@@ -51,7 +47,6 @@ library
5147 , dependent-map
5248 , dependent-sum
5349 , hashable
54− , http-types
5550 , lifted-base
5651 , monad-control
5752 , mtl
@@ -67,45 +62,6 @@ library
6762 , vinyl
6863 default-language: Haskell2010
6964
70−test-suite example
71− type: exitcode-stdio-1.0
72− main-is: Example.lhs
73− other-modules:
74− Paths_roboservant
75− hs-source-dirs:
76− ./
77− ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit
78− build-tool-depends:
79− markdown-unlit:markdown-unlit
80− build-depends:
81− aeson
82− , base >=4.7 && <5
83− , bytestring
84− , containers
85− , dependent-map
86− , dependent-sum
87− , hashable
88− , hspec
89− , hspec-core
90− , http-client
91− , http-types
92− , lifted-base
93− , monad-control
94− , mtl
95− , random
96− , roboservant
97− , servant
98− , servant-client
99− , servant-flatten
100− , servant-server
101− , string-conversions
102− , text
103− , time
104− , unordered-containers
105− , vinyl
106− , warp
107− default-language: Haskell2010
108−
10965test-suite roboservant-test
11066 type: exitcode-stdio-1.0
11167 main-is: Spec.hs
@@ -113,11 +69,8 @@ test-suite roboservant-test
11369 Breakdown
11470 Foo
11571 Headers
116− Nested
11772 Post
11873 Product
119− Put
120− QueryParams
12174 Seeded
12275 UnsafeIO
12376 Valid
@@ -135,10 +88,7 @@ test-suite roboservant-test
13588 , hashable
13689 , hspec
13790 , hspec-core
138− , hspec-wai
13991 , http-api-data
140− , http-client
141− , http-types
14292 , lifted-base
14393 , monad-control
14494 , mtl
@@ -153,6 +103,4 @@ test-suite roboservant-test
153103 , time
154104 , unordered-containers
155105 , vinyl
156− , wai
157− , warp
158106 default-language: Haskell2010
src/Roboservant.hs+2−5
@@ -1,8 +1,5 @@
1−module Roboservant
2− ( module Roboservant.Direct,
3− module Roboservant.Types,
4− )
5−where
1+module Roboservant (module Roboservant.Direct
2+ ,module Roboservant.Types) where
63
74import Roboservant.Direct
85import Roboservant.Types
src/Roboservant/Client.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE NamedFieldPuns #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE AllowAmbiguousTypes #-}
6−{-# LANGUAGE DataKinds #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−
12−{-# LANGUAGE UndecidableInstances #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE FlexibleContexts #-}
15−-- should all the NormalizeFunction instances be in one place?
16−{-# OPTIONS_GHC -fno-warn-orphans #-}
17−module Roboservant.Client where
18−
19−import Data.Proxy
20−import Servant.Client
21−import Roboservant.Types
22−import Roboservant(Report, fuzz')
23−import Servant
24−import Data.Bifunctor
25−import Data.List.NonEmpty (NonEmpty)
26−import Data.Dynamic (Dynamic,Typeable)
27−import qualified Data.Vinyl.Curry as V
28−import qualified Data.Text as T
29−import Control.Monad.Reader
30−import Data.Hashable
31−import Network.HTTP.Types.Status
32−
33−-- fuzz :: forall api.
34−-- (FlattenServer api, ToReifiedApi (Endpoints api)) =>
35−-- Server api ->
36−-- Config ->
37−-- IO (Maybe Report)
38−-- fuzz s = fuzz' (reifyServer s)
39−-- -- todo: how do we pull reifyServer out?
40−-- where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
41−-- => Server api -> ReifiedApi
42−-- reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
43−
44−fuzz :: forall api . (ToReifiedClientApi (Endpoints api), FlattenClient api, HasClient ClientM api)
45− => ClientEnv -> Config -> IO (Maybe Report)
46−fuzz clientEnv
47− = fuzz'
48− (toReifiedClientApi
49− (flattenClient @api apiClient) (Proxy @(Endpoints api)) clientEnv)
50− where apiClient = client (Proxy @api)
51−
52−
53−
54−class ToReifiedClientApi api where
55− toReifiedClientApi :: ClientBundled api -> Proxy api -> ClientEnv -> ReifiedApi
56−
57−data ClientBundled endpoints where
58− AClientEndpoint :: Client ClientM endpoint -> ClientBundled endpoints -> ClientBundled (endpoint ': endpoints)
59− NoClientEndpoints :: ClientBundled '[]
60−
61−
62−class FlattenClient api where
63− flattenClient :: Client ClientM api -> ClientBundled (Endpoints api)
64−
65−instance
66− ( NormalizeFunction (Client ClientM endpoint)
67− , Normal (Client ClientM endpoint) ~ V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))))
68− , ToReifiedClientApi endpoints
69− , V.RecordCurry' (EndpointArgs endpoint)
70− , ToReifiedEndpoint endpoint) =>
71− ToReifiedClientApi (endpoint : endpoints) where
72− toReifiedClientApi (endpoint `AClientEndpoint` endpoints) _ clientEnv =
73− (0, ReifiedEndpoint
74− { reArguments = reifiedEndpointArguments @endpoint
75− , reEndpointFunc = foo (normalize endpoint)
76− }
77− )
78− : (map . first) (+1)
79− (toReifiedClientApi endpoints (Proxy @endpoints) clientEnv)
80− where
81−
82− foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType)
83− -> V.Curried (EndpointArgs endpoint) (IO ResultType)
84− foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv)
85−
86−mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b
87−mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g
88−
89−type ResultType = Either InteractionError (NonEmpty (Dynamic,Int))
90−-- runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
91−
92−
93−instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where
94− type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int)))
95− normalize c = ReaderT $
96− fmap (bimap renderClientError breakdown) . runClientM c
97− where
98− renderClientError :: ClientError -> InteractionError
99− renderClientError err = case err of
100− FailureResponse _ Response{responseStatusCode} -> InteractionError textual (responseStatusCode == status500)
101− _ -> InteractionError textual True
102−
103− where textual = T.pack $ show err
104−instance ToReifiedClientApi '[] where
105− toReifiedClientApi NoClientEndpoints _ _ = []
106−
107−
108−instance
109− ( FlattenClient api,
110− Endpoints endpoint ~ '[endpoint]
111− ) =>
112− FlattenClient (endpoint :<|> api)
113− where
114− flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c
115−
116−instance
117− (
118− Endpoints api ~ '[api]
119− ) =>
120− FlattenClient (x :> api)
121− where
122− flattenClient c = c `AClientEndpoint` NoClientEndpoints
123−
124−
125−instance FlattenClient (Verb method statusCode contentTypes responseType)
126− where
127− flattenClient c = c `AClientEndpoint` NoClientEndpoints
src/Roboservant/Direct.hs+60−60
@@ -2,17 +2,16 @@
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE GADTs #-}
44{-# LANGUAGE LambdaCase #-}
5−{-# LANGUAGE PolyKinds #-}
65{-# LANGUAGE RankNTypes #-}
76{-# LANGUAGE RecordWildCards #-}
87{-# LANGUAGE ScopedTypeVariables #-}
98{-# LANGUAGE TupleSections #-}
10−
9+{-# LANGUAGE TypeApplications #-}
1110{-# LANGUAGE TypeFamilies #-}
1211{-# LANGUAGE UndecidableInstances #-}
1312
1413module Roboservant.Direct
15− ( fuzz',
14+ ( fuzz,
1615 Config (..),
1716 -- TODO come up with something smarter than exporting all this, we should
1817 -- have some nice error-display functions
@@ -25,30 +24,25 @@ module Roboservant.Direct
2524where
2625
2726import Control.Exception.Lifted
28− ( Exception,
29− Handler (Handler),
30− SomeAsyncException,
31− SomeException,
32− catch,
33− catches,
34− handle,
35− throw,
36− )
27+ ( SomeException,
28+ throw,
29+ Exception,
30+ SomeAsyncException,
31+ catch,
32+ catches,
33+ handle,
34+ Handler(Handler) )
3735import Control.Monad.State.Strict
38− ( MonadIO (..),
39− MonadState (get),
40− StateT (runStateT),
41− modify',
42− )
36+ ( MonadIO(..), StateT(runStateT), modify', MonadState(get) )
4337import Control.Monad.Trans.Control (MonadBaseControl)
4438import qualified Data.Dependent.Map as DM
45−import Data.Dynamic (Dynamic (..))
39+import Data.Dynamic ( Dynamic(..) )
4640import qualified Data.IntSet as IntSet
4741import Data.List.NonEmpty (NonEmpty (..))
4842import qualified Data.List.NonEmpty as NEL
4943import Data.Maybe (mapMaybe)
5044import qualified Data.Set as Set
51−import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
45+import Data.Time.Clock ( addUTCTime, getCurrentTime, UTCTime )
5246import qualified Data.Vinyl as V
5347import qualified Data.Vinyl.Curry as V
5448import qualified Data.Vinyl.Functor as V
@@ -56,17 +50,16 @@ import GHC.Generics ((:*:) (..))
5650import Roboservant.Types
5751 ( ApiOffset (..),
5852 Argument (..),
59− InteractionError(..),
53+ FlattenServer (..),
6054 Provenance (..),
61− ReifiedApi,
6255 ReifiedEndpoint (..),
6356 Stash (..),
6457 StashValue (..),
58+ ToReifiedApi (..),
6559 TypedF,
6660 )
67−import Roboservant.Types.Config
68−
69−import System.Random (Random (randomR), StdGen, mkStdGen)
61+import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
62+import System.Random ( mkStdGen, Random(randomR), StdGen )
7063import qualified Type.Reflection as R
7164
7265data RoboservantException
@@ -93,6 +86,15 @@ data FuzzOp
9386 }
9487 deriving (Show, Eq)
9588
89+data Config
90+ = Config
91+ { seed :: [(Dynamic, Int)],
92+ maxRuntime :: Double, -- seconds to test for
93+ maxReps :: Integer,
94+ rngSeed :: Int,
95+ coverageThreshold :: Double
96+ }
97+
9698data FuzzState
9799 = FuzzState
98100 { path :: [FuzzOp],
@@ -105,7 +107,7 @@ data EndpointOption
105107 = forall as.
106108 (V.RecordToList as, V.RMap as) =>
107109 EndpointOption
108− { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
110+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))),
109111 eoArgs :: V.Rec (TypedF StashValue) as
110112 }
111113
@@ -121,18 +123,14 @@ data Report
121123 }
122124 deriving (Show)
123125
124−
125−
126−-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
127−-- fuzzClient = undefined
128−
129−
130−
131−fuzz' ::
132− ReifiedApi ->
126+fuzz ::
127+ forall api.
128+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>
129+ Server api ->
133130 Config ->
131+ IO () ->
134132 IO (Maybe Report)
135−fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
133+fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
136134 let path = []
137135 stash = addToStash seed mempty
138136 currentRng = mkStdGen rngSeed
@@ -141,7 +139,7 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
141139 runStateT
142140 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
143141 FuzzState {..}
144− logInfo $ show stopreason
142+ print stopreason
145143 pure Nothing
146144 where
147145 -- something less terrible later
@@ -150,15 +148,13 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
150148 Report
151149 (unlines [show failureType, show exception])
152150 r
153− displayDiagnostics FuzzState {..} = liftIO $
154− logInfo $ unlines $
155− ["api endpoints covered"]
156− <> (map show . Set.toList . Set.fromList $ map apiOffset path)
157− <> ["", "types in stash"]
158− <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)
159− -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
160− -- $ \_k v ->
161− -- (show . NEL.length $ getStashValue v))
151+ displayDiagnostics FuzzState {..} = liftIO $ do
152+ putStrLn "api endpoints covered"
153+ mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
154+ putStrLn ""
155+ putStrLn "types in stash"
156+ DM.forWithKey_ (getStash stash) $ \_k v ->
157+ print (NEL.length $ getStashValue v)
162158
163159 evaluateCoverage f@FuzzState {..}
164160 | coverage > coverageThreshold = pure ()
@@ -178,7 +174,7 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
178174 else do
179175 _ <- action
180176 untilDone (n -1, deadline) action
181−
177+ reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
182178 routeCount = length reifiedApi
183179 elementOrFail ::
184180 (MonadState FuzzState m, MonadIO m) =>
@@ -195,7 +191,7 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
195191 ( forall as.
196192 (V.RecordToList as, V.RMap as) =>
197193 FuzzOp ->
198− V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
194+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) ->
199195 V.Rec (TypedF V.Identity) as ->
200196 m r
201197 ) ->
@@ -236,24 +232,27 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
236232 execute ::
237233 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
238234 FuzzOp ->
239− V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
235+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) ->
240236 V.Rec (TypedF V.Identity) as ->
241237 m ()
242238 execute fuzzop func args = do
243− (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
239+ (liftIO . print . (fuzzop,) . stash) =<< get
244240 liftIO (V.runcurry' func argVals) >>= \case
245− Left (e::InteractionError) ->
246− if fatalError e
247− then throw e
248− else pure ()
249− Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
241+ -- parameterise this
242+ Left (serverError :: ServerError) ->
243+ case errHTTPCode serverError of
244+ 500 -> throw serverError
245+ _ ->
246+ liftIO $ print ("ignoring non-500 error", serverError)
247+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> do
248+ -- liftIO $ print ("storing", fmap dynTypeRep dyn)
250249 modify'
251− ( \fs@FuzzState {..} ->
252− fs {stash = addToStash (NEL.toList dyn) stash}
253− )
250+ ( \fs@FuzzState {..} ->
251+ fs {stash = addToStash (NEL.toList dyn) stash}
252+ )
254253 where
255254 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
256− -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
255+ -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
257256 go ::
258257 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
259258 m ()
@@ -262,12 +261,13 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
262261 (execute op func args)
263262 [ Handler (\(e :: SomeAsyncException) -> throw e),
264263 Handler
265− ( \(e :: SomeException) ->
264+ ( \(e :: SomeException) -> do
265+ displayDiagnostics =<< get
266266 throw . RoboservantException ServerCrashed (Just e) =<< get
267267 )
268268 ]
269269 catch
270− (liftIO healthCheck)
270+ (liftIO checker)
271271 (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
272272
273273addToStash ::
src/Roboservant/Server.hsdeleted−36
@@ -1,36 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE PolyKinds #-}
4−{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE PolyKinds #-}
8−
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−module Roboservant.Server (fuzz, module Roboservant.Types ) where
15−
16−import Roboservant.Direct(fuzz',Report)
17−import Roboservant.Types
18− ( FlattenServer (..),
19− ReifiedApi,
20− )
21−import Roboservant.Types.ReifiedApi.Server(ToReifiedApi (..))
22−import Servant (Endpoints, Proxy (Proxy), Server)
23−import Roboservant.Types.Config
24−
25−fuzz :: forall api.
26− (FlattenServer api, ToReifiedApi (Endpoints api)) =>
27− Server api ->
28− Config ->
29− IO (Maybe Report)
30−fuzz s = fuzz' (reifyServer s)
31− -- todo: how do we pull reifyServer out?
32− where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
33− => Server api -> ReifiedApi
34− reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
35−-- reifyServer server = toReifiedApi server (Proxy @(Endpoints api))
36−
src/Roboservant/Types.hs+14−10
@@ -2,25 +2,29 @@
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE DerivingStrategies #-}
44{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE LambdaCase #-}
57{-# LANGUAGE PolyKinds #-}
68{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeApplications #-}
712{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
814{-# LANGUAGE UndecidableInstances #-}
915
1016module Roboservant.Types
11− ( module Roboservant.Types.Breakdown,
12− module Roboservant.Types.BuildFrom,
13− module Roboservant.Types.ReifiedApi,
14− module Roboservant.Types.ReifiedApi.Server,
15− module Roboservant.Types.Internal,
16− module Roboservant.Types.Config,
17+ ( module Roboservant.Types.Breakdown
18+ , module Roboservant.Types.BuildFrom
19+ , module Roboservant.Types.FlattenServer
20+ , module Roboservant.Types.ReifiedApi
21+ , module Roboservant.Types.Internal
22+
1723 )
1824where
1925
2026import Roboservant.Types.Breakdown
2127import Roboservant.Types.BuildFrom
22−import Roboservant.Types.Config
23−import Roboservant.Types.Internal
28+import Roboservant.Types.FlattenServer
2429import Roboservant.Types.ReifiedApi
25−import Roboservant.Types.ReifiedApi.Server
26−import Roboservant.Types.Orphans()
30+import Roboservant.Types.Internal
src/Roboservant/Types/Breakdown.hs+16−32
@@ -1,6 +1,5 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
43{-# LANGUAGE DerivingVia #-}
54{-# LANGUAGE FlexibleInstances #-}
65{-# LANGUAGE GADTs #-}
@@ -15,52 +14,42 @@
1514
1615module Roboservant.Types.Breakdown where
1716
18−import Data.Dynamic (Dynamic)
19−import Data.Hashable
20−import Data.Kind
17+import Data.Dynamic (Dynamic, toDyn)
2118import Data.List.NonEmpty (NonEmpty (..))
22−import qualified Data.List.NonEmpty as NEL
23−import Data.Typeable (Typeable)
2419import GHC.Generics
20+import Data.Typeable (Typeable)
2521import Roboservant.Types.Internal
26−import Servant
27−import Roboservant.Types.Orphans()
22+import Data.Hashable
23+import Data.Kind
24+import qualified Data.List.NonEmpty as NEL
2825
29−breakdown ::
30− (Hashable x, Typeable x, Breakdown x) =>
31− x ->
32− NonEmpty (Dynamic, Int)
26+breakdown :: (Hashable x, Typeable x, Breakdown x)
27+ => x -> NonEmpty (Dynamic, Int)
3328breakdown x = hashedDyn x :| breakdownExtras x
3429
3530class Breakdown x where
36− breakdownExtras :: x -> [(Dynamic, Int)]
31+ breakdownExtras :: x -> [(Dynamic,Int)]
3732
3833instance (Hashable x, Typeable x) => Breakdown (Atom x) where
39− breakdownExtras _ = []
34+ breakdownExtras (Atom x) = [(toDyn x, hash x)]
4035
4136deriving via (Atom ()) instance Breakdown ()
42−
4337deriving via (Atom Int) instance Breakdown Int
44−deriving via (Atom Char) instance Breakdown Char
45−
46−deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x)
47−
48−instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where
49− breakdownExtras stash = concatMap (NEL.toList . breakdown) stash
50−
38+deriving via (Atom [Char]) instance Breakdown [Char]
5139
52−class GBreakdown (f :: k -> Type) where
53− gBreakdownExtras :: f a -> [(Dynamic, Int)]
40+class GBreakdown (f :: k -> *) where
41+ gBreakdownExtras :: f a -> [(Dynamic,Int)]
5442
55−instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where
43+instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x::Type)) where
5644 breakdownExtras = gBreakdownExtras . from . unCompound
5745
58−instance GBreakdown f => GBreakdown (M1 S c f) where
46+instance GBreakdown f => GBreakdown (M1 S c f ) where
5947 gBreakdownExtras (M1 f) = gBreakdownExtras f
6048
6149instance GBreakdown b => GBreakdown (M1 D a b) where
6250 gBreakdownExtras (M1 f) = gBreakdownExtras f
6351
52+
6453instance GBreakdown b => GBreakdown (M1 C a b) where
6554 gBreakdownExtras (M1 f) = gBreakdownExtras f
6655
@@ -72,10 +61,5 @@ instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where
7261 L1 a -> gBreakdownExtras a
7362 R1 a -> gBreakdownExtras a
7463
75−instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where
64+instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where
7665 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+56−49
@@ -1,54 +1,64 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DerivingVia #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE PolyKinds #-}
61{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE TypeFamilies #-}
73{-# LANGUAGE StandaloneDeriving #-}
4+{-# LANGUAGE DerivingVia #-}
85{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE FlexibleContexts #-}
117{-# LANGUAGE UndecidableInstances #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE FlexibleInstances #-}
11+{-# LANGUAGE AllowAmbiguousTypes #-}
12+
13+
14+
15+
16+
17+
1218
1319module Roboservant.Types.BuildFrom where
1420
15−import Data.List(nub)
21+import Control.Monad(filterM)
22+import Data.List.NonEmpty (NonEmpty(..))
23+import qualified Data.List.NonEmpty as NEL
24+import Data.Typeable (Typeable)
1625import qualified Data.Dependent.Map as DM
26+import qualified Type.Reflection as R
27+import Data.Kind
28+import Roboservant.Types.Internal
1729import Data.Hashable
1830import 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)
2331import GHC.Generics
24−import Roboservant.Types.Internal
25−import qualified Type.Reflection as R
26−import Servant(NoContent)
27−import Roboservant.Types.Orphans()
32+-- import Roboservant.Types.GBuildFrom(GBuildFrom(..))
2833
29−buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
34+
35+buildFrom :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
3036buildFrom = buildStash . buildFrom'
3137 where
3238 buildStash :: [([Provenance], x)] -> Maybe (StashValue x)
33− buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty
39+ buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty
40+
3441 promoteToStash :: ([Provenance], x) -> StashValue x
35− promoteToStash (p, x) =
36− StashValue
37− (pure (p, x))
38− (IntSet.singleton (hash x))
42+ promoteToStash (p,x) = StashValue (pure (p,x))
43+ (IntSet.singleton (hash x))
44+
45+ -- | sorta fiddly. looks like (<>), but in general it's not safe to add arbitrary StashValues, because
46+ -- there's no guarantee that they came from the same run, which would invalidate all the provenance stuff.
47+ -- in this context it's safe because we have no access to anything else.
48+ --
49+ -- we _do_ have to check here that the new elements are not already contained, however.
3950 addStash :: StashValue x -> StashValue x -> StashValue x
40− addStash old (StashValue newVal _) =
41− let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal
42− in StashValue
43− (addListToNE (getStashValue old) insertableVals)
44− (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))
51+ addStash old (StashValue newVal _)
52+ = let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal
53+ in StashValue ( addListToNE (getStashValue old) insertableVals )
54+ (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))
55+
4556 addListToNE :: NonEmpty a -> [a] -> NonEmpty a
4657 addListToNE ne l = NEL.fromList (NEL.toList ne <> l)
4758
48−buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]
49−buildFrom' stash =
50− maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))
51− <> extras stash
59+buildFrom' :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]
60+buildFrom' stash = maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))
61+ <> extras stash
5262
5363class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
5464 extras :: Stash -> [([Provenance], x)]
@@ -62,38 +72,37 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x)
6272
6373-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
6474-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
65−instance (Eq x, BuildFrom x) => BuildFrom [x] where
66− extras stash =
67− nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash
75+instance (BuildFrom x) => BuildFrom [x] where
76+ extras stash = map (\xs -> (concatMap fst xs,map snd xs)) $ powerset $ take 3 $ extras @x stash
6877 where
69− -- powerset creates way too much stuff. something better here eventually.
70− notpowerset xs = []:xs:map pure xs
71−
78+ powerset xs = filterM (\_ -> [True, False]) xs
7279
73−instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where
80+instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x::Type)) where
7481 extras stash = fmap (Compound . to) <$> gExtras stash
7582
7683deriving via (Atom Int) instance BuildFrom Int
77−
7884deriving via (Atom Char) instance BuildFrom Char
7985
80−class GBuildFrom (f :: k -> Type) where
86+
87+class GBuildFrom (f :: k -> *) where
8188 gExtras :: Stash -> [([Provenance], f a)]
8289
90+
8391instance GBuildFrom b => GBuildFrom (M1 D a b) where
8492 gExtras = fmap (fmap M1) . gExtras
8593
86−-- not recursion safe!
8794instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
88− gExtras stash =
89− (fmap L1 <$> gExtras stash)
90− <> (fmap R1 <$> gExtras stash)
95+ gExtras stash = (fmap L1 <$> gExtras stash)
96+ <> (fmap R1 <$> gExtras stash)
9197
9298instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
93− gExtras stash = [(pa <> pb, a' :*: b') | (pa, a') <- gExtras stash, (pb, b') <- gExtras stash]
99+ gExtras stash = [ (pa<>pb, a' :*: b') | (pa,a') <- gExtras stash , (pb,b') <- gExtras stash]
100+
101+
102+
94103
95104instance GBuildFrom b => GBuildFrom (M1 C a b) where
96− gExtras = fmap (fmap M1) . gExtras
105+ gExtras =fmap (fmap M1) . gExtras
97106
98107instance GBuildFrom b => GBuildFrom (M1 S a b) where
99108 gExtras = fmap (fmap M1) . gExtras
@@ -102,6 +111,4 @@ instance BuildFrom a => GBuildFrom (K1 i a) where
102111 gExtras = fmap (fmap K1) . buildFrom'
103112
104113instance GBuildFrom U1 where
105− gExtras _ = [([], U1)]
106−
107−deriving via (Atom NoContent) instance BuildFrom NoContent
114+ gExtras _ = [([],U1)]
src/Roboservant/Types/Config.hsdeleted−29
@@ -1,29 +0,0 @@
1−module Roboservant.Types.Config where
2−
3−import Data.Dynamic
4−
5−data Config
6− = Config
7− { seed :: [(Dynamic, Int)],
8− maxRuntime :: Double, -- seconds to test for
9− maxReps :: Integer,
10− rngSeed :: Int,
11− coverageThreshold :: Double,
12− logInfo :: String -> IO (),
13− healthCheck :: IO ()
14− }
15−
16−defaultConfig :: Config
17−defaultConfig =
18− Config
19− { seed = [],
20− maxRuntime = 0.5,
21− maxReps = 1000,
22− rngSeed = 0,
23− coverageThreshold = 0,
24− logInfo = const (pure ()),
25− healthCheck = pure ()
26− }
27−
28−noisyConfig :: Config
29−noisyConfig = defaultConfig {logInfo = print}
src/Roboservant/Types/FlattenServer.hsnew file+45
@@ -0,0 +1,45 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+module Roboservant.Types.FlattenServer where
11+
12+import Servant
13+
14+
15+data Bundled endpoints where
16+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
17+ NoEndpoints :: Bundled '[]
18+
19+class FlattenServer api where
20+ flattenServer :: Server api -> Bundled (Endpoints api)
21+
22+instance
23+ ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
24+ Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
25+ FlattenServer api
26+ ) =>
27+ FlattenServer (endpoint :<|> api)
28+ where
29+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
30+
31+instance
32+ ( HasServer (x :> api) '[],
33+ Endpoints (x :> api) ~ '[x :> api]
34+ ) =>
35+ FlattenServer (x :> api)
36+ where
37+ flattenServer server = server `AnEndpoint` NoEndpoints
38+
39+instance
40+ ( HasServer (Verb method statusCode contentTypes responseType) '[],
41+ Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
42+ ) =>
43+ FlattenServer (Verb method statusCode contentTypes responseType)
44+ where
45+ flattenServer server = server `AnEndpoint` NoEndpoints
src/Roboservant/Types/Internal.hs+20−24
@@ -1,53 +1,49 @@
11{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
23{-# LANGUAGE DeriveGeneric #-}
34{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55
66module Roboservant.Types.Internal where
77
8+import Data.List.NonEmpty (NonEmpty(..))
9+import qualified Data.Map.Strict as Map
810import qualified Data.Dependent.Map as DM
911import Data.Dependent.Map (DMap)
10−import Data.Dependent.Sum
11−import Data.Dynamic (Dynamic, toDyn)
12−import Data.Hashable (Hashable, hash)
13−import Data.IntSet (IntSet)
14−import Data.List.NonEmpty (NonEmpty (..))
15−import qualified Data.Map.Strict as Map
16−import Data.Typeable (Typeable)
17−import GHC.Generics (Generic)
1812import qualified Type.Reflection as R
13+import Data.Dependent.Sum
14+import Data.IntSet(IntSet)
15+import Data.Hashable(Hashable,hash)
16+import GHC.Generics(Generic)
17+import Data.Typeable(Typeable)
18+import Data.Dynamic(Dynamic,toDyn)
1919
2020data Provenance
2121 = Provenance R.SomeTypeRep Int
22− deriving (Show, Eq, Generic)
22+ deriving (Show,Eq,Generic)
2323
2424instance Hashable Provenance
2525
26−data StashValue a
27− = StashValue
28− { getStashValue :: NonEmpty ([Provenance], a),
29− stashHash :: IntSet
30− }
26+data StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a)
27+ , stashHash :: IntSet
28+ }
3129 deriving (Functor, Show)
3230
3331-- wrap in newtype to give a custom Show instance, since the normal
3432-- instance for DMap is not happy since StashValue needs Show a to show
35−newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}
33+newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
3634 deriving (Semigroup, Monoid)
3735
3836instance Show Stash where
39− showsPrec i (Stash x) =
40− showsPrec i
41− $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))
42− $ DM.toList x
37+ showsPrec i (Stash x) = showsPrec i $
38+ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
4339
4440-- | Can't be built up from parts, can't be broken down further.
45−newtype Atom x = Atom {unAtom :: x}
46− deriving newtype (Hashable, Typeable,Eq)
41+newtype Atom x = Atom { unAtom :: x }
42+ deriving newtype (Hashable,Typeable)
4743
4844-- | can be broken down and built up from generic pieces
49−newtype Compound x = Compound {unCompound :: x}
50− deriving newtype (Hashable, Typeable, Eq)
45+newtype Compound x = Compound { unCompound :: x }
46+ deriving newtype (Hashable,Typeable)
5147
5248hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)
5349hashedDyn a = (toDyn a, hash a)
src/Roboservant/Types/Orphans.hsdeleted−7
@@ -1,7 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module Roboservant.Types.Orphans where
3−
4−import Servant
5−import Data.Hashable
6−
7−instance Hashable NoContent
src/Roboservant/Types/ReifiedApi.hs+58−57
@@ -1,8 +1,3 @@
1−-- | Description: ways to build a reified api from a servant description.
2−--
3−-- arguably this could be more general and be abstracted away from even relying on servant
4−-- but that's future work.
5−
61{-# LANGUAGE AllowAmbiguousTypes #-}
72{-# LANGUAGE DataKinds #-}
83{-# LANGUAGE DerivingStrategies #-}
@@ -12,7 +7,10 @@
127{-# LANGUAGE GeneralizedNewtypeDeriving #-}
138{-# LANGUAGE LambdaCase #-}
149{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE RecordWildCards #-}
1511{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE StandaloneDeriving #-}
13+{-# LANGUAGE TupleSections #-}
1614{-# LANGUAGE TypeApplications #-}
1715{-# LANGUAGE TypeFamilies #-}
1816{-# LANGUAGE TypeOperators #-}
@@ -20,22 +18,27 @@
2018{-# LANGUAGE CPP #-}
2119module Roboservant.Types.ReifiedApi where
2220
21+
22+import Control.Monad.Except (runExceptT)
23+import Data.Bifunctor
24+-- import Data.Dependent.Sum
2325import Data.Dynamic (Dynamic)
24−import Control.Exception(Exception)
26+import Data.Kind
2527import Data.List.NonEmpty (NonEmpty)
2628import Data.Typeable (Typeable)
2729import GHC.Generics ((:*:)(..))
30+import GHC.TypeLits (Symbol)
2831import Roboservant.Types.Internal
2932import Roboservant.Types.Breakdown
3033import Roboservant.Types.BuildFrom
31−import Data.Kind(Type)
34+import Roboservant.Types.FlattenServer
3235import Servant
3336import Servant.API.Modifiers(FoldRequired,FoldLenient)
34−import GHC.TypeLits (Symbol)
3537import qualified Data.Text as T
3638import qualified Data.Vinyl as V
3739import qualified Data.Vinyl.Curry as V
3840import qualified Type.Reflection as R
41+import Data.Hashable(Hashable)
3942
4043newtype ApiOffset = ApiOffset Int
4144 deriving (Eq, Show, Ord)
@@ -49,32 +52,60 @@ newtype Argument a = Argument
4952
5053data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
5154 { reArguments :: V.Rec (TypedF Argument) as
52− , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
55+ , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int))))
5356 }
5457
55−instance Show ReifiedEndpoint where
56− show _ = "lol"
58+type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
59+
60+tagType :: Typeable a => f a -> TypedF f a
61+tagType = (R.typeRep :*:)
62+
63+class ToReifiedApi (endpoints :: [*]) where
64+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
5765
58−class ( V.RecordToList (EndpointArgs endpoint)
66+class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint
67+ , V.RecordToList (EndpointArgs endpoint)
5968 , V.RMap (EndpointArgs endpoint)
60− ) => ToReifiedEndpoint (endpoint :: Type) where
69+ ) => ToReifiedEndpoint (endpoint :: *) where
6170 type EndpointArgs endpoint :: [Type]
6271 type EndpointRes endpoint :: Type
6372
6473 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
6574
75+instance ToReifiedApi '[] where
76+ toReifiedApi NoEndpoints _ = []
6677
67−tagType :: Typeable a => f a -> TypedF f a
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−
77−
78+instance
79+ ( Typeable (EndpointRes endpoint)
80+ , NormalizeFunction (ServerT endpoint Handler)
81+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int))))
82+ , ToReifiedEndpoint endpoint
83+ , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)
84+ ) =>
85+ ToReifiedApi (endpoint : endpoints)
86+ where
87+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
88+ (0, ReifiedEndpoint
89+ { reArguments = reifiedEndpointArguments @endpoint
90+ , reEndpointFunc = normalize endpoint
91+ }
92+ )
93+ : (map . first) (+1)
94+ (toReifiedApi endpoints (Proxy @endpoints))
95+
96+class NormalizeFunction m where
97+ type Normal m
98+ normalize :: m -> Normal m
99+
100+instance NormalizeFunction x => NormalizeFunction (r -> x) where
101+ type Normal (r -> x) = r -> Normal x
102+ normalize = fmap normalize
103+
104+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
105+ type Normal (Handler x) = IO (Either ServerError (NonEmpty (Dynamic,Int)))
106+ normalize handler = (runExceptT . runHandler') handler >>= \case
107+ Left serverError -> pure (Left serverError)
108+ Right x -> pure $ Right $ breakdown x
78109
79110instance
80111 (Typeable responseType, Breakdown responseType) =>
@@ -84,12 +115,6 @@ instance
84115 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
85116 reifiedEndpointArguments = V.RNil
86117
87−instance ToReifiedEndpoint (NoContentVerb method)
88− where
89− type EndpointArgs (NoContentVerb method) = '[]
90− type EndpointRes (NoContentVerb method) = NoContent
91− reifiedEndpointArguments = V.RNil
92−
93118instance
94119 (ToReifiedEndpoint endpoint) =>
95120 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
@@ -98,16 +123,6 @@ instance
98123 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
99124 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
100125
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−
111126instance
112127 (ToReifiedEndpoint endpoint) =>
113128 ToReifiedEndpoint (Description s :> endpoint)
@@ -151,23 +166,6 @@ instance
151166 V.:& reifiedEndpointArguments @endpoint
152167
153168
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−
171169instance
172170 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
173171 , ToReifiedEndpoint endpoint
@@ -180,6 +178,8 @@ instance
180178 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
181179 V.:& reifiedEndpointArguments @endpoint
182180
181+
182+-- this isn't happy in 0.16.2
183183#if MIN_VERSION_servant(0,17,0)
184184instance
185185 ( BuildFrom (IfLenient String mods captureType)
@@ -204,6 +204,7 @@ instance
204204 V.:& reifiedEndpointArguments @endpoint
205205
206206#endif
207+-- caching for merge
207208
208209instance
209210 ( BuildFrom (IfLenient String mods requestType)
src/Roboservant/Types/ReifiedApi/Server.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE PolyKinds #-}
4−{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE PolyKinds #-}
9−
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−{-# LANGUAGE CPP #-}
15−{-# LANGUAGE DataKinds #-}
16−{-# LANGUAGE TypeOperators #-}
17−{-# LANGUAGE FlexibleInstances #-}
18−{-# LANGUAGE MultiParamTypeClasses #-}
19−module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where
20−
21−import Servant
22−
23−import Control.Monad.Except (runExceptT)
24−import Data.Bifunctor
25−import Data.Dynamic (Dynamic)
26−import Data.List.NonEmpty (NonEmpty)
27−import Data.Typeable (Typeable)
28−import Roboservant.Types.Breakdown
29−import Roboservant.Types.ReifiedApi
30−
31−import qualified Data.Text as T
32−import qualified Data.Vinyl.Curry as V
33−import Data.Hashable(Hashable)
34−
35−type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]
36−
37−
38−class ToReifiedApi endpoints where
39− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
40−
41−instance ToReifiedApi '[] where
42− toReifiedApi NoEndpoints _ = []
43−
44−instance
45− ( NormalizeFunction (ServerT endpoint Handler)
46− , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
47− , ToReifiedEndpoint endpoint
48− , ToReifiedApi endpoints
49− ) =>
50− ToReifiedApi (endpoint : endpoints)
51− where
52− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
53− (0, ReifiedEndpoint
54− { reArguments = reifiedEndpointArguments @endpoint
55− , reEndpointFunc = normalize endpoint
56− }
57− )
58− : (map . first) (+1)
59− (toReifiedApi endpoints (Proxy @endpoints))
60−
61−
62−instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
63− type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))
64− normalize handler = (runExceptT . runHandler') handler >>= \case
65− Left serverError -> pure (Left (renderServerError serverError))
66− where
67− -- | TODO improve this
68− renderServerError :: ServerError -> InteractionError
69− renderServerError s = InteractionError (T.pack $ show s) (errHTTPCode serverError == 500)
70−
71− Right x -> pure $ Right $ breakdown x
72−
73−
74−-- case errHTTPCode serverError of
75−-- 500 -> throw serverError
76−-- _ ->
77−-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)
78−
79−
80−data Bundled endpoints where
81− -- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
82− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
83− NoEndpoints :: Bundled '[]
84−
85−class FlattenServer api where
86− flattenServer :: Server api -> Bundled (Endpoints api)
87−
88−instance
89− ( FlattenServer api,
90− Endpoints endpoint ~ '[endpoint]
91− ) =>
92− FlattenServer (endpoint :<|> api)
93− where
94− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
95−
96−instance
97− (
98− Endpoints api ~ '[api]
99− ) =>
100− FlattenServer (x :> api)
101− where
102− flattenServer server = server `AnEndpoint` NoEndpoints
103−
104−instance FlattenServer (Verb method statusCode contentTypes responseType)
105− where
106− flattenServer server = server `AnEndpoint` NoEndpoints
107−
108−class NormalizeFunction m where
109− type Normal m
110− normalize :: m -> Normal m
111−
112−instance NormalizeFunction x => NormalizeFunction (r -> x) where
113− type Normal (r -> x) = r -> Normal x
114− normalize = fmap normalize
stack.yaml+11−5
@@ -1,10 +1,16 @@
1−resolver: lts-20.4
1+# nb: 16.8 doesn't work because the version of servant is too old to have FoldLenient', fixme.
2+resolver: lts-16.16
23packages:
34- .
45
56extra-deps:
6−# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
7−# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
87- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
9−# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
10−- some-1.0.3
8+- vinyl-0.13.0
9+- dependent-sum-0.7.1.0
10+- constraints-extras-0.3.0.2
11+- dependent-map-0.4.0.0
12+
13+- servant-0.18.2
14+- servant-client-0.18.2
15+- servant-client-core-0.18.2
16+- servant-server-0.18.2
stack.yaml.lock+58−9
@@ -7,20 +7,69 @@ packages:
77- completed:
88 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
99 pantry-tree:
10− sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
1110 size: 325
11+ sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
1212 original:
1313 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
1414- completed:
15− hackage: some-1.0.3@sha256:938cec5fc0d3a08dde34cfc0acd5a0aa2e9fd489c9dbb64417f16588dfb47af0,2399
15+ hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724
16+ pantry-tree:
17+ size: 1857
18+ sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01
19+ original:
20+ hackage: vinyl-0.13.0
21+- completed:
22+ hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
23+ pantry-tree:
24+ size: 290
25+ sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50
26+ original:
27+ hackage: dependent-sum-0.7.1.0
28+- completed:
29+ hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
30+ pantry-tree:
31+ size: 594
32+ sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1
33+ original:
34+ hackage: constraints-extras-0.3.0.2
35+- completed:
36+ hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
37+ pantry-tree:
38+ size: 551
39+ sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5
40+ original:
41+ hackage: dependent-map-0.4.0.0
42+- completed:
43+ hackage: servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298
44+ pantry-tree:
45+ size: 2662
46+ sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2
47+ original:
48+ hackage: servant-0.18.2
49+- completed:
50+ hackage: servant-client-0.18.2@sha256:82578ade7468873259bb2fdc9d62290a0f998550900683e1410a237ed4b05410,4591
51+ pantry-tree:
52+ size: 1300
53+ sha256: 6324892c77bedbce32f0d6f1612fc2cb0d82c163d3be39efb951d3cc3792ce4a
54+ original:
55+ hackage: servant-client-0.18.2
56+- completed:
57+ hackage: servant-client-core-0.18.2@sha256:ad63ae0f227373fea7e547d4c2a7b0b69e112ff409a83cbadffc9f6ee049926f,3763
58+ pantry-tree:
59+ size: 1444
60+ sha256: 9e37bc5f8cbb70cf1accb20bd6f83fca4c2ca42472cd0fc4b22183c2c57cbe3b
61+ original:
62+ hackage: servant-client-core-0.18.2
63+- completed:
64+ hackage: servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482
1665 pantry-tree:
17− sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8
18− size: 709
66+ size: 2614
67+ sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c
1968 original:
20− hackage: some-1.0.3
69+ hackage: servant-server-0.18.2
2170snapshots:
2271- completed:
23− sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94
24− size: 648660
25− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml
26− original: lts-20.4
72+ size: 532380
73+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml
74+ sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e
75+ original: lts-16.16
test/Breakdown.hs+11−11
@@ -1,39 +1,36 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE DerivingStrategies #-}
4−
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE TypeOperators #-}
77
88module Breakdown where
99
1010import Data.Aeson
11−import Data.Hashable
1211import Data.Typeable (Typeable)
1312import GHC.Generics (Generic)
1413import Servant
14+import Data.Hashable
1515
1616data Foo = Foo Int String
1717 deriving (Generic, Eq, Show, Typeable)
1818
1919instance Hashable Foo
20−
2120instance ToJSON Foo
22−
2321instance FromJSON Foo
2422
23+
2524data SomeSum = A Int | B String
2625 deriving (Generic, Eq, Show, Typeable)
2726
2827instance Hashable SomeSum
29−
3028instance ToJSON SomeSum
31−
3229instance FromJSON SomeSum
3330
34−type ProductApi =
35− "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
36− :<|> "getFoo" :> Get '[JSON] Foo
31+
32+type ProductApi = "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
33+ :<|> "getFoo" :> Get '[JSON] Foo
3734
3835eliminate :: Int -> Handler ()
3936eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
@@ -41,10 +38,13 @@ eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
4138productServer :: Server ProductApi
4239productServer = eliminate :<|> pure (Foo 12 "abc")
4340
44−type SumApi =
45− "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
41+
42+type SumApi
43+ = "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
4644 :<|> "getFoo1" :> Get '[JSON] SomeSum
4745 :<|> "getFoo2" :> Get '[JSON] SomeSum
4846
47+
48+
4949sumServer :: Server SumApi
5050sumServer = eliminate :<|> pure (B "hi") :<|> pure (A 3)
test/Foo.hs+1−3
@@ -8,19 +8,17 @@
88module Foo where
99
1010import Data.Aeson
11−import Data.Hashable
1211import Data.Typeable (Typeable)
1312import GHC.Generics (Generic)
1413import Servant
14+import Data.Hashable
1515
1616newtype Foo = Foo Int
1717 deriving (Generic, Eq, Show, Typeable)
1818 deriving newtype (FromHttpApiData, ToHttpApiData)
1919
2020instance Hashable Foo
21−
2221instance ToJSON Foo
23−
2422instance FromJSON Foo
2523
2624type Api =
test/Headers.hs+3−4
@@ -8,19 +8,17 @@
88module Headers where
99
1010import Data.Aeson
11−import Data.Hashable
1211import Data.Typeable (Typeable)
1312import GHC.Generics (Generic)
1413import Servant
14+import Data.Hashable
1515
1616newtype Foo = Foo Int
1717 deriving (Generic, Eq, Show, Typeable)
1818 deriving newtype (FromHttpApiData, ToHttpApiData)
1919
2020instance Hashable Foo
21−
2221instance ToJSON Foo
23−
2422instance FromJSON Foo
2523
2624type Api =
@@ -35,7 +33,8 @@ combine :: Maybe Foo -> Maybe Foo -> Handler Foo
3533combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
3634combine (Just a) Nothing = pure a
3735combine Nothing (Just a) = pure a
38−combine Nothing Nothing = pure (Foo 1)
36+combine Nothing Nothing = pure (Foo 1)
37+
3938
4039eliminate :: Foo -> Handler ()
4140eliminate (Foo a)
test/Nested.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−
3−{-# LANGUAGE DerivingStrategies #-}
4−
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE TypeOperators #-}
7−
8−module Nested where
9−
10−import Servant
11−import Servant.API.Flatten
12−
13−type Api =
14− ( "one" :> Summary "foo" :> Post '[JSON] Int
15− :<|> "two" :> Post '[JSON] Int
16− )
17− :<|> ( "three" :> Post '[JSON] Int
18− )
19−
20−type FlatApi = Flat Api
21−
22−server :: Server FlatApi
23−server = pure 1 :<|> pure 2 :<|> pure 3
test/Post.hs+9−13
@@ -1,31 +1,27 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE DerivingStrategies #-}
4−
5−
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE TypeOperators #-}
77
88module Post where
99
10−import Data.Aeson
11−import Data.Hashable
1210import GHC.Generics (Generic)
1311import Servant
12+import Data.Aeson
13+import Data.Hashable
1414
15−type Api =
16− Get '[JSON] FooPost
17− :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
15+type Api = Get '[JSON] FooPost
16+ :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
1817
1918data FooPost = FooPost
20− deriving (Eq, Show, Generic)
19+ deriving (Eq,Show,Generic)
2120
2221instance Hashable FooPost
23−
2422instance ToJSON FooPost
25−
2623instance FromJSON FooPost
2724
2825server :: Server Api
29−server =
30− pure FooPost
31− :<|> const (pure ())
26+server = pure FooPost
27+ :<|> const (pure ())
test/Product.hs+2−4
@@ -1,25 +1,23 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE DerivingStrategies #-}
4−
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE TypeOperators #-}
77
88module Product where
99
1010import Data.Aeson
11−import Data.Hashable
1211import Data.Typeable (Typeable)
1312import GHC.Generics (Generic)
1413import Servant
14+import Data.Hashable
1515
1616data Foo = Foo Int String
1717 deriving (Generic, Eq, Show, Typeable)
1818
1919instance Hashable Foo
20−
2120instance ToJSON Foo
22−
2321instance FromJSON Foo
2422
2523type Api = "item" :> ReqBody '[JSON] Foo :> Post '[JSON] ()
test/Put.hsdeleted−33
@@ -1,33 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DerivingStrategies #-}
4−
5−
6−{-# LANGUAGE TypeOperators #-}
7−
8−module Put where
9−
10−import Data.Aeson
11−import Data.Hashable
12−import GHC.Generics (Generic)
13−import Servant
14−
15−type Api =
16− Get '[JSON] Foo
17− :<|> ReqBody '[JSON] Foo :> Put '[JSON] ()
18− :<|> ReqBody '[JSON] Foo :> Put '[JSON] NoContent
19−
20−data Foo = Foo
21− deriving (Eq, Show, Generic)
22−
23−instance Hashable Foo
24−
25−instance ToJSON Foo
26−
27−instance FromJSON Foo
28−
29−server :: Server Api
30−server =
31− pure Foo
32− :<|> const (pure ())
33− :<|> const (pure NoContent)
test/QueryParams.hsdeleted−15
@@ -1,15 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−
3−{-# LANGUAGE DerivingStrategies #-}
4−
5−
6−{-# LANGUAGE TypeOperators #-}
7−
8−module QueryParams where
9−
10−import Servant
11−
12−type Api = QueryParams "ints" Int :> Get '[JSON] [Int]
13−
14−server :: Server Api
15−server = pure
test/Seeded.hs+5−9
@@ -8,26 +8,22 @@
88module Seeded where
99
1010import Data.Aeson
11−import Data.Hashable
1211import Data.Typeable (Typeable)
1312import GHC.Generics (Generic)
1413import Servant
14+import Data.Hashable
1515
1616newtype Seed = Seed Int
1717 deriving (Generic, Eq, Show, Typeable)
1818 deriving newtype (FromHttpApiData, ToHttpApiData)
1919
2020instance ToJSON Seed
21−
2221instance FromJSON Seed
23−
2422instance Hashable Seed
2523
26−type Api =
27− Capture "seed" Seed :> Get '[JSON] ()
28− :<|> Get '[JSON] ()
24+type Api = Capture "seed" Seed :> Get '[JSON] ()
25+ :<|> Get '[JSON] ()
2926
3027server :: Server Api
31−server =
32− (\(Seed _) -> error "we blow up if we get here")
33− :<|> pure ()
28+server = (\(Seed _) -> error "we blow up if we get here")
29+ :<|> pure ()
test/Spec.hs+126−125
@@ -1,170 +1,171 @@
1−{-# LANGUAGE DerivingVia #-}
2−{-# LANGUAGE LambdaCase #-}
31{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE RecordWildCards #-}
52{-# LANGUAGE StandaloneDeriving #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE DerivingVia #-}
65{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE RankNTypes #-}
8−{-# LANGUAGE FlexibleContexts #-}
9−{-# LANGUAGE AllowAmbiguousTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE DataKinds #-}
12−{-# OPTIONS_GHC -fno-warn-orphans #-}
13−{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE DerivingVia #-}
148
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)
9+{-# OPTIONS_GHC -fno-warn-orphans #-}
2010import qualified Foo
11+import qualified Seeded
12+import qualified Valid
2113import qualified Headers
22−import qualified Nested
2314import qualified Post
24−import qualified Put
2515import qualified Product
26−import qualified QueryParams
27−import qualified Roboservant as R
28−import qualified Roboservant.Server as RS
29−import qualified Roboservant.Client as RC
30−import qualified Seeded
31−import Test.Hspec
32−import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
33−import qualified Valid
34−import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
16+import qualified Breakdown
3517
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((>=>))
18+import Test.Hspec.Core.Spec
19+
20+import Data.Dynamic(toDyn,Typeable,Dynamic)
21+import qualified Roboservant as RS
22+import Test.Hspec
23+import Data.Void
24+import Data.Maybe
25+import Data.Hashable
4126
4227main :: IO ()
4328main = hspec spec
4429
45−fuzzBoth
46− :: forall a .
47− (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
48− HasClient ClientM a)
49− => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
50−fuzzBoth name server config condition = do
51− it (name <> " via server") $
52− RS.fuzz @a server config >>= condition
53−
54− around (withServer (serve (Proxy :: Proxy a) server)) $
55− it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
56− RC.fuzz @a clientEnv config >>= condition
57−
58−withServer :: Application -> ActionWith ClientEnv -> IO ()
59−withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action)
60− where genClientEnv port = do
61− baseUrl <- parseBaseUrl "http://localhost"
62− manager <- newManager defaultManagerSettings
63− pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
30+noCheck :: IO ()
31+noCheck = pure ()
32+
33+defaultConfig :: RS.Config
34+defaultConfig = RS.Config
35+ { RS.seed = []
36+ , RS.maxRuntime = 0.5
37+ , RS.maxReps = 1000
38+ , RS.rngSeed = 0
39+ , RS.coverageThreshold = 0
40+ }
6441
6542spec :: Spec
6643spec = do
6744 describe "Basic usage" $ do
6845 describe "noError" $ do
69− fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
70− fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
71− fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
72− (\r ->
73− fmap (R.failureReason . R.rsException) r
74− `shouldSatisfy` ( \case
75− Just (R.InsufficientCoverage _) -> True
76− _ -> False
77− ))
78− describe "posted body" $
79− fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
80− (`shouldSatisfy` isNothing)
46+ it "finds no error in a valid app" $ do
47+ RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
48+ >>= (`shouldSatisfy` isNothing)
49+ it "finds no error in a valid generic app" $ do
50+ RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck
51+ >>= (`shouldSatisfy` isNothing)
52+
53+ it "does fail coverage check" $ do
54+ r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
55+ fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
56+ (\case
57+ Just (RS.InsufficientCoverage _) -> True
58+ _ -> False)
59+
60+ describe "posted body" $ do
61+ it "passes a coverage check using a posted body" $ do
62+ RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
63+ >>= (`shouldSatisfy` isNothing)
8164
65+ describe "seeded" $ do
66+ shouldFail $
67+ it "finds an error using information passed in" $
68+ let res = Seeded.Seed 1 in
69+ RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [(toDyn res,hash res) ] }) noCheck
70+ >>= (`shouldSatisfy` isNothing)
71+ describe "Foo" $ do
72+ it "finds an error in a basic app" $
73+ RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
74+ >>= (`shouldSatisfy` serverFailure)
8275
83− describe "PUTted body" $
84− fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}
85− (`shouldSatisfy` isNothing)
76+ describe "BuildFrom" $ do
77+ describe "headers (and sum types)" $ do
78+ it "should find a failure that's dependent on using header info" $ do
79+ RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
80+ >>= (`shouldSatisfy` serverFailure)
8681
82+ describe "product types" $ do
83+ it "should find a failure that's dependent on creating a product" $ do
84+ RS.fuzz @Product.Api Product.server defaultConfig { RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1::Int)]} noCheck
85+ >>= (`shouldSatisfy` serverFailure)
8786
88− describe "seeded" $ do
89− let res = Seeded.Seed 1
90− shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
91− (R.defaultConfig {R.seed = [(toDyn res, hash res)]})
92− (`shouldSatisfy` isNothing)
87+ describe "Breakdown" $ do
88+ it "handles products" $ do
89+ RS.fuzz @Breakdown.ProductApi Breakdown.productServer defaultConfig noCheck
90+ >>= (`shouldSatisfy` serverFailure)
9391
94− describe "Foo" $
95− fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
92+ it "handles sums" $ do
93+ RS.fuzz @Breakdown.SumApi Breakdown.sumServer defaultConfig noCheck
94+ >>= (`shouldSatisfy` serverFailure)
9695
97− describe "QueryParams" $
98− fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }
99− (`shouldSatisfy` isNothing)
10096
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)
109− describe "Breakdown" $ do
110− fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig
111− (`shouldSatisfy` serverFailure)
112− fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig
113− (`shouldSatisfy` serverFailure)
114− describe "flattening" $
115− fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}
116− (`shouldSatisfy` isNothing)
117−
118−serverFailure :: Maybe R.Report -> Bool
97+serverFailure :: Maybe RS.Report -> Bool
11998serverFailure = \case
120− Just R.Report {..} ->
121− let R.RoboservantException {..} = rsException
122− in failureReason /= R.NoPossibleMoves
99+ Just RS.Report{..} ->
100+ let RS.RoboservantException{..} = rsException
101+ in failureReason /= RS.NoPossibleMoves
123102 _ -> False
124103
125−deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
104+ -- describe "can build from pieces" $ do
105+ -- it "should find a failure that requires some assembly" $ do
106+ -- RS.fuzz @RS.BuildFrom.Api RS.BuildFrom.server defaultConfig noCheck
107+ -- >>= (`shouldSatisfy` isJust)
108+
109+
110+
111+ -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
112+ -- -- -- could: it's mostly here to show how to test for concurrency problems.
113+ -- describe "concurrency bugs" $ do
114+ -- before UnsafeIO.makeServer $ do
115+ -- describe "sequential checking" $ do
116+ -- it "safe use" $ \unsafeServer -> do
117+ -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
118+
119+ -- modifyMaxSuccess (const 10000) $
120+ -- shouldFail $
121+ -- describe "concurrent" $ do
122+ -- it "concurrent, dangerous use" $ \unsafeServer -> do
123+ -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
124+
125+
126+deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
127+deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
128+
129+deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
130+deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
131+
132+deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
133+deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
126134
127−deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
128135
129−deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
136+-- instance RS.BuildFrom Seeded.Seed
130137
131−deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
138+deriving via (RS.Atom Void) instance RS.BuildFrom Void
132139
133−deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
140+deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
141+deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
134142
135−deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
143+deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
144+deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
145+deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
136146
137−deriving via (R.Atom Void) instance R.BuildFrom Void
138147
139−deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
140−deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
141148
142−deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
143−deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
149+--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped
150+--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.Breakdown RS.BuildFrom.Wrapped
144151
145152
146153
147−deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
154+-- deriving via (RS.Atom Void) instance RS.BuildFrom Void
148155
149−deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
156+-- instance RS.Breakdown Post.FooPost
157+-- instance RS.BuildFrom Post.FooPost
150158
151−deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
152159
153160-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
154161-- this is often useful when testing tests.
155162shouldFail :: SpecWith a -> SpecWith a
156−shouldFail =
157− mapSpecItem_
158− ( \i ->
159− i
160− { itemExample = \p a cb -> do
161− r <- itemExample i p a cb
162− pure
163− r
164− { resultStatus = case resultStatus r of
165− Success -> Failure Nothing (Reason "Unexpected success")
166− Failure _ _ -> Success
167− x -> x
168− }
169− }
170− )
163+shouldFail = mapSpecItem_ (\i -> i {
164+ itemExample = \p a cb -> do
165+ r <- (itemExample i) p a cb
166+ pure r {resultStatus = case resultStatus r of
167+ Success -> Failure Nothing (Reason "Unexpected success")
168+ Failure _ _ -> Success
169+ x -> x
170+ }
171+ })
test/UnsafeIO.hs+15−13
@@ -1,39 +1,41 @@
11{-# LANGUAGE DataKinds #-}
2−
2+{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE DerivingStrategies #-}
4−
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE TypeOperators #-}
77
88module UnsafeIO where
99
10−import Control.Monad.Trans (MonadIO (liftIO))
11−import Data.Aeson ()
12−import qualified Data.ByteString.Lazy.Char8 as BL8
13−import Data.IORef (IORef, newIORef, readIORef, writeIORef)
10+import Data.Aeson()
1411import Servant
12+import Data.IORef (writeIORef, IORef, readIORef, newIORef)
13+import Control.Monad.Trans (MonadIO(liftIO))
14+import qualified Data.ByteString.Lazy.Char8 as BL8
15+
1516
1617type UnsafeApi =
1718 "add" :> Get '[JSON] ()
18− :<|> "healthcheck" :> Get '[JSON] ()
19+ :<|> "healthcheck" :> Get '[JSON] ()
1920
2021healthcheck :: IORef Int -> Handler ()
2122healthcheck ref = do
2223 t <- liftIO $ readIORef ref
2324 case t of
2425 0 -> pure ()
25− n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)}
26+ n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}
27+
28+
2629
2730makeServer :: IO (Server UnsafeApi)
2831makeServer = do
2932 ref <- newIORef 0
30− pure $
31− unsafeMunge ref
32− :<|> healthcheck ref
33+ pure $ unsafeMunge ref
34+ :<|> healthcheck ref
3335
3436unsafeMunge :: IORef Int -> Handler ()
3537unsafeMunge ref = liftIO $ do
3638 t <- readIORef ref
37− writeIORef ref (t + 1)
39+ writeIORef ref (t+1)
3840 t2 <- readIORef ref
39− writeIORef ref (t2 -1)
41+ writeIORef ref (t2-1)
test/Valid.hs+14−18
@@ -1,31 +1,28 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE DerivingStrategies #-}
4−
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE TypeOperators #-}
77
88module Valid where
99
10+import Servant
1011import Data.Void
1112import GHC.Generics
12−import Servant
13+import Servant.API.Generic
1314import Servant.Server.Generic
1415
15−type Api =
16− Get '[JSON] Int
17− :<|> Capture "void" Void :> Get '[JSON] ()
16+type Api = Get '[JSON] Int
17+ :<|> Capture "void" Void :> Get '[JSON] ()
1818
1919data Routes route
2020 = Routes
21− { getInt ::
22− route
23− :- Summary "i'm a summary!" :> Get '[JSON] Int,
24− captureIt ::
25− route
26− :- Capture "void" Void :> Get '[JSON] ()
27− }
28− deriving (Generic)
21+ { getInt :: route :-
22+ Get '[JSON] Int
23+ , captureIt :: route :-
24+ Capture "void" Void :> Get '[JSON] ()
25+ } deriving Generic
2926
3027type RoutedApi = ToServantApi Routes
3128
@@ -34,11 +31,10 @@ routedServer :: Server RoutedApi
3431routedServer = genericServer routes
3532
3633routes :: Routes AsServer
37−routes =
38− Routes
39− { getInt = pure 7,
40− captureIt = const (pure ())
41− }
34+routes = Routes
35+ { getInt = pure 7
36+ , captureIt = const (pure ())
37+ }
4238
4339server :: Server Api
4440server = pure 7 :<|> const (pure ())