git.iko.soy/roboservant
on master help sign in
swap
8ade8f357 ahead, 0 behind
.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+6−3
@@ -1,4 +1,4 @@
1−name: CI
1+name: Stack CI
2
2
3# Trigger the workflow on push or pull request, but only for the master branch
3# Trigger the workflow on push or pull request, but only for the master branch
4on:
4on:
@@ -12,13 +12,14 @@ jobs:
12 strategy:
12 strategy:
13 matrix:
13 matrix:
14 stack: ["2.3.3"]
14 stack: ["2.3.3"]
15− ghc: ["8.8.3"]
15+ ghc: ["8.10.4"]
16 os: [ubuntu-latest]
16 os: [ubuntu-latest]
17 steps:
17 steps:
18 - uses: actions/checkout@v2
18 - uses: actions/checkout@v2
19 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
19 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
20
20
21− - uses: actions/setup-haskell@v1.1
21+ - uses: actions/setup-haskell@v1.1.4
22+ if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
22 name: Setup Haskell Stack
23 name: Setup Haskell Stack
23 with:
24 with:
24 ghc-version: ${{ matrix.ghc }}
25 ghc-version: ${{ matrix.ghc }}
@@ -26,11 +27,13 @@ jobs:
26 enable-stack: true
27 enable-stack: true
27
28
28 - uses: actions/cache@v1
29 - uses: actions/cache@v1
30+ if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
29 name: Cache ~/.stack
31 name: Cache ~/.stack
30 with:
32 with:
31 path: ~/.stack
33 path: ~/.stack
32 key: ${{ runner.os }}-${{ matrix.ghc }}-stack
34 key: ${{ runner.os }}-${{ matrix.ghc }}-stack
33
35
34 - name: Test
36 - name: Test
37+ if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
35 run: |
38 run: |
36 stack test
39 stack test
EXAMPLE.mdnew file+143
@@ -0,0 +1,143 @@
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.lhsnew file+1
@@ -0,0 +1 @@
1+EXAMPLE.md
Makefile+3−1
@@ -1,2 +1,4 @@
1testwatch:
1testwatch:
2+ ghcid -T main -c 'stack repl roboservant:lib roboservant:test:roboservant-test --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
3+pedanticwatch:
2− ghcid -T main -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
4+ ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
README.md+87−23
@@ -2,45 +2,86 @@
2
2
3Automatically fuzz your servant apis in a contextually-aware way.
3Automatically fuzz your servant apis in a contextually-aware way.
4
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
8+## example
7
9
10+see full example [here](EXAMPLE.md)
11+
8−# why?
12+## why?
9
13
10Servant gives us a lot of information about what a server can do. We
14Servant gives us a lot of information about what a server can do. We
11use this information to generate arbitrarily long request/response
15use this information to generate arbitrarily long request/response
12sessions and verify properties that should hold over them.
16sessions and verify properties that should hold over them.
13
17
14−# example
18+## how?
15
19
16−Our api under test:
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.
17
25
18−```
26+We explicitly do not try to come up with plausible values that haven't
19−newtype Foo = Foo Int
27+somehow come back from the API. That's straying into QC/Hedgehog
20− deriving (Generic, Eq, Show, Typeable)
28+territory: if you want that, come up with the values on that side, and
21− deriving newtype (FromHttpApiData, ToHttpApiData)
29+set them as seeds in the configuration.
22−
30+
23−type FooApi =
31+### what does it mean to be "available"?
24− "item" :> Get '[JSON] Foo
32+
25− :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
33+In a simple API, you may make a call and get back a `Foo`, which will
26− :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
34+allow you to make another call that requires a `Foo`. In a more
27−```
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.
28
38
29−From the tests:
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.)
30
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
31```
53```
32− assert "should find an error in Foo" . not
54+
33− =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential @Foo.FooApi Foo.fooServer)])
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
34```
66```
35
67
36−We have a server that blows up if the value of the int in a `Foo` ever gets above 10. Note:
68+### priming the pump
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
41
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.
42
76
77+For those cases, override the `seed` in the `Config` with a
78+list of seed values, suitably hashed:
79+
80+``` haskell
81+defaultConfig { seed = [hashedDyn creds, hashedDyn userJwt]}
82+```
83+
43−# why not servant-quickcheck?
84+## why not servant-quickcheck?
44
85
45[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
86[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
46is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
87is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
@@ -48,3 +89,26 @@ there's a lot of the state space you just can't explore without context: modern
48full of pointer-like structures, whether they're URLs or database
89full of pointer-like structures, whether they're URLs or database
49keys/uuids, and servant-quickcheck requires that you be able to generate
90keys/uuids, and servant-quickcheck requires that you be able to generate
50these 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/README.mdnew file+30
@@ -0,0 +1,30 @@
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.shnew file+26
@@ -0,0 +1,26 @@
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/preludenew file+61
@@ -0,0 +1,61 @@
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.shnew file+10
@@ -0,0 +1,10 @@
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.shnew file+10
@@ -0,0 +1,10 @@
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+23−1
@@ -1,5 +1,6 @@
1+
1name: roboservant
2name: roboservant
2−version: 0.1.0.2
3+version: 0.1.0.3
3github: "mwotton/roboservant"
4github: "mwotton/roboservant"
4license: BSD3
5license: BSD3
5copyright: "2020 Mark Wotton, Samuel Schlesinger"
6copyright: "2020 Mark Wotton, Samuel Schlesinger"
@@ -17,6 +18,8 @@ dependencies:
17- bytestring
18- bytestring
18- containers
19- containers
19- random
20- random
21+- hashable
22+- http-types
20- lifted-base
23- lifted-base
21- monad-control
24- monad-control
22- mtl
25- mtl
@@ -28,6 +31,7 @@ dependencies:
28- vinyl
31- vinyl
29- dependent-sum
32- dependent-sum
30- dependent-map
33- dependent-map
34+- unordered-containers
31- text
35- text
32- time
36- time
33
37
@@ -52,3 +56,21 @@ tests:
52 - hspec
56 - hspec
53 - hspec-core
57 - hspec-core
54 - http-api-data
58 - http-api-data
59+ - http-client
60+ - hspec-wai
61+ - wai
62+ - warp
63+ example:
64+ main: Example.lhs
65+ source-dirs: .
66+
67+ dependencies:
68+ - roboservant
69+ - hspec
70+ - warp
71+ - http-client
72+ - aeson
73+ - hspec-core
74+ ghc-options: -pgmL markdown-unlit
75+
76+ build-tools: markdown-unlit
roboservant.cabal+64−5
@@ -1,13 +1,13 @@
1cabal-version: 1.12
1cabal-version: 1.12
2
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--
4--
5-- see: https://github.com/sol/hpack
5-- see: https://github.com/sol/hpack
6--
6--
7−-- hash: 134cfee817f86824342ecabc02ca2b48ec67539b75581c1954b95a9f9128e5a4
7+-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d
8
8
9name: roboservant
9name: roboservant
10−version: 0.1.0.2
10+version: 0.1.0.3
11synopsis: Automatic session-aware servant testing
11synopsis: Automatic session-aware servant testing
12description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
12description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
13category: Web
13category: Web
@@ -28,11 +28,17 @@ source-repository head
28library
28library
29 exposed-modules:
29 exposed-modules:
30 Roboservant
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.FlattenServer
36+ Roboservant.Types.BuildFrom
37+ Roboservant.Types.Config
38+ Roboservant.Types.Internal
39+ Roboservant.Types.Orphans
35 Roboservant.Types.ReifiedApi
40 Roboservant.Types.ReifiedApi
41+ Roboservant.Types.ReifiedApi.Server
36 other-modules:
42 other-modules:
37 Paths_roboservant
43 Paths_roboservant
38 hs-source-dirs:
44 hs-source-dirs:
@@ -44,6 +50,8 @@ library
44 , containers
50 , containers
45 , dependent-map
51 , dependent-map
46 , dependent-sum
52 , dependent-sum
53+ , hashable
54+ , http-types
47 , lifted-base
55 , lifted-base
48 , monad-control
56 , monad-control
49 , mtl
57 , mtl
@@ -55,17 +63,61 @@ library
55 , string-conversions
63 , string-conversions
56 , text
64 , text
57 , time
65 , time
66+ , unordered-containers
58 , vinyl
67 , vinyl
59 default-language: Haskell2010
68 default-language: Haskell2010
60
69
70+test-suite example
71+ type: exitcode-stdio-1.0
72+ main-is: Example.lhs
73+ other-modules:
74+ Paths_roboservant
75+ hs-source-dirs:
76+ ./
77+ ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit
78+ build-tool-depends:
79+ markdown-unlit:markdown-unlit
80+ build-depends:
81+ aeson
82+ , base >=4.7 && <5
83+ , bytestring
84+ , containers
85+ , dependent-map
86+ , dependent-sum
87+ , hashable
88+ , hspec
89+ , hspec-core
90+ , http-client
91+ , http-types
92+ , lifted-base
93+ , monad-control
94+ , mtl
95+ , random
96+ , roboservant
97+ , servant
98+ , servant-client
99+ , servant-flatten
100+ , servant-server
101+ , string-conversions
102+ , text
103+ , time
104+ , unordered-containers
105+ , vinyl
106+ , warp
107+ default-language: Haskell2010
108+
61test-suite roboservant-test
109test-suite roboservant-test
62 type: exitcode-stdio-1.0
110 type: exitcode-stdio-1.0
63 main-is: Spec.hs
111 main-is: Spec.hs
64 other-modules:
112 other-modules:
65− BuildFrom
113+ Breakdown
66 Foo
114 Foo
67 Headers
115 Headers
116+ Nested
68 Post
117 Post
118+ Product
119+ Put
120+ QueryParams
69 Seeded
121 Seeded
70 UnsafeIO
122 UnsafeIO
71 Valid
123 Valid
@@ -80,9 +132,13 @@ test-suite roboservant-test
80 , containers
132 , containers
81 , dependent-map
133 , dependent-map
82 , dependent-sum
134 , dependent-sum
135+ , hashable
83 , hspec
136 , hspec
84 , hspec-core
137 , hspec-core
138+ , hspec-wai
85 , http-api-data
139 , http-api-data
140+ , http-client
141+ , http-types
86 , lifted-base
142 , lifted-base
87 , monad-control
143 , monad-control
88 , mtl
144 , mtl
@@ -95,5 +151,8 @@ test-suite roboservant-test
95 , string-conversions
151 , string-conversions
96 , text
152 , text
97 , time
153 , time
154+ , unordered-containers
98 , vinyl
155 , vinyl
156+ , wai
157+ , warp
99 default-language: Haskell2010
158 default-language: Haskell2010
src/Roboservant.hs+6−3
@@ -1,5 +1,8 @@
1+module Roboservant
1−module Roboservant (module Roboservant.Direct
2+ ( module Roboservant.Direct,
2− ,module Roboservant.Types.Breakdown) where
3+ module Roboservant.Types,
4+ )
5+where
3
6
4import Roboservant.Direct
7import Roboservant.Direct
5−import Roboservant.Types.Breakdown
8+import 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+228−212
@@ -1,8 +1,5 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
7{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE PolyKinds #-}
@@ -10,72 +7,75 @@
10{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TupleSections #-}
9{-# LANGUAGE TupleSections #-}
13−{-# LANGUAGE TypeApplications #-}
14−{-# LANGUAGE TypeFamilies #-}
15
10
11+{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
17
13
18module Roboservant.Direct
14module Roboservant.Direct
15+ ( fuzz',
19− ( fuzz, Config(..)
16+ Config (..),
20−
21− -- TODO come up with something smarter than exporting all this, we should
17+ -- TODO come up with something smarter than exporting all this, we should
22− -- have some nice error-display functions
18+ -- have some nice error-display functions
23− , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
19+ RoboservantException (..),
20+ FuzzState (..),
21+ FuzzOp (..),
22+ FailureType (..),
23+ Report (..),
24 )
24 )
25where
25where
26
26
27−import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
27+import Control.Exception.Lifted
28+ ( Exception,
29+ Handler (Handler),
30+ SomeAsyncException,
31+ SomeException,
32+ catch,
33+ catches,
34+ handle,
35+ throw,
36+ )
28−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
37+import Control.Monad.State.Strict
29−import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
38+ ( MonadIO (..),
30−import Control.Monad(void,replicateM,forM_)
39+ MonadState (get),
31−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
40+ StateT (runStateT),
41+ modify',
42+ )
32−import Control.Monad.Trans.Control(MonadBaseControl)
43+import Control.Monad.Trans.Control (MonadBaseControl)
33−import Data.Dependent.Map (DMap)
34−import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
35−import Data.List.NonEmpty (NonEmpty(..))
36−import Data.Map.Strict(Map)
37−import qualified Data.Set as Set
38−import Data.Maybe (mapMaybe)
39−import Data.Typeable (TypeRep)
40−import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
41−import System.Random(StdGen,randomR,mkStdGen)
42−import qualified Data.List.NonEmpty as NEL
43−import qualified Data.Map.Strict as Map
44−import Data.Time.Clock
45−import Data.List(sortOn)
46−import Control.Arrow(second)
47−import System.Timeout.Lifted(timeout)
48−import GHC.Generics ((:*:)(..))
49−import qualified Data.Vinyl.Functor as V
50−import qualified Data.Vinyl.Curry as V
51import qualified Data.Dependent.Map as DM
44import qualified Data.Dependent.Map as DM
45+import Data.Dynamic (Dynamic (..))
52−import qualified Data.Vinyl as V
46+import qualified Data.IntSet as IntSet
47+import Data.List.NonEmpty (NonEmpty (..))
53import qualified Data.List.NonEmpty as NEL
48import qualified Data.List.NonEmpty as NEL
49+import Data.Maybe (mapMaybe)
54−import qualified Data.Map.Strict as Map
50+import qualified Data.Set as Set
55−import Data.Time.Clock
51+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
56−import qualified Type.Reflection as R
52+import qualified Data.Vinyl as V
57−
53+import qualified Data.Vinyl.Curry as V
58−import Roboservant.Types.Breakdown
54+import qualified Data.Vinyl.Functor as V
55+import GHC.Generics ((:*:) (..))
59import Roboservant.Types
56import Roboservant.Types
60 ( ApiOffset (..),
57 ( ApiOffset (..),
61− FlattenServer (..),
58+ Argument (..),
59+ InteractionError(..),
60+ Provenance (..),
62−-- ReifiedApi,
61+ ReifiedApi,
63− ToReifiedApi (..),
64−
65− ReifiedEndpoint(..),
62+ ReifiedEndpoint (..),
66− Argument(..),
63+ Stash (..),
64+ StashValue (..),
67− TypedF
65+ TypedF,
68−
69 )
66 )
67+import Roboservant.Types.Config
70
68
69+import System.Random (Random (randomR), StdGen, mkStdGen)
70+import qualified Type.Reflection as R
71
71
72data RoboservantException
72data RoboservantException
73 = RoboservantException
73 = RoboservantException
74− { failureReason :: FailureType
74+ { failureReason :: FailureType,
75− , serverException :: Maybe SomeException
75+ serverException :: Maybe SomeException,
76− , something :: Int
77− , fuzzState :: FuzzState
76+ fuzzState :: FuzzState
77+ }
78− } deriving (Show)
78+ deriving (Show)
79
79
80instance Exception RoboservantException
80instance Exception RoboservantException
81
81
@@ -84,212 +84,228 @@ data FailureType
84 | CheckerFailed
84 | CheckerFailed
85 | NoPossibleMoves
85 | NoPossibleMoves
86 | InsufficientCoverage Double
86 | InsufficientCoverage Double
87− deriving (Show,Eq)
87+ deriving (Show, Eq)
88−
88+
89−
90−data FuzzOp = FuzzOp
89+data FuzzOp
90+ = FuzzOp
91− { apiOffset :: ApiOffset
91+ { apiOffset :: ApiOffset,
92− , provenance :: [Provenance]
92+ provenance :: [Provenance]
93+ }
93− } deriving (Show,Eq)
94+ deriving (Show, Eq)
94−
95+
95−data Config
96+data FuzzState
96− = Config
97− { seed :: [Dynamic]
98− , maxRuntime :: Integer -- seconds to test for
99− , maxReps :: Integer
100− , rngSeed :: Int
101− , coverageThreshold :: Double
102− }
103−
104−data FuzzState = FuzzState
97+ = FuzzState
105− { path :: [FuzzOp]
98+ { path :: [FuzzOp],
106− , stash :: Stash
99+ stash :: Stash,
107− , currentRng :: StdGen
100+ currentRng :: StdGen
108− }
101+ }
109− deriving Show
102+ deriving (Show)
110
103
104+data EndpointOption
105+ = forall as.
111−data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption
106+ (V.RecordToList as, V.RMap as) =>
107+ EndpointOption
112− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
108+ { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
113− , eoArgs :: V.Rec (TypedF StashValue) as
109+ eoArgs :: V.Rec (TypedF StashValue) as
114− }
110+ }
115
111
116data StopReason
112data StopReason
117 = TimedOut
113 = TimedOut
118 | HitMaxIterations
114 | HitMaxIterations
119− deriving (Show,Eq)
115+ deriving (Show, Eq)
120
116
121−data Report = Report
117+data Report
118+ = Report
122− { textual :: String
119+ { textual :: String,
123− , rsException :: RoboservantException}
120+ rsException :: RoboservantException
121+ }
124 deriving (Show)
122 deriving (Show)
125
123
126−fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
124+
127− => Server api
125+
128− -> Config
126+-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
129− -> IO ()
127+-- fuzzClient = undefined
128+
129+
130+
131+fuzz' ::
132+ ReifiedApi ->
133+ Config ->
130− -> IO (Maybe Report)
134+ IO (Maybe Report)
131−fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
135+fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
132 let path = []
136 let path = []
133 stash = addToStash seed mempty
137 stash = addToStash seed mempty
134 currentRng = mkStdGen rngSeed
138 currentRng = mkStdGen rngSeed
135−
136−
137− deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
139+ deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime
138− (stopreason, fs ) <- runStateT
140+ (stopreason, _fs) <-
141+ runStateT
139− (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
142+ (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
143+ FuzzState {..}
140− print stopreason
144+ logInfo $ show stopreason
141 pure Nothing
145 pure Nothing
142 where
146 where
143 -- something less terrible later
147 -- something less terrible later
144 formatException :: RoboservantException -> Report
148 formatException :: RoboservantException -> Report
145− formatException r@(RoboservantException failureType exception _state) = Report
149+ formatException r@(RoboservantException failureType exception _state) =
150+ Report
146− (unlines [ show failureType , show exception ])
151+ (unlines [show failureType, show exception])
147− r
152+ r
148−
149− displayDiagnostics FuzzState{..} = liftIO $ do
153+ displayDiagnostics FuzzState {..} = liftIO $
154+ logInfo $ unlines $
150− putStrLn "api endpoints covered"
155+ ["api endpoints covered"]
151− mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
156+ <> (map show . Set.toList . Set.fromList $ map apiOffset path)
152− putStrLn ""
153− putStrLn "types in stash"
157+ <> ["", "types in stash"]
154− mapM_
158+ <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)
155− (print . second NEL.length)
159+ -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
156− (sortOn (show . fst) . Map.toList stash)
160+ -- $ \_k v ->
157−
161+ -- (show . NEL.length $ getStashValue v))
158− -- evaluateCoverage :: FuzzState -> m ()
162+
159− evaluateCoverage f@FuzzState{..}
163+ evaluateCoverage f@FuzzState {..}
160 | coverage > coverageThreshold = pure ()
164 | coverage > coverageThreshold = pure ()
161 | otherwise = do
165 | otherwise = do
162− displayDiagnostics f
166+ displayDiagnostics f
163− throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
167+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
168+ where
164− where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
169+ hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
165− totalRoutes = fromIntegral routeCount
170+ totalRoutes = fromIntegral routeCount
166− coverage = hitRoutes / totalRoutes
171+ coverage = hitRoutes / totalRoutes
167−
168−
169− untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
172+ untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
170− untilDone (0,_) _ = pure HitMaxIterations
173+ untilDone (0, _) _ = pure HitMaxIterations
171 untilDone (n, deadline) action = do
174 untilDone (n, deadline) action = do
172 now <- liftIO getCurrentTime
175 now <- liftIO getCurrentTime
173 if now > deadline
176 if now > deadline
174 then pure TimedOut
177 then pure TimedOut
175 else do
178 else do
176− action
179+ _ <- action
177− untilDone (n-1, deadline) action
180+ untilDone (n -1, deadline) action
178
181
179− reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
180 routeCount = length reifiedApi
182 routeCount = length reifiedApi
181−
183+ elementOrFail ::
182− elementOrFail :: (MonadState FuzzState m, MonadIO m)
184+ (MonadState FuzzState m, MonadIO m) =>
185+ [a] ->
183− => [a] -> m a
186+ m a
184− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
187+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
185 elementOrFail l = do
188 elementOrFail l = do
186 st <- get
189 st <- get
187− let (index,newGen) = randomR (0, length l - 1) (currentRng st)
190+ let (index, newGen) = randomR (0, length l - 1) (currentRng st)
188− modify' $ \st' -> st' { currentRng = newGen }
191+ modify' $ \st' -> st' {currentRng = newGen}
189 pure (l !! index)
192 pure (l !! index)
190−
193+ withOp ::
191− withOp :: (MonadState FuzzState m, MonadIO m)
194+ (MonadState FuzzState m, MonadIO m) =>
195+ ( forall as.
192− => (forall as. (V.RecordToList as, V.RMap as)
196+ (V.RecordToList as, V.RMap as) =>
193− => FuzzOp
197+ FuzzOp ->
194− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
198+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
195− -> V.Rec (TypedF V.Identity) as -> m r
199+ V.Rec (TypedF V.Identity) as ->
200+ m r
196− )
201+ ) ->
197− -> m r
202+ m r
198 withOp callback = do
203 withOp callback = do
199 -- choose a call to make, from the endpoints with fillable arguments.
204 -- choose a call to make, from the endpoints with fillable arguments.
200− (offset, EndpointOption{..}) <- elementOrFail . options =<< get
205+ (offset, EndpointOption {..}) <- elementOrFail . options =<< get
206+ r <-
201− r <- V.rtraverse
207+ V.rtraverse
202− (\(tr :*: StashValue svs) -> elementOrFail $
208+ ( \(tr :*: StashValue svs _) ->
209+ elementOrFail $
210+ zipWith
203− zipWith (\i xy -> V.Const i :*: tr :*: xy)
211+ (\i xy -> V.Const i :*: tr :*: xy)
204− [0..]
212+ [0 ..]
205− (NEL.toList svs)
213+ (NEL.toList svs)
206− )
214+ )
207− eoArgs
215+ eoArgs
208− let pathSegment = FuzzOp offset $
216+ let pathSegment =
217+ FuzzOp offset $
209− recordToList'
218+ recordToList'
210− (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
219+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
220+ r
221+ argValues =
222+ V.rmap
223+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
211 r
224 r
212− argValues = V.rmap
213− (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
214− r
215− modify' (\f -> f { path = path f <> [pathSegment] })
225+ modify' (\f -> f {path = path f <> [pathSegment]})
216 callback pathSegment eoCall argValues
226 callback pathSegment eoCall argValues
217 where
227 where
218 options :: FuzzState -> [(ApiOffset, EndpointOption)]
228 options :: FuzzState -> [(ApiOffset, EndpointOption)]
219− options FuzzState{..} =
229+ options FuzzState {..} =
220 mapMaybe
230 mapMaybe
221− ( \(offset, ReifiedEndpoint{..}) -> do
231+ ( \(offset, ReifiedEndpoint {..}) -> do
222− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
232+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
223− pure (offset, EndpointOption reEndpointFunc args)
233+ pure (offset, EndpointOption reEndpointFunc args)
224 )
234 )
225 reifiedApi
235 reifiedApi
226−
236+ execute ::
227− execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)
237+ (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
228− => FuzzOp
238+ FuzzOp ->
229− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
239+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
230− -> V.Rec (TypedF V.Identity) as
240+ V.Rec (TypedF V.Identity) as ->
231− -> m ()
241+ m ()
232 execute fuzzop func args = do
242 execute fuzzop func args = do
233− liftIO $ print fuzzop
243+ (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
234− st <- get
235− let showable = unlines $ ("args":map show argTypes)
236− <> ["fuzzop"
237− , show fuzzop
238− -- ,"dyncall"
239− -- ,show (dynTypeRep dyncall)
240− ,"state"
241− ,show st]
242− liftIO $ putStrLn showable
243 liftIO (V.runcurry' func argVals) >>= \case
244 liftIO (V.runcurry' func argVals) >>= \case
244− -- parameterise this
245+ Left (e::InteractionError) ->
245− Left (serverError :: ServerError) ->
246+ if fatalError e
246− case errHTTPCode serverError of
247+ then throw e
247− 500 -> throw serverError
248+ else pure ()
248− _ -> do
249− liftIO $ print ("ignoring non-500 error" , serverError)
250− Right (dyn :: NEL.NonEmpty Dynamic) -> do
249+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
251− liftIO $ print ("storing", fmap dynTypeRep dyn)
250+ modify'
252− modify' (\fs@FuzzState{..} ->
251+ ( \fs@FuzzState {..} ->
253− fs { stash = addToStash (NEL.toList dyn) stash } )
252+ fs {stash = addToStash (NEL.toList dyn) stash}
253+ )
254 where
254 where
255 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
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−
257+ go ::
258− go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
258+ (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
259− => m ()
259+ m ()
260 go = withOp $ \op func args -> do
260 go = withOp $ \op func args -> do
261+ catches
261− catches (execute op func args)
262+ (execute op func args)
262− [ Handler (\(e :: SomeAsyncException) -> throw e)
263+ [ Handler (\(e :: SomeAsyncException) -> throw e),
264+ Handler
263− , Handler (\(e :: SomeException) -> do
265+ ( \(e :: SomeException) ->
264− displayDiagnostics =<< get
265− throw . RoboservantException ServerCrashed (Just e) =<< get)
266+ throw . RoboservantException ServerCrashed (Just e) =<< get
267+ )
266 ]
268 ]
267− catch (liftIO checker)
269+ catch
270+ (liftIO healthCheck)
268− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
271+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
269−
272+
270−addToStash :: [Dynamic]
273+addToStash ::
271− -> Stash
274+ [(Dynamic, Int)] ->
275+ Stash ->
272− -> Stash
276+ Stash
273addToStash result stash =
277addToStash result stash =
278+ foldr
274− foldr (\(Dynamic tr x) (Stash dict) -> Stash $
279+ ( \(Dynamic tr x, hashed) (Stash dict) ->
280+ Stash $
281+ DM.insertWith
282+ renumber
283+ tr
275− DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict
284+ (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))
285+ dict
276 )
286 )
277 stash
287 stash
278 result
288 result
279 where
289 where
290+ renumber ::
280− renumber :: StashValue a
291+ StashValue a ->
281− -> StashValue a
292+ StashValue a ->
282− -> StashValue a
293+ StashValue a
283− renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
294+ renumber (StashValue singleDyn singleHash) orig@(StashValue l intSet)
295+ | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
296+ | otherwise =
297+ StashValue
298+ ( case NEL.toList singleDyn of
284− [([Provenance tr _], dyn)] -> l
299+ [([Provenance tr _], dyn)] ->
285− <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
300+ l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
286− _ -> error "should be impossible"
301+ _ -> error "should be impossible"
287−
302+ )
303+ (IntSet.union singleHash intSet)
288
304
289-- why isn't this in vinyl?
305-- why isn't this in vinyl?
290−recordToList'
306+recordToList' ::
291− :: (V.RecordToList as, V.RMap as)
307+ (V.RecordToList as, V.RMap as) =>
292− => (forall x. f x -> a)
308+ (forall x. f x -> a) ->
293− -> V.Rec f as
309+ V.Rec f as ->
294− -> [a]
310+ [a]
295recordToList' f = V.recordToList . V.rmap (V.Const . f)
311recordToList' f = V.recordToList . V.rmap (V.Const . f)
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+11−10
@@ -2,24 +2,25 @@
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE StandaloneDeriving #-}
10−{-# LANGUAGE TupleSections #-}
11−{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
8{-# LANGUAGE UndecidableInstances #-}
15
9
16module Roboservant.Types
10module Roboservant.Types
17− ( module Roboservant.Types.Breakdown
11+ ( module Roboservant.Types.Breakdown,
12+ module Roboservant.Types.BuildFrom,
18− , module Roboservant.Types.FlattenServer
13+ module Roboservant.Types.ReifiedApi,
14+ module Roboservant.Types.ReifiedApi.Server,
15+ module Roboservant.Types.Internal,
19− , module Roboservant.Types.ReifiedApi
16+ module Roboservant.Types.Config,
20 )
17 )
21where
18where
22
19
23import Roboservant.Types.Breakdown
20import Roboservant.Types.Breakdown
24−import Roboservant.Types.FlattenServer
21+import Roboservant.Types.BuildFrom
22+import Roboservant.Types.Config
23+import Roboservant.Types.Internal
25import Roboservant.Types.ReifiedApi
24import Roboservant.Types.ReifiedApi
25+import Roboservant.Types.ReifiedApi.Server
26+import Roboservant.Types.Orphans()
src/Roboservant/Types/Breakdown.hs+46−84
@@ -1,119 +1,81 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE DerivingVia #-}
4{-# LANGUAGE DerivingVia #-}
4−{-# LANGUAGE StandaloneDeriving #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE DefaultSignatures #-}
8−{-# LANGUAGE DeriveFunctor #-}
9−{-# LANGUAGE DerivingStrategies #-}
10{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
11{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
12−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
14{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
15{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
16{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
17−{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE StandaloneDeriving #-}
18{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
20
15
21module Roboservant.Types.Breakdown where
16module Roboservant.Types.Breakdown where
22
17
23−import Data.Dynamic (Dynamic, fromDynamic, toDyn)
18+import Data.Dynamic (Dynamic)
19+import Data.Hashable
20+import Data.Kind
24−import Data.List.NonEmpty (NonEmpty(..))
21+import Data.List.NonEmpty (NonEmpty (..))
25import qualified Data.List.NonEmpty as NEL
22import qualified Data.List.NonEmpty as NEL
26−import qualified Data.Map.Strict as Map
27−import Data.Maybe (fromMaybe)
28−import Data.Proxy (Proxy (..))
29−import Data.Typeable (TypeRep, Typeable, typeRep)
30−import GHC.Generics(Generic)
31−import qualified GHC.Generics as Generics
32import Data.Typeable (Typeable)
23import Data.Typeable (Typeable)
33−import qualified Data.Dependent.Map as DM
24+import GHC.Generics
34−import Data.Dependent.Map (DMap)
25+import Roboservant.Types.Internal
35−import qualified Type.Reflection as R
26+import Servant
36−import Data.Dependent.Sum
27+import Roboservant.Types.Orphans()
37−import Data.Kind
38
28
39−data Provenance
29+breakdown ::
40− = Provenance R.SomeTypeRep Int
30+ (Hashable x, Typeable x, Breakdown x) =>
41− deriving (Show,Eq)
31+ x ->
32+ NonEmpty (Dynamic, Int)
33+breakdown x = hashedDyn x :| breakdownExtras x
42
34
43class Breakdown x where
35class Breakdown x where
44− breakdown :: x -> NonEmpty Dynamic
36+ breakdownExtras :: x -> [(Dynamic, Int)]
45−-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
46−-- breakdown = pure . toDyn
47−
48−
49−-- | Can't be built up from parts
50−newtype Atom x = Atom { unAtom :: x }
51
37
52−-- | can be broken down and built up from generic pieces
38+instance (Hashable x, Typeable x) => Breakdown (Atom x) where
53−newtype Compound x = Compound { unCompound :: x }
39+ breakdownExtras _ = []
54
40
55−-- | so, this is quite tricky. we need to witness the structure of `x`, but
56−-- we don't have an example of it yet. not entirely sure where to go.
57−instance (Typeable x, Generic x) => BuildFrom (Compound x) where
58− buildFrom stash = error "oops"
59−-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from
60−
61−-- | this should be a bit more tractable.
62−instance (Typeable x, Generic x) => Breakdown (Compound x) where
41+deriving via (Atom ()) instance Breakdown ()
63− breakdown x = _ . Generics.from . unCompound $ x
64−
65−instance Typeable x => BuildFrom (Atom x) where
66− buildFrom = Map.lookup (typeRep (Proxy @x))
67−
68−newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }
69− deriving (Functor, Show)
70
42
71−-- wrap in newtype to give a custom Show instance, since the normal
43+deriving via (Atom Int) instance Breakdown Int
72−-- instance for DMap is not happy since StashValue needs Show a to show
44+deriving via (Atom Char) instance Breakdown Char
73−newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
74− deriving (Semigroup, Monoid)
75
45
76−instance Show Stash where
46+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x)
77− showsPrec i (Stash x) = showsPrec i $
78− Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
79
47
80−class Typeable x => BuildFrom (x :: Type) where
48+instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where
81− buildFrom :: Stash -> Maybe (StashValue x)
49+ breakdownExtras stash = concatMap (NEL.toList . breakdown) stash
82− default buildFrom :: Stash -> Maybe (StashValue x)
83− buildFrom = DM.lookup R.typeRep . getStash
84
50
85− -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))
86
51
52+class GBreakdown (f :: k -> Type) where
53+ gBreakdownExtras :: f a -> [(Dynamic, Int)]
87
54
88−-- baseLookup :: TypeRep -> Stash -> Maybe (NonEmpty ([Provenance], Dynamic))
55+instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where
89−-- baseLookup tr mmm = -- Map.lookup (typeRep (Proxy @x)) mmm
56+ breakdownExtras = gBreakdownExtras . from . unCompound
90−-- Map.lookup tr mmm
91
57
92−-- | only use this when we are using the internal typerep map.
58+instance GBreakdown f => GBreakdown (M1 S c f) where
93−promisedDyn :: Typeable a => Dynamic -> a
59+ gBreakdownExtras (M1 f) = gBreakdownExtras f
94−promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
95
60
96−-- instance BuildFrom Bool
61+instance GBreakdown b => GBreakdown (M1 D a b) where
97−deriving via (Atom Bool) instance BuildFrom Bool
62+ gBreakdownExtras (M1 f) = gBreakdownExtras f
98
63
99−instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
64+instance GBreakdown b => GBreakdown (M1 C a b) where
100− buildFrom dict = Just options
65+ gBreakdownExtras (M1 f) = gBreakdownExtras f
101− where options :: StashValue (Maybe x)
102− options = StashValue $
103− ([],Nothing) :|
104− (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict
105− )
106
66
107−deriving via (Atom ()) instance Breakdown ()
67+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :*: b) where
108−deriving via (Atom Int) instance Breakdown Int
68+ gBreakdownExtras (a :*: b) = gBreakdownExtras a <> gBreakdownExtras b
109
69
110−instance Typeable a => Breakdown (Atom a) where
70+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where
111− breakdown = pure . toDyn . unAtom
71+ gBreakdownExtras = \case
72+ L1 a -> gBreakdownExtras a
73+ R1 a -> gBreakdownExtras a
112
74
75+instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where
76+ gBreakdownExtras (K1 c) = NEL.toList $ breakdown c
113
77
114−instance (Typeable a, Breakdown a) => Breakdown [a] where
78+instance GBreakdown U1 where
115− breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
79+ gBreakdownExtras U1 = []
116
80
117−instance (BuildFrom a) => BuildFrom [a] where
81+deriving via (Atom NoContent) instance Breakdown NoContent
118− buildFrom = error "fuuuck"
119−--- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
src/Roboservant/Types/BuildFrom.hsnew file+107
@@ -0,0 +1,107 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+module Roboservant.Types.BuildFrom where
14+
15+import Data.List(nub)
16+import qualified Data.Dependent.Map as DM
17+import Data.Hashable
18+import qualified Data.IntSet as IntSet
19+import Data.Kind
20+import Data.List.NonEmpty (NonEmpty (..))
21+import qualified Data.List.NonEmpty as NEL
22+import Data.Typeable (Typeable)
23+import GHC.Generics
24+import Roboservant.Types.Internal
25+import qualified Type.Reflection as R
26+import Servant(NoContent)
27+import Roboservant.Types.Orphans()
28+
29+buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
30+buildFrom = buildStash . buildFrom'
31+ where
32+ buildStash :: [([Provenance], x)] -> Maybe (StashValue x)
33+ buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty
34+ promoteToStash :: ([Provenance], x) -> StashValue x
35+ promoteToStash (p, x) =
36+ StashValue
37+ (pure (p, x))
38+ (IntSet.singleton (hash x))
39+ addStash :: StashValue x -> StashValue x -> StashValue x
40+ addStash old (StashValue newVal _) =
41+ let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal
42+ in StashValue
43+ (addListToNE (getStashValue old) insertableVals)
44+ (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))
45+ addListToNE :: NonEmpty a -> [a] -> NonEmpty a
46+ addListToNE ne l = NEL.fromList (NEL.toList ne <> l)
47+
48+buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]
49+buildFrom' stash =
50+ maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))
51+ <> extras stash
52+
53+class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
54+ extras :: Stash -> [([Provenance], x)]
55+
56+instance (Hashable x, Typeable x) => BuildFrom (Atom x) where
57+ extras _ = []
58+
59+deriving via (Atom Bool) instance BuildFrom Bool
60+
61+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)
62+
63+-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
64+-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
65+instance (Eq x, BuildFrom x) => BuildFrom [x] where
66+ extras stash =
67+ nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash
68+ where
69+ -- powerset creates way too much stuff. something better here eventually.
70+ notpowerset xs = []:xs:map pure xs
71+
72+
73+instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where
74+ extras stash = fmap (Compound . to) <$> gExtras stash
75+
76+deriving via (Atom Int) instance BuildFrom Int
77+
78+deriving via (Atom Char) instance BuildFrom Char
79+
80+class GBuildFrom (f :: k -> Type) where
81+ gExtras :: Stash -> [([Provenance], f a)]
82+
83+instance GBuildFrom b => GBuildFrom (M1 D a b) where
84+ gExtras = fmap (fmap M1) . gExtras
85+
86+-- not recursion safe!
87+instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
88+ gExtras stash =
89+ (fmap L1 <$> gExtras stash)
90+ <> (fmap R1 <$> gExtras stash)
91+
92+instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
93+ gExtras stash = [(pa <> pb, a' :*: b') | (pa, a') <- gExtras stash, (pb, b') <- gExtras stash]
94+
95+instance GBuildFrom b => GBuildFrom (M1 C a b) where
96+ gExtras = fmap (fmap M1) . gExtras
97+
98+instance GBuildFrom b => GBuildFrom (M1 S a b) where
99+ gExtras = fmap (fmap M1) . gExtras
100+
101+instance BuildFrom a => GBuildFrom (K1 i a) where
102+ gExtras = fmap (fmap K1) . buildFrom'
103+
104+instance GBuildFrom U1 where
105+ gExtras _ = [([], U1)]
106+
107+deriving via (Atom NoContent) instance BuildFrom NoContent
src/Roboservant/Types/Config.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−45
@@ -1,45 +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−
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.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+
6+module Roboservant.Types.Internal where
7+
8+import qualified Data.Dependent.Map as DM
9+import Data.Dependent.Map (DMap)
10+import Data.Dependent.Sum
11+import Data.Dynamic (Dynamic, toDyn)
12+import Data.Hashable (Hashable, hash)
13+import Data.IntSet (IntSet)
14+import Data.List.NonEmpty (NonEmpty (..))
15+import qualified Data.Map.Strict as Map
16+import Data.Typeable (Typeable)
17+import GHC.Generics (Generic)
18+import qualified Type.Reflection as R
19+
20+data Provenance
21+ = Provenance R.SomeTypeRep Int
22+ deriving (Show, Eq, Generic)
23+
24+instance Hashable Provenance
25+
26+data StashValue a
27+ = StashValue
28+ { getStashValue :: NonEmpty ([Provenance], a),
29+ stashHash :: IntSet
30+ }
31+ deriving (Functor, Show)
32+
33+-- wrap in newtype to give a custom Show instance, since the normal
34+-- instance for DMap is not happy since StashValue needs Show a to show
35+newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}
36+ deriving (Semigroup, Monoid)
37+
38+instance Show Stash where
39+ showsPrec i (Stash x) =
40+ showsPrec i
41+ $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))
42+ $ DM.toList x
43+
44+-- | Can't be built up from parts, can't be broken down further.
45+newtype Atom x = Atom {unAtom :: x}
46+ deriving newtype (Hashable, Typeable,Eq)
47+
48+-- | can be broken down and built up from generic pieces
49+newtype Compound x = Compound {unCompound :: x}
50+ deriving newtype (Hashable, Typeable, Eq)
51+
52+hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)
53+hashedDyn a = (toDyn a, hash a)
src/Roboservant/Types/Orphans.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+73−56
@@ -1,3 +1,7 @@
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.
1
5
2{-# LANGUAGE AllowAmbiguousTypes #-}
6{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
7{-# LANGUAGE DataKinds #-}
@@ -8,37 +12,31 @@
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
12{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE PolyKinds #-}
14{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE TupleSections #-}
15{-# LANGUAGE TypeApplications #-}
16{-# LANGUAGE TypeApplications #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE UndecidableInstances #-}
19−
20+{-# LANGUAGE CPP #-}
20module Roboservant.Types.ReifiedApi where
21module Roboservant.Types.ReifiedApi where
21
22
22−
23−import Control.Monad.Except (runExceptT)
24−import Data.Bifunctor
25−-- import Data.Dependent.Sum
26import Data.Dynamic (Dynamic)
23import Data.Dynamic (Dynamic)
27−import Data.Kind
24+import Control.Exception(Exception)
28import Data.List.NonEmpty (NonEmpty)
25import Data.List.NonEmpty (NonEmpty)
29import Data.Typeable (Typeable)
26import Data.Typeable (Typeable)
30import GHC.Generics ((:*:)(..))
27import GHC.Generics ((:*:)(..))
31−import GHC.TypeLits (Symbol)
28+import Roboservant.Types.Internal
32import Roboservant.Types.Breakdown
29import Roboservant.Types.Breakdown
33−import Roboservant.Types.FlattenServer
30+import Roboservant.Types.BuildFrom
31+import Data.Kind(Type)
34import Servant
32import Servant
35import Servant.API.Modifiers(FoldRequired,FoldLenient)
33import Servant.API.Modifiers(FoldRequired,FoldLenient)
34+import GHC.TypeLits (Symbol)
36import qualified Data.Text as T
35import qualified Data.Text as T
37import qualified Data.Vinyl as V
36import qualified Data.Vinyl as V
38import qualified Data.Vinyl.Curry as V
37import qualified Data.Vinyl.Curry as V
39import qualified Type.Reflection as R
38import qualified Type.Reflection as R
40
39
41−
42newtype ApiOffset = ApiOffset Int
40newtype ApiOffset = ApiOffset Int
43 deriving (Eq, Show, Ord)
41 deriving (Eq, Show, Ord)
44 deriving newtype (Enum, Num)
42 deriving newtype (Enum, Num)
@@ -51,60 +49,32 @@ newtype Argument a = Argument
51
49
52data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
50data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
53 { reArguments :: V.Rec (TypedF Argument) as
51 { reArguments :: V.Rec (TypedF Argument) as
54− , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
52+ , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
55 }
53 }
56
54
57−type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
55+instance Show ReifiedEndpoint where
58−
56+ show _ = "lol"
59−tagType :: Typeable a => f a -> TypedF f a
60−tagType = (R.typeRep :*:)
61−
62−class ToReifiedApi (endpoints :: [*]) where
63− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
64
57
65−class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint
66− , V.RecordToList (EndpointArgs endpoint)
58+class ( V.RecordToList (EndpointArgs endpoint)
67 , V.RMap (EndpointArgs endpoint)
59 , V.RMap (EndpointArgs endpoint)
68− ) => ToReifiedEndpoint (endpoint :: *) where
60+ ) => ToReifiedEndpoint (endpoint :: Type) where
69 type EndpointArgs endpoint :: [Type]
61 type EndpointArgs endpoint :: [Type]
70 type EndpointRes endpoint :: Type
62 type EndpointRes endpoint :: Type
71
63
72 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
64 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
73
65
74−instance ToReifiedApi '[] where
75− toReifiedApi NoEndpoints _ = []
76
66
77−instance
67+tagType :: Typeable a => f a -> TypedF f a
78− ( Typeable (EndpointRes endpoint)
68+tagType = (R.typeRep :*:)
79− , NormalizeFunction (ServerT endpoint Handler)
69+
80− , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty Dynamic)))
70+data InteractionError = InteractionError
81− , ToReifiedEndpoint endpoint
71+ { errorMessage :: T.Text
82− , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)
72+ , fatalError :: Bool
83− ) =>
84− ToReifiedApi (endpoint : endpoints)
85− where
86− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
87− (0, ReifiedEndpoint
88− { reArguments = reifiedEndpointArguments @endpoint
89− , reEndpointFunc = normalize endpoint
90− }
73+ }
91− )
74+ deriving Show
92− : (map . first) (+1)
75+instance Exception InteractionError
93− (toReifiedApi endpoints (Proxy @endpoints))
76+
94−
77+
95−class NormalizeFunction m where
96− type Normal m
97− normalize :: m -> Normal m
98−
99−instance NormalizeFunction x => NormalizeFunction (r -> x) where
100− type Normal (r -> x) = r -> Normal x
101− normalize = fmap normalize
102−
103−instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
104− type Normal (Handler x) = IO (Either ServerError (NonEmpty Dynamic))
105− normalize handler = (runExceptT . runHandler') handler >>= \case
106− Left serverError -> pure (Left serverError)
107− Right x -> pure $ Right $ breakdown x
108
78
109instance
79instance
110 (Typeable responseType, Breakdown responseType) =>
80 (Typeable responseType, Breakdown responseType) =>
@@ -114,6 +84,12 @@ instance
114 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
84 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
115 reifiedEndpointArguments = V.RNil
85 reifiedEndpointArguments = V.RNil
116
86
87+instance ToReifiedEndpoint (NoContentVerb method)
88+ where
89+ type EndpointArgs (NoContentVerb method) = '[]
90+ type EndpointRes (NoContentVerb method) = NoContent
91+ reifiedEndpointArguments = V.RNil
92+
117instance
93instance
118 (ToReifiedEndpoint endpoint) =>
94 (ToReifiedEndpoint endpoint) =>
119 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
95 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
@@ -122,6 +98,16 @@ instance
122 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
98 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
123 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
124
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+
125instance
111instance
126 (ToReifiedEndpoint endpoint) =>
112 (ToReifiedEndpoint endpoint) =>
127 ToReifiedEndpoint (Description s :> endpoint)
113 ToReifiedEndpoint (Description s :> endpoint)
@@ -165,6 +151,23 @@ instance
165 V.:& reifiedEndpointArguments @endpoint
151 V.:& reifiedEndpointArguments @endpoint
166
152
167
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+
168instance
171instance
169 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
170 , ToReifiedEndpoint endpoint
173 , ToReifiedEndpoint endpoint
@@ -177,6 +180,7 @@ instance
177 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
180 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
178 V.:& reifiedEndpointArguments @endpoint
181 V.:& reifiedEndpointArguments @endpoint
179
182
183+#if MIN_VERSION_servant(0,17,0)
180instance
184instance
181 ( BuildFrom (IfLenient String mods captureType)
185 ( BuildFrom (IfLenient String mods captureType)
182 , ToReifiedEndpoint endpoint) =>
186 , ToReifiedEndpoint endpoint) =>
@@ -187,6 +191,19 @@ instance
187 reifiedEndpointArguments =
191 reifiedEndpointArguments =
188 tagType (Argument (buildFrom @(IfLenient String mods captureType)))
192 tagType (Argument (buildFrom @(IfLenient String mods captureType)))
189 V.:& reifiedEndpointArguments @endpoint
193 V.:& reifiedEndpointArguments @endpoint
194+#else
195+instance
196+ ( BuildFrom captureType
197+ , ToReifiedEndpoint endpoint) =>
198+ ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
199+ where
200+ type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint
201+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
202+ reifiedEndpointArguments =
203+ tagType (Argument (buildFrom @(captureType)))
204+ V.:& reifiedEndpointArguments @endpoint
205+
206+#endif
190
207
191instance
208instance
192 ( BuildFrom (IfLenient String mods requestType)
209 ( BuildFrom (IfLenient String mods requestType)
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−5
@@ -1,10 +1,10 @@
1−resolver: lts-16.8 #lts-16.16
1+resolver: lts-20.4
2packages:
2packages:
3- .
3- .
4
4
5extra-deps:
5extra-deps:
6+# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
7+# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
6- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
7−- vinyl-0.13.0
9+# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
8−- dependent-sum-0.7.1.0
10+- some-1.0.3
9−- constraints-extras-0.3.0.2
10−- dependent-map-0.4.0.0
stack.yaml.lock+9−58
@@ -7,69 +7,20 @@ packages:
7- completed:
7- completed:
8 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
9 pantry-tree:
9 pantry-tree:
10− size: 325
11 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
10 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
11+ size: 325
12 original:
12 original:
13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
14- completed:
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:4cac20d0b0d889a5613a95ec18526afd16abcaf0b4b7ba5fed35c7bf85800162,3638
58− pantry-tree:
59− size: 1444
60− sha256: 90279e27ba5a7f8f4f1761e81d0dded343839316fdbf34d395954487701e29df
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: 532380
24+ size: 648660
73− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml
25+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml
74− sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e
75− original: lts-16.16
26+ original: lts-20.4
test/Breakdown.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Breakdown where
9+
10+import Data.Aeson
11+import Data.Hashable
12+import Data.Typeable (Typeable)
13+import GHC.Generics (Generic)
14+import Servant
15+
16+data Foo = Foo Int String
17+ deriving (Generic, Eq, Show, Typeable)
18+
19+instance Hashable Foo
20+
21+instance ToJSON Foo
22+
23+instance FromJSON Foo
24+
25+data SomeSum = A Int | B String
26+ deriving (Generic, Eq, Show, Typeable)
27+
28+instance Hashable SomeSum
29+
30+instance ToJSON SomeSum
31+
32+instance FromJSON SomeSum
33+
34+type ProductApi =
35+ "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
36+ :<|> "getFoo" :> Get '[JSON] Foo
37+
38+eliminate :: Int -> Handler ()
39+eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
40+
41+productServer :: Server ProductApi
42+productServer = eliminate :<|> pure (Foo 12 "abc")
43+
44+type SumApi =
45+ "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
46+ :<|> "getFoo1" :> Get '[JSON] SomeSum
47+ :<|> "getFoo2" :> Get '[JSON] SomeSum
48+
49+sumServer :: Server SumApi
50+sumServer = eliminate :<|> pure (B "hi") :<|> pure (A 3)
test/Foo.hs+3
@@ -8,6 +8,7 @@
8module Foo where
8module Foo where
9
9
10import Data.Aeson
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
@@ -16,6 +17,8 @@ newtype Foo = Foo Int
16 deriving (Generic, Eq, Show, Typeable)
17 deriving (Generic, Eq, Show, Typeable)
17 deriving newtype (FromHttpApiData, ToHttpApiData)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
18
19
20+instance Hashable Foo
21+
19instance ToJSON Foo
22instance ToJSON Foo
20
23
21instance FromJSON Foo
24instance FromJSON Foo
test/Headers.hs+4−2
@@ -8,6 +8,7 @@
8module Headers where
8module Headers where
9
9
10import Data.Aeson
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
@@ -16,6 +17,8 @@ newtype Foo = Foo Int
16 deriving (Generic, Eq, Show, Typeable)
17 deriving (Generic, Eq, Show, Typeable)
17 deriving newtype (FromHttpApiData, ToHttpApiData)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
18
19
20+instance Hashable Foo
21+
19instance ToJSON Foo
22instance ToJSON Foo
20
23
21instance FromJSON Foo
24instance FromJSON Foo
@@ -32,8 +35,7 @@ combine :: Maybe Foo -> Maybe Foo -> Handler Foo
32combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
35combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
33combine (Just a) Nothing = pure a
36combine (Just a) Nothing = pure a
34combine Nothing (Just a) = pure a
37combine Nothing (Just a) = pure a
35−combine Nothing Nothing = pure (Foo 1)
38+combine Nothing Nothing = pure (Foo 1)
36−
37
39
38eliminate :: Foo -> Handler ()
40eliminate :: Foo -> Handler ()
39eliminate (Foo a)
41eliminate (Foo a)
test/Nested.hsnew file+23
@@ -0,0 +1,23 @@
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+14−8
@@ -1,25 +1,31 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5−{-# LANGUAGE OverloadedStrings #-}
5+
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module Post where
8module Post where
9
9
10+import Data.Aeson
11+import Data.Hashable
10import GHC.Generics (Generic)
12import GHC.Generics (Generic)
11import Servant
13import Servant
12−import Data.Aeson
13
14
15+type Api =
14−type Api = Get '[JSON] FooPost
16+ Get '[JSON] FooPost
15− :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
17+ :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
16
18
17data FooPost = FooPost
19data FooPost = FooPost
18− deriving (Eq,Show,Generic)
20+ deriving (Eq, Show, Generic)
21+
22+instance Hashable FooPost
19
23
20instance ToJSON FooPost
24instance ToJSON FooPost
25+
21instance FromJSON FooPost
26instance FromJSON FooPost
22
27
23server :: Server Api
28server :: Server Api
29+server =
24−server = pure FooPost
30+ pure FooPost
25− :<|> const (pure ())
31+ :<|> const (pure ())
test/Product.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Product where
9+
10+import Data.Aeson
11+import Data.Hashable
12+import Data.Typeable (Typeable)
13+import GHC.Generics (Generic)
14+import Servant
15+
16+data Foo = Foo Int String
17+ deriving (Generic, Eq, Show, Typeable)
18+
19+instance Hashable Foo
20+
21+instance ToJSON Foo
22+
23+instance FromJSON Foo
24+
25+type Api = "item" :> ReqBody '[JSON] Foo :> Post '[JSON] ()
26+
27+eliminate :: Foo -> Handler ()
28+eliminate (Foo _a _b) = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
29+
30+server :: Server Api
31+server = eliminate
test/Put.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+10−4
@@ -8,6 +8,7 @@
8module Seeded where
8module Seeded where
9
9
10import Data.Aeson
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
@@ -17,11 +18,16 @@ newtype Seed = Seed Int
17 deriving newtype (FromHttpApiData, ToHttpApiData)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
18
19
19instance ToJSON Seed
20instance ToJSON Seed
21+
20instance FromJSON Seed
22instance FromJSON Seed
21
23
24+instance Hashable Seed
25+
26+type Api =
22−type Api = Capture "seed" Seed :> Get '[JSON] ()
27+ Capture "seed" Seed :> Get '[JSON] ()
23− :<|> Get '[JSON] ()
28+ :<|> Get '[JSON] ()
24
29
25server :: Server Api
30server :: Server Api
31+server =
26−server = (\(Seed _) -> error "we blow up if we get here")
32+ (\(Seed _) -> error "we blow up if we get here")
27− :<|> pure ()
33+ :<|> pure ()
test/Spec.hs+127−85
@@ -1,128 +1,170 @@
1+{-# LANGUAGE DerivingVia #-}
2+{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE StandaloneDeriving #-}
5{-# LANGUAGE StandaloneDeriving #-}
3−{-# LANGUAGE DerivingVia #-}
4{-# LANGUAGE TypeApplications #-}
6{-# LANGUAGE TypeApplications #-}
5−{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE DataKinds #-}
6{-# 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)
7import qualified Foo
20import qualified Foo
8−import qualified Seeded
9−import qualified Valid
10import qualified Headers
21import qualified Headers
22+import qualified Nested
11import qualified Post
23import qualified Post
12−import qualified BuildFrom
24+import qualified Put
13−-- import qualified UnsafeIO
25+import qualified Product
14−
26+import qualified QueryParams
15−import Data.Dynamic(toDyn)
27+import qualified Roboservant as R
16−import qualified Roboservant as RS
28+import qualified Roboservant.Server as RS
17−import Roboservant(Breakdown, BuildFrom, Atom, Compound)
29+import qualified Roboservant.Client as RC
30+import qualified Seeded
18import Test.Hspec
31import Test.Hspec
19−import Test.Hspec.Core.Spec
32+import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
20−import Data.Void
33+import qualified Valid
21−import Data.Maybe
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((>=>))
22
41
23main :: IO ()
42main :: IO ()
24main = hspec spec
43main = hspec spec
25
44
26−noCheck :: IO ()
45+fuzzBoth
27−noCheck = pure ()
46+ :: forall a .
28−
47+ (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
29−defaultConfig :: RS.Config
48+ HasClient ClientM a)
30−defaultConfig = RS.Config [] 1 1000 1 0
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 })
31
64
32spec :: Spec
65spec :: Spec
33spec = do
66spec = do
34 describe "Basic usage" $ do
67 describe "Basic usage" $ do
35 describe "noError" $ do
68 describe "noError" $ do
36− it "finds no error in a valid app" $ do
69+ fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
37− RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
70+ fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
38− >>= (`shouldSatisfy` isNothing)
39− it "does fail coverage check" $ do
40− 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 ->
41− fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
73+ fmap (R.failureReason . R.rsException) r
42− (\case
74+ `shouldSatisfy` ( \case
43− Just (RS.InsufficientCoverage _) -> True
75+ Just (R.InsufficientCoverage _) -> True
44− _ -> False)
76+ _ -> False
45−
77+ ))
46− describe "posted body" $ do
78+ describe "posted body" $
47− it "passes a coverage check using a posted body" $ do
48− RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
79+ fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
49− >>= (`shouldSatisfy` isNothing)
80+ (`shouldSatisfy` isNothing)
50
81
51− describe "seeded" $ do
52− shouldFail $
53− it "finds an error using information passed in" $
54− RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
55− >>= (`shouldSatisfy` isNothing)
56− describe "Foo" $ do
57− it "finds an error in a basic app" $
58− RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
59− >>= (`shouldSatisfy` isJust)
60
82
61− describe "headers" $ do
83+ describe "PUTted body" $
62− it "should find a failure that's dependent on using header info" $ do
84+ fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}
63− RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
64− >>= (`shouldSatisfy` isJust)
85+ (`shouldSatisfy` isNothing)
65
86
66− describe "can build from pieces" $ do
67− it "should find a failure that requires some assembly" $ do
68− RS.fuzz @BuildFrom.Api BuildFrom.server defaultConfig noCheck
69− >>= (`shouldSatisfy` isJust)
70
87
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)
71
93
94+ describe "Foo" $
95+ fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
72
96
73− -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
97+ describe "QueryParams" $
74− -- -- -- could: it's mostly here to show how to test for concurrency problems.
98+ fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }
75− -- describe "concurrency bugs" $ do
99+ (`shouldSatisfy` isNothing)
76− -- before UnsafeIO.makeServer $ do
77− -- describe "sequential checking" $ do
78− -- it "safe use" $ \unsafeServer -> do
79− -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
80
100
81− -- modifyMaxSuccess (const 10000) $
101+ describe "BuildFrom" $ do
82− -- shouldFail $
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)
83− -- describe "concurrent" $ do
105+ describe "product types" $
84− -- it "concurrent, dangerous use" $ \unsafeServer -> do
106+ fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
85− -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
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)
86
117
118+serverFailure :: Maybe R.Report -> Bool
119+serverFailure = \case
120+ Just R.Report {..} ->
121+ let R.RoboservantException {..} = rsException
122+ in failureReason /= R.NoPossibleMoves
123+ _ -> False
87
124
88−deriving via (Atom Foo.Foo) instance Breakdown Foo.Foo
125+deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
89−deriving via (Atom Foo.Foo) instance BuildFrom Foo.Foo
90
126
91−deriving via (Atom Headers.Foo) instance Breakdown Headers.Foo
127+deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
92−deriving via (Atom Headers.Foo) instance BuildFrom Headers.Foo
93
128
94−deriving via (Atom Seeded.Seed) instance Breakdown Seeded.Seed
129+deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
95−deriving via (Atom Seeded.Seed) instance BuildFrom Seeded.Seed
96
130
131+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
97
132
98−-- instance RS.BuildFrom Seeded.Seed
133+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
99
134
100−deriving via (Atom Void) instance RS.BuildFrom Void
135+deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
101
136
102−deriving via (Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
137+deriving via (R.Atom Void) instance R.BuildFrom Void
103−deriving via (Atom Post.FooPost) instance RS.Breakdown Post.FooPost
104
138
139+deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
140+deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
105
141
106−deriving via (Compound BuildFrom.Wrapped) instance RS.BuildFrom BuildFrom.Wrapped
142+deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
107−deriving via (Compound BuildFrom.Wrapped) instance RS.Breakdown BuildFrom.Wrapped
143+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
108
144
109
145
110
146
111−-- deriving via (Atom Void) instance RS.BuildFrom Void
147+deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
112
148
113−-- instance RS.Breakdown Post.FooPost
149+deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
114−-- instance RS.BuildFrom Post.FooPost
115
150
151+deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
116
152
117-- | `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.
118-- this is often useful when testing tests.
154-- this is often useful when testing tests.
119shouldFail :: SpecWith a -> SpecWith a
155shouldFail :: SpecWith a -> SpecWith a
156+shouldFail =
120−shouldFail = mapSpecItem_ (\i -> i {
157+ mapSpecItem_
158+ ( \i ->
159+ i
121− itemExample = \p a cb -> do
160+ { itemExample = \p a cb -> do
122− r <- (itemExample i) p a cb
161+ r <- itemExample i p a cb
162+ pure
163+ r
123− pure r {resultStatus = case resultStatus r of
164+ { resultStatus = case resultStatus r of
124− Success -> Failure Nothing (Reason "Unexpected success")
165+ Success -> Failure Nothing (Reason "Unexpected success")
125− Failure _ _ -> Success
166+ Failure _ _ -> Success
126− x -> x
167+ x -> x
127− }
168+ }
128− })
169+ }
170+ )
test/UnsafeIO.hs+13−15
@@ -1,41 +1,39 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
2+
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module UnsafeIO where
8module UnsafeIO where
9
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+32−5
@@ -1,17 +1,44 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module Valid where
8module Valid where
9
9
10−import Servant
11import Data.Void
10import Data.Void
11+import GHC.Generics
12+import Servant
13+import Servant.Server.Generic
14+
15+type Api =
16+ Get '[JSON] Int
17+ :<|> Capture "void" Void :> Get '[JSON] ()
18+
19+data Routes route
20+ = Routes
21+ { getInt ::
22+ route
23+ :- Summary "i'm a summary!" :> Get '[JSON] Int,
24+ captureIt ::
25+ route
26+ :- Capture "void" Void :> Get '[JSON] ()
27+ }
28+ deriving (Generic)
29+
30+type RoutedApi = ToServantApi Routes
31+
32+-- routedApi = genericApi (Proxy :: Proxy Routes)
33+routedServer :: Server RoutedApi
34+routedServer = genericServer routes
35+
36+routes :: Routes AsServer
37+routes =
38+ Routes
39+ { getInt = pure 7,
40+ captureIt = const (pure ())
41+ }
12
42
13−type Api = Get '[JSON] Int
14− :<|> Capture "void" Void :> Get '[JSON] ()
15−
16server :: Server Api
43server :: Server Api
17server = pure 7 :<|> const (pure ())
44server = pure 7 :<|> const (pure ())