git.iko.soy/roboservant
on master help sign in
swap
8ade8f351 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+62−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: 6420e658218cfbfe27ae6037534f3e63a37fb1c9dfbd1a48c5f5e435d959a5af
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,13 +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.BuildFrom
36 Roboservant.Types.BuildFrom
35− Roboservant.Types.FlattenServer
37+ Roboservant.Types.Config
36 Roboservant.Types.Internal
38 Roboservant.Types.Internal
39+ Roboservant.Types.Orphans
37 Roboservant.Types.ReifiedApi
40 Roboservant.Types.ReifiedApi
41+ Roboservant.Types.ReifiedApi.Server
38 other-modules:
42 other-modules:
39 Paths_roboservant
43 Paths_roboservant
40 hs-source-dirs:
44 hs-source-dirs:
@@ -46,6 +50,8 @@ library
46 , containers
50 , containers
47 , dependent-map
51 , dependent-map
48 , dependent-sum
52 , dependent-sum
53+ , hashable
54+ , http-types
49 , lifted-base
55 , lifted-base
50 , monad-control
56 , monad-control
51 , mtl
57 , mtl
@@ -57,17 +63,61 @@ library
57 , string-conversions
63 , string-conversions
58 , text
64 , text
59 , time
65 , time
66+ , unordered-containers
60 , vinyl
67 , vinyl
61 default-language: Haskell2010
68 default-language: Haskell2010
62
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+
63test-suite roboservant-test
109test-suite roboservant-test
64 type: exitcode-stdio-1.0
110 type: exitcode-stdio-1.0
65 main-is: Spec.hs
111 main-is: Spec.hs
66 other-modules:
112 other-modules:
67− BuildFrom
113+ Breakdown
68 Foo
114 Foo
69 Headers
115 Headers
116+ Nested
70 Post
117 Post
118+ Product
119+ Put
120+ QueryParams
71 Seeded
121 Seeded
72 UnsafeIO
122 UnsafeIO
73 Valid
123 Valid
@@ -82,9 +132,13 @@ test-suite roboservant-test
82 , containers
132 , containers
83 , dependent-map
133 , dependent-map
84 , dependent-sum
134 , dependent-sum
135+ , hashable
85 , hspec
136 , hspec
86 , hspec-core
137 , hspec-core
138+ , hspec-wai
87 , http-api-data
139 , http-api-data
140+ , http-client
141+ , http-types
88 , lifted-base
142 , lifted-base
89 , monad-control
143 , monad-control
90 , mtl
144 , mtl
@@ -97,5 +151,8 @@ test-suite roboservant-test
97 , string-conversions
151 , string-conversions
98 , text
152 , text
99 , time
153 , time
154+ , unordered-containers
100 , vinyl
155 , vinyl
156+ , wai
157+ , warp
101 default-language: Haskell2010
158 default-language: Haskell2010
src/Roboservant.hs+5−2
@@ -1,5 +1,8 @@
1+module Roboservant
1−module Roboservant (module Roboservant.Direct
2+ ( module Roboservant.Direct,
2− ,module Roboservant.Types) where
3+ module Roboservant.Types,
4+ )
5+where
3
6
4import Roboservant.Direct
7import Roboservant.Direct
5import Roboservant.Types
8import Roboservant.Types
src/Roboservant/Client.hsnew file+127
@@ -0,0 +1,127 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE NamedFieldPuns #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE AllowAmbiguousTypes #-}
6+{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+
12+{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE FlexibleContexts #-}
15+-- should all the NormalizeFunction instances be in one place?
16+{-# OPTIONS_GHC -fno-warn-orphans #-}
17+module Roboservant.Client where
18+
19+import Data.Proxy
20+import Servant.Client
21+import Roboservant.Types
22+import Roboservant(Report, fuzz')
23+import Servant
24+import Data.Bifunctor
25+import Data.List.NonEmpty (NonEmpty)
26+import Data.Dynamic (Dynamic,Typeable)
27+import qualified Data.Vinyl.Curry as V
28+import qualified Data.Text as T
29+import Control.Monad.Reader
30+import Data.Hashable
31+import Network.HTTP.Types.Status
32+
33+-- fuzz :: forall api.
34+-- (FlattenServer api, ToReifiedApi (Endpoints api)) =>
35+-- Server api ->
36+-- Config ->
37+-- IO (Maybe Report)
38+-- fuzz s = fuzz' (reifyServer s)
39+-- -- todo: how do we pull reifyServer out?
40+-- where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
41+-- => Server api -> ReifiedApi
42+-- reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
43+
44+fuzz :: forall api . (ToReifiedClientApi (Endpoints api), FlattenClient api, HasClient ClientM api)
45+ => ClientEnv -> Config -> IO (Maybe Report)
46+fuzz clientEnv
47+ = fuzz'
48+ (toReifiedClientApi
49+ (flattenClient @api apiClient) (Proxy @(Endpoints api)) clientEnv)
50+ where apiClient = client (Proxy @api)
51+
52+
53+
54+class ToReifiedClientApi api where
55+ toReifiedClientApi :: ClientBundled api -> Proxy api -> ClientEnv -> ReifiedApi
56+
57+data ClientBundled endpoints where
58+ AClientEndpoint :: Client ClientM endpoint -> ClientBundled endpoints -> ClientBundled (endpoint ': endpoints)
59+ NoClientEndpoints :: ClientBundled '[]
60+
61+
62+class FlattenClient api where
63+ flattenClient :: Client ClientM api -> ClientBundled (Endpoints api)
64+
65+instance
66+ ( NormalizeFunction (Client ClientM endpoint)
67+ , Normal (Client ClientM endpoint) ~ V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))))
68+ , ToReifiedClientApi endpoints
69+ , V.RecordCurry' (EndpointArgs endpoint)
70+ , ToReifiedEndpoint endpoint) =>
71+ ToReifiedClientApi (endpoint : endpoints) where
72+ toReifiedClientApi (endpoint `AClientEndpoint` endpoints) _ clientEnv =
73+ (0, ReifiedEndpoint
74+ { reArguments = reifiedEndpointArguments @endpoint
75+ , reEndpointFunc = foo (normalize endpoint)
76+ }
77+ )
78+ : (map . first) (+1)
79+ (toReifiedClientApi endpoints (Proxy @endpoints) clientEnv)
80+ where
81+
82+ foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType)
83+ -> V.Curried (EndpointArgs endpoint) (IO ResultType)
84+ foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv)
85+
86+mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b
87+mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g
88+
89+type ResultType = Either InteractionError (NonEmpty (Dynamic,Int))
90+-- runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
91+
92+
93+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where
94+ type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int)))
95+ normalize c = ReaderT $
96+ fmap (bimap renderClientError breakdown) . runClientM c
97+ where
98+ renderClientError :: ClientError -> InteractionError
99+ renderClientError err = case err of
100+ FailureResponse _ Response{responseStatusCode} -> InteractionError textual (responseStatusCode == status500)
101+ _ -> InteractionError textual True
102+
103+ where textual = T.pack $ show err
104+instance ToReifiedClientApi '[] where
105+ toReifiedClientApi NoClientEndpoints _ _ = []
106+
107+
108+instance
109+ ( FlattenClient api,
110+ Endpoints endpoint ~ '[endpoint]
111+ ) =>
112+ FlattenClient (endpoint :<|> api)
113+ where
114+ flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c
115+
116+instance
117+ (
118+ Endpoints api ~ '[api]
119+ ) =>
120+ FlattenClient (x :> api)
121+ where
122+ flattenClient c = c `AClientEndpoint` NoClientEndpoints
123+
124+
125+instance FlattenClient (Verb method statusCode contentTypes responseType)
126+ where
127+ flattenClient c = c `AClientEndpoint` NoClientEndpoints
src/Roboservant/Direct.hs+129−138
@@ -2,60 +2,53 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TupleSections #-}
9{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11
10
11+{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
13
13
14module Roboservant.Direct
14module Roboservant.Direct
15+ ( fuzz',
15− ( fuzz, Config(..)
16+ Config (..),
16−
17− -- 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
18− -- have some nice error-display functions
18+ -- have some nice error-display functions
19− , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
19+ RoboservantException (..),
20+ FuzzState (..),
21+ FuzzOp (..),
22+ FailureType (..),
23+ Report (..),
20 )
24 )
21where
25where
22
26
23−import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
27+import Control.Exception.Lifted
24−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
28+ ( Exception,
25−import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
29+ Handler (Handler),
26−import Control.Monad(void,replicateM,forM_)
30+ SomeAsyncException,
31+ SomeException,
32+ catch,
33+ catches,
34+ handle,
35+ throw,
36+ )
27−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
37+import Control.Monad.State.Strict
28−import Control.Monad.Trans.Control(MonadBaseControl)
38+ ( MonadIO (..),
29−import Data.Dependent.Map (DMap)
39+ MonadState (get),
30−import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
40+ StateT (runStateT),
31−import Data.List.NonEmpty (NonEmpty(..))
41+ modify',
32−import Data.Map.Strict(Map)
42+ )
33−import qualified Data.Set as Set
34−import Data.Maybe (mapMaybe)
35−import Data.Typeable (TypeRep)
36−import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
37−import System.Random(StdGen,randomR,mkStdGen)
38−import qualified Data.List.NonEmpty as NEL
39−import qualified Data.Map.Strict as Map
40−import Data.Time.Clock
41−import Data.List(sortOn)
42−import Control.Arrow(second)
43−import System.Timeout.Lifted(timeout)
44−import GHC.Generics ((:*:)(..))
45−import qualified Data.Vinyl.Functor as V
46−import qualified Data.Vinyl.Curry as V
47−
48−
49−import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)
50−import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)
51import Control.Monad.Trans.Control (MonadBaseControl)
43import Control.Monad.Trans.Control (MonadBaseControl)
52import qualified Data.Dependent.Map as DM
44import qualified Data.Dependent.Map as DM
53−import Data.Dynamic (Dynamic (..), dynTypeRep)
45+import Data.Dynamic (Dynamic (..))
46+import qualified Data.IntSet as IntSet
54import Data.List.NonEmpty (NonEmpty (..))
47import Data.List.NonEmpty (NonEmpty (..))
55import qualified Data.List.NonEmpty as NEL
48import qualified Data.List.NonEmpty as NEL
56import Data.Maybe (mapMaybe)
49import Data.Maybe (mapMaybe)
57import qualified Data.Set as Set
50import qualified Data.Set as Set
58−import Data.Time.Clock
51+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
59import qualified Data.Vinyl as V
52import qualified Data.Vinyl as V
60import qualified Data.Vinyl.Curry as V
53import qualified Data.Vinyl.Curry as V
61import qualified Data.Vinyl.Functor as V
54import qualified Data.Vinyl.Functor as V
@@ -63,25 +56,26 @@ import GHC.Generics ((:*:) (..))
63import Roboservant.Types
56import Roboservant.Types
64 ( ApiOffset (..),
57 ( ApiOffset (..),
65 Argument (..),
58 Argument (..),
66− FlattenServer (..),
59+ InteractionError(..),
67 Provenance (..),
60 Provenance (..),
61+ ReifiedApi,
68 ReifiedEndpoint (..),
62 ReifiedEndpoint (..),
69 Stash (..),
63 Stash (..),
70 StashValue (..),
64 StashValue (..),
71− ToReifiedApi (..),
65+ TypedF,
72− TypedF
73 )
66 )
74−import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
67+import Roboservant.Types.Config
75−import System.Random (StdGen, mkStdGen, randomR)
76−import qualified Type.Reflection as R
77
68
69+import System.Random (Random (randomR), StdGen, mkStdGen)
70+import qualified Type.Reflection as R
78
71
79data RoboservantException
72data RoboservantException
80 = RoboservantException
73 = RoboservantException
81− { failureReason :: FailureType
74+ { failureReason :: FailureType,
82− , serverException :: Maybe SomeException
75+ serverException :: Maybe SomeException,
83− , fuzzState :: FuzzState
76+ fuzzState :: FuzzState
77+ }
84− } deriving (Show)
78+ deriving (Show)
85
79
86instance Exception RoboservantException
80instance Exception RoboservantException
87
81
@@ -90,7 +84,7 @@ data FailureType
90 | CheckerFailed
84 | CheckerFailed
91 | NoPossibleMoves
85 | NoPossibleMoves
92 | InsufficientCoverage Double
86 | InsufficientCoverage Double
93− deriving (Show,Eq)
87+ deriving (Show, Eq)
94
88
95data FuzzOp
89data FuzzOp
96 = FuzzOp
90 = FuzzOp
@@ -99,15 +93,6 @@ data FuzzOp
99 }
93 }
100 deriving (Show, Eq)
94 deriving (Show, Eq)
101
95
102−data Config
103− = Config
104− { seed :: [Dynamic],
105− maxRuntime :: Integer, -- seconds to test for
106− maxReps :: Integer,
107− rngSeed :: Int,
108− coverageThreshold :: Double
109− }
110−
111data FuzzState
96data FuzzState
112 = FuzzState
97 = FuzzState
113 { path :: [FuzzOp],
98 { path :: [FuzzOp],
@@ -120,7 +105,7 @@ data EndpointOption
120 = forall as.
105 = forall as.
121 (V.RecordToList as, V.RMap as) =>
106 (V.RecordToList as, V.RMap as) =>
122 EndpointOption
107 EndpointOption
123− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic))),
108+ { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
124 eoArgs :: V.Rec (TypedF StashValue) as
109 eoArgs :: V.Rec (TypedF StashValue) as
125 }
110 }
126
111
@@ -129,60 +114,63 @@ data StopReason
129 | HitMaxIterations
114 | HitMaxIterations
130 deriving (Show, Eq)
115 deriving (Show, Eq)
131
116
132−data Report = Report
117+data Report
118+ = Report
133− { textual :: String
119+ { textual :: String,
134− , rsException :: RoboservantException}
120+ rsException :: RoboservantException
121+ }
135 deriving (Show)
122 deriving (Show)
136
123
124+
125+
126+-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
127+-- fuzzClient = undefined
128+
129+
130+
137−fuzz ::
131+fuzz' ::
138− forall api.
132+ ReifiedApi ->
139− (FlattenServer api, ToReifiedApi (Endpoints api)) =>
140− Server api ->
141 Config ->
133 Config ->
142− IO () ->
143 IO (Maybe Report)
134 IO (Maybe Report)
144−fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
135+fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
145 let path = []
136 let path = []
146 stash = addToStash seed mempty
137 stash = addToStash seed mempty
147 currentRng = mkStdGen rngSeed
138 currentRng = mkStdGen rngSeed
148− deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
139+ deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime
149 (stopreason, _fs) <-
140 (stopreason, _fs) <-
150 runStateT
141 runStateT
151 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
142 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
152 FuzzState {..}
143 FuzzState {..}
153− print stopreason
144+ logInfo $ show stopreason
154 pure Nothing
145 pure Nothing
155 where
146 where
156 -- something less terrible later
147 -- something less terrible later
157 formatException :: RoboservantException -> Report
148 formatException :: RoboservantException -> Report
158− formatException r@(RoboservantException failureType exception _state) = Report
149+ formatException r@(RoboservantException failureType exception _state) =
150+ Report
159− (unlines [ show failureType , show exception ])
151+ (unlines [show failureType, show exception])
160− r
152+ r
153+ displayDiagnostics FuzzState {..} = liftIO $
154+ logInfo $ unlines $
155+ ["api endpoints covered"]
156+ <> (map show . Set.toList . Set.fromList $ map apiOffset path)
157+ <> ["", "types in stash"]
158+ <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)
159+ -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
160+ -- $ \_k v ->
161+ -- (show . NEL.length $ getStashValue v))
161
162
162− displayDiagnostics FuzzState{..} = liftIO $ do
163− putStrLn "api endpoints covered"
164− mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
165− putStrLn ""
166− putStrLn "types in stash"
167− DM.forWithKey_ (getStash stash) $ \k v ->
168− print (NEL.length $ getStashValue v)
169− -- mapM_
170− -- (print . second NEL.length)
171− -- (sortOn (show . fst) $ Map.toList $ getStash stash)
172−
173− -- evaluateCoverage :: FuzzState -> m ()
174− evaluateCoverage f@FuzzState{..}
163+ evaluateCoverage f@FuzzState {..}
175 | coverage > coverageThreshold = pure ()
164 | coverage > coverageThreshold = pure ()
176 | otherwise = do
165 | otherwise = do
177− displayDiagnostics f
166+ displayDiagnostics f
178− throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
167+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
168+ where
179− where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
169+ hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
180− totalRoutes = fromIntegral routeCount
170+ totalRoutes = fromIntegral routeCount
181− coverage = hitRoutes / totalRoutes
171+ coverage = hitRoutes / totalRoutes
182−
183−
184− untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
172+ untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
185− untilDone (0,_) _ = pure HitMaxIterations
173+ untilDone (0, _) _ = pure HitMaxIterations
186 untilDone (n, deadline) action = do
174 untilDone (n, deadline) action = do
187 now <- liftIO getCurrentTime
175 now <- liftIO getCurrentTime
188 if now > deadline
176 if now > deadline
@@ -190,12 +178,13 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
190 else do
178 else do
191 _ <- action
179 _ <- action
192 untilDone (n -1, deadline) action
180 untilDone (n -1, deadline) action
193− reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
194− routeCount = length reifiedApi
195
181
182+ routeCount = length reifiedApi
183+ elementOrFail ::
196− elementOrFail :: (MonadState FuzzState m, MonadIO m)
184+ (MonadState FuzzState m, MonadIO m) =>
185+ [a] ->
197− => [a] -> m a
186+ m a
198− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
187+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
199 elementOrFail l = do
188 elementOrFail l = do
200 st <- get
189 st <- get
201 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
190 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
@@ -206,7 +195,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
206 ( forall as.
195 ( forall as.
207 (V.RecordToList as, V.RMap as) =>
196 (V.RecordToList as, V.RMap as) =>
208 FuzzOp ->
197 FuzzOp ->
209− V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
198+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
210 V.Rec (TypedF V.Identity) as ->
199 V.Rec (TypedF V.Identity) as ->
211 m r
200 m r
212 ) ->
201 ) ->
@@ -216,7 +205,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
216 (offset, EndpointOption {..}) <- elementOrFail . options =<< get
205 (offset, EndpointOption {..}) <- elementOrFail . options =<< get
217 r <-
206 r <-
218 V.rtraverse
207 V.rtraverse
219− ( \(tr :*: StashValue svs) ->
208+ ( \(tr :*: StashValue svs _) ->
220 elementOrFail $
209 elementOrFail $
221 zipWith
210 zipWith
222 (\i xy -> V.Const i :*: tr :*: xy)
211 (\i xy -> V.Const i :*: tr :*: xy)
@@ -247,56 +236,53 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
247 execute ::
236 execute ::
248 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
237 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
249 FuzzOp ->
238 FuzzOp ->
250− V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
239+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
251 V.Rec (TypedF V.Identity) as ->
240 V.Rec (TypedF V.Identity) as ->
252 m ()
241 m ()
253 execute fuzzop func args = do
242 execute fuzzop func args = do
254− (liftIO . print . (fuzzop,) . stash ) =<< get
243+ (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
255− st <- get
256− let showable = unlines $ ("args":map show argTypes)
257− <> ["fuzzop"
258− , show fuzzop
259− -- ,"dyncall"
260− -- ,show (dynTypeRep dyncall)
261− ,"state"
262− ]
263− -- liftIO $ putStrLn showable
264 liftIO (V.runcurry' func argVals) >>= \case
244 liftIO (V.runcurry' func argVals) >>= \case
265− -- parameterise this
245+ Left (e::InteractionError) ->
266− Left (serverError :: ServerError) ->
246+ if fatalError e
267− case errHTTPCode serverError of
247+ then throw e
268− 500 -> throw serverError
248+ else pure ()
269− _ -> do
270− liftIO $ print ("ignoring non-500 error", serverError)
271− Right (dyn :: NEL.NonEmpty Dynamic) -> do
249+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
272− -- liftIO $ print ("storing", fmap dynTypeRep dyn)
250+ modify'
273− modify' (\fs@FuzzState{..} ->
251+ ( \fs@FuzzState {..} ->
274− fs { stash = addToStash (NEL.toList dyn) stash } )
252+ fs {stash = addToStash (NEL.toList dyn) stash}
253+ )
275 where
254 where
276 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
255 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
277− argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
256+ -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
278 go ::
257 go ::
279 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
258 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
280 m ()
259 m ()
281 go = withOp $ \op func args -> do
260 go = withOp $ \op func args -> do
261+ catches
282− catches (execute op func args)
262+ (execute op func args)
283− [ Handler (\(e :: SomeAsyncException) -> throw e)
263+ [ Handler (\(e :: SomeAsyncException) -> throw e),
264+ Handler
284− , Handler (\(e :: SomeException) -> do
265+ ( \(e :: SomeException) ->
285− displayDiagnostics =<< get
286− throw . RoboservantException ServerCrashed (Just e) =<< get)
266+ throw . RoboservantException ServerCrashed (Just e) =<< get
267+ )
287 ]
268 ]
288− catch (liftIO checker)
269+ catch
270+ (liftIO healthCheck)
289− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
271+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
290
272
291addToStash ::
273addToStash ::
292− [Dynamic] ->
274+ [(Dynamic, Int)] ->
293 Stash ->
275 Stash ->
294 Stash
276 Stash
295addToStash result stash =
277addToStash result stash =
296 foldr
278 foldr
297− ( \(Dynamic tr x) (Stash dict) ->
279+ ( \(Dynamic tr x, hashed) (Stash dict) ->
298 Stash $
280 Stash $
281+ DM.insertWith
282+ renumber
283+ tr
299− 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
300 )
286 )
301 stash
287 stash
302 result
288 result
@@ -305,11 +291,16 @@ addToStash result stash =
305 StashValue a ->
291 StashValue a ->
306 StashValue a ->
292 StashValue a ->
307 StashValue a
293 StashValue a
308− 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
309− [([Provenance tr _], dyn)] ->
299+ [([Provenance tr _], dyn)] ->
310− l
311− <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
300+ l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
312− _ -> error "should be impossible"
301+ _ -> error "should be impossible"
302+ )
303+ (IntSet.union singleHash intSet)
313
304
314-- why isn't this in vinyl?
305-- why isn't this in vinyl?
315recordToList' ::
306recordToList' ::
src/Roboservant/Server.hsnew file+36
@@ -0,0 +1,36 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE PolyKinds #-}
8+
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+module Roboservant.Server (fuzz, module Roboservant.Types ) where
15+
16+import Roboservant.Direct(fuzz',Report)
17+import Roboservant.Types
18+ ( FlattenServer (..),
19+ ReifiedApi,
20+ )
21+import Roboservant.Types.ReifiedApi.Server(ToReifiedApi (..))
22+import Servant (Endpoints, Proxy (Proxy), Server)
23+import Roboservant.Types.Config
24+
25+fuzz :: forall api.
26+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>
27+ Server api ->
28+ Config ->
29+ IO (Maybe Report)
30+fuzz s = fuzz' (reifyServer s)
31+ -- todo: how do we pull reifyServer out?
32+ where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
33+ => Server api -> ReifiedApi
34+ reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
35+-- reifyServer server = toReifiedApi server (Proxy @(Endpoints api))
36+
src/Roboservant/Types.hs+10−14
@@ -2,29 +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,
18− , module Roboservant.Types.BuildFrom
12+ module Roboservant.Types.BuildFrom,
19− , module Roboservant.Types.FlattenServer
13+ module Roboservant.Types.ReifiedApi,
20− , module Roboservant.Types.ReifiedApi
14+ module Roboservant.Types.ReifiedApi.Server,
21− , module Roboservant.Types.Internal
15+ module Roboservant.Types.Internal,
22−
16+ module Roboservant.Types.Config,
23 )
17 )
24where
18where
25
19
26import Roboservant.Types.Breakdown
20import Roboservant.Types.Breakdown
27import Roboservant.Types.BuildFrom
21import Roboservant.Types.BuildFrom
28−import Roboservant.Types.FlattenServer
22+import Roboservant.Types.Config
29−import Roboservant.Types.ReifiedApi
30import Roboservant.Types.Internal
23import Roboservant.Types.Internal
24+import Roboservant.Types.ReifiedApi
25+import Roboservant.Types.ReifiedApi.Server
26+import Roboservant.Types.Orphans()
src/Roboservant/Types/Breakdown.hs+55−24
@@ -1,50 +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 DerivingStrategies #-}
9{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
11−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
12{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
14{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
15{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
16−{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE StandaloneDeriving #-}
17{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
19−{-# LANGUAGE StandaloneDeriving #-}
20−{-# LANGUAGE DerivingVia #-}
21−
22
15
23module Roboservant.Types.Breakdown where
16module Roboservant.Types.Breakdown where
24
17
25−import Data.Dynamic (Dynamic, fromDynamic, toDyn)
18+import Data.Dynamic (Dynamic)
19+import Data.Hashable
20+import Data.Kind
26import Data.List.NonEmpty (NonEmpty (..))
21import Data.List.NonEmpty (NonEmpty (..))
27import qualified Data.List.NonEmpty as NEL
22import qualified Data.List.NonEmpty as NEL
28−import Data.Maybe (fromMaybe)
29−import GHC.Generics(Generic)
30import Data.Typeable (Typeable)
23import Data.Typeable (Typeable)
24+import GHC.Generics
31import Roboservant.Types.Internal
25import Roboservant.Types.Internal
26+import Servant
27+import Roboservant.Types.Orphans()
32
28
33−-- | only use this when we are using the internal typerep map.
29+breakdown ::
34−promisedDyn :: Typeable a => Dynamic -> a
30+ (Hashable x, Typeable x, Breakdown x) =>
35−promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
31+ x ->
32+ NonEmpty (Dynamic, Int)
33+breakdown x = hashedDyn x :| breakdownExtras x
36
34
37class Breakdown x where
35class Breakdown x where
38− breakdown :: x -> NonEmpty Dynamic
36+ breakdownExtras :: x -> [(Dynamic, Int)]
39−-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
40−-- breakdown = pure . toDyn
41−
42
37
43−instance Typeable x => Breakdown (Atom x) where
38+instance (Hashable x, Typeable x) => Breakdown (Atom x) where
44− breakdown = pure . toDyn . unAtom
39+ breakdownExtras _ = []
45
40
46deriving via (Atom ()) instance Breakdown ()
41deriving via (Atom ()) instance Breakdown ()
42+
47deriving via (Atom Int) instance Breakdown Int
43deriving via (Atom Int) instance Breakdown Int
44+deriving via (Atom Char) instance Breakdown Char
45+
46+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x)
47+
48+instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where
49+ breakdownExtras stash = concatMap (NEL.toList . breakdown) stash
50+
51+
52+class GBreakdown (f :: k -> Type) where
53+ gBreakdownExtras :: f a -> [(Dynamic, Int)]
54+
55+instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where
56+ breakdownExtras = gBreakdownExtras . from . unCompound
57+
58+instance GBreakdown f => GBreakdown (M1 S c f) where
59+ gBreakdownExtras (M1 f) = gBreakdownExtras f
60+
61+instance GBreakdown b => GBreakdown (M1 D a b) where
62+ gBreakdownExtras (M1 f) = gBreakdownExtras f
63+
64+instance GBreakdown b => GBreakdown (M1 C a b) where
65+ gBreakdownExtras (M1 f) = gBreakdownExtras f
66+
67+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :*: b) where
68+ gBreakdownExtras (a :*: b) = gBreakdownExtras a <> gBreakdownExtras b
69+
70+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where
71+ gBreakdownExtras = \case
72+ L1 a -> gBreakdownExtras a
73+ R1 a -> gBreakdownExtras a
74+
75+instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where
76+ gBreakdownExtras (K1 c) = NEL.toList $ breakdown c
77+
78+instance GBreakdown U1 where
79+ gBreakdownExtras U1 = []
48
80
49−instance (Typeable a, Breakdown a) => Breakdown [a] where
81+deriving via (Atom NoContent) instance Breakdown NoContent
50− breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
src/Roboservant/Types/BuildFrom.hs+93−25
@@ -1,39 +1,107 @@
1−{-# LANGUAGE DefaultSignatures #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DerivingStrategies #-}
2+{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE PolyKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeApplications #-}
5{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE DerivingVia #-}
11+{-# LANGUAGE UndecidableInstances #-}
8−
9−
10
12
11module Roboservant.Types.BuildFrom where
13module Roboservant.Types.BuildFrom where
12
14
13−import Data.List.NonEmpty (NonEmpty(..))
15+import Data.List(nub)
14−import qualified Data.List.NonEmpty as NEL
15−import Data.Typeable (Typeable)
16import qualified Data.Dependent.Map as DM
16import qualified Data.Dependent.Map as DM
17−import qualified Type.Reflection as R
17+import Data.Hashable
18+import qualified Data.IntSet as IntSet
18import Data.Kind
19import 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
19import Roboservant.Types.Internal
24import 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
20
52
21−class Typeable x => BuildFrom (x :: Type) where
53+class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
22− buildFrom :: Stash -> Maybe (StashValue x)
54+ extras :: Stash -> [([Provenance], x)]
23
55
24−-- | this is a little esoteric: basically, we're always going to use this with
25−-- deriving-via, so we need to look up the underlying `x` and then wrap it in Atom.
26−instance Typeable x => BuildFrom (Atom x) where
56+instance (Hashable x, Typeable x) => BuildFrom (Atom x) where
27− buildFrom = fmap (fmap Atom) <$> DM.lookup R.typeRep . getStash
57+ extras _ = []
28
58
29deriving via (Atom Bool) instance BuildFrom Bool
59deriving via (Atom Bool) instance BuildFrom Bool
30
60
31−instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
61+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)
32− buildFrom dict = Just options
62+
33− where options :: StashValue (Maybe x)
63+-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
34− options = StashValue $
64+-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
35− ([],Nothing) :|
65+instance (Eq x, BuildFrom x) => BuildFrom [x] where
36− (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict
66+ extras stash =
37− )
67+ nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash
38−-- instance (BuildFrom a) => BuildFrom [a] -- where
68+ where
39− --breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
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.hs+30−10
@@ -1,33 +1,53 @@
1{-# LANGUAGE DeriveFunctor #-}
1{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3
5
4module Roboservant.Types.Internal where
6module Roboservant.Types.Internal where
5
7
6−import Data.List.NonEmpty (NonEmpty(..))
7−import qualified Data.Map.Strict as Map
8import qualified Data.Dependent.Map as DM
8import qualified Data.Dependent.Map as DM
9import Data.Dependent.Map (DMap)
9import Data.Dependent.Map (DMap)
10−import qualified Type.Reflection as R
11import Data.Dependent.Sum
10import 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
12
19
13data Provenance
20data Provenance
14 = Provenance R.SomeTypeRep Int
21 = Provenance R.SomeTypeRep Int
15− deriving (Show,Eq)
22+ deriving (Show, Eq, Generic)
23+
24+instance Hashable Provenance
16
25
26+data StashValue a
27+ = StashValue
17−newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }
28+ { getStashValue :: NonEmpty ([Provenance], a),
29+ stashHash :: IntSet
30+ }
18 deriving (Functor, Show)
31 deriving (Functor, Show)
19
32
20-- wrap in newtype to give a custom Show instance, since the normal
33-- wrap in newtype to give a custom Show instance, since the normal
21-- instance for DMap is not happy since StashValue needs Show a to show
34-- instance for DMap is not happy since StashValue needs Show a to show
22−newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
35+newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}
23 deriving (Semigroup, Monoid)
36 deriving (Semigroup, Monoid)
24
37
25instance Show Stash where
38instance Show Stash where
26− showsPrec i (Stash x) = showsPrec i $
39+ showsPrec i (Stash x) =
40+ showsPrec i
27− Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
41+ $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))
42+ $ DM.toList x
28
43
29-- | Can't be built up from parts, can't be broken down further.
44-- | Can't be built up from parts, can't be broken down further.
30−newtype Atom x = Atom { unAtom :: x }
45+newtype Atom x = Atom {unAtom :: x}
46+ deriving newtype (Hashable, Typeable,Eq)
31
47
32-- | can be broken down and built up from generic pieces
48-- | can be broken down and built up from generic pieces
33−newtype Compound x = Compound { unCompound :: x }
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+71−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,39 +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)
32import Roboservant.Types.Internal
28import Roboservant.Types.Internal
33import Roboservant.Types.Breakdown
29import Roboservant.Types.Breakdown
34import Roboservant.Types.BuildFrom
30import Roboservant.Types.BuildFrom
35−import Roboservant.Types.FlattenServer
31+import Data.Kind(Type)
36import Servant
32import Servant
37import Servant.API.Modifiers(FoldRequired,FoldLenient)
33import Servant.API.Modifiers(FoldRequired,FoldLenient)
34+import GHC.TypeLits (Symbol)
38import qualified Data.Text as T
35import qualified Data.Text as T
39import qualified Data.Vinyl as V
36import qualified Data.Vinyl as V
40import qualified Data.Vinyl.Curry as V
37import qualified Data.Vinyl.Curry as V
41import qualified Type.Reflection as R
38import qualified Type.Reflection as R
42
39
43−
44newtype ApiOffset = ApiOffset Int
40newtype ApiOffset = ApiOffset Int
45 deriving (Eq, Show, Ord)
41 deriving (Eq, Show, Ord)
46 deriving newtype (Enum, Num)
42 deriving newtype (Enum, Num)
@@ -53,60 +49,32 @@ newtype Argument a = Argument
53
49
54data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
50data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
55 { reArguments :: V.Rec (TypedF Argument) as
51 { reArguments :: V.Rec (TypedF Argument) as
56− , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
52+ , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
57 }
53 }
58
54
59−type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
55+instance Show ReifiedEndpoint where
60−
56+ show _ = "lol"
61−tagType :: Typeable a => f a -> TypedF f a
62−tagType = (R.typeRep :*:)
63−
64−class ToReifiedApi (endpoints :: [*]) where
65− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
66
57
67−class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint
68− , V.RecordToList (EndpointArgs endpoint)
58+class ( V.RecordToList (EndpointArgs endpoint)
69 , V.RMap (EndpointArgs endpoint)
59 , V.RMap (EndpointArgs endpoint)
70− ) => ToReifiedEndpoint (endpoint :: *) where
60+ ) => ToReifiedEndpoint (endpoint :: Type) where
71 type EndpointArgs endpoint :: [Type]
61 type EndpointArgs endpoint :: [Type]
72 type EndpointRes endpoint :: Type
62 type EndpointRes endpoint :: Type
73
63
74 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
64 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
75
65
76−instance ToReifiedApi '[] where
77− toReifiedApi NoEndpoints _ = []
78
66
79−instance
67+tagType :: Typeable a => f a -> TypedF f a
80− ( Typeable (EndpointRes endpoint)
68+tagType = (R.typeRep :*:)
81− , NormalizeFunction (ServerT endpoint Handler)
69+
82− , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty Dynamic)))
70+data InteractionError = InteractionError
83− , ToReifiedEndpoint endpoint
71+ { errorMessage :: T.Text
84− , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)
72+ , fatalError :: Bool
85− ) =>
86− ToReifiedApi (endpoint : endpoints)
87− where
88− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
89− (0, ReifiedEndpoint
90− { reArguments = reifiedEndpointArguments @endpoint
91− , reEndpointFunc = normalize endpoint
92− }
73+ }
93− )
74+ deriving Show
94− : (map . first) (+1)
75+instance Exception InteractionError
95− (toReifiedApi endpoints (Proxy @endpoints))
76+
96−
77+
97−class NormalizeFunction m where
98− type Normal m
99− normalize :: m -> Normal m
100−
101−instance NormalizeFunction x => NormalizeFunction (r -> x) where
102− type Normal (r -> x) = r -> Normal x
103− normalize = fmap normalize
104−
105−instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
106− type Normal (Handler x) = IO (Either ServerError (NonEmpty Dynamic))
107− normalize handler = (runExceptT . runHandler') handler >>= \case
108− Left serverError -> pure (Left serverError)
109− Right x -> pure $ Right $ breakdown x
110
78
111instance
79instance
112 (Typeable responseType, Breakdown responseType) =>
80 (Typeable responseType, Breakdown responseType) =>
@@ -116,6 +84,12 @@ instance
116 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
84 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
117 reifiedEndpointArguments = V.RNil
85 reifiedEndpointArguments = V.RNil
118
86
87+instance ToReifiedEndpoint (NoContentVerb method)
88+ where
89+ type EndpointArgs (NoContentVerb method) = '[]
90+ type EndpointRes (NoContentVerb method) = NoContent
91+ reifiedEndpointArguments = V.RNil
92+
119instance
93instance
120 (ToReifiedEndpoint endpoint) =>
94 (ToReifiedEndpoint endpoint) =>
121 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
95 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
@@ -124,6 +98,16 @@ instance
124 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
98 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
125 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
126
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+
127instance
111instance
128 (ToReifiedEndpoint endpoint) =>
112 (ToReifiedEndpoint endpoint) =>
129 ToReifiedEndpoint (Description s :> endpoint)
113 ToReifiedEndpoint (Description s :> endpoint)
@@ -167,6 +151,23 @@ instance
167 V.:& reifiedEndpointArguments @endpoint
151 V.:& reifiedEndpointArguments @endpoint
168
152
169
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+
170instance
171instance
171 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
172 , ToReifiedEndpoint endpoint
173 , ToReifiedEndpoint endpoint
@@ -179,6 +180,7 @@ instance
179 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
180 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
180 V.:& reifiedEndpointArguments @endpoint
181 V.:& reifiedEndpointArguments @endpoint
181
182
183+#if MIN_VERSION_servant(0,17,0)
182instance
184instance
183 ( BuildFrom (IfLenient String mods captureType)
185 ( BuildFrom (IfLenient String mods captureType)
184 , ToReifiedEndpoint endpoint) =>
186 , ToReifiedEndpoint endpoint) =>
@@ -189,6 +191,19 @@ instance
189 reifiedEndpointArguments =
191 reifiedEndpointArguments =
190 tagType (Argument (buildFrom @(IfLenient String mods captureType)))
192 tagType (Argument (buildFrom @(IfLenient String mods captureType)))
191 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
192
207
193instance
208instance
194 ( 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−10
@@ -1,15 +1,10 @@
1−# nb: 16.8 doesn't work because the version of servant is too old to have FoldLenient', fixme.
2−resolver: lts-16.16
1+resolver: lts-20.4
3packages:
2packages:
4- .
3- .
5
4
6extra-deps:
5extra-deps:
6+# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
7+# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
7- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8−- vinyl-0.13.0
9+# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
9−- dependent-sum-0.7.1.0
10+- some-1.0.3
10−- constraints-extras-0.3.0.2
11−- dependent-map-0.4.0.0
12−- servant-0.18.2
13−- servant-client-0.18.2
14−- servant-client-core-0.18.2
15−- servant-server-0.18.2
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−87
@@ -1,130 +1,170 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE StandaloneDeriving #-}
3{-# LANGUAGE DerivingVia #-}
1{-# LANGUAGE DerivingVia #-}
4−{-# LANGUAGE TypeApplications #-}
5{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE StandaloneDeriving #-}
5{-# LANGUAGE StandaloneDeriving #-}
8−
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE DataKinds #-}
9{-# 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)
10import qualified Foo
20import qualified Foo
11−import qualified Seeded
12−import qualified Valid
13import qualified Headers
21import qualified Headers
22+import qualified Nested
14import qualified Post
23import qualified Post
15−import qualified BuildFrom
24+import qualified Put
16−-- import qualified UnsafeIO
25+import qualified Product
17−
26+import qualified QueryParams
18−import Data.Dynamic(toDyn)
27+import qualified Roboservant as R
19−import qualified Roboservant as RS
28+import qualified Roboservant.Server as RS
20−import Roboservant(Breakdown, BuildFrom, Atom, Compound)
29+import qualified Roboservant.Client as RC
30+import qualified Seeded
21import Test.Hspec
31import Test.Hspec
22−import Data.Void
32+import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
23−import Data.Maybe
33+import qualified Valid
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((>=>))
24
41
25main :: IO ()
42main :: IO ()
26main = hspec spec
43main = hspec spec
27
44
28−noCheck :: IO ()
45+fuzzBoth
29−noCheck = pure ()
46+ :: forall a .
30−
47+ (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
31−defaultConfig :: RS.Config
48+ HasClient ClientM a)
32−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 })
33
64
34spec :: Spec
65spec :: Spec
35spec = do
66spec = do
36 describe "Basic usage" $ do
67 describe "Basic usage" $ do
37 describe "noError" $ do
68 describe "noError" $ do
38− 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)
39− 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)
40− >>= (`shouldSatisfy` isNothing)
41− it "does fail coverage check" $ do
42− 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 ->
43− fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
73+ fmap (R.failureReason . R.rsException) r
44− (\case
74+ `shouldSatisfy` ( \case
45− Just (RS.InsufficientCoverage _) -> True
75+ Just (R.InsufficientCoverage _) -> True
46− _ -> False)
76+ _ -> False
47−
77+ ))
48− describe "posted body" $ do
78+ describe "posted body" $
49− it "passes a coverage check using a posted body" $ do
50− 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}
51− >>= (`shouldSatisfy` isNothing)
80+ (`shouldSatisfy` isNothing)
52
81
53− describe "seeded" $ do
54− shouldFail $
55− it "finds an error using information passed in" $
56− RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
57− >>= (`shouldSatisfy` isNothing)
58− describe "Foo" $ do
59− it "finds an error in a basic app" $
60− RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
61− >>= (`shouldSatisfy` isJust)
62
82
63− describe "headers" $ do
83+ describe "PUTted body" $
64− 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}
65− RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
66− >>= (`shouldSatisfy` isJust)
85+ (`shouldSatisfy` isNothing)
67
86
68− -- describe "can build from pieces" $ do
69− -- it "should find a failure that requires some assembly" $ do
70− -- RS.fuzz @BuildFrom.Api BuildFrom.server defaultConfig noCheck
71− -- >>= (`shouldSatisfy` isJust)
72
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)
73
93
94+ describe "Foo" $
95+ fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
74
96
75− -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
97+ describe "QueryParams" $
76− -- -- -- 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)] }
77− -- describe "concurrency bugs" $ do
99+ (`shouldSatisfy` isNothing)
78− -- before UnsafeIO.makeServer $ do
79− -- describe "sequential checking" $ do
80− -- it "safe use" $ \unsafeServer -> do
81− -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
82
100
83− -- modifyMaxSuccess (const 10000) $
101+ describe "BuildFrom" $ do
84− -- 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)
85− -- describe "concurrent" $ do
105+ describe "product types" $
86− -- it "concurrent, dangerous use" $ \unsafeServer -> do
106+ fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
87− -- 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)
88
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
89
124
90−deriving via (Atom Foo.Foo) instance Breakdown Foo.Foo
125+deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
91−deriving via (Atom Foo.Foo) instance BuildFrom Foo.Foo
92
126
93−deriving via (Atom Headers.Foo) instance Breakdown Headers.Foo
127+deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
94−deriving via (Atom Headers.Foo) instance BuildFrom Headers.Foo
95
128
96−deriving via (Atom Seeded.Seed) instance Breakdown Seeded.Seed
129+deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
97−deriving via (Atom Seeded.Seed) instance BuildFrom Seeded.Seed
98
130
131+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
99
132
100−-- instance RS.BuildFrom Seeded.Seed
133+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
101
134
102−deriving via (Atom Void) instance RS.BuildFrom Void
135+deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
103
136
104−deriving via (Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
137+deriving via (R.Atom Void) instance R.BuildFrom Void
105−deriving via (Atom Post.FooPost) instance RS.Breakdown Post.FooPost
106
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
107
141
108−--deriving via (Compound BuildFrom.Wrapped) instance RS.BuildFrom BuildFrom.Wrapped
142+deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
109−--deriving via (Compound BuildFrom.Wrapped) instance RS.Breakdown BuildFrom.Wrapped
143+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
110
144
111
145
112
146
113−-- deriving via (Atom Void) instance RS.BuildFrom Void
147+deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
114
148
115−-- instance RS.Breakdown Post.FooPost
149+deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
116−-- instance RS.BuildFrom Post.FooPost
117
150
151+deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
118
152
119-- | `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.
120-- this is often useful when testing tests.
154-- this is often useful when testing tests.
121shouldFail :: SpecWith a -> SpecWith a
155shouldFail :: SpecWith a -> SpecWith a
156+shouldFail =
122−shouldFail = mapSpecItem_ (\i -> i {
157+ mapSpecItem_
158+ ( \i ->
159+ i
123− itemExample = \p a cb -> do
160+ { itemExample = \p a cb -> do
124− r <- (itemExample i) p a cb
161+ r <- itemExample i p a cb
162+ pure
163+ r
125− pure r {resultStatus = case resultStatus r of
164+ { resultStatus = case resultStatus r of
126− Success -> Failure Nothing (Reason "Unexpected success")
165+ Success -> Failure Nothing (Reason "Unexpected success")
127− Failure _ _ -> Success
166+ Failure _ _ -> Success
128− x -> x
167+ x -> x
129− }
168+ }
130− })
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 ())