git.iko.soy/roboservant
on master help sign in
swap
8ade8f366 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+24−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
@@ -51,3 +55,22 @@ tests:
51 - aeson
55 - aeson
52 - hspec
56 - hspec
53 - hspec-core
57 - hspec-core
58+ - http-api-data
59+ - http-client
60+ - hspec-wai
61+ - wai
62+ - warp
63+ example:
64+ main: Example.lhs
65+ source-dirs: .
66+
67+ dependencies:
68+ - roboservant
69+ - hspec
70+ - warp
71+ - http-client
72+ - aeson
73+ - hspec-core
74+ ghc-options: -pgmL markdown-unlit
75+
76+ build-tools: markdown-unlit
roboservant.cabal+64−5
@@ -1,13 +1,13 @@
1cabal-version: 1.12
1cabal-version: 1.12
2
2
3−-- This file has been generated from package.yaml by hpack version 0.33.0.
3+-- This file has been generated from package.yaml by hpack version 0.35.0.
4--
4--
5-- see: https://github.com/sol/hpack
5-- see: https://github.com/sol/hpack
6--
6--
7−-- hash: a0f650472f077eb44b9eefc36c90786ca0e371f2dc596f9a5d4e0e808ddc0396
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,16 +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
117+ Post
118+ Product
119+ Put
120+ QueryParams
70 Seeded
121 Seeded
71 UnsafeIO
122 UnsafeIO
72 Valid
123 Valid
@@ -81,8 +132,13 @@ test-suite roboservant-test
81 , containers
132 , containers
82 , dependent-map
133 , dependent-map
83 , dependent-sum
134 , dependent-sum
135+ , hashable
84 , hspec
136 , hspec
85 , hspec-core
137 , hspec-core
138+ , hspec-wai
139+ , http-api-data
140+ , http-client
141+ , http-types
86 , lifted-base
142 , lifted-base
87 , monad-control
143 , monad-control
88 , mtl
144 , mtl
@@ -95,5 +151,8 @@ test-suite roboservant-test
95 , string-conversions
151 , string-conversions
96 , text
152 , text
97 , time
153 , time
154+ , unordered-containers
98 , vinyl
155 , vinyl
156+ , wai
157+ , warp
99 default-language: Haskell2010
158 default-language: Haskell2010
src/Roboservant.hs+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+113−82
@@ -2,33 +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+
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
10
13
11module Roboservant.Direct
14module Roboservant.Direct
12− ( fuzz,
15+ ( fuzz',
13 Config (..),
16 Config (..),
14 -- 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
15 -- have some nice error-display functions
18 -- have some nice error-display functions
16 RoboservantException (..),
19 RoboservantException (..),
17 FuzzState (..),
20 FuzzState (..),
18 FuzzOp (..),
21 FuzzOp (..),
22+ FailureType (..),
23+ Report (..),
19 )
24 )
20where
25where
21
26
22−import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)
27+import Control.Exception.Lifted
28+ ( Exception,
29+ Handler (Handler),
30+ SomeAsyncException,
31+ SomeException,
32+ catch,
33+ catches,
34+ handle,
35+ throw,
36+ )
23−import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)
37+import Control.Monad.State.Strict
38+ ( MonadIO (..),
39+ MonadState (get),
40+ StateT (runStateT),
41+ modify',
42+ )
24import Control.Monad.Trans.Control (MonadBaseControl)
43import Control.Monad.Trans.Control (MonadBaseControl)
25import qualified Data.Dependent.Map as DM
44import qualified Data.Dependent.Map as DM
26−import Data.Dynamic (Dynamic (..), dynTypeRep)
45+import Data.Dynamic (Dynamic (..))
46+import qualified Data.IntSet as IntSet
27import Data.List.NonEmpty (NonEmpty (..))
47import Data.List.NonEmpty (NonEmpty (..))
28import qualified Data.List.NonEmpty as NEL
48import qualified Data.List.NonEmpty as NEL
29import Data.Maybe (mapMaybe)
49import Data.Maybe (mapMaybe)
30import qualified Data.Set as Set
50import qualified Data.Set as Set
31−import Data.Time.Clock
51+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
32import qualified Data.Vinyl as V
52import qualified Data.Vinyl as V
33import qualified Data.Vinyl.Curry as V
53import qualified Data.Vinyl.Curry as V
34import qualified Data.Vinyl.Functor as V
54import qualified Data.Vinyl.Functor as V
@@ -36,30 +56,34 @@ import GHC.Generics ((:*:) (..))
36import Roboservant.Types
56import Roboservant.Types
37 ( ApiOffset (..),
57 ( ApiOffset (..),
38 Argument (..),
58 Argument (..),
39− FlattenServer (..),
59+ InteractionError(..),
40 Provenance (..),
60 Provenance (..),
61+ ReifiedApi,
41 ReifiedEndpoint (..),
62 ReifiedEndpoint (..),
42 Stash (..),
63 Stash (..),
43 StashValue (..),
64 StashValue (..),
44− ToReifiedApi (..),
45 TypedF,
65 TypedF,
46 )
66 )
47−import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
67+import Roboservant.Types.Config
68+
48−import System.Random (StdGen, mkStdGen, randomR)
69+import System.Random (Random (randomR), StdGen, mkStdGen)
49import qualified Type.Reflection as R
70import qualified Type.Reflection as R
50
71
51data RoboservantException
72data RoboservantException
52− = RoboservantException FailureType (Maybe SomeException) Int FuzzState
73+ = RoboservantException
74+ { failureReason :: FailureType,
75+ serverException :: Maybe SomeException,
76+ fuzzState :: FuzzState
77+ }
53 deriving (Show)
78 deriving (Show)
54
79
55−-- we believe in nussink, lebowski
56instance Exception RoboservantException
80instance Exception RoboservantException
57
81
58data FailureType
82data FailureType
59 = ServerCrashed
83 = ServerCrashed
60 | CheckerFailed
84 | CheckerFailed
61 | NoPossibleMoves
85 | NoPossibleMoves
62− | InsufficientCoverage
86+ | InsufficientCoverage Double
63 deriving (Show, Eq)
87 deriving (Show, Eq)
64
88
65data FuzzOp
89data FuzzOp
@@ -69,15 +93,6 @@ data FuzzOp
69 }
93 }
70 deriving (Show, Eq)
94 deriving (Show, Eq)
71
95
72−data Config
73− = Config
74− { seed :: [Dynamic],
75− maxRuntime :: Integer, -- seconds to test for
76− maxReps :: Integer,
77− rngSeed :: Int,
78− coverageThreshold :: Double
79− }
80−
81data FuzzState
96data FuzzState
82 = FuzzState
97 = FuzzState
83 { path :: [FuzzOp],
98 { path :: [FuzzOp],
@@ -90,7 +105,7 @@ data EndpointOption
90 = forall as.
105 = forall as.
91 (V.RecordToList as, V.RMap as) =>
106 (V.RecordToList as, V.RMap as) =>
92 EndpointOption
107 EndpointOption
93− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic))),
108+ { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
94 eoArgs :: V.Rec (TypedF StashValue) as
109 eoArgs :: V.Rec (TypedF StashValue) as
95 }
110 }
96
111
@@ -101,40 +116,59 @@ data StopReason
101
116
102data Report
117data Report
103 = Report
118 = Report
104− {textual :: String}
119+ { textual :: String,
120+ rsException :: RoboservantException
121+ }
105− deriving (Show, Eq)
122+ deriving (Show)
123+
106
124
125+
126+-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
127+-- fuzzClient = undefined
128+
129+
130+
107−fuzz ::
131+fuzz' ::
108− forall api.
132+ ReifiedApi ->
109− (FlattenServer api, ToReifiedApi (Endpoints api)) =>
110− Server api ->
111 Config ->
133 Config ->
112− IO () ->
113 IO (Maybe Report)
134 IO (Maybe Report)
114−fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
135+fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
115 let path = []
136 let path = []
116 stash = addToStash seed mempty
137 stash = addToStash seed mempty
117 currentRng = mkStdGen rngSeed
138 currentRng = mkStdGen rngSeed
118− deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
139+ deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime
119 (stopreason, _fs) <-
140 (stopreason, _fs) <-
120 runStateT
141 runStateT
121 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
142 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
122 FuzzState {..}
143 FuzzState {..}
123− print stopreason
144+ logInfo $ show stopreason
124 pure Nothing
145 pure Nothing
125 where
146 where
126 -- something less terrible later
147 -- something less terrible later
127 formatException :: RoboservantException -> Report
148 formatException :: RoboservantException -> Report
128− formatException = Report . show
149+ formatException r@(RoboservantException failureType exception _state) =
129− -- evaluateCoverage :: FuzzState -> m ()
150+ Report
151+ (unlines [show failureType, show exception])
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))
162+
130 evaluateCoverage f@FuzzState {..}
163 evaluateCoverage f@FuzzState {..}
131− | hitRoutes / totalRoutes > coverageThreshold = do
164+ | coverage > coverageThreshold = pure ()
132− liftIO $ print ("passed coverage", hitRoutes, totalRoutes)
165+ | otherwise = do
133− pure ()
166+ displayDiagnostics f
134− | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
167+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
135 where
168 where
136− hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
169+ hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
137− totalRoutes = (fromIntegral routeCount)
170+ totalRoutes = fromIntegral routeCount
171+ coverage = hitRoutes / totalRoutes
138 untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
172 untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
139 untilDone (0, _) _ = pure HitMaxIterations
173 untilDone (0, _) _ = pure HitMaxIterations
140 untilDone (n, deadline) action = do
174 untilDone (n, deadline) action = do
@@ -144,13 +178,13 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
144 else do
178 else do
145 _ <- action
179 _ <- action
146 untilDone (n -1, deadline) action
180 untilDone (n -1, deadline) action
147− reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
181+
148 routeCount = length reifiedApi
182 routeCount = length reifiedApi
149 elementOrFail ::
183 elementOrFail ::
150 (MonadState FuzzState m, MonadIO m) =>
184 (MonadState FuzzState m, MonadIO m) =>
151 [a] ->
185 [a] ->
152 m a
186 m a
153− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
187+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
154 elementOrFail l = do
188 elementOrFail l = do
155 st <- get
189 st <- get
156 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
190 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
@@ -161,7 +195,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
161 ( forall as.
195 ( forall as.
162 (V.RecordToList as, V.RMap as) =>
196 (V.RecordToList as, V.RMap as) =>
163 FuzzOp ->
197 FuzzOp ->
164− V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
198+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
165 V.Rec (TypedF V.Identity) as ->
199 V.Rec (TypedF V.Identity) as ->
166 m r
200 m r
167 ) ->
201 ) ->
@@ -171,7 +205,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
171 (offset, EndpointOption {..}) <- elementOrFail . options =<< get
205 (offset, EndpointOption {..}) <- elementOrFail . options =<< get
172 r <-
206 r <-
173 V.rtraverse
207 V.rtraverse
174− ( \(tr :*: StashValue svs) ->
208+ ( \(tr :*: StashValue svs _) ->
175 elementOrFail $
209 elementOrFail $
176 zipWith
210 zipWith
177 (\i xy -> V.Const i :*: tr :*: xy)
211 (\i xy -> V.Const i :*: tr :*: xy)
@@ -202,39 +236,24 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
202 execute ::
236 execute ::
203 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
237 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
204 FuzzOp ->
238 FuzzOp ->
205− V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
239+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
206 V.Rec (TypedF V.Identity) as ->
240 V.Rec (TypedF V.Identity) as ->
207 m ()
241 m ()
208 execute fuzzop func args = do
242 execute fuzzop func args = do
209− liftIO $ print fuzzop
243+ (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
210− st <- get
211− let showable =
212− unlines $
213− ("args" : map show argTypes)
214− <> [ "fuzzop",
215− show fuzzop,
216− -- ,"dyncall"
217− -- ,show (dynTypeRep dyncall)
218− "state",
219− show st
220− ]
221− liftIO $ putStrLn showable
222 liftIO (V.runcurry' func argVals) >>= \case
244 liftIO (V.runcurry' func argVals) >>= \case
223− -- parameterise this
245+ Left (e::InteractionError) ->
224− Left (serverError :: ServerError) ->
246+ if fatalError e
225− case errHTTPCode serverError of
247+ then throw e
226− 500 -> throw serverError
248+ else pure ()
227− _ -> do
228− liftIO $ print ("ignoring non-500 error", serverError)
229− Right (dyn :: NEL.NonEmpty Dynamic) -> do
249+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
230− liftIO $ print ("storing", fmap dynTypeRep dyn)
231 modify'
250 modify'
232− ( \fs@FuzzState {..} ->
251+ ( \fs@FuzzState {..} ->
233− fs {stash = addToStash (NEL.toList dyn) stash}
252+ fs {stash = addToStash (NEL.toList dyn) stash}
234− )
253+ )
235 where
254 where
236 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
255 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
237− argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
256+ -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
238 go ::
257 go ::
239 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
258 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
240 m ()
259 m ()
@@ -242,21 +261,28 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
242 catches
261 catches
243 (execute op func args)
262 (execute op func args)
244 [ Handler (\(e :: SomeAsyncException) -> throw e),
263 [ Handler (\(e :: SomeAsyncException) -> throw e),
264+ Handler
265+ ( \(e :: SomeException) ->
245− Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
266+ throw . RoboservantException ServerCrashed (Just e) =<< get
267+ )
246 ]
268 ]
247 catch
269 catch
248− (liftIO checker)
270+ (liftIO healthCheck)
249− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
271+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
250
272
251addToStash ::
273addToStash ::
252− [Dynamic] ->
274+ [(Dynamic, Int)] ->
253 Stash ->
275 Stash ->
254 Stash
276 Stash
255addToStash result stash =
277addToStash result stash =
256 foldr
278 foldr
257− ( \(Dynamic tr x) (Stash dict) ->
279+ ( \(Dynamic tr x, hashed) (Stash dict) ->
258 Stash $
280 Stash $
281+ DM.insertWith
282+ renumber
283+ tr
259− 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
260 )
286 )
261 stash
287 stash
262 result
288 result
@@ -265,11 +291,16 @@ addToStash result stash =
265 StashValue a ->
291 StashValue a ->
266 StashValue a ->
292 StashValue a ->
267 StashValue a
293 StashValue a
268− 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
269− [([Provenance tr _], dyn)] ->
299+ [([Provenance tr _], dyn)] ->
270− l
271− <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
300+ l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
272− _ -> error "should be impossible"
301+ _ -> error "should be impossible"
302+ )
303+ (IntSet.union singleHash intSet)
273
304
274-- why isn't this in vinyl?
305-- why isn't this in vinyl?
275recordToList' ::
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+67−20
@@ -1,34 +1,81 @@
1−{-# LANGUAGE DefaultSignatures #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DerivingStrategies #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE DerivingVia #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
3
15
4module Roboservant.Types.Breakdown where
16module Roboservant.Types.Breakdown where
5
17
6−import Data.Dynamic (Dynamic, fromDynamic, toDyn)
18+import Data.Dynamic (Dynamic)
19+import Data.Hashable
20+import Data.Kind
7import Data.List.NonEmpty (NonEmpty (..))
21import Data.List.NonEmpty (NonEmpty (..))
8import qualified Data.List.NonEmpty as NEL
22import qualified Data.List.NonEmpty as NEL
9−import Data.Maybe (fromMaybe)
10import Data.Typeable (Typeable)
23import Data.Typeable (Typeable)
24+import GHC.Generics
25+import Roboservant.Types.Internal
26+import Servant
27+import Roboservant.Types.Orphans()
11
28
12−-- | only use this when we are using the internal typerep map.
29+breakdown ::
13−promisedDyn :: Typeable a => Dynamic -> a
30+ (Hashable x, Typeable x, Breakdown x) =>
14−promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
31+ x ->
32+ NonEmpty (Dynamic, Int)
33+breakdown x = hashedDyn x :| breakdownExtras x
15
34
16class Breakdown x where
35class Breakdown x where
17− breakdown :: x -> NonEmpty Dynamic
36+ breakdownExtras :: x -> [(Dynamic, Int)]
18− default breakdown :: Typeable x => x -> NonEmpty Dynamic
19− breakdown = pure . toDyn
20
37
21−-- | Can't break it down any further -- stuck in your teeth, maybe.
38+instance (Hashable x, Typeable x) => Breakdown (Atom x) where
22−newtype Chewy x = Chewy {unChew :: x}
39+ breakdownExtras _ = []
23
40
24−instance Breakdown () where
41+deriving via (Atom ()) instance Breakdown ()
25− breakdown = pure . toDyn
26
42
27−instance Breakdown Int where
43+deriving via (Atom Int) instance Breakdown Int
28− breakdown = pure . toDyn
44+deriving via (Atom Char) instance Breakdown Char
29
45
30−instance Typeable x => Breakdown (Chewy x) where
46+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x)
31− breakdown x = pure (toDyn x)
32
47
33−instance (Typeable a, Breakdown a) => Breakdown [a] where
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
34− breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
76+ gBreakdownExtras (K1 c) = NEL.toList $ breakdown c
77+
78+instance GBreakdown U1 where
79+ gBreakdownExtras U1 = []
80+
81+deriving via (Atom NoContent) instance Breakdown NoContent
src/Roboservant/Types/BuildFrom.hsnew file+107
@@ -0,0 +1,107 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+module Roboservant.Types.BuildFrom where
14+
15+import Data.List(nub)
16+import qualified Data.Dependent.Map as DM
17+import Data.Hashable
18+import qualified Data.IntSet as IntSet
19+import Data.Kind
20+import Data.List.NonEmpty (NonEmpty (..))
21+import qualified Data.List.NonEmpty as NEL
22+import Data.Typeable (Typeable)
23+import GHC.Generics
24+import Roboservant.Types.Internal
25+import qualified Type.Reflection as R
26+import Servant(NoContent)
27+import Roboservant.Types.Orphans()
28+
29+buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
30+buildFrom = buildStash . buildFrom'
31+ where
32+ buildStash :: [([Provenance], x)] -> Maybe (StashValue x)
33+ buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty
34+ promoteToStash :: ([Provenance], x) -> StashValue x
35+ promoteToStash (p, x) =
36+ StashValue
37+ (pure (p, x))
38+ (IntSet.singleton (hash x))
39+ addStash :: StashValue x -> StashValue x -> StashValue x
40+ addStash old (StashValue newVal _) =
41+ let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal
42+ in StashValue
43+ (addListToNE (getStashValue old) insertableVals)
44+ (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))
45+ addListToNE :: NonEmpty a -> [a] -> NonEmpty a
46+ addListToNE ne l = NEL.fromList (NEL.toList ne <> l)
47+
48+buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]
49+buildFrom' stash =
50+ maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))
51+ <> extras stash
52+
53+class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
54+ extras :: Stash -> [([Provenance], x)]
55+
56+instance (Hashable x, Typeable x) => BuildFrom (Atom x) where
57+ extras _ = []
58+
59+deriving via (Atom Bool) instance BuildFrom Bool
60+
61+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)
62+
63+-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
64+-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
65+instance (Eq x, BuildFrom x) => BuildFrom [x] where
66+ extras stash =
67+ nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash
68+ where
69+ -- powerset creates way too much stuff. something better here eventually.
70+ notpowerset xs = []:xs:map pure xs
71+
72+
73+instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where
74+ extras stash = fmap (Compound . to) <$> gExtras stash
75+
76+deriving via (Atom Int) instance BuildFrom Int
77+
78+deriving via (Atom Char) instance BuildFrom Char
79+
80+class GBuildFrom (f :: k -> Type) where
81+ gExtras :: Stash -> [([Provenance], f a)]
82+
83+instance GBuildFrom b => GBuildFrom (M1 D a b) where
84+ gExtras = fmap (fmap M1) . gExtras
85+
86+-- not recursion safe!
87+instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
88+ gExtras stash =
89+ (fmap L1 <$> gExtras stash)
90+ <> (fmap R1 <$> gExtras stash)
91+
92+instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
93+ gExtras stash = [(pa <> pb, a' :*: b') | (pa, a') <- gExtras stash, (pb, b') <- gExtras stash]
94+
95+instance GBuildFrom b => GBuildFrom (M1 C a b) where
96+ gExtras = fmap (fmap M1) . gExtras
97+
98+instance GBuildFrom b => GBuildFrom (M1 S a b) where
99+ gExtras = fmap (fmap M1) . gExtras
100+
101+instance BuildFrom a => GBuildFrom (K1 i a) where
102+ gExtras = fmap (fmap K1) . buildFrom'
103+
104+instance GBuildFrom U1 where
105+ gExtras _ = [([], U1)]
106+
107+deriving via (Atom NoContent) instance BuildFrom NoContent
src/Roboservant/Types/Config.hsnew file+29
@@ -0,0 +1,29 @@
1+module Roboservant.Types.Config where
2+
3+import Data.Dynamic
4+
5+data Config
6+ = Config
7+ { seed :: [(Dynamic, Int)],
8+ maxRuntime :: Double, -- seconds to test for
9+ maxReps :: Integer,
10+ rngSeed :: Int,
11+ coverageThreshold :: Double,
12+ logInfo :: String -> IO (),
13+ healthCheck :: IO ()
14+ }
15+
16+defaultConfig :: Config
17+defaultConfig =
18+ Config
19+ { seed = [],
20+ maxRuntime = 0.5,
21+ maxReps = 1000,
22+ rngSeed = 0,
23+ coverageThreshold = 0,
24+ logInfo = const (pure ()),
25+ healthCheck = pure ()
26+ }
27+
28+noisyConfig :: Config
29+noisyConfig = defaultConfig {logInfo = print}
src/Roboservant/Types/FlattenServer.hsdeleted−45
@@ -1,45 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE TypeOperators #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−module Roboservant.Types.FlattenServer where
11−
12−import Servant
13−
14−
15−data Bundled endpoints where
16− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
17− NoEndpoints :: Bundled '[]
18−
19−class FlattenServer api where
20− flattenServer :: Server api -> Bundled (Endpoints api)
21−
22−instance
23− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
24− Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
25− FlattenServer api
26− ) =>
27− FlattenServer (endpoint :<|> api)
28− where
29− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
30−
31−instance
32− ( HasServer (x :> api) '[],
33− Endpoints (x :> api) ~ '[x :> api]
34− ) =>
35− FlattenServer (x :> api)
36− where
37− flattenServer server = server `AnEndpoint` NoEndpoints
38−
39−instance
40− ( HasServer (Verb method statusCode contentTypes responseType) '[],
41− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
42− ) =>
43− FlattenServer (Verb method statusCode contentTypes responseType)
44− where
45− flattenServer server = server `AnEndpoint` NoEndpoints
src/Roboservant/Types/Internal.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+
6+module Roboservant.Types.Internal where
7+
8+import qualified Data.Dependent.Map as DM
9+import Data.Dependent.Map (DMap)
10+import Data.Dependent.Sum
11+import Data.Dynamic (Dynamic, toDyn)
12+import Data.Hashable (Hashable, hash)
13+import Data.IntSet (IntSet)
14+import Data.List.NonEmpty (NonEmpty (..))
15+import qualified Data.Map.Strict as Map
16+import Data.Typeable (Typeable)
17+import GHC.Generics (Generic)
18+import qualified Type.Reflection as R
19+
20+data Provenance
21+ = Provenance R.SomeTypeRep Int
22+ deriving (Show, Eq, Generic)
23+
24+instance Hashable Provenance
25+
26+data StashValue a
27+ = StashValue
28+ { getStashValue :: NonEmpty ([Provenance], a),
29+ stashHash :: IntSet
30+ }
31+ deriving (Functor, Show)
32+
33+-- wrap in newtype to give a custom Show instance, since the normal
34+-- instance for DMap is not happy since StashValue needs Show a to show
35+newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}
36+ deriving (Semigroup, Monoid)
37+
38+instance Show Stash where
39+ showsPrec i (Stash x) =
40+ showsPrec i
41+ $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))
42+ $ DM.toList x
43+
44+-- | Can't be built up from parts, can't be broken down further.
45+newtype Atom x = Atom {unAtom :: x}
46+ deriving newtype (Hashable, Typeable,Eq)
47+
48+-- | can be broken down and built up from generic pieces
49+newtype Compound x = Compound {unCompound :: x}
50+ deriving newtype (Hashable, Typeable, Eq)
51+
52+hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)
53+hashedDyn a = (toDyn a, hash a)
src/Roboservant/Types/Orphans.hsnew file+7
@@ -0,0 +1,7 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module Roboservant.Types.Orphans where
3+
4+import Servant
5+import Data.Hashable
6+
7+instance Hashable NoContent
src/Roboservant/Types/ReifiedApi.hs+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−22
@@ -1,27 +1,10 @@
1−resolver: lts-16.16
1+resolver: lts-20.4
2packages:
2packages:
3- .
3- .
4
4
5extra-deps:
5extra-deps:
6+# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
7+# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
6- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
7−- markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112
9+# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
8−- servant-0.18
10+- some-1.0.3
9−- servant-client-0.18
10−- servant-client-core-0.18
11−- servant-server-0.18
12−# - hspec-hedgehog-0.0.1.2@sha256:aaeeb50a43d2bce8a1850baa3ddf934a964bfe38c64efd59306b0c1421e55b45,1405
13−- QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736
14−- random-1.2.0
15−- splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253
16−- vinyl-0.13.0
17−- dependent-sum-0.7.1.0
18−- constraints-extras-0.3.0.2
19−- dependent-map-0.4.0.0
20−- git: https://github.com/hedgehogqa/haskell-hedgehog.git
21− commit: 03714682586e43b5ddf5c00391035471a6e01238
22− subdirs:
23− - hedgehog
24−- git: https://github.com/mwotton/hspec
25− commit: cd9012414a93cf08f86e409544d4d3a8f282b507
26− subdirs:
27− - hspec-core
stack.yaml.lock+9−112
@@ -7,123 +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: markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112
15+ hackage: some-1.0.3@sha256:938cec5fc0d3a08dde34cfc0acd5a0aa2e9fd489c9dbb64417f16588dfb47af0,2399
16− pantry-tree:
17− size: 432
18− sha256: 6871bd9281acf589296d0998a3d62892b036040ab10e74e8a0f356f68c194f4f
19− original:
20− hackage: markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112
21−- completed:
22− hackage: servant-0.18@sha256:2b5c81089540c208b1945b5ca0c3551c862138d71b224a39fa275a62852a5c75,5068
23− pantry-tree:
24− size: 2458
25− sha256: 701b6443e486601dd127b92a28ca052278dea8dc528f013781c1304826e117d8
26− original:
27− hackage: servant-0.18
28−- completed:
29− hackage: servant-client-0.18@sha256:3e3b8d145cf811e19849744ad305aa0bd42301d01ff75e1dac169bc9f5d18221,4589
30− pantry-tree:
31− size: 1299
32− sha256: 445c610d83a6e356ed2a7808af8deac84708be3e44d38cbf76e60fd6105f9715
33− original:
34− hackage: servant-client-0.18
35−- completed:
36− hackage: servant-client-core-0.18@sha256:6702f04f3e5ac47abace5b26ab1948480437334747895407f0697502a403b96a,3593
37− pantry-tree:
38− size: 1444
39− sha256: 20f538ae12091696073a2ac5f3301a4a56686f5e2889b2a9e539c0d61a332cd1
40− original:
41− hackage: servant-client-core-0.18
42−- completed:
43− hackage: servant-server-0.18@sha256:ec7f361bc9848968b1fff8091fa2213b721d3f47549421945c6a7ca1702e22e6,5424
44− pantry-tree:
45− size: 2546
46− sha256: c2470cd8665742cee13faae1db7e3d49d70b027d57c4578e3f7ba66ffc8dc7b4
47− original:
48− hackage: servant-server-0.18
49−- completed:
50− hackage: QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736
51− pantry-tree:
52− size: 2315
53− sha256: 21961d0875fc156cdd97110a6fb277f37aa31faa3c7910895f84c82630e7ba46
54− original:
55− hackage: QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736
56−- completed:
57− hackage: random-1.2.0@sha256:4321209c8faedc034810ea8ed0dbc4a36f1a1df97b75af024219f2f533da57de,6094
58− pantry-tree:
59− size: 1259
60− sha256: 29ff0a7ec5bf123e2c40f849b7af163950854a6c08c68b4a1b4364ce7a515af0
61− original:
62− hackage: random-1.2.0
63−- completed:
64− hackage: splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253
65− pantry-tree:
66− size: 1149
67− sha256: b9a0c60e2d4786bbb276ce6606027a99615bf703fa3e0f01911e8c6a656c5161
68− original:
69− hackage: splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253
70−- completed:
71− hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724
72− pantry-tree:
73− size: 1857
74− sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01
75− original:
76− hackage: vinyl-0.13.0
77−- completed:
78− hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
79− pantry-tree:
80− size: 290
81− sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50
82− original:
83− hackage: dependent-sum-0.7.1.0
84−- completed:
85− hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
86− pantry-tree:
87− size: 594
88− sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1
89− original:
90− hackage: constraints-extras-0.3.0.2
91−- completed:
92− hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
93− pantry-tree:
94− size: 551
95− sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5
96− original:
97− hackage: dependent-map-0.4.0.0
98−- completed:
99− subdir: hedgehog
100− name: hedgehog
101− version: 1.0.3
102− git: https://github.com/hedgehogqa/haskell-hedgehog.git
103− pantry-tree:
104− size: 2575
105− sha256: 7e69930fef281dfeb47b2f7c745c26234768e56ffb5490065f607c57146ffbab
106− commit: 03714682586e43b5ddf5c00391035471a6e01238
107− original:
108− subdir: hedgehog
109− git: https://github.com/hedgehogqa/haskell-hedgehog.git
110− commit: 03714682586e43b5ddf5c00391035471a6e01238
111−- completed:
112− subdir: hspec-core
113− name: hspec-core
114− version: 2.7.4
115− git: https://github.com/mwotton/hspec
116 pantry-tree:
16 pantry-tree:
17+ sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8
117− size: 3899
18+ size: 709
118− sha256: 6ece11ad28a7f122a502e766eb1b3ef950815c2d16babb0ea8744646f1c1bd70
119− commit: cd9012414a93cf08f86e409544d4d3a8f282b507
120 original:
19 original:
121− subdir: hspec-core
20+ hackage: some-1.0.3
122− git: https://github.com/mwotton/hspec
123− commit: cd9012414a93cf08f86e409544d4d3a8f282b507
124snapshots:
21snapshots:
125- completed:
22- completed:
23+ sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94
126− size: 532380
24+ size: 648660
127− 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
128− sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e
129− 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.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Post 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] FooPost
17+ :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
18+
19+data FooPost = FooPost
20+ deriving (Eq, Show, Generic)
21+
22+instance Hashable FooPost
23+
24+instance ToJSON FooPost
25+
26+instance FromJSON FooPost
27+
28+server :: Server Api
29+server =
30+ pure FooPost
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+150−56
@@ -1,76 +1,170 @@
1−
1+{-# LANGUAGE DerivingVia #-}
2+{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE StandaloneDeriving #-}
3{-# LANGUAGE TypeApplications #-}
6{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE DataKinds #-}
4{-# 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)
5import qualified Foo
20import qualified Foo
21+import qualified Headers
22+import qualified Nested
23+import qualified Post
24+import qualified Put
25+import qualified Product
26+import qualified QueryParams
27+import qualified Roboservant as R
28+import qualified Roboservant.Server as RS
29+import qualified Roboservant.Client as RC
6import qualified Seeded
30import qualified Seeded
31+import Test.Hspec
32+import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
7import qualified Valid
33import qualified Valid
8−import qualified Headers
34+import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
9−-- import qualified UnsafeIO
10−
11−import Data.Dynamic(toDyn)
12−import qualified Roboservant as RS
13
35
14−import Test.Hspec
36+import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
15−import Test.Hspec.Core.Spec(shouldFail)
37+import Network.Wai(Application)
16−import Data.Void
38+import qualified Network.Wai.Handler.Warp as Warp
17−import Data.Maybe
39+import Network.HTTP.Client (newManager, defaultManagerSettings)
40+import Control.Monad((>=>))
18
41
19main :: IO ()
42main :: IO ()
20main = hspec spec
43main = hspec spec
21
44
22−noCheck :: IO ()
45+fuzzBoth
23−noCheck = pure ()
46+ :: forall a .
24−
47+ (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
25−defaultConfig :: RS.Config
48+ HasClient ClientM a)
26−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 })
27
64
28spec :: Spec
65spec :: Spec
29spec = do
66spec = do
30 describe "Basic usage" $ do
67 describe "Basic usage" $ do
31 describe "noError" $ do
68 describe "noError" $ do
32− 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)
33− RS.fuzz @Valid.Api Valid.server defaultConfig noCheck `shouldReturn` Nothing
70+ fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
34− it "does fail coverage check" $ do
35− 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 ->
73+ fmap (R.failureReason . R.rsException) r
36− r `shouldSatisfy` isJust
74+ `shouldSatisfy` ( \case
75+ Just (R.InsufficientCoverage _) -> True
76+ _ -> False
77+ ))
37− describe "seeded" $ do
78+ describe "posted body" $
38− shouldFail $
79+ fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
39− it "finds an error using information passed in" $
80+ (`shouldSatisfy` isNothing)
40− RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
41− `shouldReturn` Nothing
42− shouldFail $ it "finds an error in a basic app" $
43− RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
44− `shouldReturn` Nothing
45− shouldFail $ it "should find a failure that's dependent on using header info" $ do
46− RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
47− `shouldReturn` Nothing
48− -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
49− -- -- -- could: it's mostly here to show how to test for concurrency problems.
50− -- describe "concurrency bugs" $ do
51− -- before UnsafeIO.makeServer $ do
52− -- describe "sequential checking" $ do
53− -- it "safe use" $ \unsafeServer -> do
54− -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
55−
56− -- modifyMaxSuccess (const 10000) $
57− -- shouldFail $
58− -- describe "concurrent" $ do
59− -- it "concurrent, dangerous use" $ \unsafeServer -> do
60− -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
61−
62−
63−instance RS.Breakdown Foo.Foo where
64− breakdown = pure . toDyn
65
81
66
82
67−instance RS.Breakdown Headers.Foo where
83+ describe "PUTted body" $
68− breakdown = pure . toDyn
84+ fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}
85+ (`shouldSatisfy` isNothing)
69
86
70−instance RS.BuildFrom Foo.Foo
71
87
72−instance RS.BuildFrom Headers.Foo
88+ describe "seeded" $ do
73−
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)
93+
94+ describe "Foo" $
95+ fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
96+
97+ describe "QueryParams" $
98+ fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }
99+ (`shouldSatisfy` isNothing)
100+
101+ describe "BuildFrom" $ do
102+ describe "headers (and sum types)" $
103+ fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig
104+ (`shouldSatisfy` serverFailure)
105+ describe "product types" $
106+ fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
107+ R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}
108+ (`shouldSatisfy` serverFailure)
109+ describe "Breakdown" $ do
110+ fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig
111+ (`shouldSatisfy` serverFailure)
112+ fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig
113+ (`shouldSatisfy` serverFailure)
114+ describe "flattening" $
115+ fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}
116+ (`shouldSatisfy` isNothing)
117+
118+serverFailure :: Maybe R.Report -> Bool
119+serverFailure = \case
120+ Just R.Report {..} ->
121+ let R.RoboservantException {..} = rsException
122+ in failureReason /= R.NoPossibleMoves
123+ _ -> False
124+
125+deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
126+
127+deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
128+
129+deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
130+
74−instance RS.BuildFrom Seeded.Seed
131+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
75−
132+
133+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
134+
76−instance RS.BuildFrom Void
135+deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
136+
137+deriving via (R.Atom Void) instance R.BuildFrom Void
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
141+
142+deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
143+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
144+
145+
146+
147+deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
148+
149+deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
150+
151+deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
152+
153+-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
154+-- this is often useful when testing tests.
155+shouldFail :: SpecWith a -> SpecWith a
156+shouldFail =
157+ mapSpecItem_
158+ ( \i ->
159+ i
160+ { itemExample = \p a cb -> do
161+ r <- itemExample i p a cb
162+ pure
163+ r
164+ { resultStatus = case resultStatus r of
165+ Success -> Failure Nothing (Reason "Unexpected success")
166+ Failure _ _ -> Success
167+ x -> x
168+ }
169+ }
170+ )
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 ())