git.iko.soy/roboservant
on 4ad2b33 help sign in
8ade8f3
swap
0 ahead, 47 behind
.github/workflows/cabal.ymldeleted−64
since splitsnapshots
unifiedsplit
@@ -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+2−5
@@ -1,4 +1,4 @@
1−name: Stack CI
1+name: CI
2
2
3# Trigger the workflow on push or pull request, but only for the master branch
3# Trigger the workflow on push or pull request, but only for the master branch
4on:
4on:
@@ -12,14 +12,13 @@ jobs:
12 strategy:
12 strategy:
13 matrix:
13 matrix:
14 stack: ["2.3.3"]
14 stack: ["2.3.3"]
15− ghc: ["8.10.4"]
15+ ghc: ["8.8.3"]
16 os: [ubuntu-latest]
16 os: [ubuntu-latest]
17 steps:
17 steps:
18 - uses: actions/checkout@v2
18 - uses: actions/checkout@v2
19 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
19 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
20
20
21 - uses: actions/setup-haskell@v1.1.4
21 - uses: actions/setup-haskell@v1.1.4
22− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
23 name: Setup Haskell Stack
22 name: Setup Haskell Stack
24 with:
23 with:
25 ghc-version: ${{ matrix.ghc }}
24 ghc-version: ${{ matrix.ghc }}
@@ -27,13 +26,11 @@ jobs:
27 enable-stack: true
26 enable-stack: true
28
27
29 - uses: actions/cache@v1
28 - uses: actions/cache@v1
30− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
31 name: Cache ~/.stack
29 name: Cache ~/.stack
32 with:
30 with:
33 path: ~/.stack
31 path: ~/.stack
34 key: ${{ runner.os }}-${{ matrix.ghc }}-stack
32 key: ${{ runner.os }}-${{ matrix.ghc }}-stack
35
33
36 - name: Test
34 - name: Test
37− if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
38 run: |
35 run: |
39 stack test
36 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 @@
1testwatch:
1testwatch:
2− ghcid -T main -c 'stack repl roboservant:lib roboservant:test:roboservant-test --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
3−pedanticwatch:
4− ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
2+ ghcid -T main -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
README.md+23−87
@@ -2,86 +2,45 @@
2
2
3Automatically fuzz your servant apis in a contextually-aware way.
3Automatically fuzz your servant apis in a contextually-aware way.
4
4
5−[![Stack CI](https://github.com/mwotton/roboservant/actions/workflows/ci.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/ci.yml)
5+![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)
6−[![Cabal CI](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml)
7
6
8−## example
9
7
10−see full example [here](EXAMPLE.md)
11−
12−## why?
8+# why?
13
9
14Servant gives us a lot of information about what a server can do. We
10Servant gives us a lot of information about what a server can do. We
15use this information to generate arbitrarily long request/response
11use this information to generate arbitrarily long request/response
16sessions and verify properties that should hold over them.
12sessions and verify properties that should hold over them.
17
13
18−## how?
14+# example
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
15
39−To cope with this, we have the typeclasses `BuildFrom` and
16+Our api under test:
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
17
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```
18```
54−
19+newtype Foo = Foo Int
55−This is saying "A can neither be built from components or broken down
20+ deriving (Generic, Eq, Show, Typeable)
56−for spare parts. Hands off!". This is a good strategy for key types,
21+ deriving newtype (FromHttpApiData, ToHttpApiData)
57−for instance.
22+
58−
23+type FooApi =
59−If instead it's a big complicated thing with lots of juicy
24+ "item" :> Get '[JSON] Foo
60−subcomponents, we want to rip it apart using Generics and feast on
25+ :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
61−its succulent headmeats:
26+ :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
62−
63−``` haskell
64−deriving via (Compound Payload) instance Breakdown Payload
65−deriving via (Compound Payload) instance BuildFrom Payload
66```
27```
67
28
68−### priming the pump
29+From the tests:
69
30
70−Sometimes there are values we'd like to smuggle into the API that are
31+```
71−not derivable from within the API itself: sometimes this is a warning
32+ assert "should find an error in Foo" . not
72−sign that your API is incomplete, but it can be quite reasonable to
33+ =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential @Foo.FooApi Foo.fooServer)])
73−require identifying credentials within an API and not provide a way to
34+```
74−get them. It might also be reasonable to have some sample values that
75−the user is expected to come up with.
76
35
77−For those cases, override the `seed` in the `Config` with a
36+We have a server that blows up if the value of the int in a `Foo` ever gets above 10. Note:
78−list of seed values, suitably hashed:
37+there is no generator for `Foo` types: larger `Foo`s can only be made only by combining existing
38+`Foo`s with `itemAdd`. This is an important distinction, because many APIs will return UUIDs or
39+similar as keys, which make it impossible to cover a useful section of the state space without
40+using the values returned by the API
79
41
80−``` haskell
81−defaultConfig { seed = [hashedDyn creds, hashedDyn userJwt]}
82−```
83
42
84−## why not servant-quickcheck?
43+# why not servant-quickcheck?
85
44
86[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
45[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
87is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
46is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
@@ -89,26 +48,3 @@ there's a lot of the state space you just can't explore without context: modern
89full of pointer-like structures, whether they're URLs or database
48full of pointer-like structures, whether they're URLs or database
90keys/uuids, and servant-quickcheck requires that you be able to generate
49keys/uuids, and servant-quickcheck requires that you be able to generate
91these without context via Arbitrary.
50these without context via Arbitrary.
92−
93−## limitations and future work
94−
95−Currently, the display of failing traces is pretty tragic, both in the
96−formatting and in its non-minimality. This is pretty ticklish:
97−arguably the right way to do this is to return a trace that we can
98−also rerun, and let quickcheck or hedgehog a level up shrink it until
99−it's satisfactorily short. In the interest of being useful earlier
100−rather than later, I'm releasing v1.0 before I crack this particular
101−nut. We do know which calls we made that led to the failing case, so
102−we would want to show that distinction in a visible way: it's possible
103−that other calls that don't have direct data dependencies were
104−important, but we definitely know we need the direct data dependencies.
105−
106−The provenance stuff is a bit underbaked. It should at least pull a
107−representation of the route chosen rather than just an integer index.
108−
109−It would also be nice to have a robust strategy for deriving recursive
110−datatypes, or at least rejecting attempts to generate them that don't
111−end in an infinite loop.
112−
113−Currently the `FlattenServer` instance for `:>` is quadratic. It would
114−be nice to fix this but I lack the art.
benchmarks/README.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+1−21
@@ -1,6 +1,5 @@
1−
2name: roboservant
1name: roboservant
3−version: 0.1.0.3
2+version: 0.1.0.2
4github: "mwotton/roboservant"
3github: "mwotton/roboservant"
5license: BSD3
4license: BSD3
6copyright: "2020 Mark Wotton, Samuel Schlesinger"
5copyright: "2020 Mark Wotton, Samuel Schlesinger"
@@ -19,7 +18,6 @@ dependencies:
19- containers
18- containers
20- random
19- random
21- hashable
20- hashable
22−- http-types
23- lifted-base
21- lifted-base
24- monad-control
22- monad-control
25- mtl
23- mtl
@@ -56,21 +54,3 @@ tests:
56 - hspec
54 - hspec
57 - hspec-core
55 - hspec-core
58 - http-api-data
56 - 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+5−58
@@ -1,13 +1,13 @@
1cabal-version: 1.12
1cabal-version: 1.12
2
2
3−-- This file has been generated from package.yaml by hpack version 0.35.0.
3+-- This file has been generated from package.yaml by hpack version 0.33.0.
4--
4--
5-- see: https://github.com/sol/hpack
5-- see: https://github.com/sol/hpack
6--
6--
7−-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d
7+-- hash: 0c7e475fb1182766bcb6f2b602d95ca2ce986757d1d23c061fb2800fee49f483
8
8
9name: roboservant
9name: roboservant
10−version: 0.1.0.3
10+version: 0.1.0.2
11synopsis: Automatic session-aware servant testing
11synopsis: Automatic session-aware servant testing
12description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
12description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
13category: Web
13category: Web
@@ -28,17 +28,13 @@ source-repository head
28library
28library
29 exposed-modules:
29 exposed-modules:
30 Roboservant
30 Roboservant
31− Roboservant.Client
32 Roboservant.Direct
31 Roboservant.Direct
33− Roboservant.Server
34 Roboservant.Types
32 Roboservant.Types
35 Roboservant.Types.Breakdown
33 Roboservant.Types.Breakdown
36 Roboservant.Types.BuildFrom
34 Roboservant.Types.BuildFrom
37− Roboservant.Types.Config
35+ Roboservant.Types.FlattenServer
38 Roboservant.Types.Internal
36 Roboservant.Types.Internal
39− Roboservant.Types.Orphans
40 Roboservant.Types.ReifiedApi
37 Roboservant.Types.ReifiedApi
41− Roboservant.Types.ReifiedApi.Server
42 other-modules:
38 other-modules:
43 Paths_roboservant
39 Paths_roboservant
44 hs-source-dirs:
40 hs-source-dirs:
@@ -51,7 +47,6 @@ library
51 , dependent-map
47 , dependent-map
52 , dependent-sum
48 , dependent-sum
53 , hashable
49 , hashable
54− , http-types
55 , lifted-base
50 , lifted-base
56 , monad-control
51 , monad-control
57 , mtl
52 , mtl
@@ -67,57 +62,14 @@ library
67 , vinyl
62 , vinyl
68 default-language: Haskell2010
63 default-language: Haskell2010
69
64
70−test-suite example
71− type: exitcode-stdio-1.0
72− main-is: Example.lhs
73− other-modules:
74− Paths_roboservant
75− hs-source-dirs:
76− ./
77− ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit
78− build-tool-depends:
79− markdown-unlit:markdown-unlit
80− build-depends:
81− aeson
82− , base >=4.7 && <5
83− , bytestring
84− , containers
85− , dependent-map
86− , dependent-sum
87− , hashable
88− , hspec
89− , hspec-core
90− , http-client
91− , http-types
92− , lifted-base
93− , monad-control
94− , mtl
95− , random
96− , roboservant
97− , servant
98− , servant-client
99− , servant-flatten
100− , servant-server
101− , string-conversions
102− , text
103− , time
104− , unordered-containers
105− , vinyl
106− , warp
107− default-language: Haskell2010
108−
109test-suite roboservant-test
65test-suite roboservant-test
110 type: exitcode-stdio-1.0
66 type: exitcode-stdio-1.0
111 main-is: Spec.hs
67 main-is: Spec.hs
112 other-modules:
68 other-modules:
113− Breakdown
69+ BuildFrom
114 Foo
70 Foo
115 Headers
71 Headers
116− Nested
117 Post
72 Post
118− Product
119− Put
120− QueryParams
121 Seeded
73 Seeded
122 UnsafeIO
74 UnsafeIO
123 Valid
75 Valid
@@ -135,10 +87,7 @@ test-suite roboservant-test
135 , hashable
87 , hashable
136 , hspec
88 , hspec
137 , hspec-core
89 , hspec-core
138− , hspec-wai
139 , http-api-data
90 , http-api-data
140− , http-client
141− , http-types
142 , lifted-base
91 , lifted-base
143 , monad-control
92 , monad-control
144 , mtl
93 , mtl
@@ -153,6 +102,4 @@ test-suite roboservant-test
153 , time
102 , time
154 , unordered-containers
103 , unordered-containers
155 , vinyl
104 , vinyl
156− , wai
157− , warp
158 default-language: Haskell2010
105 default-language: Haskell2010
src/Roboservant.hs+2−5
@@ -1,8 +1,5 @@
1−module Roboservant
2− ( module Roboservant.Direct,
1+module Roboservant (module Roboservant.Direct
3− module Roboservant.Types,
2+ ,module Roboservant.Types) where
4− )
5−where
6
3
7import Roboservant.Direct
4import Roboservant.Direct
8import Roboservant.Types
5import Roboservant.Types
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/Direct.hs+138−122
@@ -2,53 +2,60 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE LambdaCase #-}
5−{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE RecordWildCards #-}
8{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE TupleSections #-}
10−
9+{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11+
12{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
13
13
14module Roboservant.Direct
14module Roboservant.Direct
15− ( fuzz',
16− Config (..),
15+ ( fuzz, Config(..)
16+
17− -- TODO come up with something smarter than exporting all this, we should
17+ -- TODO come up with something smarter than exporting all this, we should
18− -- have some nice error-display functions
18+ -- have some nice error-display functions
19− RoboservantException (..),
19+ , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
20− FuzzState (..),
21− FuzzOp (..),
22− FailureType (..),
23− Report (..),
24 )
20 )
25where
21where
26
22
27−import Control.Exception.Lifted
23+import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
28− ( Exception,
24+import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
29− Handler (Handler),
25+import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
30− SomeAsyncException,
26+import Control.Monad(void,replicateM,forM_)
31− SomeException,
32− catch,
33− catches,
34− handle,
35− throw,
36− )
37−import Control.Monad.State.Strict
27+import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
38− ( MonadIO (..),
28+import Control.Monad.Trans.Control(MonadBaseControl)
39− MonadState (get),
29+import Data.Dependent.Map (DMap)
40− StateT (runStateT),
30+import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
41− modify',
31+import Data.List.NonEmpty (NonEmpty(..))
42− )
32+import Data.Map.Strict(Map)
33+import qualified Data.Set as Set
34+import Data.Maybe (mapMaybe)
35+import Data.Typeable (TypeRep)
36+import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
37+import System.Random(StdGen,randomR,mkStdGen)
38+import qualified Data.List.NonEmpty as NEL
39+import qualified Data.Map.Strict as Map
40+import Data.Time.Clock
41+import Data.List(sortOn)
42+import Control.Arrow(second)
43+import System.Timeout.Lifted(timeout)
44+import GHC.Generics ((:*:)(..))
45+import qualified Data.Vinyl.Functor as V
46+import qualified Data.Vinyl.Curry as V
47+
48+
49+import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)
50+import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)
43import Control.Monad.Trans.Control (MonadBaseControl)
51import Control.Monad.Trans.Control (MonadBaseControl)
44import qualified Data.Dependent.Map as DM
52import qualified Data.Dependent.Map as DM
45−import Data.Dynamic (Dynamic (..))
53+import Data.Dynamic (Dynamic (..), dynTypeRep)
46−import qualified Data.IntSet as IntSet
47import Data.List.NonEmpty (NonEmpty (..))
54import Data.List.NonEmpty (NonEmpty (..))
48import qualified Data.List.NonEmpty as NEL
55import qualified Data.List.NonEmpty as NEL
49import Data.Maybe (mapMaybe)
56import Data.Maybe (mapMaybe)
50import qualified Data.Set as Set
57import qualified Data.Set as Set
51−import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
58+import Data.Time.Clock
52import qualified Data.Vinyl as V
59import qualified Data.Vinyl as V
53import qualified Data.Vinyl.Curry as V
60import qualified Data.Vinyl.Curry as V
54import qualified Data.Vinyl.Functor as V
61import qualified Data.Vinyl.Functor as V
@@ -56,26 +63,25 @@ import GHC.Generics ((:*:) (..))
56import Roboservant.Types
63import Roboservant.Types
57 ( ApiOffset (..),
64 ( ApiOffset (..),
58 Argument (..),
65 Argument (..),
59− InteractionError(..),
66+ FlattenServer (..),
60 Provenance (..),
67 Provenance (..),
61− ReifiedApi,
62 ReifiedEndpoint (..),
68 ReifiedEndpoint (..),
63 Stash (..),
69 Stash (..),
64 StashValue (..),
70 StashValue (..),
71+ ToReifiedApi (..),
65− TypedF,
72+ TypedF
66 )
73 )
67−import Roboservant.Types.Config
74+import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
68−
69−import System.Random (Random (randomR), StdGen, mkStdGen)
75+import System.Random (StdGen, mkStdGen, randomR)
70import qualified Type.Reflection as R
76import qualified Type.Reflection as R
77+import qualified Data.IntSet as IntSet
71
78
72data RoboservantException
79data RoboservantException
73 = RoboservantException
80 = RoboservantException
74− { failureReason :: FailureType,
81+ { failureReason :: FailureType
75− serverException :: Maybe SomeException,
82+ , serverException :: Maybe SomeException
76− fuzzState :: FuzzState
83+ , fuzzState :: FuzzState
77− }
78− deriving (Show)
84+ } deriving (Show)
79
85
80instance Exception RoboservantException
86instance Exception RoboservantException
81
87
@@ -84,7 +90,7 @@ data FailureType
84 | CheckerFailed
90 | CheckerFailed
85 | NoPossibleMoves
91 | NoPossibleMoves
86 | InsufficientCoverage Double
92 | InsufficientCoverage Double
87− deriving (Show, Eq)
93+ deriving (Show,Eq)
88
94
89data FuzzOp
95data FuzzOp
90 = FuzzOp
96 = FuzzOp
@@ -93,6 +99,15 @@ data FuzzOp
93 }
99 }
94 deriving (Show, Eq)
100 deriving (Show, Eq)
95
101
102+data Config
103+ = Config
104+ { seed :: [(Dynamic,Int)],
105+ maxRuntime :: Double, -- seconds to test for
106+ maxReps :: Integer,
107+ rngSeed :: Int,
108+ coverageThreshold :: Double
109+ }
110+
96data FuzzState
111data FuzzState
97 = FuzzState
112 = FuzzState
98 { path :: [FuzzOp],
113 { path :: [FuzzOp],
@@ -105,7 +120,7 @@ data EndpointOption
105 = forall as.
120 = forall as.
106 (V.RecordToList as, V.RMap as) =>
121 (V.RecordToList as, V.RMap as) =>
107 EndpointOption
122 EndpointOption
108− { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
123+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))),
109 eoArgs :: V.Rec (TypedF StashValue) as
124 eoArgs :: V.Rec (TypedF StashValue) as
110 }
125 }
111
126
@@ -114,25 +129,19 @@ data StopReason
114 | HitMaxIterations
129 | HitMaxIterations
115 deriving (Show, Eq)
130 deriving (Show, Eq)
116
131
117−data Report
132+data Report = Report
118− = Report
119− { textual :: String,
133+ { textual :: String
120− rsException :: RoboservantException
134+ , rsException :: RoboservantException}
121− }
122 deriving (Show)
135 deriving (Show)
123
136
124−
125−
126−-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
127−-- fuzzClient = undefined
128−
129−
130−
131−fuzz' ::
137+fuzz ::
132− ReifiedApi ->
138+ forall api.
139+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>
140+ Server api ->
133 Config ->
141 Config ->
142+ IO () ->
134 IO (Maybe Report)
143 IO (Maybe Report)
135−fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
144+fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
136 let path = []
145 let path = []
137 stash = addToStash seed mempty
146 stash = addToStash seed mempty
138 currentRng = mkStdGen rngSeed
147 currentRng = mkStdGen rngSeed
@@ -141,36 +150,39 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
141 runStateT
150 runStateT
142 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
151 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
143 FuzzState {..}
152 FuzzState {..}
144− logInfo $ show stopreason
153+ print stopreason
145 pure Nothing
154 pure Nothing
146 where
155 where
147 -- something less terrible later
156 -- something less terrible later
148 formatException :: RoboservantException -> Report
157 formatException :: RoboservantException -> Report
149− formatException r@(RoboservantException failureType exception _state) =
158+ formatException r@(RoboservantException failureType exception _state) = Report
150− Report
151− (unlines [show failureType, show exception])
159+ (unlines [ show failureType , show exception ])
152− r
160+ r
161+
153− displayDiagnostics FuzzState {..} = liftIO $
162+ displayDiagnostics FuzzState{..} = liftIO $ do
154− logInfo $ unlines $
155− ["api endpoints covered"]
163+ putStrLn "api endpoints covered"
156− <> (map show . Set.toList . Set.fromList $ map apiOffset path)
164+ mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
165+ putStrLn ""
157− <> ["", "types in stash"]
166+ putStrLn "types in stash"
167+ DM.forWithKey_ (getStash stash) $ \k v ->
158− <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)
168+ print (NEL.length $ getStashValue v)
159− -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
169+ -- mapM_
160− -- $ \_k v ->
170+ -- (print . second NEL.length)
161− -- (show . NEL.length $ getStashValue v))
171+ -- (sortOn (show . fst) $ Map.toList $ getStash stash)
162
172
173+ -- evaluateCoverage :: FuzzState -> m ()
163− evaluateCoverage f@FuzzState {..}
174+ evaluateCoverage f@FuzzState{..}
164 | coverage > coverageThreshold = pure ()
175 | coverage > coverageThreshold = pure ()
165 | otherwise = do
176 | otherwise = do
166− displayDiagnostics f
177+ displayDiagnostics f
167− throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
178+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
168− where
169− hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
179+ where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
170− totalRoutes = fromIntegral routeCount
180+ totalRoutes = fromIntegral routeCount
171− coverage = hitRoutes / totalRoutes
181+ coverage = hitRoutes / totalRoutes
182+
183+
172− untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
184+ untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
173− untilDone (0, _) _ = pure HitMaxIterations
185+ untilDone (0,_) _ = pure HitMaxIterations
174 untilDone (n, deadline) action = do
186 untilDone (n, deadline) action = do
175 now <- liftIO getCurrentTime
187 now <- liftIO getCurrentTime
176 if now > deadline
188 if now > deadline
@@ -178,13 +190,12 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
178 else do
190 else do
179 _ <- action
191 _ <- action
180 untilDone (n -1, deadline) action
192 untilDone (n -1, deadline) action
181−
193+ reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
182 routeCount = length reifiedApi
194 routeCount = length reifiedApi
183− elementOrFail ::
195+
184− (MonadState FuzzState m, MonadIO m) =>
196+ elementOrFail :: (MonadState FuzzState m, MonadIO m)
185− [a] ->
186− m a
197+ => [a] -> m a
187− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
198+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
188 elementOrFail l = do
199 elementOrFail l = do
189 st <- get
200 st <- get
190 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
201 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
@@ -195,7 +206,7 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
195 ( forall as.
206 ( forall as.
196 (V.RecordToList as, V.RMap as) =>
207 (V.RecordToList as, V.RMap as) =>
197 FuzzOp ->
208 FuzzOp ->
198− V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
209+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
199 V.Rec (TypedF V.Identity) as ->
210 V.Rec (TypedF V.Identity) as ->
200 m r
211 m r
201 ) ->
212 ) ->
@@ -236,53 +247,57 @@ fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
236 execute ::
247 execute ::
237 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
248 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
238 FuzzOp ->
249 FuzzOp ->
239− V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
250+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
240 V.Rec (TypedF V.Identity) as ->
251 V.Rec (TypedF V.Identity) as ->
241 m ()
252 m ()
242 execute fuzzop func args = do
253 execute fuzzop func args = do
243− (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
254+ (liftIO . print . (fuzzop,) . stash ) =<< get
255+ st <- get
256+ -- let showable = unlines $ ("args":map show argTypes)
257+ -- <> ["fuzzop"
258+ -- , show fuzzop
259+ -- -- ,"dyncall"
260+ -- -- ,show (dynTypeRep dyncall)
261+ -- ,"state"
262+ -- ]
263+ -- liftIO $ putStrLn showable
244 liftIO (V.runcurry' func argVals) >>= \case
264 liftIO (V.runcurry' func argVals) >>= \case
245− Left (e::InteractionError) ->
265+ -- parameterise this
246− if fatalError e
266+ Left (serverError :: ServerError) ->
247− then throw e
267+ case errHTTPCode serverError of
248− else pure ()
268+ 500 -> throw serverError
269+ _ -> do
270+ liftIO $ print ("ignoring non-500 error", serverError)
249− Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
271+ Right (dyn :: NEL.NonEmpty (Dynamic,Int)) -> do
250− modify'
272+ -- liftIO $ print ("storing", fmap dynTypeRep dyn)
251− ( \fs@FuzzState {..} ->
273+ modify' (\fs@FuzzState{..} ->
252− fs {stash = addToStash (NEL.toList dyn) stash}
274+ fs { stash = addToStash (NEL.toList dyn) stash } )
253− )
254 where
275 where
255 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
276 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
256− -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
277+ argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
257 go ::
278 go ::
258 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
279 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
259 m ()
280 m ()
260 go = withOp $ \op func args -> do
281 go = withOp $ \op func args -> do
261− catches
262− (execute op func args)
282+ catches (execute op func args)
263− [ Handler (\(e :: SomeAsyncException) -> throw e),
283+ [ Handler (\(e :: SomeAsyncException) -> throw e)
264− Handler
265− ( \(e :: SomeException) ->
284+ , Handler (\(e :: SomeException) -> do
285+ displayDiagnostics =<< get
266− throw . RoboservantException ServerCrashed (Just e) =<< get
286+ throw . RoboservantException ServerCrashed (Just e) =<< get)
267− )
268 ]
287 ]
269− catch
288+ catch (liftIO checker)
270− (liftIO healthCheck)
271− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
289+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
272
290
273addToStash ::
291addToStash ::
274− [(Dynamic, Int)] ->
292+ [(Dynamic,Int)] ->
275 Stash ->
293 Stash ->
276 Stash
294 Stash
277addToStash result stash =
295addToStash result stash =
278 foldr
296 foldr
279− ( \(Dynamic tr x, hashed) (Stash dict) ->
297+ ( \(Dynamic tr x,hashed) (Stash dict) ->
280 Stash $
298 Stash $
281− DM.insertWith
299+ DM.insertWith renumber tr
282− renumber
283− tr
284− (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))
300+ (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed)) dict
285− dict
286 )
301 )
287 stash
302 stash
288 result
303 result
@@ -295,11 +310,12 @@ addToStash result stash =
295 | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
310 | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
296 | otherwise =
311 | otherwise =
297 StashValue
312 StashValue
298− ( case NEL.toList singleDyn of
313+ (case NEL.toList singleDyn of
299− [([Provenance tr _], dyn)] ->
314+ [([Provenance tr _], dyn)] ->
315+ l
300− l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
316+ <> pure (([Provenance tr (length (NEL.last l) + 1)], dyn))
301− _ -> error "should be impossible"
317+ _ -> error "should be impossible")
302− )
318+
303 (IntSet.union singleHash intSet)
319 (IntSet.union singleHash intSet)
304
320
305-- why isn't this in vinyl?
321-- why isn't this in vinyl?
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/Types.hs+14−10
@@ -2,25 +2,29 @@
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeApplications #-}
7{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
9
15
10module Roboservant.Types
16module Roboservant.Types
11− ( module Roboservant.Types.Breakdown,
17+ ( module Roboservant.Types.Breakdown
12− module Roboservant.Types.BuildFrom,
18+ , module Roboservant.Types.BuildFrom
13− module Roboservant.Types.ReifiedApi,
19+ , module Roboservant.Types.FlattenServer
14− module Roboservant.Types.ReifiedApi.Server,
20+ , module Roboservant.Types.ReifiedApi
15− module Roboservant.Types.Internal,
21+ , module Roboservant.Types.Internal
16− module Roboservant.Types.Config,
22+
17 )
23 )
18where
24where
19
25
20import Roboservant.Types.Breakdown
26import Roboservant.Types.Breakdown
21import Roboservant.Types.BuildFrom
27import Roboservant.Types.BuildFrom
22−import Roboservant.Types.Config
28+import Roboservant.Types.FlattenServer
23−import Roboservant.Types.Internal
24import Roboservant.Types.ReifiedApi
29import Roboservant.Types.ReifiedApi
25−import Roboservant.Types.ReifiedApi.Server
30+import Roboservant.Types.Internal
26−import Roboservant.Types.Orphans()
src/Roboservant/Types/Breakdown.hs+24−54
@@ -1,81 +1,51 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE DerivingVia #-}
3{-# LANGUAGE DerivingVia #-}
4+{-# LANGUAGE StandaloneDeriving #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE DefaultSignatures #-}
8+{-# LANGUAGE DerivingStrategies #-}
5{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
10{-# LANGUAGE GADTs #-}
11+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE PolyKinds #-}
14{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE StandaloneDeriving #-}
16+{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
19+{-# LANGUAGE StandaloneDeriving #-}
20+{-# LANGUAGE DerivingVia #-}
21+
15
22
16module Roboservant.Types.Breakdown where
23module Roboservant.Types.Breakdown where
17
24
18−import Data.Dynamic (Dynamic)
25+import Data.Dynamic (Dynamic, fromDynamic, toDyn)
19−import Data.Hashable
20−import Data.Kind
21import Data.List.NonEmpty (NonEmpty (..))
26import Data.List.NonEmpty (NonEmpty (..))
22import qualified Data.List.NonEmpty as NEL
27import qualified Data.List.NonEmpty as NEL
28+import Data.Maybe (fromMaybe)
29+import GHC.Generics(Generic)
23import Data.Typeable (Typeable)
30import Data.Typeable (Typeable)
24−import GHC.Generics
25import Roboservant.Types.Internal
31import Roboservant.Types.Internal
26−import Servant
32+import Data.Hashable
27−import Roboservant.Types.Orphans()
28
33
29−breakdown ::
34+-- | only use this when we are using the internal typerep map.
30− (Hashable x, Typeable x, Breakdown x) =>
35+promisedDyn :: Typeable a => Dynamic -> a
31− x ->
36+promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
32− NonEmpty (Dynamic, Int)
33−breakdown x = hashedDyn x :| breakdownExtras x
34
37
35class Breakdown x where
38class Breakdown x where
36− breakdownExtras :: x -> [(Dynamic, Int)]
39+ breakdown :: x -> NonEmpty (Dynamic,Int)
40+-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
41+-- breakdown = pure . toDyn
42+
37
43
38instance (Hashable x, Typeable x) => Breakdown (Atom x) where
44instance (Hashable x, Typeable x) => Breakdown (Atom x) where
39− breakdownExtras _ = []
45+ breakdown (Atom x) = pure (toDyn x, hash x)
40
46
41deriving via (Atom ()) instance Breakdown ()
47deriving via (Atom ()) instance Breakdown ()
42−
43deriving via (Atom Int) instance Breakdown Int
48deriving 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
49
81−deriving via (Atom NoContent) instance Breakdown NoContent
50+-- instance (Typeable a, Breakdown a) => Breakdown [a] where
51+-- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
src/Roboservant/Types/BuildFrom.hs+27−93
@@ -1,107 +1,41 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE DefaultSignatures #-}
2−{-# LANGUAGE DerivingVia #-}
2+{-# LANGUAGE DerivingStrategies #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE TypeApplications #-}
4{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE StandaloneDeriving #-}
11−{-# LANGUAGE UndecidableInstances #-}
7+{-# LANGUAGE DerivingVia #-}
8+
9+
12
10
13module Roboservant.Types.BuildFrom where
11module Roboservant.Types.BuildFrom where
14
12
15−import Data.List(nub)
13+import Data.List.NonEmpty (NonEmpty(..))
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 (..))
21import qualified Data.List.NonEmpty as NEL
14import qualified Data.List.NonEmpty as NEL
22import Data.Typeable (Typeable)
15import Data.Typeable (Typeable)
23−import GHC.Generics
16+import qualified Data.Dependent.Map as DM
24−import Roboservant.Types.Internal
25import qualified Type.Reflection as R
17import qualified Type.Reflection as R
26−import Servant(NoContent)
18+import Data.Kind
27−import Roboservant.Types.Orphans()
19+import Roboservant.Types.Internal
28−
20+import Data.Hashable
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
21
53−class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
22+class Typeable x => BuildFrom (x :: Type) where
54− extras :: Stash -> [([Provenance], x)]
23+ buildFrom :: Stash -> Maybe (StashValue x)
55
24
25+-- | this is a little esoteric: basically, we're always going to use this with
26+-- deriving-via, so we need to look up the underlying `x` and then wrap it in Atom.
56−instance (Hashable x, Typeable x) => BuildFrom (Atom x) where
27+instance Typeable x => BuildFrom (Atom x) where
57− extras _ = []
28+ buildFrom = fmap (fmap Atom) <$> DM.lookup R.typeRep . getStash
58
29
59deriving via (Atom Bool) instance BuildFrom Bool
30deriving via (Atom Bool) instance BuildFrom Bool
60
31
61−deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)
32+-- instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x) where
62−
33+-- buildFrom dict = Just options
63−-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
34+-- where options :: StashValue (Maybe x)
64−-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
35+-- options = StashValue
65−instance (Eq x, BuildFrom x) => BuildFrom [x] where
36+-- ([],Nothing) :|
66− extras stash =
37+-- (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict
67− nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash
38+-- )
68− where
39+-- _
69− -- powerset creates way too much stuff. something better here eventually.
40+-- -- instance (BuildFrom a) => BuildFrom [a] -- where
70− notpowerset xs = []:xs:map pure xs
41+-- --breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
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/FlattenServer.hsnew file+45
@@ -0,0 +1,45 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+module Roboservant.Types.FlattenServer where
11+
12+import Servant
13+
14+
15+data Bundled endpoints where
16+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
17+ NoEndpoints :: Bundled '[]
18+
19+class FlattenServer api where
20+ flattenServer :: Server api -> Bundled (Endpoints api)
21+
22+instance
23+ ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
24+ Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
25+ FlattenServer api
26+ ) =>
27+ FlattenServer (endpoint :<|> api)
28+ where
29+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
30+
31+instance
32+ ( HasServer (x :> api) '[],
33+ Endpoints (x :> api) ~ '[x :> api]
34+ ) =>
35+ FlattenServer (x :> api)
36+ where
37+ flattenServer server = server `AnEndpoint` NoEndpoints
38+
39+instance
40+ ( HasServer (Verb method statusCode contentTypes responseType) '[],
41+ Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
42+ ) =>
43+ FlattenServer (Verb method statusCode contentTypes responseType)
44+ where
45+ flattenServer server = server `AnEndpoint` NoEndpoints
src/Roboservant/Types/Internal.hs+13−30
@@ -1,53 +1,36 @@
1{-# LANGUAGE DeriveFunctor #-}
1{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5
3
6module Roboservant.Types.Internal where
4module Roboservant.Types.Internal where
7
5
6+import Data.List.NonEmpty (NonEmpty(..))
7+import qualified Data.Map.Strict as Map
8import qualified Data.Dependent.Map as DM
8import qualified Data.Dependent.Map as DM
9import Data.Dependent.Map (DMap)
9import Data.Dependent.Map (DMap)
10−import 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)
18import qualified Type.Reflection as R
10import qualified Type.Reflection as R
11+import Data.Dependent.Sum
12+import Data.IntSet(IntSet)
19
13
20data Provenance
14data Provenance
21 = Provenance R.SomeTypeRep Int
15 = Provenance R.SomeTypeRep Int
22− deriving (Show, Eq, Generic)
16+ deriving (Show,Eq)
23−
24−instance Hashable Provenance
25
17
26−data StashValue a
27− = StashValue
28− { getStashValue :: NonEmpty ([Provenance], a),
18+data StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a)
29− stashHash :: IntSet
19+ , stashHash :: IntSet
30− }
20+ }
31 deriving (Functor, Show)
21 deriving (Functor, Show)
32
22
33-- wrap in newtype to give a custom Show instance, since the normal
23-- 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
24-- instance for DMap is not happy since StashValue needs Show a to show
35−newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}
25+newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
36 deriving (Semigroup, Monoid)
26 deriving (Semigroup, Monoid)
37
27
38instance Show Stash where
28instance Show Stash where
39− showsPrec i (Stash x) =
29+ showsPrec i (Stash x) = showsPrec i $
40− showsPrec i
41− $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))
30+ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
42− $ DM.toList x
43
31
44-- | Can't be built up from parts, can't be broken down further.
32-- | Can't be built up from parts, can't be broken down further.
45−newtype Atom x = Atom {unAtom :: x}
33+newtype Atom x = Atom { unAtom :: x }
46− deriving newtype (Hashable, Typeable,Eq)
47
34
48-- | can be broken down and built up from generic pieces
35-- | can be broken down and built up from generic pieces
49−newtype Compound x = Compound {unCompound :: x}
36+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.hs+56−71
@@ -1,7 +1,3 @@
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
1
6{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
7{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
@@ -12,31 +8,39 @@
12{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE LambdaCase #-}
14{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE RecordWildCards #-}
15{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE StandaloneDeriving #-}
14+{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TypeApplications #-}
15{-# LANGUAGE TypeApplications #-}
17{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
20−{-# LANGUAGE CPP #-}
19+
21module Roboservant.Types.ReifiedApi where
20module Roboservant.Types.ReifiedApi where
22
21
22+
23+import Control.Monad.Except (runExceptT)
24+import Data.Bifunctor
25+-- import Data.Dependent.Sum
23import Data.Dynamic (Dynamic)
26import Data.Dynamic (Dynamic)
24−import Control.Exception(Exception)
27+import Data.Kind
25import Data.List.NonEmpty (NonEmpty)
28import Data.List.NonEmpty (NonEmpty)
26import Data.Typeable (Typeable)
29import Data.Typeable (Typeable)
27import GHC.Generics ((:*:)(..))
30import GHC.Generics ((:*:)(..))
31+import GHC.TypeLits (Symbol)
28import Roboservant.Types.Internal
32import Roboservant.Types.Internal
29import Roboservant.Types.Breakdown
33import Roboservant.Types.Breakdown
30import Roboservant.Types.BuildFrom
34import Roboservant.Types.BuildFrom
31−import Data.Kind(Type)
35+import Roboservant.Types.FlattenServer
32import Servant
36import Servant
33import Servant.API.Modifiers(FoldRequired,FoldLenient)
37import Servant.API.Modifiers(FoldRequired,FoldLenient)
34−import GHC.TypeLits (Symbol)
35import qualified Data.Text as T
38import qualified Data.Text as T
36import qualified Data.Vinyl as V
39import qualified Data.Vinyl as V
37import qualified Data.Vinyl.Curry as V
40import qualified Data.Vinyl.Curry as V
38import qualified Type.Reflection as R
41import qualified Type.Reflection as R
39
42
43+
40newtype ApiOffset = ApiOffset Int
44newtype ApiOffset = ApiOffset Int
41 deriving (Eq, Show, Ord)
45 deriving (Eq, Show, Ord)
42 deriving newtype (Enum, Num)
46 deriving newtype (Enum, Num)
@@ -49,32 +53,60 @@ newtype Argument a = Argument
49
53
50data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
54data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
51 { reArguments :: V.Rec (TypedF Argument) as
55 { reArguments :: V.Rec (TypedF Argument) as
52− , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
56+ , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int))))
53 }
57 }
54
58
55−instance Show ReifiedEndpoint where
59+type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
56− show _ = "lol"
60+
61+tagType :: Typeable a => f a -> TypedF f a
62+tagType = (R.typeRep :*:)
63+
64+class ToReifiedApi (endpoints :: [*]) where
65+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
57
66
67+class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint
58−class ( V.RecordToList (EndpointArgs endpoint)
68+ , V.RecordToList (EndpointArgs endpoint)
59 , V.RMap (EndpointArgs endpoint)
69 , V.RMap (EndpointArgs endpoint)
60− ) => ToReifiedEndpoint (endpoint :: Type) where
70+ ) => ToReifiedEndpoint (endpoint :: *) where
61 type EndpointArgs endpoint :: [Type]
71 type EndpointArgs endpoint :: [Type]
62 type EndpointRes endpoint :: Type
72 type EndpointRes endpoint :: Type
63
73
64 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
74 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
65
75
76+instance ToReifiedApi '[] where
77+ toReifiedApi NoEndpoints _ = []
66
78
67−tagType :: Typeable a => f a -> TypedF f a
79+instance
68−tagType = (R.typeRep :*:)
80+ ( Typeable (EndpointRes endpoint)
69−
81+ , NormalizeFunction (ServerT endpoint Handler)
70−data InteractionError = InteractionError
82+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int))))
71− { errorMessage :: T.Text
83+ , ToReifiedEndpoint endpoint
72− , fatalError :: Bool
84+ , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)
85+ ) =>
86+ ToReifiedApi (endpoint : endpoints)
87+ where
88+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
89+ (0, ReifiedEndpoint
90+ { reArguments = reifiedEndpointArguments @endpoint
91+ , reEndpointFunc = normalize endpoint
73− }
92+ }
74− deriving Show
93+ )
75−instance Exception InteractionError
94+ : (map . first) (+1)
76−
95+ (toReifiedApi endpoints (Proxy @endpoints))
77−
96+
97+class NormalizeFunction m where
98+ type Normal m
99+ normalize :: m -> Normal m
100+
101+instance NormalizeFunction x => NormalizeFunction (r -> x) where
102+ type Normal (r -> x) = r -> Normal x
103+ normalize = fmap normalize
104+
105+instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
106+ type Normal (Handler x) = IO (Either ServerError (NonEmpty (Dynamic,Int)))
107+ normalize handler = (runExceptT . runHandler') handler >>= \case
108+ Left serverError -> pure (Left serverError)
109+ Right x -> pure $ Right $ breakdown x
78
110
79instance
111instance
80 (Typeable responseType, Breakdown responseType) =>
112 (Typeable responseType, Breakdown responseType) =>
@@ -84,12 +116,6 @@ instance
84 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
116 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
85 reifiedEndpointArguments = V.RNil
117 reifiedEndpointArguments = V.RNil
86
118
87−instance ToReifiedEndpoint (NoContentVerb method)
88− where
89− type EndpointArgs (NoContentVerb method) = '[]
90− type EndpointRes (NoContentVerb method) = NoContent
91− reifiedEndpointArguments = V.RNil
92−
93instance
119instance
94 (ToReifiedEndpoint endpoint) =>
120 (ToReifiedEndpoint endpoint) =>
95 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
121 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
@@ -98,16 +124,6 @@ instance
98 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
124 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
125 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
100
126
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−
111instance
127instance
112 (ToReifiedEndpoint endpoint) =>
128 (ToReifiedEndpoint endpoint) =>
113 ToReifiedEndpoint (Description s :> endpoint)
129 ToReifiedEndpoint (Description s :> endpoint)
@@ -151,23 +167,6 @@ instance
151 V.:& reifiedEndpointArguments @endpoint
167 V.:& reifiedEndpointArguments @endpoint
152
168
153
169
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−
171instance
170instance
172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
171 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
173 , ToReifiedEndpoint endpoint
172 , ToReifiedEndpoint endpoint
@@ -180,7 +179,6 @@ instance
180 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
179 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
181 V.:& reifiedEndpointArguments @endpoint
180 V.:& reifiedEndpointArguments @endpoint
182
181
183−#if MIN_VERSION_servant(0,17,0)
184instance
182instance
185 ( BuildFrom (IfLenient String mods captureType)
183 ( BuildFrom (IfLenient String mods captureType)
186 , ToReifiedEndpoint endpoint) =>
184 , ToReifiedEndpoint endpoint) =>
@@ -191,19 +189,6 @@ instance
191 reifiedEndpointArguments =
189 reifiedEndpointArguments =
192 tagType (Argument (buildFrom @(IfLenient String mods captureType)))
190 tagType (Argument (buildFrom @(IfLenient String mods captureType)))
193 V.:& reifiedEndpointArguments @endpoint
191 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
192
208instance
193instance
209 ( BuildFrom (IfLenient String mods requestType)
194 ( BuildFrom (IfLenient String mods requestType)
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+10−5
@@ -1,10 +1,15 @@
1+# nb: 16.8 doesn't work because the version of servant is too old to have FoldLenient', fixme.
1−resolver: lts-20.4
2+resolver: lts-16.16
2packages:
3packages:
3- .
4- .
4
5
5extra-deps:
6extra-deps:
6−# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
7−# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
8- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
7- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
9−# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
8+- vinyl-0.13.0
10−- some-1.0.3
9+- dependent-sum-0.7.1.0
10+- constraints-extras-0.3.0.2
11+- dependent-map-0.4.0.0
12+- servant-0.18.2
13+- servant-client-0.18.2
14+- servant-client-core-0.18.2
15+- servant-server-0.18.2
stack.yaml.lock+58−9
@@ -7,20 +7,69 @@ packages:
7- completed:
7- completed:
8 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
9 pantry-tree:
9 pantry-tree:
10− sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
11 size: 325
10 size: 325
11+ sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
12 original:
12 original:
13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
14- completed:
14- completed:
15− hackage: some-1.0.3@sha256:938cec5fc0d3a08dde34cfc0acd5a0aa2e9fd489c9dbb64417f16588dfb47af0,2399
15+ hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724
16+ pantry-tree:
17+ size: 1857
18+ sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01
19+ original:
20+ hackage: vinyl-0.13.0
21+- completed:
22+ hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
23+ pantry-tree:
24+ size: 290
25+ sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50
26+ original:
27+ hackage: dependent-sum-0.7.1.0
28+- completed:
29+ hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
30+ pantry-tree:
31+ size: 594
32+ sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1
33+ original:
34+ hackage: constraints-extras-0.3.0.2
35+- completed:
36+ hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
37+ pantry-tree:
38+ size: 551
39+ sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5
40+ original:
41+ hackage: dependent-map-0.4.0.0
42+- completed:
43+ hackage: servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298
44+ pantry-tree:
45+ size: 2662
46+ sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2
47+ original:
48+ hackage: servant-0.18.2
49+- completed:
50+ hackage: servant-client-0.18.2@sha256:82578ade7468873259bb2fdc9d62290a0f998550900683e1410a237ed4b05410,4591
51+ pantry-tree:
52+ size: 1300
53+ sha256: 6324892c77bedbce32f0d6f1612fc2cb0d82c163d3be39efb951d3cc3792ce4a
54+ original:
55+ hackage: servant-client-0.18.2
56+- completed:
57+ hackage: servant-client-core-0.18.2@sha256:4cac20d0b0d889a5613a95ec18526afd16abcaf0b4b7ba5fed35c7bf85800162,3638
58+ pantry-tree:
59+ size: 1444
60+ sha256: 90279e27ba5a7f8f4f1761e81d0dded343839316fdbf34d395954487701e29df
61+ original:
62+ hackage: servant-client-core-0.18.2
63+- completed:
64+ hackage: servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482
16 pantry-tree:
65 pantry-tree:
17− sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8
66+ size: 2614
18− size: 709
67+ sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c
19 original:
68 original:
20− hackage: some-1.0.3
69+ hackage: servant-server-0.18.2
21snapshots:
70snapshots:
22- completed:
71- completed:
23− sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94
24− size: 648660
72+ size: 532380
25− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml
73+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml
74+ sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e
26− original: lts-20.4
75+ original: lts-16.16
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.hs+1−3
@@ -8,19 +8,17 @@
8module Foo where
8module Foo where
9
9
10import Data.Aeson
10import Data.Aeson
11−import Data.Hashable
12import Data.Typeable (Typeable)
11import Data.Typeable (Typeable)
13import GHC.Generics (Generic)
12import GHC.Generics (Generic)
14import Servant
13import Servant
14+import Data.Hashable
15
15
16newtype Foo = Foo Int
16newtype Foo = Foo Int
17 deriving (Generic, Eq, Show, Typeable)
17 deriving (Generic, Eq, Show, Typeable)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
19
19
20instance Hashable Foo
20instance Hashable Foo
21−
22instance ToJSON Foo
21instance ToJSON Foo
23−
24instance FromJSON Foo
22instance FromJSON Foo
25
23
26type Api =
24type Api =
test/Headers.hs+3−4
@@ -8,19 +8,17 @@
8module Headers where
8module Headers where
9
9
10import Data.Aeson
10import Data.Aeson
11−import Data.Hashable
12import Data.Typeable (Typeable)
11import Data.Typeable (Typeable)
13import GHC.Generics (Generic)
12import GHC.Generics (Generic)
14import Servant
13import Servant
14+import Data.Hashable
15
15
16newtype Foo = Foo Int
16newtype Foo = Foo Int
17 deriving (Generic, Eq, Show, Typeable)
17 deriving (Generic, Eq, Show, Typeable)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
19
19
20instance Hashable Foo
20instance Hashable Foo
21−
22instance ToJSON Foo
21instance ToJSON Foo
23−
24instance FromJSON Foo
22instance FromJSON Foo
25
23
26type Api =
24type Api =
@@ -35,7 +33,8 @@ combine :: Maybe Foo -> Maybe Foo -> Handler Foo
35combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
33combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
36combine (Just a) Nothing = pure a
34combine (Just a) Nothing = pure a
37combine Nothing (Just a) = pure a
35combine Nothing (Just a) = pure a
38−combine Nothing Nothing = pure (Foo 1)
36+combine Nothing Nothing = pure (Foo 1)
37+
39
38
40eliminate :: Foo -> Handler ()
39eliminate :: Foo -> Handler ()
41eliminate (Foo a)
40eliminate (Foo a)
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.hs+9−13
@@ -1,31 +1,27 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−
5+{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module Post where
8module Post where
9
9
10−import Data.Aeson
11−import Data.Hashable
12import GHC.Generics (Generic)
10import GHC.Generics (Generic)
13import Servant
11import Servant
12+import Data.Aeson
13+import Data.Hashable
14
14
15−type Api =
16− Get '[JSON] FooPost
15+type Api = Get '[JSON] FooPost
17− :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
16+ :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
18
17
19data FooPost = FooPost
18data FooPost = FooPost
20− deriving (Eq, Show, Generic)
19+ deriving (Eq,Show,Generic)
21
20
22instance Hashable FooPost
21instance Hashable FooPost
23−
24instance ToJSON FooPost
22instance ToJSON FooPost
25−
26instance FromJSON FooPost
23instance FromJSON FooPost
27
24
28server :: Server Api
25server :: Server Api
29−server =
26+server = pure FooPost
30− pure FooPost
31− :<|> const (pure ())
27+ :<|> 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.hs+5−9
@@ -8,26 +8,22 @@
8module Seeded where
8module Seeded where
9
9
10import Data.Aeson
10import Data.Aeson
11−import Data.Hashable
12import Data.Typeable (Typeable)
11import Data.Typeable (Typeable)
13import GHC.Generics (Generic)
12import GHC.Generics (Generic)
14import Servant
13import Servant
14+import Data.Hashable
15
15
16newtype Seed = Seed Int
16newtype Seed = Seed Int
17 deriving (Generic, Eq, Show, Typeable)
17 deriving (Generic, Eq, Show, Typeable)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
18 deriving newtype (FromHttpApiData, ToHttpApiData)
19
19
20instance ToJSON Seed
20instance ToJSON Seed
21−
22instance FromJSON Seed
21instance FromJSON Seed
23−
24instance Hashable Seed
22instance Hashable Seed
25
23
26−type Api =
27− Capture "seed" Seed :> Get '[JSON] ()
24+type Api = Capture "seed" Seed :> Get '[JSON] ()
28− :<|> Get '[JSON] ()
25+ :<|> Get '[JSON] ()
29
26
30server :: Server Api
27server :: Server Api
31−server =
32− (\(Seed _) -> error "we blow up if we get here")
28+server = (\(Seed _) -> error "we blow up if we get here")
33− :<|> pure ()
29+ :<|> pure ()
test/Spec.hs+97−127
@@ -1,170 +1,140 @@
1−{-# LANGUAGE DerivingVia #-}
2−{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE StandaloneDeriving #-}
2{-# LANGUAGE StandaloneDeriving #-}
3+{-# LANGUAGE DerivingVia #-}
6{-# LANGUAGE TypeApplications #-}
4{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE FlexibleContexts #-}
9−{-# LANGUAGE AllowAmbiguousTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE DerivingVia #-}
12−{-# OPTIONS_GHC -fno-warn-orphans #-}
7+{-# LANGUAGE StandaloneDeriving #-}
13−{-# LANGUAGE TypeFamilies #-}
14
8
15−import qualified Breakdown
9+{-# OPTIONS_GHC -fno-warn-orphans #-}
16−import Data.Dynamic (toDyn)
17−import Data.Hashable (Hashable (hash))
18−import Data.Maybe (isNothing)
19−import Data.Void (Void)
20import qualified Foo
10import 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
30import qualified Seeded
11import qualified Seeded
31−import Test.Hspec
32−import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
33import qualified Valid
12import qualified Valid
34−import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
13+import qualified Headers
14+import qualified Post
15+import Test.Hspec.Core.Spec
35
16
36−import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
17+import Data.Dynamic(toDyn)
37−import Network.Wai(Application)
38−import qualified Network.Wai.Handler.Warp as Warp
18+import qualified Roboservant as RS
39−import Network.HTTP.Client (newManager, defaultManagerSettings)
19+import Test.Hspec
40−import Control.Monad((>=>))
20+import Data.Void
21+import Data.Maybe
22+import Data.Hashable
41
23
42main :: IO ()
24main :: IO ()
43main = hspec spec
25main = hspec spec
44
26
45−fuzzBoth
27+noCheck :: IO ()
46− :: forall a .
28+noCheck = pure ()
47− (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
29+
48− HasClient ClientM a)
30+defaultConfig :: RS.Config
49− => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
31+defaultConfig = RS.Config
50−fuzzBoth name server config condition = do
32+ { RS.seed = []
51− it (name <> " via server") $
33+ , RS.maxRuntime = 0.5
52− RS.fuzz @a server config >>= condition
34+ , RS.maxReps = 1000
53−
35+ , RS.rngSeed = 0
54− around (withServer (serve (Proxy :: Proxy a) server)) $
36+ , RS.coverageThreshold = 0
55− it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
37+ }
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
38
65spec :: Spec
39spec :: Spec
66spec = do
40spec = do
67 describe "Basic usage" $ do
41 describe "Basic usage" $ do
68 describe "noError" $ do
42 describe "noError" $ do
43+ it "finds no error in a valid app" $ do
44+ RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
69− fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
45+ >>= (`shouldSatisfy` isNothing)
46+ it "finds no error in a valid generic app" $ do
70− fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)
47+ RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck
48+ >>= (`shouldSatisfy` isNothing)
49+
50+ it "does fail coverage check" $ do
71− fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
51+ r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
72− (\r ->
73− fmap (R.failureReason . R.rsException) r
52+ fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
74− `shouldSatisfy` ( \case
53+ (\case
75− Just (R.InsufficientCoverage _) -> True
54+ Just (RS.InsufficientCoverage _) -> True
76− _ -> False
55+ _ -> False)
77− ))
56+
78− describe "posted body" $
57+ describe "posted body" $ do
79− fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
58+ it "passes a coverage check using a posted body" $ do
59+ RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
80− (`shouldSatisfy` isNothing)
60+ >>= (`shouldSatisfy` isNothing)
81
61
62+ describe "seeded" $ do
63+ shouldFail $
64+ it "finds an error using information passed in" $
65+ let res = Seeded.Seed 1 in
66+ RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [(toDyn res,hash res) ] }) noCheck
67+ >>= (`shouldSatisfy` isNothing)
68+ describe "Foo" $ do
69+ it "finds an error in a basic app" $
70+ RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
71+ >>= (`shouldSatisfy` isJust)
82
72
83− describe "PUTted body" $
73+ -- describe "headers" $ do
84− fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}
74+ -- it "should find a failure that's dependent on using header info" $ do
75+ -- RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
85− (`shouldSatisfy` isNothing)
76+ -- >>= (`shouldSatisfy` isJust)
86
77
78+ -- describe "can build from pieces" $ do
79+ -- it "should find a failure that requires some assembly" $ do
80+ -- RS.fuzz @RS.BuildFrom.Api RS.BuildFrom.server defaultConfig noCheck
81+ -- >>= (`shouldSatisfy` isJust)
87
82
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
83
94− describe "Foo" $
95− fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
96
84
97− describe "QueryParams" $
85+ -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
98− fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }
86+ -- -- -- could: it's mostly here to show how to test for concurrency problems.
99− (`shouldSatisfy` isNothing)
87+ -- describe "concurrency bugs" $ do
88+ -- before UnsafeIO.makeServer $ do
89+ -- describe "sequential checking" $ do
90+ -- it "safe use" $ \unsafeServer -> do
91+ -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
100
92
101− describe "BuildFrom" $ do
93+ -- modifyMaxSuccess (const 10000) $
102− describe "headers (and sum types)" $
94+ -- shouldFail $
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" $
95+ -- describe "concurrent" $ do
106− fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
96+ -- it "concurrent, dangerous use" $ \unsafeServer -> do
107− R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}
97+ -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
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
98
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
99
125−deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
100+deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
101+deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
126
102
103+deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
127−deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
104+deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
128
105
129−deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
106+deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
107+deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
130
108
131−deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
132
109
133−deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
110+-- instance RS.BuildFrom Seeded.Seed
134
111
135−deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
112+deriving via (RS.Atom Void) instance RS.BuildFrom Void
136
113
137−deriving via (R.Atom Void) instance R.BuildFrom Void
114+deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
115+deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
138
116
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
117
142−deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
118+--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped
143−deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
119+--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.Breakdown RS.BuildFrom.Wrapped
144
120
145
121
146
122
147−deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
123+-- deriving via (RS.Atom Void) instance RS.BuildFrom Void
148
124
149−deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
125+-- instance RS.Breakdown Post.FooPost
126+-- instance RS.BuildFrom Post.FooPost
150
127
151−deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
152
128
153-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
129-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
154-- this is often useful when testing tests.
130-- this is often useful when testing tests.
155shouldFail :: SpecWith a -> SpecWith a
131shouldFail :: SpecWith a -> SpecWith a
156−shouldFail =
157− mapSpecItem_
132+shouldFail = mapSpecItem_ (\i -> i {
158− ( \i ->
159− i
160− { itemExample = \p a cb -> do
133+ itemExample = \p a cb -> do
161− r <- itemExample i p a cb
134+ r <- (itemExample i) p a cb
162− pure
163− r
164− { resultStatus = case resultStatus r of
135+ pure r {resultStatus = case resultStatus r of
165− Success -> Failure Nothing (Reason "Unexpected success")
136+ Success -> Failure Nothing (Reason "Unexpected success")
166− Failure _ _ -> Success
137+ Failure _ _ -> Success
167− x -> x
138+ x -> x
168− }
139+ }
169− }
140+ })
170− )
test/UnsafeIO.hs+15−13
@@ -1,39 +1,41 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−
2+{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module UnsafeIO where
8module UnsafeIO where
9
9
10−import Control.Monad.Trans (MonadIO (liftIO))
11−import Data.Aeson ()
10+import Data.Aeson()
12−import qualified Data.ByteString.Lazy.Char8 as BL8
13−import Data.IORef (IORef, newIORef, readIORef, writeIORef)
14import Servant
11import Servant
12+import Data.IORef (writeIORef, IORef, readIORef, newIORef)
13+import Control.Monad.Trans (MonadIO(liftIO))
14+import qualified Data.ByteString.Lazy.Char8 as BL8
15+
15
16
16type UnsafeApi =
17type UnsafeApi =
17 "add" :> Get '[JSON] ()
18 "add" :> Get '[JSON] ()
18− :<|> "healthcheck" :> Get '[JSON] ()
19+ :<|> "healthcheck" :> Get '[JSON] ()
19
20
20healthcheck :: IORef Int -> Handler ()
21healthcheck :: IORef Int -> Handler ()
21healthcheck ref = do
22healthcheck ref = do
22 t <- liftIO $ readIORef ref
23 t <- liftIO $ readIORef ref
23 case t of
24 case t of
24 0 -> pure ()
25 0 -> pure ()
25− n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)}
26+ n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}
27+
28+
26
29
27makeServer :: IO (Server UnsafeApi)
30makeServer :: IO (Server UnsafeApi)
28makeServer = do
31makeServer = do
29 ref <- newIORef 0
32 ref <- newIORef 0
30− pure $
33+ pure $ unsafeMunge ref
31− unsafeMunge ref
32− :<|> healthcheck ref
34+ :<|> healthcheck ref
33
35
34unsafeMunge :: IORef Int -> Handler ()
36unsafeMunge :: IORef Int -> Handler ()
35unsafeMunge ref = liftIO $ do
37unsafeMunge ref = liftIO $ do
36 t <- readIORef ref
38 t <- readIORef ref
37− writeIORef ref (t + 1)
39+ writeIORef ref (t+1)
38 t2 <- readIORef ref
40 t2 <- readIORef ref
39− writeIORef ref (t2 -1)
41+ writeIORef ref (t2-1)
test/Valid.hs+14−18
@@ -1,31 +1,28 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module Valid where
8module Valid where
9
9
10+import Servant
10import Data.Void
11import Data.Void
11import GHC.Generics
12import GHC.Generics
12−import Servant
13+import Servant.API.Generic
13import Servant.Server.Generic
14import Servant.Server.Generic
14
15
15−type Api =
16− Get '[JSON] Int
16+type Api = Get '[JSON] Int
17− :<|> Capture "void" Void :> Get '[JSON] ()
17+ :<|> Capture "void" Void :> Get '[JSON] ()
18
18
19data Routes route
19data Routes route
20 = Routes
20 = Routes
21− { getInt ::
21+ { getInt :: route :-
22− route
23− :- Summary "i'm a summary!" :> Get '[JSON] Int,
22+ Get '[JSON] Int
24− captureIt ::
23+ , captureIt :: route :-
25− route
26− :- Capture "void" Void :> Get '[JSON] ()
24+ Capture "void" Void :> Get '[JSON] ()
27− }
28− deriving (Generic)
25+ } deriving Generic
29
26
30type RoutedApi = ToServantApi Routes
27type RoutedApi = ToServantApi Routes
31
28
@@ -34,11 +31,10 @@ routedServer :: Server RoutedApi
34routedServer = genericServer routes
31routedServer = genericServer routes
35
32
36routes :: Routes AsServer
33routes :: Routes AsServer
37−routes =
34+routes = Routes
38− Routes
39− { getInt = pure 7,
35+ { getInt = pure 7
40− captureIt = const (pure ())
36+ , captureIt = const (pure ())
41− }
37+ }
42
38
43server :: Server Api
39server :: Server Api
44server = pure 7 :<|> const (pure ())
40server = pure 7 :<|> const (pure ())