git.iko.soy/roboservant
on 56f705f help sign in
8ade8f3
swap
0 ahead, 104 behind
43 files changed+923−2348
since splitsnapshots
unifiedsplit
.github/workflows/cabal.yml−64 .github/workflows/ci.yml+5−8 EXAMPLE.md−143 Example.lhs−1 Makefile+1−3 README.md+57−101 TODO.md+8−32 benchmarks/README.md−30 benchmarks/genFile.sh−26 benchmarks/prelude−61 benchmarks/runTiming.sh−10 benchmarks/runTimingNoisy.sh−10 package.yaml+30−48 roboservant.cabal+33−102 src/Roboservant.hs+110−8 src/Roboservant/Client.hs−127 src/Roboservant/ContextualGenRequest.hs+238 src/Roboservant/Direct.hs−311 src/Roboservant/Hedgehog.hs+41 src/Roboservant/Server.hs−36 src/Roboservant/StateMachine.hs+342 src/Roboservant/Types.hs−26 src/Roboservant/Types/Breakdown.hs−81 src/Roboservant/Types/BuildFrom.hs−107 src/Roboservant/Types/Config.hs−29 src/Roboservant/Types/Internal.hs−53 src/Roboservant/Types/Orphans.hs−7 src/Roboservant/Types/ReifiedApi.hs−217 src/Roboservant/Types/ReifiedApi/Server.hs−114 stack.yaml+8−5 stack.yaml.lock−26 test/Breakdown.hs−50 test/Foo.hs−46 test/Headers.hs−49 test/Nested.hs−23 test/Post.hs−31 test/Product.hs−31 test/Put.hs−33 test/QueryParams.hs−15 test/Seeded.hs−33 test/Spec.hs+50−168 test/UnsafeIO.hs−39 test/Valid.hs−44
.github/workflows/cabal.ymldeleted−64
@@ -1,64 +0,0 @@
1−# modified from https://github.com/jgm/pandoc/blob/master/.github/workflows/ci.yml
2−name: Cabal CI
3−
4−on:
5− push:
6− branches:
7− - '**'
8− paths-ignore: []
9− pull_request:
10− paths-ignore: []
11−
12−jobs:
13− linux:
14−
15− runs-on: ubuntu-20.04
16− strategy:
17− fail-fast: false
18− matrix:
19− versions:
20− - ghc: '8.8.4'
21− cabal: '3.4'
22− - ghc: '8.10.4'
23− cabal: '3.4'
24− steps:
25− - uses: actions/checkout@v2
26−
27− # need to install older cabal/ghc versions from ppa repository
28−
29− - name: Install recent cabal/ghc
30− uses: actions/setup-haskell@v1.1.3
31− with:
32− ghc-version: ${{ matrix.versions.ghc }}
33− cabal-version: ${{ matrix.versions.cabal }}
34−
35− # declare/restore cached things
36− # caching doesn't work for scheduled runs yet
37− # https://github.com/actions/cache/issues/63
38−
39− - name: Cache cabal global package db
40− id: cabal-global
41− uses: actions/cache@v2
42− with:
43− path: |
44− ~/.cabal
45− key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-global-${{ hashFiles('cabal.project') }}
46−
47− - name: Cache cabal work
48− id: cabal-local
49− uses: actions/cache@v2
50− with:
51− path: |
52− dist-newstyle
53− key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-local
54−
55− - name: Install dependencies
56− run: |
57− cabal update
58− cabal build all --dependencies-only --enable-tests --disable-optimization
59− - name: Build
60− run: |
61− cabal build all --enable-tests --disable-optimization 2>&1 | tee build.log
62− - name: Test
63− run: |
64− cabal test all --disable-optimization
.github/workflows/ci.yml+5−8
@@ -1,4 +1,4 @@
1−name: Stack CI
1+name: CI
22
33# Trigger the workflow on push or pull request, but only for the master branch
44on:
@@ -11,15 +11,14 @@ jobs:
1111 runs-on: ${{ matrix.os }}
1212 strategy:
1313 matrix:
14− stack: ["2.3.3"]
15− ghc: ["8.10.4"]
16− os: [ubuntu-latest]
14+ stack: ["2.1.3"]
15+ ghc: ["8.8.3"]
16+ os: [ubuntu-latest, macOS-latest]
1717 steps:
1818 - uses: actions/checkout@v2
1919 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
2020
21− - uses: actions/setup-haskell@v1.1.4
22− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
21+ - uses: actions/setup-haskell@v1.1
2322 name: Setup Haskell Stack
2423 with:
2524 ghc-version: ${{ matrix.ghc }}
@@ -27,13 +26,11 @@ jobs:
2726 enable-stack: true
2827
2928 - uses: actions/cache@v1
30− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
3129 name: Cache ~/.stack
3230 with:
3331 path: ~/.stack
3432 key: ${{ runner.os }}-${{ matrix.ghc }}-stack
3533
3634 - name: Test
37− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
3835 run: |
3936 stack test
EXAMPLE.mddeleted−143
@@ -1,143 +0,0 @@
1−# Example
2−
3−Our api under test:
4−
5−``` haskell
6−-- Obligatory fancy-types pragma tax
7−{-# LANGUAGE DataKinds #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE DerivingStrategies #-}
10−{-# LANGUAGE StandaloneDeriving #-}
11−{-# LANGUAGE DerivingVia #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE DeriveGeneric #-}
14−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
15−{-# LANGUAGE RecordWildCards #-}
16−{-# LANGUAGE ScopedTypeVariables #-}
17−{-# LANGUAGE TypeApplications #-}
18−
19−import qualified Roboservant.Server as RS
20−import qualified Roboservant.Client as RC
21−import Servant.Client(ClientEnv, baseUrlPort, parseBaseUrl, mkClientEnv)
22−import Network.HTTP.Client (newManager, defaultManagerSettings)
23−import Roboservant.Types
24−import Test.Hspec
25−import Servant
26−import GHC.Generics
27−import Data.Typeable
28−import Data.Hashable
29−import Data.Maybe(isNothing, isJust)
30−import qualified Network.Wai.Handler.Warp as Warp
31−import Data.Aeson(FromJSON,ToJSON)
32−
33−newtype A = A Int
34− deriving (Generic, Eq, Show, Typeable)
35− deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
36−
37−instance FromJSON A
38−instance ToJSON A
39−
40−newtype B = B Int
41− deriving (Generic, Eq, Show, Typeable)
42− deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
43−
44−instance FromJSON B
45−instance ToJSON B
46−
47−type Api =
48− "item" :> Get '[JSON] A
49− :<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B
50− :<|> "item" :> Capture "itemId" B :> Get '[JSON] ()
51−
52−server :: Handler A -> Server Api
53−server introduce = introduce :<|> combine :<|> eliminate
54− where
55− combine (B i) (B j) = pure $ B (i + j)
56− eliminate (B i)
57− | i > 10 = error "give up, eleven is way too big and probably not even real"
58− | otherwise = pure ()
59−```
60−
61−We have a "good" server, that never generates anything other than a 0. This means repeated application of
62−the combination/addition rule can never bring us to the dangerous state of numbers larger than 10.
63−
64−``` haskell
65−goodServer, badServer :: Server Api
66−goodServer = server (pure $ A 0)
67−badServer = server (pure $ A 1)
68−```
69−
70−In the test file, we first define the tests: the faulty server should fail and the good server should pass.
71−
72−```haskell
73−main :: IO ()
74−main = hspec spec
75−
76−spec :: Spec
77−spec = describe "example" $ do
78− it "good server should not fail" $ do
79− RS.fuzz @Api goodServer config
80− >>= (`shouldSatisfy` isNothing)
81− it "bad server should fail" $ do
82− RS.fuzz @Api badServer config
83− >>= (`shouldSatisfy` isJust)
84−```
85−
86−The previous test just picked apart the server and ran functions manually: sometimes, we want to test via
87−an honest-to-goodness network port, like so:
88−
89−```haskell
90− around (withServer (serve (Proxy :: Proxy Api) badServer)) $ do
91− it "we should also be able to run the _client_ to an independent server (ignore server error messages)" $ \(clientEnv::ClientEnv) -> do
92− RC.fuzz @Api clientEnv config >>= (`shouldSatisfy` isJust)
93−```
94−
95−(we use withApplication rather than testWithApplication because we don't primarily care what the server does here:
96−we want to check what a client does when presented with a faulty server.)
97−
98−We expect to be able to cover the whole api from our starting point, so let's set the coverage to 0.99.
99−There are other tweakable things in the config, like maximum runtime, reps,
100−per-request healthchecks, seeds, and verbose logging. Have a look at
101−Roboservant.Types.Config for details.
102−
103−``` haskell
104−config :: Config
105−config = defaultConfig
106− { coverageThreshold = 0.99
107− }
108−```
109−
110−Unless we want to ship roboservant and all its dependencies to production, we also need
111−some orphan instances: because As are the only value we can get without
112−an input, we need to be able to break them down.
113−
114−``` haskell
115−deriving via (Compound A) instance Breakdown A
116−```
117−
118−if we wanted to assemble As from parts as well, we'd derive using Compound, but in this case we don't care.
119−
120−``` haskell
121−deriving via (Atom A) instance BuildFrom A
122−
123−```
124−
125−Similarly, to generate the first B from the Ints we got from inside the A, we need to be able to
126−build it up from components.
127−
128−```haskell
129−deriving via (Compound B) instance BuildFrom B
130−deriving via (Atom B) instance Breakdown B
131−```
132−
133−
134−test utilities:
135−
136−``` haskell
137−withServer :: Application -> ActionWith ClientEnv -> IO ()
138−withServer app action = Warp.withApplication (pure app) (\p -> genClientEnv p >>= action)
139− where genClientEnv port = do
140− baseUrl <- parseBaseUrl "http://localhost"
141− manager <- newManager defaultManagerSettings
142− pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
143−```
Example.lhsdeleted−1
@@ -1 +0,0 @@
1−EXAMPLE.md
Makefile+1−3
@@ -1,4 +1,2 @@
11testwatch:
2− ghcid -T main -c 'stack repl roboservant:lib roboservant:test:roboservant-test --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
3−pedanticwatch:
4− ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
2+ ghcid -c 'stack repl --test --ghc-options=-fobject-code roboservant' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
README.md+57−101
@@ -2,113 +2,69 @@
22
33Automatically fuzz your servant apis in a contextually-aware way.
44
5−[![Stack CI](https://github.com/mwotton/roboservant/actions/workflows/ci.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/ci.yml)
6−[![Cabal CI](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml)
5+![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)
76
8−## example
9−
10−see full example [here](EXAMPLE.md)
11−
12−## why?
7+# why?
138
149Servant gives us a lot of information about what a server can do. We
1510use this information to generate arbitrarily long request/response
1611sessions and verify properties that should hold over them.
1712
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−
84−## why not servant-quickcheck?
13+# why not servant-quickcheck?
8514
8615[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
87−is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
88−there's a lot of the state space you just can't explore without context: modern webapps are
16+is a great package and I've learned a lot from it. Unfortunately,
17+there's a lot of the state space it can't explore: modern webapps are
8918full of pointer-like structures, whether they're URLs or database
90−keys/uuids, and servant-quickcheck requires that you be able to generate
91−these without context via Arbitrary.
92−
93−## limitations and future work
94−
95−Currently, the display of failing traces is pretty tragic, both in the
96−formatting and in its non-minimality. This is pretty ticklish:
97−arguably the right way to do this is to return a trace that we can
98−also rerun, and let quickcheck or hedgehog a level up shrink it until
99−it's satisfactorily short. In the interest of being useful earlier
100−rather than later, I'm releasing v1.0 before I crack this particular
101−nut. We do know which calls we made that led to the failing case, so
102−we would want to show that distinction in a visible way: it's possible
103−that other calls that don't have direct data dependencies were
104−important, but we definitely know we need the direct data dependencies.
105−
106−The provenance stuff is a bit underbaked. It should at least pull a
107−representation of the route chosen rather than just an integer index.
108−
109−It would also be nice to have a robust strategy for deriving recursive
110−datatypes, or at least rejecting attempts to generate them that don't
111−end in an infinite loop.
112−
113−Currently the `FlattenServer` instance for `:>` is quadratic. It would
114−be nice to fix this but I lack the art.
19+keys/uuids. servant-quickcheck demands that you be able to generate
20+these without context via Arbitrary: good luck exploring an API that
21+requires you to generate just the right UUID to hit non-trivial code.
22+
23+roboservant avoids this by using
24+[quickcheck-state-machine](https://github.com/advancedtelematic/quickcheck-state-machine#readme),
25+which models the dynamic state in such a way that we can use results
26+of previous calls.
27+
28+# concept
29+
30+we start with a servant api and a server that fulfills the type.
31+
32+From that api, we should be able to summon up an empty type-indexed store with a key
33+for each response type in the API.
34+
35+We can then look at each callable endpoint, and eliminate any that require values that are
36+empty in the type-indexed store. this allows a generative process where we can extend a sequence
37+of calls indefinitely, by making a call to the concrete server and recording the result in the
38+type-indexed store.
39+
40+## extensions
41+- add some "starter" values to the store
42+ - there may be a JWT that's established outside the servant app, for instance.
43+- `class Extras a where extras :: Gen [a]`
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+8−32
@@ -1,32 +1,8 @@
1−## extensions/todo
2−
3−- add some "starter" values to the store
4− - there may be a JWT that's established outside the servant app, for instance.
5−- `class Extras a where extras :: Gen [a]`
6− - default implementation `pure []`
7− - selectively allow some types to create values we haven't seen from the api.
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.
1+DONE
2+- basic setup
3+- extract response types from the api
4+- proper readme
5+
6+TODO
7+- some way to select a random endpoint to run from a given Server.
8+- hook up quickcheck-state-machine/hedgehog
benchmarks/README.mddeleted−30
@@ -1,30 +0,0 @@
1−# Benchmarks
2−
3−I've noticed compilation can be a little slow on realistic apps so I set up a test.
4−
5−## components
6−
7−1. codegen
8−
9− given an integer input n, create an api with n endpoints. they should take a reasonably
10− complicated input and return a reasonably complicated output
11−
12−2. runner
13−
14− build dependencies
15− for i from 1 to 100
16− generate api with i endpoints
17− compile it, but timed
18− print (i,time)
19−
20−3. plot to see linearity/quadraticity?
21−
22−## possible gotchas
23−
24−- we usually compile these in different modules rather than together: if we don't get slow
25− compilation in one file, try out multiple files.
26−
27−## notes
28−
29−- flat profile if you don't have the call to `fuzz`
30−- no difference between deriving via Atom vs Compound, so not a Generics thing.
benchmarks/genFile.shdeleted−26
@@ -1,26 +0,0 @@
1−n=$1
2−k=$2
3−
4−cat prelude
5−echo -n "type SubApi = \"route1\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"
6−for i in $(seq 2 $n); do
7− echo -n " :<|> \"route${i}\" :> "
8− echo "ReqBody '[JSON] Input :> Post '[JSON] Output"
9−done
10−
11−echo -n "server = handler "
12−
13−for i in $(seq 2 $n); do
14− echo -n ":<|> handler "
15−done
16−echo
17−echo
18−
19−echo -n "type Api = Flatten ("
20−for i in $(seq 1 $k); do
21− echo -n '"foo" :> '
22−done;
23−
24−echo "SubApi )"
25−
26−
benchmarks/preludedeleted−61
@@ -1,61 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE TypeApplications #-}
5−{-# LANGUAGE DerivingVia #-}
6−{-# LANGUAGE StandaloneDeriving #-}
7−{-# LANGUAGE DeriveGeneric #-}
8−
9−
10−import Roboservant
11−import Servant
12−import Data.Hashable
13−import GHC.Generics
14−import Data.Aeson
15−import Servant.API.Flatten
16−
17−data Input = Input1 { foo :: String }
18− | Input2 { bar :: Int }
19− deriving (Generic, Eq)
20−
21−instance FromJSON Input
22−instance ToJSON Input
23−
24−
25−deriving via (Compound Input) instance Breakdown Input
26−deriving via (Compound Input) instance BuildFrom Input
27−
28−
29−-- deriving via (Atom Input) instance Breakdown Input
30−-- deriving via (Atom Input) instance BuildFrom Input
31−
32−instance Hashable Input
33−
34−
35−data Output = Output1 { ofoo :: String }
36− | Output2 { obar :: Int }
37− deriving (Generic, Eq)
38−
39−instance FromJSON Output
40−instance ToJSON Output
41−
42−instance Hashable Output
43−
44−deriving via (Compound Output) instance Breakdown Output
45−deriving via (Compound Output) instance BuildFrom Output
46−
47−-- deriving via (Atom Output) instance Breakdown Output
48−-- deriving via (Atom Output) instance BuildFrom Output
49−
50−
51−handler :: Input -> Handler Output
52−handler = pure . \case
53− Input1 foo -> Output1 foo
54− Input2 bar -> Output2 bar
55−
56−main =
57− -- fuzz @Api server defaultConfig
58− pure ()
59−
60−f = flatten (Proxy @Api)
61−
benchmarks/runTiming.shdeleted−10
@@ -1,10 +0,0 @@
1−lo=$1
2−hi=$2
3−k=$3
4−for i in $(seq $lo 5 $hi); do
5− ./genFile.sh $i $k > main.hs;
6− echo "sievedn: $i,";
7− /usr/bin/time -f "%e" stack ghc main.hs 2>&1;
8−# /usr/bin/time -f "%e" stack ghc -- -fomit-interface-pragmas main.hs 2>&1;
9−
10−done | grep -v Compiling | grep -v Linking | awk '/,$/ { printf("%s", $0); next } 1' | sed 's/sievedn: //'
benchmarks/runTimingNoisy.shdeleted−10
@@ -1,10 +0,0 @@
1−lo=$1
2−hi=$2
3−
4−for i in $(seq $lo 5 $hi); do
5− ./genFile.sh $i > main.hs;
6− echo "sievedn: $i,";
7− /usr/bin/time -f "%e" stack ghc main.hs 2>&1;
8−# /usr/bin/time -f "%e" stack ghc -- -fomit-interface-pragmas main.hs 2>&1;
9−
10−done
package.yaml+30−48
@@ -1,44 +1,48 @@
1−
21name: roboservant
3−version: 0.1.0.3
4−github: "mwotton/roboservant"
2+version: 0.1.0.0
3+github: "githubuser/roboservant"
54license: BSD3
6−copyright: "2020 Mark Wotton, Samuel Schlesinger"
7−synopsis: Automatic session-aware servant testing
8−category: Web
9−description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
5+author: "Author name here"
6+maintainer: "example@example.com"
7+copyright: "2020 Author name here"
108
119extra-source-files:
1210- README.md
1311- ChangeLog.md
1412
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+
1522dependencies:
1623- base >= 4.7 && < 5
1724
25+
1826- bytestring
27+- hedgehog
28+- constrained-dynamic
1929- containers
20−- random
21−- hashable
22−- http-types
23−- lifted-base
24−- monad-control
30+- http-client
31+- http-media
32+- QuickCheck
33+- quickcheck-state-machine >= 0.7
2534- mtl
26−- servant # >= 0.17
27−- servant-client # >= 0.17
35+- servant >= 0.17
36+- servant-client >= 0.17
2837- servant-flatten
29−- servant-server # >= 0.17
38+- servant-server >= 0.17
3039- string-conversions
31−- vinyl
32−- dependent-sum
33−- dependent-map
34−- unordered-containers
35−- text
36−- time
37−
38−ghc-options:
39−- -Wall
40−- -fwrite-ide-info
41−- -hiedir=.hie
40+# test deps
41+- hspec
42+- QuickCheck
43+- warp
44+- aeson
45+- wai
4246library:
4347 source-dirs: src
4448
@@ -52,25 +56,3 @@ tests:
5256 - -with-rtsopts=-N
5357 dependencies:
5458 - 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+33−102
@@ -1,19 +1,19 @@
11cabal-version: 1.12
22
3−-- This file has been generated from package.yaml by hpack version 0.35.0.
3+-- This file has been generated from package.yaml by hpack version 0.31.2.
44--
55-- see: https://github.com/sol/hpack
66--
7−-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d
7+-- hash: 9d15f4554f9f8ea8913a6766643b63ee6633016374fc98164e81058799204a87
88
99name: roboservant
10−version: 0.1.0.3
11−synopsis: Automatic session-aware servant testing
12−description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
13−category: Web
14−homepage: https://github.com/mwotton/roboservant#readme
15−bug-reports: https://github.com/mwotton/roboservant/issues
16−copyright: 2020 Mark Wotton, Samuel Schlesinger
10+version: 0.1.0.0
11+description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
12+homepage: https://github.com/githubuser/roboservant#readme
13+bug-reports: https://github.com/githubuser/roboservant/issues
14+author: Author name here
15+maintainer: example@example.com
16+copyright: 2020 Author name here
1717license: BSD3
1818license-file: LICENSE
1919build-type: Simple
@@ -23,86 +23,37 @@ extra-source-files:
2323
2424source-repository head
2525 type: git
26− location: https://github.com/mwotton/roboservant
26+ location: https://github.com/githubuser/roboservant
2727
2828library
2929 exposed-modules:
3030 Roboservant
31− Roboservant.Client
32− Roboservant.Direct
33− Roboservant.Server
34− Roboservant.Types
35− Roboservant.Types.Breakdown
36− Roboservant.Types.BuildFrom
37− Roboservant.Types.Config
38− Roboservant.Types.Internal
39− Roboservant.Types.Orphans
40− Roboservant.Types.ReifiedApi
41− Roboservant.Types.ReifiedApi.Server
31+ Roboservant.ContextualGenRequest
32+ Roboservant.Hedgehog
33+ Roboservant.StateMachine
4234 other-modules:
4335 Paths_roboservant
4436 hs-source-dirs:
4537 src
46− ghc-options: -Wall -fwrite-ide-info -hiedir=.hie
4738 build-depends:
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:
81− aeson
39+ QuickCheck
40+ , aeson
8241 , base >=4.7 && <5
8342 , bytestring
43+ , constrained-dynamic
8444 , containers
85− , dependent-map
86− , dependent-sum
87− , hashable
45+ , hedgehog
8846 , hspec
89− , hspec-core
9047 , http-client
91− , http-types
92− , lifted-base
93− , monad-control
48+ , http-media
9449 , mtl
95− , random
96− , roboservant
97− , servant
98− , servant-client
50+ , quickcheck-state-machine >=0.7
51+ , servant >=0.17
52+ , servant-client >=0.17
9953 , servant-flatten
100− , servant-server
54+ , servant-server >=0.17
10155 , string-conversions
102− , text
103− , time
104− , unordered-containers
105− , vinyl
56+ , wai
10657 , warp
10758 default-language: Haskell2010
10859
@@ -110,49 +61,29 @@ test-suite roboservant-test
11061 type: exitcode-stdio-1.0
11162 main-is: Spec.hs
11263 other-modules:
113− Breakdown
114− Foo
115− Headers
116− Nested
117− Post
118− Product
119− Put
120− QueryParams
121− Seeded
122− UnsafeIO
123− Valid
12464 Paths_roboservant
12565 hs-source-dirs:
12666 test
127− ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N
67+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
12868 build-depends:
129− aeson
69+ QuickCheck
70+ , aeson
13071 , base >=4.7 && <5
13172 , bytestring
73+ , constrained-dynamic
13274 , containers
133− , dependent-map
134− , dependent-sum
135− , hashable
75+ , hedgehog
13676 , hspec
137− , hspec-core
138− , hspec-wai
139− , http-api-data
14077 , http-client
141− , http-types
142− , lifted-base
143− , monad-control
78+ , http-media
14479 , mtl
145− , random
80+ , quickcheck-state-machine >=0.7
14681 , roboservant
147− , servant
148− , servant-client
82+ , servant >=0.17
83+ , servant-client >=0.17
14984 , servant-flatten
150− , servant-server
85+ , servant-server >=0.17
15186 , string-conversions
152− , text
153− , time
154− , unordered-containers
155− , vinyl
15687 , wai
15788 , warp
15889 default-language: Haskell2010
src/Roboservant.hs+110−8
@@ -1,8 +1,110 @@
1−module Roboservant
2− ( module Roboservant.Direct,
3− module Roboservant.Types,
4− )
5−where
6−
7−import Roboservant.Direct
8−import Roboservant.Types
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
20+
21+import Prelude hiding (lookup)
22+import GHC.TypeLits
23+import Servant.API
24+
25+import Roboservant.ContextualGenRequest
26+import Roboservant.StateMachine
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.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE NamedFieldPuns #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE AllowAmbiguousTypes #-}
6−{-# LANGUAGE DataKinds #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−
12−{-# LANGUAGE UndecidableInstances #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE FlexibleContexts #-}
15−-- should all the NormalizeFunction instances be in one place?
16−{-# OPTIONS_GHC -fno-warn-orphans #-}
17−module Roboservant.Client where
18−
19−import Data.Proxy
20−import Servant.Client
21−import Roboservant.Types
22−import Roboservant(Report, fuzz')
23−import Servant
24−import Data.Bifunctor
25−import Data.List.NonEmpty (NonEmpty)
26−import Data.Dynamic (Dynamic,Typeable)
27−import qualified Data.Vinyl.Curry as V
28−import qualified Data.Text as T
29−import Control.Monad.Reader
30−import Data.Hashable
31−import Network.HTTP.Types.Status
32−
33−-- fuzz :: forall api.
34−-- (FlattenServer api, ToReifiedApi (Endpoints api)) =>
35−-- Server api ->
36−-- Config ->
37−-- IO (Maybe Report)
38−-- fuzz s = fuzz' (reifyServer s)
39−-- -- todo: how do we pull reifyServer out?
40−-- where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
41−-- => Server api -> ReifiedApi
42−-- reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
43−
44−fuzz :: forall api . (ToReifiedClientApi (Endpoints api), FlattenClient api, HasClient ClientM api)
45− => ClientEnv -> Config -> IO (Maybe Report)
46−fuzz clientEnv
47− = fuzz'
48− (toReifiedClientApi
49− (flattenClient @api apiClient) (Proxy @(Endpoints api)) clientEnv)
50− where apiClient = client (Proxy @api)
51−
52−
53−
54−class ToReifiedClientApi api where
55− toReifiedClientApi :: ClientBundled api -> Proxy api -> ClientEnv -> ReifiedApi
56−
57−data ClientBundled endpoints where
58− AClientEndpoint :: Client ClientM endpoint -> ClientBundled endpoints -> ClientBundled (endpoint ': endpoints)
59− NoClientEndpoints :: ClientBundled '[]
60−
61−
62−class FlattenClient api where
63− flattenClient :: Client ClientM api -> ClientBundled (Endpoints api)
64−
65−instance
66− ( NormalizeFunction (Client ClientM endpoint)
67− , Normal (Client ClientM endpoint) ~ V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))))
68− , ToReifiedClientApi endpoints
69− , V.RecordCurry' (EndpointArgs endpoint)
70− , ToReifiedEndpoint endpoint) =>
71− ToReifiedClientApi (endpoint : endpoints) where
72− toReifiedClientApi (endpoint `AClientEndpoint` endpoints) _ clientEnv =
73− (0, ReifiedEndpoint
74− { reArguments = reifiedEndpointArguments @endpoint
75− , reEndpointFunc = foo (normalize endpoint)
76− }
77− )
78− : (map . first) (+1)
79− (toReifiedClientApi endpoints (Proxy @endpoints) clientEnv)
80− where
81−
82− foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType)
83− -> V.Curried (EndpointArgs endpoint) (IO ResultType)
84− foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv)
85−
86−mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b
87−mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g
88−
89−type ResultType = Either InteractionError (NonEmpty (Dynamic,Int))
90−-- runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
91−
92−
93−instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where
94− type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int)))
95− normalize c = ReaderT $
96− fmap (bimap renderClientError breakdown) . runClientM c
97− where
98− renderClientError :: ClientError -> InteractionError
99− renderClientError err = case err of
100− FailureResponse _ Response{responseStatusCode} -> InteractionError textual (responseStatusCode == status500)
101− _ -> InteractionError textual True
102−
103− where textual = T.pack $ show err
104−instance ToReifiedClientApi '[] where
105− toReifiedClientApi NoClientEndpoints _ _ = []
106−
107−
108−instance
109− ( FlattenClient api,
110− Endpoints endpoint ~ '[endpoint]
111− ) =>
112− FlattenClient (endpoint :<|> api)
113− where
114− flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c
115−
116−instance
117− (
118− Endpoints api ~ '[api]
119− ) =>
120− FlattenClient (x :> api)
121− where
122− flattenClient c = c `AClientEndpoint` NoClientEndpoints
123−
124−
125−instance FlattenClient (Verb method statusCode contentTypes responseType)
126− where
127− flattenClient c = c `AClientEndpoint` NoClientEndpoints
src/Roboservant/ContextualGenRequest.hsnew file+238
@@ -0,0 +1,238 @@
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.hsdeleted−311
@@ -1,311 +0,0 @@
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.hsnew file+41
@@ -0,0 +1,41 @@
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.hsdeleted−36
@@ -1,36 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE PolyKinds #-}
4−{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE PolyKinds #-}
8−
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−module Roboservant.Server (fuzz, module Roboservant.Types ) where
15−
16−import Roboservant.Direct(fuzz',Report)
17−import Roboservant.Types
18− ( FlattenServer (..),
19− ReifiedApi,
20− )
21−import Roboservant.Types.ReifiedApi.Server(ToReifiedApi (..))
22−import Servant (Endpoints, Proxy (Proxy), Server)
23−import Roboservant.Types.Config
24−
25−fuzz :: forall api.
26− (FlattenServer api, ToReifiedApi (Endpoints api)) =>
27− Server api ->
28− Config ->
29− IO (Maybe Report)
30−fuzz s = fuzz' (reifyServer s)
31− -- todo: how do we pull reifyServer out?
32− where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
33− => Server api -> ReifiedApi
34− reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
35−-- reifyServer server = toReifiedApi server (Proxy @(Endpoints api))
36−
src/Roboservant/StateMachine.hsnew file+342
@@ -0,0 +1,342 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE TypeApplications #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE AllowAmbiguousTypes #-}
8+{-# LANGUAGE DataKinds #-}
9+{-# LANGUAGE DeriveAnyClass #-}
10+{-# LANGUAGE DeriveGeneric #-}
11+{-# LANGUAGE DerivingStrategies #-}
12+{-# LANGUAGE ExistentialQuantification #-}
13+{-# LANGUAGE FlexibleContexts #-}
14+{-# LANGUAGE FlexibleInstances #-}
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+{-# LANGUAGE KindSignatures #-}
17+{-# LANGUAGE LambdaCase #-}
18+{-# LANGUAGE OverloadedStrings #-}
19+{-# LANGUAGE PartialTypeSignatures #-}
20+{-# LANGUAGE RankNTypes #-}
21+{-# LANGUAGE RecordWildCards #-}
22+{-# LANGUAGE ScopedTypeVariables #-}
23+{-# LANGUAGE StandaloneDeriving #-}
24+{-# LANGUAGE TemplateHaskell #-}
25+{-# LANGUAGE TupleSections #-}
26+{-# LANGUAGE TypeOperators #-}
27+
28+-- for servant
29+
30+module Roboservant.StateMachine where
31+
32+import Control.Arrow (second)
33+-- import Data.Dynamic (Dynamic, fromDynamic)
34+
35+--import Test.QuickCheck (Property)
36+-- import Test.StateMachine
37+
38+import Type.Reflection (SomeTypeRep)
39+import Servant.API.Flatten (Flat)
40+import GHC.TypeLits (Nat, Symbol)
41+import Data.Function ((&))
42+import Control.Concurrent (forkIO)
43+import Control.Monad ((<=<))
44+import Control.Monad.IO.Class
45+import Data.Aeson
46+import Data.Dynamic
47+import Data.IORef (IORef, newIORef)
48+import qualified Data.List.NonEmpty as NEL
49+import Data.List.NonEmpty (NonEmpty)
50+import Data.Map.Strict (Map)
51+import qualified Data.Map.Strict as Map
52+import Data.Maybe
53+import Data.Type.HasClass
54+import Data.Type.HasClassPreludeInstances
55+import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)
56+import Debug.Trace (traceM, traceShowM)
57+import GHC.Generics (Generic)
58+import GHC.Generics
59+import GHC.IORef (readIORef)
60+import Control.Monad.Except (runExceptT)
61+import Hedgehog
62+import Hedgehog
63+import qualified Hedgehog.Gen as Gen
64+import qualified Hedgehog.Range as Range
65+import Network.HTTP.Client (defaultManagerSettings, newManager)
66+import Network.Wai
67+import Network.Wai.Handler.Warp
68+import Roboservant.ContextualGenRequest
69+import Servant
70+import Servant.Client
71+import Servant.Server (Server)
72+
73+-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
74+-- this into a property
75+--
76+-- TODO: how do we tie the model, command and response types to the Server?
77+-- genStateMachine :: HasContextualGenRequest a => Server a -> StateMachine Model Command IO Response
78+-- genStateMachine = StateMachine initModel _transition _precondition _postcondition
79+-- Nothing _generator _shrinker _semantics _mock
80+
81+-- initModel :: Model r
82+-- initModel = Model mempty
83+
84+-- newtype Model r = Model (Map TypeRep Dynamic)
85+
86+-- data Command r
87+-- = CallEndpoint
88+-- | Read (Reference (Opaque (IORef Int)) r)
89+-- | Write (Reference (Opaque (IORef Int)) r) Int
90+-- | Increment (Reference (Opaque (IORef Int)) r)
91+
92+-- data Response r
93+-- = Created (Reference (Opaque (IORef Int)) r)
94+-- | ReadValue Int
95+-- | Written
96+-- | Incremented
97+
98+-- deriving Show
99+
100+-- instance Eq MyDyn where
101+-- MyDyn a == MyDyn b = show a == show b
102+
103+data State v
104+ = State
105+ { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
106+ }
107+
108+class FlattenServer api where
109+ flattenServer :: Server api -> Bundled (Endpoints api)
110+
111+instance
112+ ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api)
113+ , Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api)
114+ , FlattenServer api
115+ ) => FlattenServer (endpoint :<|> api) where
116+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
117+
118+instance
119+ ( HasServer (x :> api) '[]
120+ , Endpoints (x :> api) ~ '[x :> api]
121+ ) => FlattenServer (x :> api) where
122+ flattenServer server = server `AnEndpoint` NoEndpoints
123+
124+instance
125+ ( HasServer (Verb method statusCode contentTypes responseType) '[],
126+ Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
127+ ) => FlattenServer (Verb method statusCode contentTypes responseType) where
128+ flattenServer server = server `AnEndpoint` NoEndpoints
129+
130+type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
131+
132+type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
133+
134+data Bundled endpoints where
135+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
136+ NoEndpoints :: Bundled '[]
137+
138+class ToReifiedApi (endpoints :: [*]) where
139+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
140+
141+class ToReifiedEndpoint (endpoint :: *) where
142+ toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
143+
144+instance ToReifiedApi '[] where
145+ toReifiedApi NoEndpoints _ = []
146+
147+instance (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler))
148+ => ToReifiedApi (endpoint : endpoints)
149+ where
150+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
151+ withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
152+ : map (\(n, x, y, z) -> (n + 1, x, y, z))
153+ (toReifiedApi endpoints (Proxy @endpoints))
154+ where
155+ withOffset (x, y, z) = (0, x, y, z)
156+
157+class NormalizeFunction m where
158+ type Normal m
159+ normalize :: m -> Normal m
160+
161+instance NormalizeFunction x => NormalizeFunction (r -> x) where
162+ type Normal (r -> x) = r -> Normal x
163+ normalize = fmap normalize
164+
165+instance Typeable x => NormalizeFunction (Handler x) where
166+ type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
167+ normalize handler = (runExceptT . runHandler') handler >>= \case
168+ Left serverError -> pure (Left serverError)
169+ Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
170+
171+instance Typeable responseType
172+ => ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
173+ where
174+ toReifiedEndpoint endpoint _ =
175+ ([], typeRep (Proxy @responseType), endpoint)
176+
177+instance (ToReifiedEndpoint endpoint)
178+ => ToReifiedEndpoint ((x :: Symbol) :> endpoint)
179+ where
180+ toReifiedEndpoint endpoint _ =
181+ toReifiedEndpoint endpoint (Proxy @endpoint)
182+
183+instance (Typeable requestType, ToReifiedEndpoint endpoint)
184+ => ToReifiedEndpoint (Capture name requestType :> endpoint)
185+ where
186+ toReifiedEndpoint endpoint _ =
187+ toReifiedEndpoint endpoint (Proxy @endpoint)
188+ & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
189+
190+instance (Typeable requestType, ToReifiedEndpoint endpoint)
191+ => ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
192+ where
193+ toReifiedEndpoint endpoint _ =
194+ toReifiedEndpoint endpoint (Proxy @endpoint)
195+ & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
196+
197+newtype ApiOffset = ApiOffset Int
198+ deriving (Eq, Show)
199+ deriving newtype (Enum, Num)
200+
201+-- | we need to specify an offset because it's entirely possible to have two
202+-- functions with the same arguments that do different things.
203+data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
204+
205+deriving instance Show (Op Symbolic)
206+
207+instance HTraversable Op where
208+ htraverse r op@(Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
209+
210+callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
211+callEndpoint staticRoutes =
212+ let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
213+ gen State {..}
214+ | any null options = Nothing
215+ | otherwise = Just $ do
216+ uncurry Op <$> chooseOne options
217+ where
218+ chooseOne ::
219+ MonadGen n =>
220+ [ ( ApiOffset,
221+ [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
222+ )
223+ ] ->
224+ n
225+ ( ApiOffset,
226+ [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
227+ )
228+ chooseOne opts = do
229+ (offset, args) <- Gen.element opts
230+ (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> Gen.element argOpts) args
231+ options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
232+ options =
233+ mapMaybe
234+ ( \(offset, argreps, retType, dynCall) -> (offset,) <$> do
235+ mapM (\x -> (x,) <$> fillableWith x) argreps
236+ )
237+ staticRoutes
238+ fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
239+ fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
240+ execute ::
241+ (MonadIO m) =>
242+ Op Concrete ->
243+ m (Opaque (IORef Dynamic))
244+ execute (Op (ApiOffset offset) args) = do
245+ -- traceM (show (offset, args))
246+ fmap Opaque . liftIO $ do
247+ realArgs <- mapM (\(tr, v) -> readIORef (opaque v)) args
248+ let (_offset, staticArgs, ret, endpoint) = staticRoutes !! offset
249+ -- now, magic happens: we apply some dynamic arguments to a dynamic
250+ -- function and hopefully somtehing useful pops out the end.
251+ func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
252+ let showable = map dynTypeRep (endpoint : realArgs)
253+ case func of
254+ Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
255+ Just (f') -> do
256+ case fromDynamic f' of
257+ Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
258+ Just f -> liftIO f >>= \case
259+ Left (serverError :: ServerError) -> error (show serverError)
260+ Right (typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
261+ in Command
262+ gen
263+ execute
264+ [ Update $ \s@State {..} (Op (ApiOffset offset) args) o' ->
265+ -- let foo :: Var (Opaque Dynamic) v -> Var (Opaque (IORef Dynamic)) v
266+ -- foo = _ . opaque
267+ -- in
268+ s
269+ { stateRefs =
270+ let (_, _, tr, _) = staticRoutes !! offset
271+ in Map.insertWith
272+ (<>)
273+ tr
274+ (pure o')
275+ stateRefs
276+ }
277+ -- , Ensure (no-500 here)
278+ ]
279+
280+prop_sm_sequential :: ReifiedApi -> Property
281+prop_sm_sequential reifiedApi = do
282+ property $ do
283+ let initialState = State mempty
284+ actions <-
285+ forAll $
286+ Gen.sequential
287+ (Range.linear 1 100)
288+ initialState
289+ [callEndpoint reifiedApi]
290+ executeSequential initialState actions
291+
292+newtype Foo = Foo Int
293+ deriving (Generic, Eq, Show, Typeable)
294+ deriving newtype (FromHttpApiData, ToHttpApiData)
295+
296+instance ToJSON Foo
297+
298+instance FromJSON Foo
299+
300+type FooApi =
301+ "item" :> Get '[JSON] Foo
302+ :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
303+ :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
304+
305+intro = pure (Foo 1)
306+
307+combine = (\(Foo a) (Foo b) -> pure (Foo (a + b)))
308+
309+eliminate =
310+ ( \(Foo a) ->
311+ if a > 10
312+ then error "eliminate blew up, oh no!"
313+ else pure ()
314+ )
315+
316+fooServer :: Server FooApi
317+fooServer =
318+ intro
319+ :<|> combine
320+ :<|> eliminate
321+
322+bundledFooServer :: Bundled (Endpoints FooApi)
323+bundledFooServer = flattenServer @FooApi fooServer
324+
325+runServer :: IO ()
326+runServer = do
327+ let port = 3000
328+ settings =
329+ setPort port
330+ $ setBeforeMainLoop (putStrLn ("listening on port " ++ show port))
331+ $ defaultSettings
332+ runSettings settings (serve fooApi fooServer)
333+
334+fooApi :: Proxy FooApi
335+fooApi = Proxy
336+
337+introC :<|> combineC :<|> eliminateC = Servant.Client.client fooApi
338+
339+tests :: IO Bool
340+tests = do
341+ let reifiedApi = toReifiedApi (flattenServer @FooApi fooServer) (Proxy @(Endpoints FooApi))
342+ checkParallel $ Group "props" [("aprop", prop_sm_sequential reifiedApi)]
src/Roboservant/Types.hsdeleted−26
@@ -1,26 +0,0 @@
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.hsdeleted−81
@@ -1,81 +0,0 @@
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.hsdeleted−107
@@ -1,107 +0,0 @@
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.hsdeleted−29
@@ -1,29 +0,0 @@
1−module Roboservant.Types.Config where
2−
3−import Data.Dynamic
4−
5−data Config
6− = Config
7− { seed :: [(Dynamic, Int)],
8− maxRuntime :: Double, -- seconds to test for
9− maxReps :: Integer,
10− rngSeed :: Int,
11− coverageThreshold :: Double,
12− logInfo :: String -> IO (),
13− healthCheck :: IO ()
14− }
15−
16−defaultConfig :: Config
17−defaultConfig =
18− Config
19− { seed = [],
20− maxRuntime = 0.5,
21− maxReps = 1000,
22− rngSeed = 0,
23− coverageThreshold = 0,
24− logInfo = const (pure ()),
25− healthCheck = pure ()
26− }
27−
28−noisyConfig :: Config
29−noisyConfig = defaultConfig {logInfo = print}
src/Roboservant/Types/Internal.hsdeleted−53
@@ -1,53 +0,0 @@
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.hsdeleted−7
@@ -1,7 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module Roboservant.Types.Orphans where
3−
4−import Servant
5−import Data.Hashable
6−
7−instance Hashable NoContent
src/Roboservant/Types/ReifiedApi.hsdeleted−217
@@ -1,217 +0,0 @@
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.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE PolyKinds #-}
4−{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE PolyKinds #-}
9−
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−{-# LANGUAGE CPP #-}
15−{-# LANGUAGE DataKinds #-}
16−{-# LANGUAGE TypeOperators #-}
17−{-# LANGUAGE FlexibleInstances #-}
18−{-# LANGUAGE MultiParamTypeClasses #-}
19−module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where
20−
21−import Servant
22−
23−import Control.Monad.Except (runExceptT)
24−import Data.Bifunctor
25−import Data.Dynamic (Dynamic)
26−import Data.List.NonEmpty (NonEmpty)
27−import Data.Typeable (Typeable)
28−import Roboservant.Types.Breakdown
29−import Roboservant.Types.ReifiedApi
30−
31−import qualified Data.Text as T
32−import qualified Data.Vinyl.Curry as V
33−import Data.Hashable(Hashable)
34−
35−type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]
36−
37−
38−class ToReifiedApi endpoints where
39− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
40−
41−instance ToReifiedApi '[] where
42− toReifiedApi NoEndpoints _ = []
43−
44−instance
45− ( NormalizeFunction (ServerT endpoint Handler)
46− , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
47− , ToReifiedEndpoint endpoint
48− , ToReifiedApi endpoints
49− ) =>
50− ToReifiedApi (endpoint : endpoints)
51− where
52− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
53− (0, ReifiedEndpoint
54− { reArguments = reifiedEndpointArguments @endpoint
55− , reEndpointFunc = normalize endpoint
56− }
57− )
58− : (map . first) (+1)
59− (toReifiedApi endpoints (Proxy @endpoints))
60−
61−
62−instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
63− type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))
64− normalize handler = (runExceptT . runHandler') handler >>= \case
65− Left serverError -> pure (Left (renderServerError serverError))
66− where
67− -- | TODO improve this
68− renderServerError :: ServerError -> InteractionError
69− renderServerError s = InteractionError (T.pack $ show s) (errHTTPCode serverError == 500)
70−
71− Right x -> pure $ Right $ breakdown x
72−
73−
74−-- case errHTTPCode serverError of
75−-- 500 -> throw serverError
76−-- _ ->
77−-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)
78−
79−
80−data Bundled endpoints where
81− -- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
82− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
83− NoEndpoints :: Bundled '[]
84−
85−class FlattenServer api where
86− flattenServer :: Server api -> Bundled (Endpoints api)
87−
88−instance
89− ( FlattenServer api,
90− Endpoints endpoint ~ '[endpoint]
91− ) =>
92− FlattenServer (endpoint :<|> api)
93− where
94− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
95−
96−instance
97− (
98− Endpoints api ~ '[api]
99− ) =>
100− FlattenServer (x :> api)
101− where
102− flattenServer server = server `AnEndpoint` NoEndpoints
103−
104−instance FlattenServer (Verb method statusCode contentTypes responseType)
105− where
106− flattenServer server = server `AnEndpoint` NoEndpoints
107−
108−class NormalizeFunction m where
109− type Normal m
110− normalize :: m -> Normal m
111−
112−instance NormalizeFunction x => NormalizeFunction (r -> x) where
113− type Normal (r -> x) = r -> Normal x
114− normalize = fmap normalize
stack.yaml+8−5
@@ -1,10 +1,13 @@
1−resolver: lts-20.4
1+resolver: lts-15.15
22packages:
33- .
44
55extra-deps:
6−# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
7−# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
86- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
9−# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
10−- some-1.0.3
7+- quickcheck-state-machine-0.7.0@sha256:4fc4467380e35b88aab72c278856aacebbf95688059d8ad70eb82fe048df476b,4958
8+- markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112
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.lockdeleted−26
@@ -1,26 +0,0 @@
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.hsdeleted−50
@@ -1,50 +0,0 @@
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.hsdeleted−46
@@ -1,46 +0,0 @@
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.hsdeleted−49
@@ -1,49 +0,0 @@
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.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−
3−{-# LANGUAGE DerivingStrategies #-}
4−
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE TypeOperators #-}
7−
8−module Nested where
9−
10−import Servant
11−import Servant.API.Flatten
12−
13−type Api =
14− ( "one" :> Summary "foo" :> Post '[JSON] Int
15− :<|> "two" :> Post '[JSON] Int
16− )
17− :<|> ( "three" :> Post '[JSON] Int
18− )
19−
20−type FlatApi = Flat Api
21−
22−server :: Server FlatApi
23−server = pure 1 :<|> pure 2 :<|> pure 3
test/Post.hsdeleted−31
@@ -1,31 +0,0 @@
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.hsdeleted−31
@@ -1,31 +0,0 @@
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.hsdeleted−33
@@ -1,33 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DerivingStrategies #-}
4−
5−
6−{-# LANGUAGE TypeOperators #-}
7−
8−module Put where
9−
10−import Data.Aeson
11−import Data.Hashable
12−import GHC.Generics (Generic)
13−import Servant
14−
15−type Api =
16− Get '[JSON] Foo
17− :<|> ReqBody '[JSON] Foo :> Put '[JSON] ()
18− :<|> ReqBody '[JSON] Foo :> Put '[JSON] NoContent
19−
20−data Foo = Foo
21− deriving (Eq, Show, Generic)
22−
23−instance Hashable Foo
24−
25−instance ToJSON Foo
26−
27−instance FromJSON Foo
28−
29−server :: Server Api
30−server =
31− pure Foo
32− :<|> const (pure ())
33− :<|> const (pure NoContent)
test/QueryParams.hsdeleted−15
@@ -1,15 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−
3−{-# LANGUAGE DerivingStrategies #-}
4−
5−
6−{-# LANGUAGE TypeOperators #-}
7−
8−module QueryParams where
9−
10−import Servant
11−
12−type Api = QueryParams "ints" Int :> Get '[JSON] [Int]
13−
14−server :: Server Api
15−server = pure
test/Seeded.hsdeleted−33
@@ -1,33 +0,0 @@
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+50−168
@@ -1,170 +1,52 @@
1−{-# LANGUAGE DerivingVia #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE StandaloneDeriving #-}
6−{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE RankNTypes #-}
8−{-# LANGUAGE FlexibleContexts #-}
9−{-# LANGUAGE AllowAmbiguousTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE DataKinds #-}
12−{-# OPTIONS_GHC -fno-warn-orphans #-}
13−{-# LANGUAGE TypeFamilies #-}
14−
15−import qualified Breakdown
16−import Data.Dynamic (toDyn)
17−import Data.Hashable (Hashable (hash))
18−import Data.Maybe (isNothing)
19−import Data.Void (Void)
20−import qualified Foo
21−import qualified Headers
22−import qualified Nested
23−import qualified Post
24−import qualified Put
25−import qualified Product
26−import qualified QueryParams
27−import qualified Roboservant as R
28−import qualified Roboservant.Server as RS
29−import qualified Roboservant.Client as RC
30−import qualified Seeded
31−import Test.Hspec
32−import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
33−import qualified Valid
34−import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
35−
36−import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
37−import Network.Wai(Application)
38−import qualified Network.Wai.Handler.Warp as Warp
39−import Network.HTTP.Client (newManager, defaultManagerSettings)
40−import Control.Monad((>=>))
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
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 #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+
17+import Roboservant
18+import Servant.API
19+import Test.Hspec
20+import qualified Roboservant.StateMachine as SM
21+
22+newtype Foo = Foo Int
23+ deriving (Show)
24+
25+newtype Bar = Bar String
26+ deriving (Show)
27+
28+type FooApi = "foo" :> "fle" :> "far" :> Get '[JSON] Foo
29+
30+type BarApi = "bar" :> ReqBody '[JSON] Foo :> Post '[JSON] Bar
31+
32+type Api =
33+ FooApi :<|> BarApi
34+
35+type Foo' = ExtractRespType FooApi
36+
37+test :: ()
38+test = foo'EqualFoo
39+ where
40+ foo'EqualFoo :: Foo' ~ Foo => ()
41+ foo'EqualFoo = ()
42+
43+test' :: ()
44+test' = blah
45+ where
46+ blah :: ExtractRespTypes Api ~ '[Foo, Bar] => ()
47+ blah = ()
48+
49+storeOfOurApi = storeOfApi @Api
4150
4251main :: IO ()
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− )
52+main = SM.tests >>= print
test/UnsafeIO.hsdeleted−39
@@ -1,39 +0,0 @@
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.hsdeleted−44
@@ -1,44 +0,0 @@
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 ())