git.iko.soy/roboservant
on master help sign in
swap
8ade8f3106 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+8−5
@@ -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:
@@ -11,14 +11,15 @@ jobs:
11 runs-on: ${{ matrix.os }}
11 runs-on: ${{ matrix.os }}
12 strategy:
12 strategy:
13 matrix:
13 matrix:
14− stack: ["2.1.3"]
14+ stack: ["2.3.3"]
15− ghc: ["8.8.3"]
15+ ghc: ["8.10.4"]
16− os: [ubuntu-latest, macOS-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 -c 'stack repl --test --ghc-options=-fobject-code roboservant' --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+101−57
@@ -2,69 +2,113 @@
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
9+
10+see full example [here](EXAMPLE.md)
11+
7−# why?
12+## why?
8
13
9Servant 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
10use this information to generate arbitrarily long request/response
15use this information to generate arbitrarily long request/response
11sessions and verify properties that should hold over them.
16sessions and verify properties that should hold over them.
12
17
18+## how?
19+
20+In essence, ```fuzz @Api yourServer config``` will make a bunch of
21+calls to your API, and record the results in a type-indexed
22+dictionary. This means that they are now available for the
23+prerequisites of other calls, so as you proceed, more and more api
24+calls become possible.
25+
26+We explicitly do not try to come up with plausible values that haven't
27+somehow come back from the API. That's straying into QC/Hedgehog
28+territory: if you want that, come up with the values on that side, and
29+set them as seeds in the configuration.
30+
31+### what does it mean to be "available"?
32+
33+In a simple API, you may make a call and get back a `Foo`, which will
34+allow you to make another call that requires a `Foo`. In a more
35+complicated app, it's likely that you'll send a request body that
36+includes many subcomponents, and it's likely you'll get a response
37+that needs to be broken down into pieces before it's useful.
38+
39+To cope with this, we have the typeclasses `BuildFrom` and
40+`Breakdown`. You can write instances for them if you feel like it, and
41+indeed it's currently required for recursive datatypes if you don't
42+want the fuzzer to hang, but for the majority of your types it should
43+be sufficient to derive them generically. (Sensible instances are
44+provided for lists.)
45+
46+There are two basic strategies here. In some cases, you want to regard
47+a type as indivisible: that's why we like newtypes, right? In this
48+case, we can derive using the `Atom` strategy.
49+
50+``` haskell
51+deriving via (Atom NewtypedKey) instance Breakdown NewtypedKey
52+deriving via (Atom NewtypedKey) instance BuildFrom NewtypedKey
53+```
54+
55+This is saying "A can neither be built from components or broken down
56+for spare parts. Hands off!". This is a good strategy for key types,
57+for instance.
58+
59+If instead it's a big complicated thing with lots of juicy
60+subcomponents, we want to rip it apart using Generics and feast on
61+its succulent headmeats:
62+
63+``` haskell
64+deriving via (Compound Payload) instance Breakdown Payload
65+deriving via (Compound Payload) instance BuildFrom Payload
66+```
67+
68+### priming the pump
69+
70+Sometimes there are values we'd like to smuggle into the API that are
71+not derivable from within the API itself: sometimes this is a warning
72+sign that your API is incomplete, but it can be quite reasonable to
73+require identifying credentials within an API and not provide a way to
74+get them. It might also be reasonable to have some sample values that
75+the user is expected to come up with.
76+
77+For those cases, override the `seed` in the `Config` with a
78+list of seed values, suitably hashed:
79+
80+``` haskell
81+defaultConfig { seed = [hashedDyn creds, hashedDyn userJwt]}
82+```
83+
13−# why not servant-quickcheck?
84+## why not servant-quickcheck?
14
85
15[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
86[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
16−is a great package and I've learned a lot from it. Unfortunately,
87+is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
17−there's a lot of the state space it can't explore: modern webapps are
88+there's a lot of the state space you just can't explore without context: modern webapps are
18full of pointer-like structures, whether they're URLs or database
89full of pointer-like structures, whether they're URLs or database
19−keys/uuids. servant-quickcheck demands that you be able to generate
90+keys/uuids, and servant-quickcheck requires that you be able to generate
20−these without context via Arbitrary: good luck exploring an API that
91+these without context via Arbitrary.
21−requires you to generate just the right UUID to hit non-trivial code.
92+
22−
93+## limitations and future work
23−roboservant avoids this by using
94+
24−[quickcheck-state-machine](https://github.com/advancedtelematic/quickcheck-state-machine#readme),
95+Currently, the display of failing traces is pretty tragic, both in the
25−which models the dynamic state in such a way that we can use results
96+formatting and in its non-minimality. This is pretty ticklish:
26−of previous calls.
97+arguably the right way to do this is to return a trace that we can
27−
98+also rerun, and let quickcheck or hedgehog a level up shrink it until
28−# concept
99+it's satisfactorily short. In the interest of being useful earlier
29−
100+rather than later, I'm releasing v1.0 before I crack this particular
30−we start with a servant api and a server that fulfills the type.
101+nut. We do know which calls we made that led to the failing case, so
31−
102+we would want to show that distinction in a visible way: it's possible
32−From that api, we should be able to summon up an empty type-indexed store with a key
103+that other calls that don't have direct data dependencies were
33−for each response type in the API.
104+important, but we definitely know we need the direct data dependencies.
34−
105+
35−We can then look at each callable endpoint, and eliminate any that require values that are
106+The provenance stuff is a bit underbaked. It should at least pull a
36−empty in the type-indexed store. this allows a generative process where we can extend a sequence
107+representation of the route chosen rather than just an integer index.
37−of calls indefinitely, by making a call to the concrete server and recording the result in the
108+
38−type-indexed store.
109+It would also be nice to have a robust strategy for deriving recursive
39−
110+datatypes, or at least rejecting attempts to generate them that don't
40−## extensions
111+end in an infinite loop.
41−- add some "starter" values to the store
112+
42− - there may be a JWT that's established outside the servant app, for instance.
113+Currently the `FlattenServer` instance for `:>` is quadratic. It would
43−- `class Extras a where extras :: Gen [a]`
114+be nice to fix this but I lack the art.
44− - default implementation `pure []`
45− - selectively allow some types to create values we haven't seen from the api.
46− `newtype FirstName = FirstName Text`, say.
47−- break down each response type into its components
48− - if i have
49− - `data Foo = FBar Bar | FBaz Baz`
50− - an endpoint `foo` that returns a `Foo`
51− - and an endpoint `bar` that takes a `Bar`
52− - I should be able to call `foo` to get a `Foo`, and if it happens to be an `FBar Bar`, I
53− should be able to use that `Bar` to call `bar`.
54−
55−## applications
56−- testing
57− - some properties should always hold (no 500s)
58− - there may be some other properties that hold contextually
59− - healthcheck should be 200
60− - test complex permissions/ownership/delegation logic - should never be able to
61− get access to something you don't own or haven't been delegated access to.
62−
63−- coverage
64− - if you run the checker for a while and `hpc` suggests you still have bad coverage,
65− your api is designed in a way that requires external manipulation and may be improvable.
66−
67−- benchmarking
68− - we can generate "big-enough" call sequences, then save the database & a sample call for each
69− endpoint that takes long enough to be a reasonable test.
70− - from this we can generate tests that a given call on that setup never gets slower.
TODO.md+32−8
@@ -1,8 +1,32 @@
1−DONE
1+## extensions/todo
2−- basic setup
2+
3−- extract response types from the api
3+- add some "starter" values to the store
4−- proper readme
4+ - there may be a JWT that's established outside the servant app, for instance.
5−
5+- `class Extras a where extras :: Gen [a]`
6−TODO
6+ - default implementation `pure []`
7−- some way to select a random endpoint to run from a given Server.
7+ - selectively allow some types to create values we haven't seen from the api.
8−- hook up quickcheck-state-machine/hedgehog
8+ `newtype FirstName = FirstName Text`, say.
9+- break down each response type into its components
10+ - if i have
11+ - `data Foo = FBar Bar | FBaz Baz`
12+ - an endpoint `foo` that returns a `Foo`
13+ - and an endpoint `bar` that takes a `Bar`
14+ - I should be able to call `foo` to get a `Foo`, and if it happens to be an `FBar Bar`, I
15+ should be able to use that `Bar` to call `bar`.
16+- better handling of properties to be verified
17+ - some properties should always hold (no 500s): this already works.
18+ - to-do: there may be some other properties that hold contextually
19+ - healthcheck should be 200
20+ - test complex permissions/ownership/delegation logic - should never be able to
21+ get access to something you don't own or haven't been delegated access to.
22+
23+## other possible applications
24+
25+- coverage
26+ - if you run the checker for a while and `hpc` suggests you still have bad coverage,
27+ your api is designed in a way that requires external manipulation and may be improvable.
28+
29+- benchmarking
30+ - we can generate "big-enough" call sequences, then save the database & a sample call for each
31+ endpoint that takes long enough to be a reasonable test.
32+ - from this we can generate tests that a given call on that setup never gets slower.
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+49−30
@@ -1,47 +1,44 @@
1+
1name: roboservant
2name: roboservant
2−version: 0.1.0.0
3+version: 0.1.0.3
3−github: "githubuser/roboservant"
4+github: "mwotton/roboservant"
4license: BSD3
5license: BSD3
5−author: "Author name here"
6+copyright: "2020 Mark Wotton, Samuel Schlesinger"
6−maintainer: "example@example.com"
7+synopsis: Automatic session-aware servant testing
7−copyright: "2020 Author name here"
8+category: Web
9+description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
8
10
9extra-source-files:
11extra-source-files:
10- README.md
12- README.md
11- ChangeLog.md
13- ChangeLog.md
12
14
13−# Metadata used when publishing your package
14−# synopsis: Short description of your package
15−# category: Web
16−
17−# To avoid duplicated efforts in documentation and dealing with the
18−# complications of embedding Haddock markup inside cabal files, it is
19−# common to point users to the README.md file.
20−description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
21−
22dependencies:
15dependencies:
23- base >= 4.7 && < 5
16- base >= 4.7 && < 5
24
17
25−
26- bytestring
18- bytestring
27−- hedgehog
28−- constrained-dynamic
29- containers
19- containers
30−- http-client
20+- random
21+- hashable
31−- http-media
22+- http-types
32−- QuickCheck
23+- lifted-base
33−- quickcheck-state-machine >= 0.7
24+- monad-control
25+- mtl
34−- servant >= 0.17
26+- servant # >= 0.17
35−- servant-client >= 0.17
27+- servant-client # >= 0.17
36- servant-flatten
28- servant-flatten
37−- servant-server >= 0.17
29+- servant-server # >= 0.17
38- string-conversions
30- string-conversions
39−# test deps
31+- vinyl
40−- hspec
32+- dependent-sum
41−- QuickCheck
33+- dependent-map
42−- warp
34+- unordered-containers
43−- aeson
35+- text
44−- wai
36+- time
37+
38+ghc-options:
39+- -Wall
40+- -fwrite-ide-info
41+- -hiedir=.hie
45library:
42library:
46 source-dirs: src
43 source-dirs: src
47
44
@@ -55,3 +52,25 @@ tests:
55 - -with-rtsopts=-N
52 - -with-rtsopts=-N
56 dependencies:
53 dependencies:
57 - roboservant
54 - roboservant
55+ - aeson
56+ - hspec
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+104−33
@@ -1,19 +1,19 @@
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: bc1746c1053b1f6bf66cc30046bb205fefd129303feff615f0d885999eace809
7+-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d
8
8
9name: roboservant
9name: roboservant
10−version: 0.1.0.0
10+version: 0.1.0.3
11+synopsis: Automatic session-aware servant testing
11−description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
12+description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
13+category: Web
12−homepage: https://github.com/githubuser/roboservant#readme
14+homepage: https://github.com/mwotton/roboservant#readme
13−bug-reports: https://github.com/githubuser/roboservant/issues
15+bug-reports: https://github.com/mwotton/roboservant/issues
14−author: Author name here
16+copyright: 2020 Mark Wotton, Samuel Schlesinger
15−maintainer: example@example.com
16−copyright: 2020 Author name here
17license: BSD3
17license: BSD3
18license-file: LICENSE
18license-file: LICENSE
19build-type: Simple
19build-type: Simple
@@ -23,36 +23,86 @@ extra-source-files:
23
23
24source-repository head
24source-repository head
25 type: git
25 type: git
26− location: https://github.com/githubuser/roboservant
26+ location: https://github.com/mwotton/roboservant
27
27
28library
28library
29 exposed-modules:
29 exposed-modules:
30 Roboservant
30 Roboservant
31− Roboservant.ContextualGenRequest
31+ Roboservant.Client
32+ Roboservant.Direct
33+ Roboservant.Server
34+ Roboservant.Types
35+ Roboservant.Types.Breakdown
36+ Roboservant.Types.BuildFrom
37+ Roboservant.Types.Config
32− Roboservant.Hedgehog
38+ Roboservant.Types.Internal
33− Roboservant.StateMachine
39+ Roboservant.Types.Orphans
40+ Roboservant.Types.ReifiedApi
41+ Roboservant.Types.ReifiedApi.Server
34 other-modules:
42 other-modules:
35 Paths_roboservant
43 Paths_roboservant
36 hs-source-dirs:
44 hs-source-dirs:
37 src
45 src
46+ ghc-options: -Wall -fwrite-ide-info -hiedir=.hie
38 build-depends:
47 build-depends:
39− QuickCheck
48+ base >=4.7 && <5
49+ , bytestring
50+ , containers
51+ , dependent-map
52+ , dependent-sum
53+ , hashable
54+ , http-types
55+ , lifted-base
56+ , monad-control
57+ , mtl
58+ , random
59+ , servant
60+ , servant-client
61+ , servant-flatten
62+ , servant-server
63+ , string-conversions
64+ , text
65+ , time
66+ , unordered-containers
67+ , vinyl
68+ default-language: Haskell2010
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:
40− , aeson
81+ aeson
41 , base >=4.7 && <5
82 , base >=4.7 && <5
42 , bytestring
83 , bytestring
43− , constrained-dynamic
44 , containers
84 , containers
45− , hedgehog
85+ , dependent-map
86+ , dependent-sum
87+ , hashable
46 , hspec
88 , hspec
89+ , hspec-core
47 , http-client
90 , http-client
48− , http-media
91+ , http-types
49− , quickcheck-state-machine >=0.7
92+ , lifted-base
93+ , monad-control
94+ , mtl
95+ , random
96+ , roboservant
50− , servant >=0.17
97+ , servant
51− , servant-client >=0.17
98+ , servant-client
52 , servant-flatten
99 , servant-flatten
53− , servant-server >=0.17
100+ , servant-server
54 , string-conversions
101 , string-conversions
55− , wai
102+ , text
103+ , time
104+ , unordered-containers
105+ , vinyl
56 , warp
106 , warp
57 default-language: Haskell2010
107 default-language: Haskell2010
58
108
@@ -60,28 +110,49 @@ test-suite roboservant-test
60 type: exitcode-stdio-1.0
110 type: exitcode-stdio-1.0
61 main-is: Spec.hs
111 main-is: Spec.hs
62 other-modules:
112 other-modules:
113+ Breakdown
114+ Foo
115+ Headers
116+ Nested
117+ Post
118+ Product
119+ Put
120+ QueryParams
121+ Seeded
122+ UnsafeIO
123+ Valid
63 Paths_roboservant
124 Paths_roboservant
64 hs-source-dirs:
125 hs-source-dirs:
65 test
126 test
66− ghc-options: -threaded -rtsopts -with-rtsopts=-N
127+ ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N
67 build-depends:
128 build-depends:
68− QuickCheck
69− , aeson
129+ aeson
70 , base >=4.7 && <5
130 , base >=4.7 && <5
71 , bytestring
131 , bytestring
72− , constrained-dynamic
73 , containers
132 , containers
74− , hedgehog
133+ , dependent-map
134+ , dependent-sum
135+ , hashable
75 , hspec
136 , hspec
137+ , hspec-core
138+ , hspec-wai
139+ , http-api-data
76 , http-client
140 , http-client
77− , http-media
141+ , http-types
78− , quickcheck-state-machine >=0.7
142+ , lifted-base
143+ , monad-control
144+ , mtl
145+ , random
79 , roboservant
146 , roboservant
80− , servant >=0.17
147+ , servant
81− , servant-client >=0.17
148+ , servant-client
82 , servant-flatten
149 , servant-flatten
83− , servant-server >=0.17
150+ , servant-server
84 , string-conversions
151 , string-conversions
152+ , text
153+ , time
154+ , unordered-containers
155+ , vinyl
85 , wai
156 , wai
86 , warp
157 , warp
87 default-language: Haskell2010
158 default-language: Haskell2010
src/Roboservant.hs+8−110
@@ -1,110 +1,8 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE StandaloneDeriving #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE KindSignatures #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE QuantifiedConstraints #-}
12−{-# LANGUAGE RankNTypes #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TypeApplications #-}
15−{-# LANGUAGE TypeFamilies #-}
16−{-# LANGUAGE TypeOperators #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−{-# LANGUAGE FunctionalDependencies #-}
19−module Roboservant where
1+module Roboservant
20−
2+ ( module Roboservant.Direct,
21−import Prelude hiding (lookup)
3+ module Roboservant.Types,
22−import GHC.TypeLits
4+ )
23−import Servant.API
5+where
24−
6+
25−import Roboservant.ContextualGenRequest
7+import Roboservant.Direct
26−import Roboservant.StateMachine
8+import Roboservant.Types
27−
28−
29−-- | Extract the response types from a single servant endpoint, i.e. one
30−-- without any ':<|>' type constructors in it.
31−type family ExtractRespType (path :: *) :: * where
32− ExtractRespType (_ :> b) = ExtractRespType b
33− ExtractRespType (Verb (method :: StdMethod) (responseCode :: Nat) (contentTypes :: [*]) (respType :: *)) = respType
34−
35−-- | Extract the response types from a flattened servant API, i.e. one
36−-- which has the distributive law (modulo isomorphism) applied to it until
37−-- it reaches a normal form.
38−type family ExtractRespTypes (paths :: *) :: [*] where
39− ExtractRespTypes (a :<|> b) = ExtractRespTypes a <> ExtractRespTypes b
40− ExtractRespTypes a = '[ExtractRespType a]
41−
42−-- | Append two type level lists.
43−type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where
44− (x ': xs) <> ys = x ': (xs <> ys)
45− '[] <> ys = ys
46−
47−-- | A homogeneous-functor-list, I guess.
48−data List :: (* -> *) -> [*] -> * where
49− Cons :: f a -> List f as -> List f (a ': as)
50− Nil :: List f '[]
51−
52−-- | So we can use efficient container types for specific types if the need
53−-- arises.
54−class Listy f a where
55− cons :: a -> f a -> f a
56− empty :: f a
57− uncons :: f a -> Maybe (a, f a)
58−
59−instance Listy [] a where
60− cons = (:)
61− empty = []
62− uncons = \case
63− a : as -> Just (a, as)
64− [] -> Nothing
65−
66−-- | A function for inserting elements into their slot in the store.
67−class Insert f a as where
68− insert :: a -> List f as -> List f as
69−instance {-# OVERLAPPABLE #-} Listy f a => Insert f a (a ': as) where
70− insert a (Cons as ls) = Cons (cons a as) ls
71−instance {-# OVERLAPPABLE #-} Insert f a as => Insert f a (b ': as) where
72− insert a (Cons as ls) = Cons as (insert a ls)
73−
74−-- | A function for looking up the container of elements for a specific
75−-- type in the store.
76−class Lookup f a as where
77− lookup :: List f as -> f a
78−
79−instance {-# OVERLAPPABLE #-} Lookup f a (a ': as) where
80− lookup (Cons fa ls) = fa
81−instance {-# OVERLAPPABLE #-} Lookup f a as => Lookup f a (b ': as) where
82− lookup (Cons fa ls) = lookup ls
83−
84−deriving instance (Show (List f as), forall a. Show a => Show (f a), Show a)
85− => Show (List f (a ': as))
86−
87−instance Show (List f '[]) where show _ = "Nil"
88−
89−storeOfApi :: BuildStore [] (ExtractRespTypes api) => List [] (ExtractRespTypes api)
90−storeOfApi = buildStore
91−
92−class BuildStore f xs where
93− buildStore :: List f xs
94−
95−instance BuildStore f '[] where
96− buildStore = Nil
97−
98−instance (BuildStore f as, Listy f a) => BuildStore f (a ': as) where
99− buildStore = Cons empty buildStore
100−-- 1.
101−-- Instead of just the resptype, let's return a tuple of (resptype, '[]::[ ? respType])
102−
103−-- 2.
104−-- break down respType into "useful" components
105−-- data Baz = Baz { key1 :: Key Foo, key2 :: Key Bar }
106−-- should insert into type-indexed list three elements
107−-- 'Baz -> whole value
108−-- '(Key Bar) -> key2
109−-- '(Key Foo) -> key1
110−--
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/ContextualGenRequest.hsdeleted−238
@@ -1,238 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE QuantifiedConstraints #-}
12−{-# LANGUAGE RankNTypes #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE TypeApplications #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
18−{-# LANGUAGE UndecidableInstances #-}
19−module Roboservant.ContextualGenRequest where
20−
21−import qualified Data.ByteString as BS
22−import qualified Data.ByteString.Internal as BS (c2w)
23−import Data.Data (Proxy (Proxy))
24−import Data.String (IsString (fromString))
25−import Data.String.Conversions (cs)
26−import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
27−import Network.HTTP.Client (Request,
28− RequestBody (RequestBodyLBS),
29− defaultRequest, host, method, path,
30− port, queryString, requestBody,
31− requestHeaders, secure)
32−import Network.HTTP.Media (renderHeader)
33−import Servant
34−import Servant.API
35−import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
36−import Servant.Client
37−-- import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
38−
39−import Data.Dynamic (Dynamic, fromDynamic)
40−import Data.Map.Strict (Map)
41−import qualified Data.Map.Strict as Map
42−import Data.Maybe
43−import Data.Typeable (TypeRep, Typeable, typeRep)
44−import Hedgehog
45−import qualified Hedgehog.Gen as Gen
46−import Roboservant.Hedgehog
47−
48−class HasContextualGenRequest a where
49− genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
50−
51−-- | Generatable is functionally equivalent to Arbitrary with a default.
52−-- It is separate because we want to allow overwriting at will.
53−class Generatable a where
54− generator :: Gen [a]
55− generator = pure []
56−
57−instance ( HasContextualGenRequest a
58− , HasContextualGenRequest b)
59− => HasContextualGenRequest (a :<|> b) where
60− genContextualRequest _ store
61− = case sub of
62− [] -> Nothing
63− _ -> Just (newfreq, Gen.frequency sub)
64− where
65− newfreq = sum (map fst sub)
66− sub = catMaybes [l,r]
67− l = genContextualRequest (Proxy :: Proxy a) store
68− r = genContextualRequest (Proxy :: Proxy b) store
69−
70−withGeneratable p store cont = cont <$> genContextualRequest p store
71−
72−getCandidates p st cont =
73− case Map.lookup (typeRep p) st of
74− Nothing -> (0,error "shouldn't ever be invoked")
75− Just x -> do
76− case fromDynamic x of
77− Nothing -> (0,error "shouldn't ever be invoked")
78− Just candidates -> cont candidates
79−
80−instance (KnownSymbol path, HasContextualGenRequest b )
81− => HasContextualGenRequest (path :> b) where
82− genContextualRequest _ store =
83− withGeneratable (Proxy :: Proxy b) store $ \(oldf,old') -> do
84− ( oldf, do
85− old <- old'
86− pure $ \burl ->
87− let r = old burl
88− oldPath = path r
89− oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
90− paths = filter (not . BS.null) [new, oldPath']
91− in r { path = "/" <> BS.intercalate "/" paths }
92−
93− )
94− where
95− -- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
96− new = cs $ symbolVal (Proxy :: Proxy path)
97−
98−instance HasContextualGenRequest EmptyAPI where
99− genContextualRequest _ _ = Nothing
100−
101−instance HasContextualGenRequest api => HasContextualGenRequest (Summary d :> api) where
102− genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
103−
104−instance HasContextualGenRequest api => HasContextualGenRequest (Description d :> api) where
105− genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
106−
107−instance (HasContextualGenRequest b, Typeable c, ToHttpApiData c )
108− => HasContextualGenRequest (Capture' mods x c :> b) where
109− genContextualRequest _ st = withGeneratable (Proxy :: Proxy b) st $ \(oldf,old) ->
110− getCandidates (Proxy :: Proxy c) st $ \candidates ->
111− (oldf
112− ,do
113− piece :: c <- Gen.choice candidates
114− old' <- old
115− pure $ \burl ->
116− let r = old' burl
117− in r { path = cs (toUrlPiece piece) <> path r })
118−
119−-- unsure how CaptureAll works, finish later.
120−-- instance (HasContextualGenRequest b, ToHttpApiData c, Typeable c )
121−-- => HasContextualGenRequest (CaptureAll x c :> b) where
122−-- genContextualRequest _ st = withGeneratable (Proxy :: Proxy b) st $ \(oldf,old) ->
123−-- getCandidates (Proxy :: Proxy c) st $ \candidates ->
124−-- (oldf, do
125−-- old' <- old
126−-- piece :: c <- Gen.choice candidates
127−-- let new'' = BS.intercalate "/" . fmap (cs . toUrlPiece) $ piece
128−
129−
130−
131−-- return $ \burl -> let r = old' burl
132−-- in r { path = new'' <> path r })
133−
134−-- -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
135−-- -- new = _arbitrary :: Gen [c]
136−
137−-- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
138−-- => HasContextualGenRequest (Header' mods h c :> b) st where
139−-- genContextualRequest _ = (oldf, do
140−-- old' <- old
141−-- new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
142−-- return $ \burl st -> let r = old' burl st in r {
143−-- requestHeaders = (hdr, cs new') : requestHeaders r })
144−-- where
145−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
146−-- hdr = fromString $ symbolVal (Proxy :: Proxy h)
147−-- new = _arbitrary :: Gen c
148−
149−-- instance (AllMimeRender x c, HasContextualGenRequest b st)
150−-- => HasContextualGenRequest (ReqBody' mods x c :> b) st where
151−-- genContextualRequest _ = (oldf, do
152−-- old' <- old -- TODO: generate lenient
153−-- new' <- new
154−-- (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
155−-- return $ \burl st -> let r = old' burl st in r {
156−-- requestBody = RequestBodyLBS bd
157−-- , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
158−-- })
159−-- where
160−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
161−-- new = _arbitrary :: Gen c
162−
163−-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
164−-- => HasContextualGenRequest (QueryParam' mods x c :> b) st where
165−-- genContextualRequest _ = (oldf, do
166−-- new' <- new -- TODO: generate lenient or/and optional
167−-- old' <- old
168−-- return $ \burl st -> let
169−-- r = old' burl st
170−-- newExpr = param <> "=" <> cs (toQueryParam new')
171−-- qs = queryString r in r {
172−-- queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
173−-- where
174−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
175−-- param = cs $ symbolVal (Proxy :: Proxy x)
176−-- new = _arbitrary :: Gen c
177−
178−-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
179−-- => HasContextualGenRequest (QueryParams x c :> b) st where
180−-- genContextualRequest _ = (oldf, do
181−-- (new' :: c) <- _fetch
182−-- old' <- old
183−-- return $ \burl st -> let r = old' burl st in r {
184−-- queryString = queryString r
185−-- <> if length new' > 0 then fold (toParam <$> new') else ""})
186−-- where
187−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
188−-- param = cs $ symbolVal (Proxy :: Proxy x)
189−-- toParam c = param <> "[]=" <> cs (toQueryParam c)
190−-- fold = foldr1 (\a b -> a <> "&" <> b)
191−
192−-- instance (KnownSymbol x, HasContextualGenRequest b st)
193−-- => HasContextualGenRequest (QueryFlag x :> b) st where
194−-- genContextualRequest _ = (oldf, do
195−-- old' <- old
196−-- return $ \burl st -> let r = old' burl st
197−-- qs = queryString r in r {
198−-- queryString = if BS.null qs then param else param <> "&" <> qs })
199−-- where
200−-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
201−-- param = cs $ symbolVal (Proxy :: Proxy x)
202−
203−-- instance (ReflectMethod method)
204−-- => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
205−-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
206−-- { host = cs $ baseUrlHost burl
207−-- , port = baseUrlPort burl
208−-- , secure = baseUrlScheme burl == Https
209−-- , method = reflectMethod (Proxy :: Proxy method)
210−-- })
211−
212−-- instance (ReflectMethod method)
213−-- => HasContextualGenRequest (NoContentVerb (method :: k)) st where
214−-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
215−-- { host = cs $ baseUrlHost burl
216−-- , port = baseUrlPort burl
217−-- , secure = baseUrlScheme burl == Https
218−-- , method = reflectMethod (Proxy :: Proxy method)
219−-- })
220−
221−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
222−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
223−
224−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
225−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
226−
227−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
228−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
229−
230−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
231−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
232−
233−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
234−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
235−
236−-- -- TODO: Try logging in
237−-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
238−-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
src/Roboservant/Direct.hsnew file+311
@@ -0,0 +1,311 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TupleSections #-}
10+
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+module Roboservant.Direct
15+ ( fuzz',
16+ Config (..),
17+ -- TODO come up with something smarter than exporting all this, we should
18+ -- have some nice error-display functions
19+ RoboservantException (..),
20+ FuzzState (..),
21+ FuzzOp (..),
22+ FailureType (..),
23+ Report (..),
24+ )
25+where
26+
27+import Control.Exception.Lifted
28+ ( Exception,
29+ Handler (Handler),
30+ SomeAsyncException,
31+ SomeException,
32+ catch,
33+ catches,
34+ handle,
35+ throw,
36+ )
37+import Control.Monad.State.Strict
38+ ( MonadIO (..),
39+ MonadState (get),
40+ StateT (runStateT),
41+ modify',
42+ )
43+import Control.Monad.Trans.Control (MonadBaseControl)
44+import qualified Data.Dependent.Map as DM
45+import Data.Dynamic (Dynamic (..))
46+import qualified Data.IntSet as IntSet
47+import Data.List.NonEmpty (NonEmpty (..))
48+import qualified Data.List.NonEmpty as NEL
49+import Data.Maybe (mapMaybe)
50+import qualified Data.Set as Set
51+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
52+import qualified Data.Vinyl as V
53+import qualified Data.Vinyl.Curry as V
54+import qualified Data.Vinyl.Functor as V
55+import GHC.Generics ((:*:) (..))
56+import Roboservant.Types
57+ ( ApiOffset (..),
58+ Argument (..),
59+ InteractionError(..),
60+ Provenance (..),
61+ ReifiedApi,
62+ ReifiedEndpoint (..),
63+ Stash (..),
64+ StashValue (..),
65+ TypedF,
66+ )
67+import Roboservant.Types.Config
68+
69+import System.Random (Random (randomR), StdGen, mkStdGen)
70+import qualified Type.Reflection as R
71+
72+data RoboservantException
73+ = RoboservantException
74+ { failureReason :: FailureType,
75+ serverException :: Maybe SomeException,
76+ fuzzState :: FuzzState
77+ }
78+ deriving (Show)
79+
80+instance Exception RoboservantException
81+
82+data FailureType
83+ = ServerCrashed
84+ | CheckerFailed
85+ | NoPossibleMoves
86+ | InsufficientCoverage Double
87+ deriving (Show, Eq)
88+
89+data FuzzOp
90+ = FuzzOp
91+ { apiOffset :: ApiOffset,
92+ provenance :: [Provenance]
93+ }
94+ deriving (Show, Eq)
95+
96+data FuzzState
97+ = FuzzState
98+ { path :: [FuzzOp],
99+ stash :: Stash,
100+ currentRng :: StdGen
101+ }
102+ deriving (Show)
103+
104+data EndpointOption
105+ = forall as.
106+ (V.RecordToList as, V.RMap as) =>
107+ EndpointOption
108+ { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
109+ eoArgs :: V.Rec (TypedF StashValue) as
110+ }
111+
112+data StopReason
113+ = TimedOut
114+ | HitMaxIterations
115+ deriving (Show, Eq)
116+
117+data Report
118+ = Report
119+ { textual :: String,
120+ rsException :: RoboservantException
121+ }
122+ deriving (Show)
123+
124+
125+
126+-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
127+-- fuzzClient = undefined
128+
129+
130+
131+fuzz' ::
132+ ReifiedApi ->
133+ Config ->
134+ IO (Maybe Report)
135+fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
136+ let path = []
137+ stash = addToStash seed mempty
138+ currentRng = mkStdGen rngSeed
139+ deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime
140+ (stopreason, _fs) <-
141+ runStateT
142+ (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
143+ FuzzState {..}
144+ logInfo $ show stopreason
145+ pure Nothing
146+ where
147+ -- something less terrible later
148+ formatException :: RoboservantException -> Report
149+ formatException r@(RoboservantException failureType exception _state) =
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+
163+ evaluateCoverage f@FuzzState {..}
164+ | coverage > coverageThreshold = pure ()
165+ | otherwise = do
166+ displayDiagnostics f
167+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
168+ where
169+ hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
170+ totalRoutes = fromIntegral routeCount
171+ coverage = hitRoutes / totalRoutes
172+ untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
173+ untilDone (0, _) _ = pure HitMaxIterations
174+ untilDone (n, deadline) action = do
175+ now <- liftIO getCurrentTime
176+ if now > deadline
177+ then pure TimedOut
178+ else do
179+ _ <- action
180+ untilDone (n -1, deadline) action
181+
182+ routeCount = length reifiedApi
183+ elementOrFail ::
184+ (MonadState FuzzState m, MonadIO m) =>
185+ [a] ->
186+ m a
187+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
188+ elementOrFail l = do
189+ st <- get
190+ let (index, newGen) = randomR (0, length l - 1) (currentRng st)
191+ modify' $ \st' -> st' {currentRng = newGen}
192+ pure (l !! index)
193+ withOp ::
194+ (MonadState FuzzState m, MonadIO m) =>
195+ ( forall as.
196+ (V.RecordToList as, V.RMap as) =>
197+ FuzzOp ->
198+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
199+ V.Rec (TypedF V.Identity) as ->
200+ m r
201+ ) ->
202+ m r
203+ withOp callback = do
204+ -- choose a call to make, from the endpoints with fillable arguments.
205+ (offset, EndpointOption {..}) <- elementOrFail . options =<< get
206+ r <-
207+ V.rtraverse
208+ ( \(tr :*: StashValue svs _) ->
209+ elementOrFail $
210+ zipWith
211+ (\i xy -> V.Const i :*: tr :*: xy)
212+ [0 ..]
213+ (NEL.toList svs)
214+ )
215+ eoArgs
216+ let pathSegment =
217+ FuzzOp offset $
218+ recordToList'
219+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
220+ r
221+ argValues =
222+ V.rmap
223+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
224+ r
225+ modify' (\f -> f {path = path f <> [pathSegment]})
226+ callback pathSegment eoCall argValues
227+ where
228+ options :: FuzzState -> [(ApiOffset, EndpointOption)]
229+ options FuzzState {..} =
230+ mapMaybe
231+ ( \(offset, ReifiedEndpoint {..}) -> do
232+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
233+ pure (offset, EndpointOption reEndpointFunc args)
234+ )
235+ reifiedApi
236+ execute ::
237+ (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
238+ FuzzOp ->
239+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
240+ V.Rec (TypedF V.Identity) as ->
241+ m ()
242+ execute fuzzop func args = do
243+ (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
244+ liftIO (V.runcurry' func argVals) >>= \case
245+ Left (e::InteractionError) ->
246+ if fatalError e
247+ then throw e
248+ else pure ()
249+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
250+ modify'
251+ ( \fs@FuzzState {..} ->
252+ fs {stash = addToStash (NEL.toList dyn) stash}
253+ )
254+ where
255+ argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
256+ -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
257+ go ::
258+ (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
259+ m ()
260+ go = withOp $ \op func args -> do
261+ catches
262+ (execute op func args)
263+ [ Handler (\(e :: SomeAsyncException) -> throw e),
264+ Handler
265+ ( \(e :: SomeException) ->
266+ throw . RoboservantException ServerCrashed (Just e) =<< get
267+ )
268+ ]
269+ catch
270+ (liftIO healthCheck)
271+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
272+
273+addToStash ::
274+ [(Dynamic, Int)] ->
275+ Stash ->
276+ Stash
277+addToStash result stash =
278+ foldr
279+ ( \(Dynamic tr x, hashed) (Stash dict) ->
280+ Stash $
281+ DM.insertWith
282+ renumber
283+ tr
284+ (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))
285+ dict
286+ )
287+ stash
288+ result
289+ where
290+ renumber ::
291+ StashValue a ->
292+ StashValue a ->
293+ StashValue a
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
299+ [([Provenance tr _], dyn)] ->
300+ l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
301+ _ -> error "should be impossible"
302+ )
303+ (IntSet.union singleHash intSet)
304+
305+-- why isn't this in vinyl?
306+recordToList' ::
307+ (V.RecordToList as, V.RMap as) =>
308+ (forall x. f x -> a) ->
309+ V.Rec f as ->
310+ [a]
311+recordToList' f = V.recordToList . V.rmap (V.Const . f)
src/Roboservant/Hedgehog.hsdeleted−41
@@ -1,41 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−module Roboservant.Hedgehog where
3−
4−import Hedgehog
5−import Hedgehog.Gen
6−import qualified Hedgehog.Range as Range
7−
8−-- | Uses a weighted distribution to randomly select one of the generators in
9−-- the list.
10−--
11−-- This generator shrinks towards the first generator in the list.
12−--
13−-- This is to be used when the generator returning a Nothing indicates
14−-- that it will never succeed so should be abandoned entirely.
15−--
16−-- /The input list must be non-empty./
17−--
18−frequencyM :: MonadGen m => [(Int, m (Maybe a))] -> m (Maybe a)
19−frequencyM = \case
20− [] -> pure Nothing
21− -- error "Hedgehog.Gen.frequency: used with empty list"
22− xs0 -> do
23− let
24− pick acc n = \case
25− [] -> pure Nothing
26−-- error "Hedgehog.Gen.frequency/pick: used with empty list"
27− (k, x) : xs ->
28− if n <= k then
29− x >>= \case
30− Nothing -> do
31− -- this one will never come out right, so reassemble list without it
32− frequencyM (acc <> xs)
33− Just y -> pure $ Just y
34− else
35− pick ((k,x):acc) (n - k) xs
36−
37− total =
38− sum (fmap fst xs0)
39−
40− n <- integral $ Range.constant 1 total
41− pick [] n xs0
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/StateMachine.hsdeleted−278
@@ -1,278 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveAnyClass #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE DerivingStrategies #-}
6−{-# LANGUAGE ExistentialQuantification #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE FlexibleInstances #-}
9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10−{-# LANGUAGE KindSignatures #-}
11−{-# LANGUAGE LambdaCase #-}
12−{-# LANGUAGE OverloadedStrings #-}
13−{-# LANGUAGE PartialTypeSignatures #-}
14−{-# LANGUAGE RankNTypes #-}
15−{-# LANGUAGE RecordWildCards #-}
16−{-# LANGUAGE ScopedTypeVariables #-}
17−{-# LANGUAGE StandaloneDeriving #-}
18−{-# LANGUAGE TemplateHaskell #-}
19−{-# LANGUAGE TupleSections #-}
20−{-# LANGUAGE TypeOperators #-}
21−
22−-- for servant
23−
24−module Roboservant.StateMachine where
25−
26−import Control.Arrow (second)
27−-- import Data.Dynamic (Dynamic, fromDynamic)
28−
29−--import Test.QuickCheck (Property)
30−-- import Test.StateMachine
31−
32−import Control.Concurrent (forkIO)
33−import Control.Monad ((<=<))
34−import Control.Monad.IO.Class
35−import Data.Aeson
36−import Data.Dynamic
37−import Data.IORef (IORef, newIORef)
38−import qualified Data.List.NonEmpty as NEL
39−import Data.List.NonEmpty (NonEmpty)
40−import Data.Map.Strict (Map)
41−import qualified Data.Map.Strict as Map
42−import Data.Maybe
43−import Data.Type.HasClass
44−import Data.Type.HasClassPreludeInstances
45−import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)
46−import Debug.Trace (traceM, traceShowM)
47−import GHC.Generics (Generic)
48−import GHC.Generics
49−import GHC.IORef (readIORef)
50−import Hedgehog
51−import Hedgehog
52−import qualified Hedgehog.Gen as Gen
53−import qualified Hedgehog.Range as Range
54−import Network.HTTP.Client (defaultManagerSettings, newManager)
55−import Network.Wai
56−import Network.Wai.Handler.Warp
57−import Roboservant.ContextualGenRequest
58−import Servant
59−import Servant.Client
60−import Servant.Server (Server)
61−
62−-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
63−-- this into a property
64−--
65−-- TODO: how do we tie the model, command and response types to the Server?
66−-- genStateMachine :: HasContextualGenRequest a => Server a -> StateMachine Model Command IO Response
67−-- genStateMachine = StateMachine initModel _transition _precondition _postcondition
68−-- Nothing _generator _shrinker _semantics _mock
69−
70−-- initModel :: Model r
71−-- initModel = Model mempty
72−
73−-- newtype Model r = Model (Map TypeRep Dynamic)
74−
75−-- data Command r
76−-- = CallEndpoint
77−-- | Read (Reference (Opaque (IORef Int)) r)
78−-- | Write (Reference (Opaque (IORef Int)) r) Int
79−-- | Increment (Reference (Opaque (IORef Int)) r)
80−
81−-- data Response r
82−-- = Created (Reference (Opaque (IORef Int)) r)
83−-- | ReadValue Int
84−-- | Written
85−-- | Incremented
86−
87−-- deriving Show
88−
89−-- instance Eq MyDyn where
90−-- MyDyn a == MyDyn b = show a == show b
91−
92−data State v
93− = State
94− { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
95− }
96−
97−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
98−
99−newtype ApiOffset = ApiOffset Int
100− deriving (Eq, Show)
101− deriving newtype (Enum, Num)
102−
103−-- | we need to specify an offset because it's entirely possible to have two
104−-- functions with the same arguments that do different things.
105−data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
106−
107−deriving instance Show (Op Symbolic)
108−
109−instance HTraversable Op where
110− htraverse r op@(Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
111−
112−callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
113−callEndpoint staticRoutes =
114− let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
115− gen State {..}
116− | any null options = Nothing
117− | otherwise = Just $ do
118− uncurry Op <$> chooseOne options
119− where
120− chooseOne ::
121− MonadGen n =>
122− [ ( ApiOffset,
123− [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
124− )
125− ] ->
126− n
127− ( ApiOffset,
128− [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
129− )
130− chooseOne opts = do
131− (offset, args) <- Gen.element opts
132− (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> Gen.element argOpts) args
133− options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
134− options =
135− mapMaybe
136− ( \(offset, argreps, retType, dynCall) -> (offset,) <$> do
137− mapM (\x -> (x,) <$> fillableWith x) argreps
138− )
139− staticRoutes
140− fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
141− fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
142− execute ::
143− (MonadIO m) =>
144− Op Concrete ->
145− m (Opaque (IORef Dynamic))
146− execute (Op (ApiOffset offset) args) = do
147− -- traceM (show (offset, args))
148− fmap Opaque . liftIO $ do
149− realArgs <- mapM (\(tr, v) -> readIORef (opaque v)) args
150− let (_offset, staticArgs, ret, endpoint) = staticRoutes !! offset
151− -- now, magic happens: we apply some dynamic arguments to a dynamic
152− -- function and hopefully somtehing useful pops out the end.
153− func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
154− let showable = map dynTypeRep (endpoint : realArgs)
155− case func of
156− Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
157− Just (f') -> do
158− case fromDynamic f' of
159− Nothing -> error "failed on casting final function"
160− Just f -> liftIO f >>= newIORef -- >>= either (const $ error "blah") pure
161− in Command
162− gen
163− execute
164− [ Update $ \s@State {..} (Op (ApiOffset offset) args) o' ->
165− -- let foo :: Var (Opaque Dynamic) v -> Var (Opaque (IORef Dynamic)) v
166− -- foo = _ . opaque
167− -- in
168− s
169− { stateRefs =
170− let (_, _, tr, _) = staticRoutes !! offset
171− in Map.insertWith
172− (<>)
173− tr
174− (pure o')
175− stateRefs
176− }
177− -- , Ensure (no-500 here)
178− ]
179−
180−prop_sm_sequential :: ReifiedApi -> Property
181−prop_sm_sequential reifiedApi = do
182− property $ do
183− let initialState = State mempty
184− actions <-
185− forAll $
186− Gen.sequential
187− (Range.linear 1 100)
188− initialState
189− [callEndpoint reifiedApi]
190− executeSequential initialState actions
191−
192−newtype Foo = Foo Int
193− deriving (Generic, Eq, Show)
194− deriving newtype (FromHttpApiData, ToHttpApiData)
195−
196−instance ToJSON Foo
197−
198−instance FromJSON Foo
199−
200−type FooApi =
201− "item" :> Get '[JSON] Foo
202− :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
203− :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
204−
205−intro = pure (Foo 1)
206−
207−combine = (\(Foo a) (Foo b) -> pure (Foo (a + b)))
208−
209−eliminate =
210− ( \(Foo a) ->
211− if a > 10
212− then error "eliminate blew up, oh no!"
213− else pure ()
214− )
215−
216−fooServer :: Server FooApi
217−fooServer =
218− intro
219− :<|> combine
220− :<|> eliminate
221−
222−runServer :: IO ()
223−runServer = do
224− let port = 3000
225− settings =
226− setPort port
227− $ setBeforeMainLoop (putStrLn ("listening on port " ++ show port))
228− $ defaultSettings
229− runSettings settings (serve fooApi fooServer)
230−
231−fooApi :: Proxy FooApi
232−fooApi = Proxy
233−
234−introC :<|> combineC :<|> eliminateC = Servant.Client.client fooApi
235−
236−tests :: IO Bool
237−tests = do
238− withServantServer fooApi (pure fooServer) $ \burl -> do
239− manager <- newManager defaultManagerSettings
240− let clientEnv = mkClientEnv manager burl
241− -- faking this out for now.
242− footype = typeOf Foo
243− handleError :: forall a b m. Applicative m => (Either b a) -> m a
244− handleError = either (error "oopsie") pure
245− reifiedApi =
246− [ (ApiOffset 0, [], footype, toDyn $ toDyn <$> (runClientM introC clientEnv >>= handleError)),
247− (ApiOffset 1, [footype, footype], footype, toDyn $ \f1 f2 -> toDyn <$> (runClientM (combineC f1 f2) clientEnv >>= handleError)),
248− (ApiOffset 2, [footype], (typeOf ()), toDyn $ \f -> toDyn <$> (runClientM (eliminateC f) clientEnv >>= handleError))
249− ]
250− -- type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
251− checkParallel $ Group "props" [("aprop", prop_sm_sequential reifiedApi)]
252−
253−-- | Start a servant application on an open port, run the provided function,
254−-- then stop the application.
255−--
256−-- /Since 0.0.0.0/
257−withServantServer ::
258− HasServer a '[] =>
259− Proxy a ->
260− IO (Server a) ->
261− (BaseUrl -> IO r) ->
262− IO r
263−withServantServer api = withServantServerAndContext api EmptyContext
264−
265−-- | Like 'withServantServer', but allows passing in a 'Context' to the
266−-- application.
267−--
268−-- /Since 0.0.0.0/
269−withServantServerAndContext ::
270− (HasServer a ctx) =>
271− Proxy a ->
272− Context ctx ->
273− IO (Server a) ->
274− (BaseUrl -> IO r) ->
275− IO r
276−withServantServerAndContext api ctx server t =
277− withApplication (return . serveWithContext api ctx =<< server) $ \port ->
278− t (BaseUrl Http "localhost" port "")
src/Roboservant/Types.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+module Roboservant.Types
11+ ( module Roboservant.Types.Breakdown,
12+ module Roboservant.Types.BuildFrom,
13+ module Roboservant.Types.ReifiedApi,
14+ module Roboservant.Types.ReifiedApi.Server,
15+ module Roboservant.Types.Internal,
16+ module Roboservant.Types.Config,
17+ )
18+where
19+
20+import Roboservant.Types.Breakdown
21+import Roboservant.Types.BuildFrom
22+import Roboservant.Types.Config
23+import Roboservant.Types.Internal
24+import Roboservant.Types.ReifiedApi
25+import Roboservant.Types.ReifiedApi.Server
26+import Roboservant.Types.Orphans()
src/Roboservant/Types/Breakdown.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
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 #-}
15+
16+module Roboservant.Types.Breakdown where
17+
18+import Data.Dynamic (Dynamic)
19+import Data.Hashable
20+import Data.Kind
21+import Data.List.NonEmpty (NonEmpty (..))
22+import qualified Data.List.NonEmpty as NEL
23+import Data.Typeable (Typeable)
24+import GHC.Generics
25+import Roboservant.Types.Internal
26+import Servant
27+import Roboservant.Types.Orphans()
28+
29+breakdown ::
30+ (Hashable x, Typeable x, Breakdown x) =>
31+ x ->
32+ NonEmpty (Dynamic, Int)
33+breakdown x = hashedDyn x :| breakdownExtras x
34+
35+class Breakdown x where
36+ breakdownExtras :: x -> [(Dynamic, Int)]
37+
38+instance (Hashable x, Typeable x) => Breakdown (Atom x) where
39+ breakdownExtras _ = []
40+
41+deriving via (Atom ()) instance Breakdown ()
42+
43+deriving via (Atom Int) instance Breakdown Int
44+deriving via (Atom Char) instance Breakdown Char
45+
46+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x)
47+
48+instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where
49+ breakdownExtras stash = concatMap (NEL.toList . breakdown) stash
50+
51+
52+class GBreakdown (f :: k -> Type) where
53+ gBreakdownExtras :: f a -> [(Dynamic, Int)]
54+
55+instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where
56+ breakdownExtras = gBreakdownExtras . from . unCompound
57+
58+instance GBreakdown f => GBreakdown (M1 S c f) where
59+ gBreakdownExtras (M1 f) = gBreakdownExtras f
60+
61+instance GBreakdown b => GBreakdown (M1 D a b) where
62+ gBreakdownExtras (M1 f) = gBreakdownExtras f
63+
64+instance GBreakdown b => GBreakdown (M1 C a b) where
65+ gBreakdownExtras (M1 f) = gBreakdownExtras f
66+
67+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :*: b) where
68+ gBreakdownExtras (a :*: b) = gBreakdownExtras a <> gBreakdownExtras b
69+
70+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where
71+ gBreakdownExtras = \case
72+ L1 a -> gBreakdownExtras a
73+ R1 a -> gBreakdownExtras a
74+
75+instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where
76+ gBreakdownExtras (K1 c) = NEL.toList $ breakdown c
77+
78+instance GBreakdown U1 where
79+ gBreakdownExtras U1 = []
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/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.hsnew file+217
@@ -0,0 +1,217 @@
1+-- | Description: ways to build a reified api from a servant description.
2+--
3+-- arguably this could be more general and be abstracted away from even relying on servant
4+-- but that's future work.
5+
6+{-# LANGUAGE AllowAmbiguousTypes #-}
7+{-# LANGUAGE DataKinds #-}
8+{-# LANGUAGE DerivingStrategies #-}
9+{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE FlexibleInstances #-}
11+{-# LANGUAGE GADTs #-}
12+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13+{-# LANGUAGE LambdaCase #-}
14+{-# LANGUAGE PolyKinds #-}
15+{-# LANGUAGE ScopedTypeVariables #-}
16+{-# LANGUAGE TypeApplications #-}
17+{-# LANGUAGE TypeFamilies #-}
18+{-# LANGUAGE TypeOperators #-}
19+{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE CPP #-}
21+module Roboservant.Types.ReifiedApi where
22+
23+import Data.Dynamic (Dynamic)
24+import Control.Exception(Exception)
25+import Data.List.NonEmpty (NonEmpty)
26+import Data.Typeable (Typeable)
27+import GHC.Generics ((:*:)(..))
28+import Roboservant.Types.Internal
29+import Roboservant.Types.Breakdown
30+import Roboservant.Types.BuildFrom
31+import Data.Kind(Type)
32+import Servant
33+import Servant.API.Modifiers(FoldRequired,FoldLenient)
34+import GHC.TypeLits (Symbol)
35+import qualified Data.Text as T
36+import qualified Data.Vinyl as V
37+import qualified Data.Vinyl.Curry as V
38+import qualified Type.Reflection as R
39+
40+newtype ApiOffset = ApiOffset Int
41+ deriving (Eq, Show, Ord)
42+ deriving newtype (Enum, Num)
43+
44+type TypedF = (:*:) R.TypeRep
45+
46+newtype Argument a = Argument
47+ { getArgument :: Stash -> Maybe (StashValue a)
48+ }
49+
50+data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
51+ { reArguments :: V.Rec (TypedF Argument) as
52+ , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
53+ }
54+
55+instance Show ReifiedEndpoint where
56+ show _ = "lol"
57+
58+class ( V.RecordToList (EndpointArgs endpoint)
59+ , V.RMap (EndpointArgs endpoint)
60+ ) => ToReifiedEndpoint (endpoint :: Type) where
61+ type EndpointArgs endpoint :: [Type]
62+ type EndpointRes endpoint :: Type
63+
64+ reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
65+
66+
67+tagType :: Typeable a => f a -> TypedF f a
68+tagType = (R.typeRep :*:)
69+
70+data InteractionError = InteractionError
71+ { errorMessage :: T.Text
72+ , fatalError :: Bool
73+ }
74+ deriving Show
75+instance Exception InteractionError
76+
77+
78+
79+instance
80+ (Typeable responseType, Breakdown responseType) =>
81+ ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
82+ where
83+ type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]
84+ type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
85+ reifiedEndpointArguments = V.RNil
86+
87+instance ToReifiedEndpoint (NoContentVerb method)
88+ where
89+ type EndpointArgs (NoContentVerb method) = '[]
90+ type EndpointRes (NoContentVerb method) = NoContent
91+ reifiedEndpointArguments = V.RNil
92+
93+instance
94+ (ToReifiedEndpoint endpoint) =>
95+ ToReifiedEndpoint ((x :: Symbol) :> endpoint)
96+ where
97+ type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint
98+ type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
99+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
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+
111+instance
112+ (ToReifiedEndpoint endpoint) =>
113+ ToReifiedEndpoint (Description s :> endpoint)
114+ where
115+ type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint
116+ type EndpointRes (Description s :> endpoint) = EndpointRes endpoint
117+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
118+
119+instance
120+ (ToReifiedEndpoint endpoint) =>
121+ ToReifiedEndpoint (Summary s :> endpoint)
122+ where
123+ type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint
124+ type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint
125+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
126+
127+instance
128+ (Typeable requestType
129+ ,BuildFrom requestType
130+ ,ToReifiedEndpoint endpoint) =>
131+ ToReifiedEndpoint (QueryFlag name :> endpoint)
132+ where
133+ type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint
134+ type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint
135+ reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint
136+
137+type IfLenient s mods t = If (FoldLenient mods) (Either s t) t
138+type IfRequired mods t = If (FoldRequired mods) t (Maybe t)
139+type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)
140+
141+instance
142+ ( BuildFrom (IfRequiredLenient T.Text mods paramType)
143+ , ToReifiedEndpoint endpoint
144+ ) =>
145+ ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
146+ where
147+ type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint
148+ type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint
149+ reifiedEndpointArguments =
150+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
151+ V.:& reifiedEndpointArguments @endpoint
152+
153+
154+instance
155+ ( BuildFrom paramType
156+ , ToReifiedEndpoint endpoint
157+ , Show paramType
158+ , Eq paramType
159+ ) =>
160+ ToReifiedEndpoint (QueryParams name paramType :> endpoint)
161+ where
162+ type EndpointArgs (QueryParams name paramType :> endpoint) = [paramType] ': EndpointArgs endpoint
163+ type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint
164+ reifiedEndpointArguments =
165+ tagType (Argument (buildFrom @[paramType]))
166+ V.:& reifiedEndpointArguments @endpoint
167+
168+
169+
170+
171+instance
172+ ( BuildFrom (IfRequiredLenient T.Text mods headerType)
173+ , ToReifiedEndpoint endpoint
174+ ) =>
175+ ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
176+ where
177+ type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint
178+ type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint
179+ reifiedEndpointArguments =
180+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
181+ V.:& reifiedEndpointArguments @endpoint
182+
183+#if MIN_VERSION_servant(0,17,0)
184+instance
185+ ( BuildFrom (IfLenient String mods captureType)
186+ , ToReifiedEndpoint endpoint) =>
187+ ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
188+ where
189+ type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint
190+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
191+ reifiedEndpointArguments =
192+ tagType (Argument (buildFrom @(IfLenient String mods captureType)))
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
207+
208+instance
209+ ( BuildFrom (IfLenient String mods requestType)
210+ , ToReifiedEndpoint endpoint) =>
211+ ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
212+ where
213+ type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint
214+ type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint
215+ reifiedEndpointArguments =
216+ tagType (Argument (buildFrom @(IfLenient String mods requestType)))
217+ V.:& reifiedEndpointArguments @endpoint
src/Roboservant/Types/ReifiedApi/Server.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE PolyKinds #-}
9+
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeApplications #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+{-# LANGUAGE CPP #-}
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE FlexibleInstances #-}
18+{-# LANGUAGE MultiParamTypeClasses #-}
19+module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where
20+
21+import Servant
22+
23+import Control.Monad.Except (runExceptT)
24+import Data.Bifunctor
25+import Data.Dynamic (Dynamic)
26+import Data.List.NonEmpty (NonEmpty)
27+import Data.Typeable (Typeable)
28+import Roboservant.Types.Breakdown
29+import Roboservant.Types.ReifiedApi
30+
31+import qualified Data.Text as T
32+import qualified Data.Vinyl.Curry as V
33+import Data.Hashable(Hashable)
34+
35+type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]
36+
37+
38+class ToReifiedApi endpoints where
39+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
40+
41+instance ToReifiedApi '[] where
42+ toReifiedApi NoEndpoints _ = []
43+
44+instance
45+ ( NormalizeFunction (ServerT endpoint Handler)
46+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
47+ , ToReifiedEndpoint endpoint
48+ , ToReifiedApi endpoints
49+ ) =>
50+ ToReifiedApi (endpoint : endpoints)
51+ where
52+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
53+ (0, ReifiedEndpoint
54+ { reArguments = reifiedEndpointArguments @endpoint
55+ , reEndpointFunc = normalize endpoint
56+ }
57+ )
58+ : (map . first) (+1)
59+ (toReifiedApi endpoints (Proxy @endpoints))
60+
61+
62+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
63+ type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))
64+ normalize handler = (runExceptT . runHandler') handler >>= \case
65+ Left serverError -> pure (Left (renderServerError serverError))
66+ where
67+ -- | TODO improve this
68+ renderServerError :: ServerError -> InteractionError
69+ renderServerError s = InteractionError (T.pack $ show s) (errHTTPCode serverError == 500)
70+
71+ Right x -> pure $ Right $ breakdown x
72+
73+
74+-- case errHTTPCode serverError of
75+-- 500 -> throw serverError
76+-- _ ->
77+-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)
78+
79+
80+data Bundled endpoints where
81+ -- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
82+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
83+ NoEndpoints :: Bundled '[]
84+
85+class FlattenServer api where
86+ flattenServer :: Server api -> Bundled (Endpoints api)
87+
88+instance
89+ ( FlattenServer api,
90+ Endpoints endpoint ~ '[endpoint]
91+ ) =>
92+ FlattenServer (endpoint :<|> api)
93+ where
94+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
95+
96+instance
97+ (
98+ Endpoints api ~ '[api]
99+ ) =>
100+ FlattenServer (x :> api)
101+ where
102+ flattenServer server = server `AnEndpoint` NoEndpoints
103+
104+instance FlattenServer (Verb method statusCode contentTypes responseType)
105+ where
106+ flattenServer server = server `AnEndpoint` NoEndpoints
107+
108+class NormalizeFunction m where
109+ type Normal m
110+ normalize :: m -> Normal m
111+
112+instance NormalizeFunction x => NormalizeFunction (r -> x) where
113+ type Normal (r -> x) = r -> Normal x
114+ normalize = fmap normalize
stack.yaml+5−8
@@ -1,13 +1,10 @@
1−resolver: lts-15.15
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−- quickcheck-state-machine-0.7.0@sha256:4fc4467380e35b88aab72c278856aacebbf95688059d8ad70eb82fe048df476b,4958
9+# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
8−- markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112
10+- some-1.0.3
9−- servant-0.17
10−- servant-client-0.17
11−- servant-client-core-0.17
12−- servant-server-0.17
13−- constrained-dynamic-0.1.0.0@sha256:3516d3b95c8180f8904671aa982af2fae55a185b18642192f5c8f50657108e82,1207
stack.yaml.locknew file+26
@@ -0,0 +1,26 @@
1+# This file was autogenerated by Stack.
2+# You should not edit this file by hand.
3+# For more information, please see the documentation at:
4+# https://docs.haskellstack.org/en/stable/lock_files
5+
6+packages:
7+- completed:
8+ hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
9+ pantry-tree:
10+ sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
11+ size: 325
12+ original:
13+ hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
14+- completed:
15+ hackage: some-1.0.3@sha256:938cec5fc0d3a08dde34cfc0acd5a0aa2e9fd489c9dbb64417f16588dfb47af0,2399
16+ pantry-tree:
17+ sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8
18+ size: 709
19+ original:
20+ hackage: some-1.0.3
21+snapshots:
22+- completed:
23+ sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94
24+ size: 648660
25+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml
26+ original: lts-20.4
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.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Foo 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+newtype Foo = Foo Int
17+ deriving (Generic, Eq, Show, Typeable)
18+ deriving newtype (FromHttpApiData, ToHttpApiData)
19+
20+instance Hashable Foo
21+
22+instance ToJSON Foo
23+
24+instance FromJSON Foo
25+
26+type Api =
27+ "item" :> Get '[JSON] Foo
28+ :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
29+ :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
30+
31+intro :: Handler Foo
32+intro = pure (Foo 1)
33+
34+combine :: Foo -> Foo -> Handler Foo
35+combine (Foo a) (Foo b) = pure (Foo (a + b))
36+
37+eliminate :: Foo -> Handler ()
38+eliminate (Foo a)
39+ | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
40+ | otherwise = pure ()
41+
42+server :: Server Api
43+server =
44+ intro
45+ :<|> combine
46+ :<|> eliminate
test/Headers.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Headers 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+newtype Foo = Foo Int
17+ deriving (Generic, Eq, Show, Typeable)
18+ deriving newtype (FromHttpApiData, ToHttpApiData)
19+
20+instance Hashable Foo
21+
22+instance ToJSON Foo
23+
24+instance FromJSON Foo
25+
26+type Api =
27+ "item" :> Get '[JSON] Foo
28+ :<|> "itemAdd" :> Header "one" Foo :> Header "two" Foo :> Get '[JSON] Foo
29+ :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
30+
31+intro :: Handler Foo
32+intro = pure (Foo 1)
33+
34+combine :: Maybe Foo -> Maybe Foo -> Handler Foo
35+combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
36+combine (Just a) Nothing = pure a
37+combine Nothing (Just a) = pure a
38+combine Nothing Nothing = pure (Foo 1)
39+
40+eliminate :: Foo -> Handler ()
41+eliminate (Foo a)
42+ | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
43+ | otherwise = pure ()
44+
45+server :: Server Api
46+server =
47+ intro
48+ :<|> combine
49+ :<|> eliminate
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.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Seeded 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+newtype Seed = Seed Int
17+ deriving (Generic, Eq, Show, Typeable)
18+ deriving newtype (FromHttpApiData, ToHttpApiData)
19+
20+instance ToJSON Seed
21+
22+instance FromJSON Seed
23+
24+instance Hashable Seed
25+
26+type Api =
27+ Capture "seed" Seed :> Get '[JSON] ()
28+ :<|> Get '[JSON] ()
29+
30+server :: Server Api
31+server =
32+ (\(Seed _) -> error "we blow up if we get here")
33+ :<|> pure ()
test/Spec.hs+168−50
@@ -1,52 +1,170 @@
1+{-# LANGUAGE DerivingVia #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE StandaloneDeriving #-}
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleContexts #-}
1−{-# LANGUAGE AllowAmbiguousTypes #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
2−{-# LANGUAGE DataKinds #-}
11+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
12+{-# OPTIONS_GHC -fno-warn-orphans #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE QuantifiedConstraints #-}
10−{-# LANGUAGE RankNTypes #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
14+
15−{-# LANGUAGE UndecidableInstances #-}
15+import qualified Breakdown
16−
16+import Data.Dynamic (toDyn)
17−import Roboservant
17+import Data.Hashable (Hashable (hash))
18−import Servant.API
18+import Data.Maybe (isNothing)
19−import Test.Hspec
19+import Data.Void (Void)
20−import qualified Roboservant.StateMachine as SM
20+import qualified Foo
21−
21+import qualified Headers
22−newtype Foo = Foo Int
22+import qualified Nested
23− deriving (Show)
23+import qualified Post
24−
24+import qualified Put
25−newtype Bar = Bar String
25+import qualified Product
26− deriving (Show)
26+import qualified QueryParams
27−
27+import qualified Roboservant as R
28−type FooApi = "foo" :> "fle" :> "far" :> Get '[JSON] Foo
28+import qualified Roboservant.Server as RS
29−
29+import qualified Roboservant.Client as RC
30−type BarApi = "bar" :> ReqBody '[JSON] Foo :> Post '[JSON] Bar
30+import qualified Seeded
31−
31+import Test.Hspec
32−type Api =
32+import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
33− FooApi :<|> BarApi
33+import qualified Valid
34−
34+import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
35−type Foo' = ExtractRespType FooApi
35+
36−
36+import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
37−test :: ()
37+import Network.Wai(Application)
38−test = foo'EqualFoo
38+import qualified Network.Wai.Handler.Warp as Warp
39− where
39+import Network.HTTP.Client (newManager, defaultManagerSettings)
40− foo'EqualFoo :: Foo' ~ Foo => ()
40+import Control.Monad((>=>))
41− foo'EqualFoo = ()
42−
43−test' :: ()
44−test' = blah
45− where
46− blah :: ExtractRespTypes Api ~ '[Foo, Bar] => ()
47− blah = ()
48−
49−storeOfOurApi = storeOfApi @Api
50
41
51main :: IO ()
42main :: IO ()
52−main = SM.tests >>= print
43+main = hspec spec
44+
45+fuzzBoth
46+ :: forall a .
47+ (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
48+ HasClient ClientM a)
49+ => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
50+fuzzBoth name server config condition = do
51+ it (name <> " via server") $
52+ RS.fuzz @a server config >>= condition
53+
54+ around (withServer (serve (Proxy :: Proxy a) server)) $
55+ it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
56+ RC.fuzz @a clientEnv config >>= condition
57+
58+withServer :: Application -> ActionWith ClientEnv -> IO ()
59+withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action)
60+ where genClientEnv port = do
61+ baseUrl <- parseBaseUrl "http://localhost"
62+ manager <- newManager defaultManagerSettings
63+ pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
64+
65+spec :: Spec
66+spec = do
67+ describe "Basic usage" $ do
68+ describe "noError" $ do
69+ fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
70+ fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
71+ fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
72+ (\r ->
73+ fmap (R.failureReason . R.rsException) r
74+ `shouldSatisfy` ( \case
75+ Just (R.InsufficientCoverage _) -> True
76+ _ -> False
77+ ))
78+ describe "posted body" $
79+ fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
80+ (`shouldSatisfy` isNothing)
81+
82+
83+ describe "PUTted body" $
84+ fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}
85+ (`shouldSatisfy` isNothing)
86+
87+
88+ describe "seeded" $ do
89+ let res = Seeded.Seed 1
90+ shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
91+ (R.defaultConfig {R.seed = [(toDyn res, hash res)]})
92+ (`shouldSatisfy` isNothing)
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+
131+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
132+
133+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
134+
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.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE DataKinds #-}
2+
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module UnsafeIO where
9+
10+import Control.Monad.Trans (MonadIO (liftIO))
11+import Data.Aeson ()
12+import qualified Data.ByteString.Lazy.Char8 as BL8
13+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
14+import Servant
15+
16+type UnsafeApi =
17+ "add" :> Get '[JSON] ()
18+ :<|> "healthcheck" :> Get '[JSON] ()
19+
20+healthcheck :: IORef Int -> Handler ()
21+healthcheck ref = do
22+ t <- liftIO $ readIORef ref
23+ case t of
24+ 0 -> pure ()
25+ n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)}
26+
27+makeServer :: IO (Server UnsafeApi)
28+makeServer = do
29+ ref <- newIORef 0
30+ pure $
31+ unsafeMunge ref
32+ :<|> healthcheck ref
33+
34+unsafeMunge :: IORef Int -> Handler ()
35+unsafeMunge ref = liftIO $ do
36+ t <- readIORef ref
37+ writeIORef ref (t + 1)
38+ t2 <- readIORef ref
39+ writeIORef ref (t2 -1)
test/Valid.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Valid where
9+
10+import 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+ }
42+
43+server :: Server Api
44+server = pure 7 :<|> const (pure ())