git.iko.soy/roboservant
on master help sign in
swap
8ade8f342 ahead, 0 behind
.github/workflows/cabal.ymlnew file+64
since splitsnapshots
unifiedsplit
@@ -0,0 +1,64 @@
1+# modified from https://github.com/jgm/pandoc/blob/master/.github/workflows/ci.yml
2+name: Cabal CI
3+
4+on:
5+ push:
6+ branches:
7+ - '**'
8+ paths-ignore: []
9+ pull_request:
10+ paths-ignore: []
11+
12+jobs:
13+ linux:
14+
15+ runs-on: ubuntu-20.04
16+ strategy:
17+ fail-fast: false
18+ matrix:
19+ versions:
20+ - ghc: '8.8.4'
21+ cabal: '3.4'
22+ - ghc: '8.10.4'
23+ cabal: '3.4'
24+ steps:
25+ - uses: actions/checkout@v2
26+
27+ # need to install older cabal/ghc versions from ppa repository
28+
29+ - name: Install recent cabal/ghc
30+ uses: actions/setup-haskell@v1.1.3
31+ with:
32+ ghc-version: ${{ matrix.versions.ghc }}
33+ cabal-version: ${{ matrix.versions.cabal }}
34+
35+ # declare/restore cached things
36+ # caching doesn't work for scheduled runs yet
37+ # https://github.com/actions/cache/issues/63
38+
39+ - name: Cache cabal global package db
40+ id: cabal-global
41+ uses: actions/cache@v2
42+ with:
43+ path: |
44+ ~/.cabal
45+ key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-global-${{ hashFiles('cabal.project') }}
46+
47+ - name: Cache cabal work
48+ id: cabal-local
49+ uses: actions/cache@v2
50+ with:
51+ path: |
52+ dist-newstyle
53+ key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-local
54+
55+ - name: Install dependencies
56+ run: |
57+ cabal update
58+ cabal build all --dependencies-only --enable-tests --disable-optimization
59+ - name: Build
60+ run: |
61+ cabal build all --enable-tests --disable-optimization 2>&1 | tee build.log
62+ - name: Test
63+ run: |
64+ cabal test all --disable-optimization
.github/workflows/ci.yml+2−2
@@ -1,4 +1,4 @@
1−name: CI
1+name: Stack CI
2
2
3# Trigger the workflow on push or pull request, but only for the master branch
3# Trigger the workflow on push or pull request, but only for the master branch
4on:
4on:
@@ -12,7 +12,7 @@ jobs:
12 strategy:
12 strategy:
13 matrix:
13 matrix:
14 stack: ["2.3.3"]
14 stack: ["2.3.3"]
15− ghc: ["8.8.3"]
15+ ghc: ["8.10.4"]
16 os: [ubuntu-latest]
16 os: [ubuntu-latest]
17 steps:
17 steps:
18 - uses: actions/checkout@v2
18 - uses: actions/checkout@v2
EXAMPLE.mdnew file+143
@@ -0,0 +1,143 @@
1+# Example
2+
3+Our api under test:
4+
5+``` haskell
6+-- Obligatory fancy-types pragma tax
7+{-# LANGUAGE DataKinds #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE DerivingStrategies #-}
10+{-# LANGUAGE StandaloneDeriving #-}
11+{-# LANGUAGE DerivingVia #-}
12+{-# LANGUAGE TypeApplications #-}
13+{-# LANGUAGE DeriveGeneric #-}
14+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
15+{-# LANGUAGE RecordWildCards #-}
16+{-# LANGUAGE ScopedTypeVariables #-}
17+{-# LANGUAGE TypeApplications #-}
18+
19+import qualified Roboservant.Server as RS
20+import qualified Roboservant.Client as RC
21+import Servant.Client(ClientEnv, baseUrlPort, parseBaseUrl, mkClientEnv)
22+import Network.HTTP.Client (newManager, defaultManagerSettings)
23+import Roboservant.Types
24+import Test.Hspec
25+import Servant
26+import GHC.Generics
27+import Data.Typeable
28+import Data.Hashable
29+import Data.Maybe(isNothing, isJust)
30+import qualified Network.Wai.Handler.Warp as Warp
31+import Data.Aeson(FromJSON,ToJSON)
32+
33+newtype A = A Int
34+ deriving (Generic, Eq, Show, Typeable)
35+ deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
36+
37+instance FromJSON A
38+instance ToJSON A
39+
40+newtype B = B Int
41+ deriving (Generic, Eq, Show, Typeable)
42+ deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)
43+
44+instance FromJSON B
45+instance ToJSON B
46+
47+type Api =
48+ "item" :> Get '[JSON] A
49+ :<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B
50+ :<|> "item" :> Capture "itemId" B :> Get '[JSON] ()
51+
52+server :: Handler A -> Server Api
53+server introduce = introduce :<|> combine :<|> eliminate
54+ where
55+ combine (B i) (B j) = pure $ B (i + j)
56+ eliminate (B i)
57+ | i > 10 = error "give up, eleven is way too big and probably not even real"
58+ | otherwise = pure ()
59+```
60+
61+We have a "good" server, that never generates anything other than a 0. This means repeated application of
62+the combination/addition rule can never bring us to the dangerous state of numbers larger than 10.
63+
64+``` haskell
65+goodServer, badServer :: Server Api
66+goodServer = server (pure $ A 0)
67+badServer = server (pure $ A 1)
68+```
69+
70+In the test file, we first define the tests: the faulty server should fail and the good server should pass.
71+
72+```haskell
73+main :: IO ()
74+main = hspec spec
75+
76+spec :: Spec
77+spec = describe "example" $ do
78+ it "good server should not fail" $ do
79+ RS.fuzz @Api goodServer config
80+ >>= (`shouldSatisfy` isNothing)
81+ it "bad server should fail" $ do
82+ RS.fuzz @Api badServer config
83+ >>= (`shouldSatisfy` isJust)
84+```
85+
86+The previous test just picked apart the server and ran functions manually: sometimes, we want to test via
87+an honest-to-goodness network port, like so:
88+
89+```haskell
90+ around (withServer (serve (Proxy :: Proxy Api) badServer)) $ do
91+ it "we should also be able to run the _client_ to an independent server (ignore server error messages)" $ \(clientEnv::ClientEnv) -> do
92+ RC.fuzz @Api clientEnv config >>= (`shouldSatisfy` isJust)
93+```
94+
95+(we use withApplication rather than testWithApplication because we don't primarily care what the server does here:
96+we want to check what a client does when presented with a faulty server.)
97+
98+We expect to be able to cover the whole api from our starting point, so let's set the coverage to 0.99.
99+There are other tweakable things in the config, like maximum runtime, reps,
100+per-request healthchecks, seeds, and verbose logging. Have a look at
101+Roboservant.Types.Config for details.
102+
103+``` haskell
104+config :: Config
105+config = defaultConfig
106+ { coverageThreshold = 0.99
107+ }
108+```
109+
110+Unless we want to ship roboservant and all its dependencies to production, we also need
111+some orphan instances: because As are the only value we can get without
112+an input, we need to be able to break them down.
113+
114+``` haskell
115+deriving via (Compound A) instance Breakdown A
116+```
117+
118+if we wanted to assemble As from parts as well, we'd derive using Compound, but in this case we don't care.
119+
120+``` haskell
121+deriving via (Atom A) instance BuildFrom A
122+
123+```
124+
125+Similarly, to generate the first B from the Ints we got from inside the A, we need to be able to
126+build it up from components.
127+
128+```haskell
129+deriving via (Compound B) instance BuildFrom B
130+deriving via (Atom B) instance Breakdown B
131+```
132+
133+
134+test utilities:
135+
136+``` haskell
137+withServer :: Application -> ActionWith ClientEnv -> IO ()
138+withServer app action = Warp.withApplication (pure app) (\p -> genClientEnv p >>= action)
139+ where genClientEnv port = do
140+ baseUrl <- parseBaseUrl "http://localhost"
141+ manager <- newManager defaultManagerSettings
142+ pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
143+```
Example.lhsnew file+1
@@ -0,0 +1 @@
1+EXAMPLE.md
Makefile+3−1
@@ -1,2 +1,4 @@
1testwatch:
1testwatch:
2+ ghcid -T main -c 'stack repl roboservant:lib roboservant:test:roboservant-test --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
3+pedanticwatch:
2− ghcid -T main -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
4+ ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W
README.md+87−23
@@ -2,45 +2,86 @@
2
2
3Automatically fuzz your servant apis in a contextually-aware way.
3Automatically fuzz your servant apis in a contextually-aware way.
4
4
5−![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)
5+[![Stack CI](https://github.com/mwotton/roboservant/actions/workflows/ci.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/ci.yml)
6+[![Cabal CI](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml)
6
7
8+## example
7
9
10+see full example [here](EXAMPLE.md)
11+
8−# why?
12+## why?
9
13
10Servant gives us a lot of information about what a server can do. We
14Servant gives us a lot of information about what a server can do. We
11use this information to generate arbitrarily long request/response
15use this information to generate arbitrarily long request/response
12sessions and verify properties that should hold over them.
16sessions and verify properties that should hold over them.
13
17
14−# example
18+## how?
15
19
16−Our api under test:
20+In essence, ```fuzz @Api yourServer config``` will make a bunch of
21+calls to your API, and record the results in a type-indexed
22+dictionary. This means that they are now available for the
23+prerequisites of other calls, so as you proceed, more and more api
24+calls become possible.
17
25
18−```
26+We explicitly do not try to come up with plausible values that haven't
19−newtype Foo = Foo Int
27+somehow come back from the API. That's straying into QC/Hedgehog
20− deriving (Generic, Eq, Show, Typeable)
28+territory: if you want that, come up with the values on that side, and
21− deriving newtype (FromHttpApiData, ToHttpApiData)
29+set them as seeds in the configuration.
22−
30+
23−type FooApi =
31+### what does it mean to be "available"?
24− "item" :> Get '[JSON] Foo
32+
25− :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
33+In a simple API, you may make a call and get back a `Foo`, which will
26− :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
34+allow you to make another call that requires a `Foo`. In a more
27−```
35+complicated app, it's likely that you'll send a request body that
36+includes many subcomponents, and it's likely you'll get a response
37+that needs to be broken down into pieces before it's useful.
28
38
29−From the tests:
39+To cope with this, we have the typeclasses `BuildFrom` and
40+`Breakdown`. You can write instances for them if you feel like it, and
41+indeed it's currently required for recursive datatypes if you don't
42+want the fuzzer to hang, but for the majority of your types it should
43+be sufficient to derive them generically. (Sensible instances are
44+provided for lists.)
30
45
46+There are two basic strategies here. In some cases, you want to regard
47+a type as indivisible: that's why we like newtypes, right? In this
48+case, we can derive using the `Atom` strategy.
49+
50+``` haskell
51+deriving via (Atom NewtypedKey) instance Breakdown NewtypedKey
52+deriving via (Atom NewtypedKey) instance BuildFrom NewtypedKey
31```
53```
32− assert "should find an error in Foo" . not
54+
33− =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential @Foo.FooApi Foo.fooServer)])
55+This is saying "A can neither be built from components or broken down
56+for spare parts. Hands off!". This is a good strategy for key types,
57+for instance.
58+
59+If instead it's a big complicated thing with lots of juicy
60+subcomponents, we want to rip it apart using Generics and feast on
61+its succulent headmeats:
62+
63+``` haskell
64+deriving via (Compound Payload) instance Breakdown Payload
65+deriving via (Compound Payload) instance BuildFrom Payload
34```
66```
35
67
36−We have a server that blows up if the value of the int in a `Foo` ever gets above 10. Note:
68+### priming the pump
37−there is no generator for `Foo` types: larger `Foo`s can only be made only by combining existing
38−`Foo`s with `itemAdd`. This is an important distinction, because many APIs will return UUIDs or
39−similar as keys, which make it impossible to cover a useful section of the state space without
40−using the values returned by the API
41
69
70+Sometimes there are values we'd like to smuggle into the API that are
71+not derivable from within the API itself: sometimes this is a warning
72+sign that your API is incomplete, but it can be quite reasonable to
73+require identifying credentials within an API and not provide a way to
74+get them. It might also be reasonable to have some sample values that
75+the user is expected to come up with.
42
76
77+For those cases, override the `seed` in the `Config` with a
78+list of seed values, suitably hashed:
79+
80+``` haskell
81+defaultConfig { seed = [hashedDyn creds, hashedDyn userJwt]}
82+```
83+
43−# why not servant-quickcheck?
84+## why not servant-quickcheck?
44
85
45[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
86[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
46is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
87is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,
@@ -48,3 +89,26 @@ there's a lot of the state space you just can't explore without context: modern
48full of pointer-like structures, whether they're URLs or database
89full of pointer-like structures, whether they're URLs or database
49keys/uuids, and servant-quickcheck requires that you be able to generate
90keys/uuids, and servant-quickcheck requires that you be able to generate
50these without context via Arbitrary.
91these without context via Arbitrary.
92+
93+## limitations and future work
94+
95+Currently, the display of failing traces is pretty tragic, both in the
96+formatting and in its non-minimality. This is pretty ticklish:
97+arguably the right way to do this is to return a trace that we can
98+also rerun, and let quickcheck or hedgehog a level up shrink it until
99+it's satisfactorily short. In the interest of being useful earlier
100+rather than later, I'm releasing v1.0 before I crack this particular
101+nut. We do know which calls we made that led to the failing case, so
102+we would want to show that distinction in a visible way: it's possible
103+that other calls that don't have direct data dependencies were
104+important, but we definitely know we need the direct data dependencies.
105+
106+The provenance stuff is a bit underbaked. It should at least pull a
107+representation of the route chosen rather than just an integer index.
108+
109+It would also be nice to have a robust strategy for deriving recursive
110+datatypes, or at least rejecting attempts to generate them that don't
111+end in an infinite loop.
112+
113+Currently the `FlattenServer` instance for `:>` is quadratic. It would
114+be nice to fix this but I lack the art.
benchmarks/README.mdnew file+30
@@ -0,0 +1,30 @@
1+# Benchmarks
2+
3+I've noticed compilation can be a little slow on realistic apps so I set up a test.
4+
5+## components
6+
7+1. codegen
8+
9+ given an integer input n, create an api with n endpoints. they should take a reasonably
10+ complicated input and return a reasonably complicated output
11+
12+2. runner
13+
14+ build dependencies
15+ for i from 1 to 100
16+ generate api with i endpoints
17+ compile it, but timed
18+ print (i,time)
19+
20+3. plot to see linearity/quadraticity?
21+
22+## possible gotchas
23+
24+- we usually compile these in different modules rather than together: if we don't get slow
25+ compilation in one file, try out multiple files.
26+
27+## notes
28+
29+- flat profile if you don't have the call to `fuzz`
30+- no difference between deriving via Atom vs Compound, so not a Generics thing.
benchmarks/genFile.shnew file+26
@@ -0,0 +1,26 @@
1+n=$1
2+k=$2
3+
4+cat prelude
5+echo -n "type SubApi = \"route1\" :> ReqBody '[JSON] Input :> Post '[JSON] Output"
6+for i in $(seq 2 $n); do
7+ echo -n " :<|> \"route${i}\" :> "
8+ echo "ReqBody '[JSON] Input :> Post '[JSON] Output"
9+done
10+
11+echo -n "server = handler "
12+
13+for i in $(seq 2 $n); do
14+ echo -n ":<|> handler "
15+done
16+echo
17+echo
18+
19+echo -n "type Api = Flatten ("
20+for i in $(seq 1 $k); do
21+ echo -n '"foo" :> '
22+done;
23+
24+echo "SubApi )"
25+
26+
benchmarks/preludenew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE TypeApplications #-}
5+{-# LANGUAGE DerivingVia #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE DeriveGeneric #-}
8+
9+
10+import Roboservant
11+import Servant
12+import Data.Hashable
13+import GHC.Generics
14+import Data.Aeson
15+import Servant.API.Flatten
16+
17+data Input = Input1 { foo :: String }
18+ | Input2 { bar :: Int }
19+ deriving (Generic, Eq)
20+
21+instance FromJSON Input
22+instance ToJSON Input
23+
24+
25+deriving via (Compound Input) instance Breakdown Input
26+deriving via (Compound Input) instance BuildFrom Input
27+
28+
29+-- deriving via (Atom Input) instance Breakdown Input
30+-- deriving via (Atom Input) instance BuildFrom Input
31+
32+instance Hashable Input
33+
34+
35+data Output = Output1 { ofoo :: String }
36+ | Output2 { obar :: Int }
37+ deriving (Generic, Eq)
38+
39+instance FromJSON Output
40+instance ToJSON Output
41+
42+instance Hashable Output
43+
44+deriving via (Compound Output) instance Breakdown Output
45+deriving via (Compound Output) instance BuildFrom Output
46+
47+-- deriving via (Atom Output) instance Breakdown Output
48+-- deriving via (Atom Output) instance BuildFrom Output
49+
50+
51+handler :: Input -> Handler Output
52+handler = pure . \case
53+ Input1 foo -> Output1 foo
54+ Input2 bar -> Output2 bar
55+
56+main =
57+ -- fuzz @Api server defaultConfig
58+ pure ()
59+
60+f = flatten (Proxy @Api)
61+
benchmarks/runTiming.shnew file+10
@@ -0,0 +1,10 @@
1+lo=$1
2+hi=$2
3+k=$3
4+for i in $(seq $lo 5 $hi); do
5+ ./genFile.sh $i $k > main.hs;
6+ echo "sievedn: $i,";
7+ /usr/bin/time -f "%e" stack ghc main.hs 2>&1;
8+# /usr/bin/time -f "%e" stack ghc -- -fomit-interface-pragmas main.hs 2>&1;
9+
10+done | grep -v Compiling | grep -v Linking | awk '/,$/ { printf("%s", $0); next } 1' | sed 's/sievedn: //'
benchmarks/runTimingNoisy.shnew file+10
@@ -0,0 +1,10 @@
1+lo=$1
2+hi=$2
3+
4+for i in $(seq $lo 5 $hi); do
5+ ./genFile.sh $i > main.hs;
6+ echo "sievedn: $i,";
7+ /usr/bin/time -f "%e" stack ghc main.hs 2>&1;
8+# /usr/bin/time -f "%e" stack ghc -- -fomit-interface-pragmas main.hs 2>&1;
9+
10+done
package.yaml+21−1
@@ -1,5 +1,6 @@
1+
1name: roboservant
2name: roboservant
2−version: 0.1.0.2
3+version: 0.1.0.3
3github: "mwotton/roboservant"
4github: "mwotton/roboservant"
4license: BSD3
5license: BSD3
5copyright: "2020 Mark Wotton, Samuel Schlesinger"
6copyright: "2020 Mark Wotton, Samuel Schlesinger"
@@ -18,6 +19,7 @@ dependencies:
18- containers
19- containers
19- random
20- random
20- hashable
21- hashable
22+- http-types
21- lifted-base
23- lifted-base
22- monad-control
24- monad-control
23- mtl
25- mtl
@@ -54,3 +56,21 @@ tests:
54 - hspec
56 - hspec
55 - hspec-core
57 - hspec-core
56 - http-api-data
58 - http-api-data
59+ - http-client
60+ - hspec-wai
61+ - wai
62+ - warp
63+ example:
64+ main: Example.lhs
65+ source-dirs: .
66+
67+ dependencies:
68+ - roboservant
69+ - hspec
70+ - warp
71+ - http-client
72+ - aeson
73+ - hspec-core
74+ ghc-options: -pgmL markdown-unlit
75+
76+ build-tools: markdown-unlit
roboservant.cabal+58−4
@@ -1,13 +1,13 @@
1cabal-version: 1.12
1cabal-version: 1.12
2
2
3−-- This file has been generated from package.yaml by hpack version 0.33.0.
3+-- This file has been generated from package.yaml by hpack version 0.35.0.
4--
4--
5-- see: https://github.com/sol/hpack
5-- see: https://github.com/sol/hpack
6--
6--
7−-- hash: d023be57a293833b53804ddc85db27855bf67fd8d96adb0bdab38c899f691147
7+-- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d
8
8
9name: roboservant
9name: roboservant
10−version: 0.1.0.2
10+version: 0.1.0.3
11synopsis: Automatic session-aware servant testing
11synopsis: Automatic session-aware servant testing
12description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
12description: Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme>
13category: Web
13category: Web
@@ -28,13 +28,17 @@ source-repository head
28library
28library
29 exposed-modules:
29 exposed-modules:
30 Roboservant
30 Roboservant
31+ Roboservant.Client
31 Roboservant.Direct
32 Roboservant.Direct
33+ Roboservant.Server
32 Roboservant.Types
34 Roboservant.Types
33 Roboservant.Types.Breakdown
35 Roboservant.Types.Breakdown
34 Roboservant.Types.BuildFrom
36 Roboservant.Types.BuildFrom
35− Roboservant.Types.FlattenServer
37+ Roboservant.Types.Config
36 Roboservant.Types.Internal
38 Roboservant.Types.Internal
39+ Roboservant.Types.Orphans
37 Roboservant.Types.ReifiedApi
40 Roboservant.Types.ReifiedApi
41+ Roboservant.Types.ReifiedApi.Server
38 other-modules:
42 other-modules:
39 Paths_roboservant
43 Paths_roboservant
40 hs-source-dirs:
44 hs-source-dirs:
@@ -47,6 +51,7 @@ library
47 , dependent-map
51 , dependent-map
48 , dependent-sum
52 , dependent-sum
49 , hashable
53 , hashable
54+ , http-types
50 , lifted-base
55 , lifted-base
51 , monad-control
56 , monad-control
52 , mtl
57 , mtl
@@ -62,13 +67,57 @@ library
62 , vinyl
67 , vinyl
63 default-language: Haskell2010
68 default-language: Haskell2010
64
69
70+test-suite example
71+ type: exitcode-stdio-1.0
72+ main-is: Example.lhs
73+ other-modules:
74+ Paths_roboservant
75+ hs-source-dirs:
76+ ./
77+ ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit
78+ build-tool-depends:
79+ markdown-unlit:markdown-unlit
80+ build-depends:
81+ aeson
82+ , base >=4.7 && <5
83+ , bytestring
84+ , containers
85+ , dependent-map
86+ , dependent-sum
87+ , hashable
88+ , hspec
89+ , hspec-core
90+ , http-client
91+ , http-types
92+ , lifted-base
93+ , monad-control
94+ , mtl
95+ , random
96+ , roboservant
97+ , servant
98+ , servant-client
99+ , servant-flatten
100+ , servant-server
101+ , string-conversions
102+ , text
103+ , time
104+ , unordered-containers
105+ , vinyl
106+ , warp
107+ default-language: Haskell2010
108+
65test-suite roboservant-test
109test-suite roboservant-test
66 type: exitcode-stdio-1.0
110 type: exitcode-stdio-1.0
67 main-is: Spec.hs
111 main-is: Spec.hs
68 other-modules:
112 other-modules:
113+ Breakdown
69 Foo
114 Foo
70 Headers
115 Headers
116+ Nested
71 Post
117 Post
118+ Product
119+ Put
120+ QueryParams
72 Seeded
121 Seeded
73 UnsafeIO
122 UnsafeIO
74 Valid
123 Valid
@@ -86,7 +135,10 @@ test-suite roboservant-test
86 , hashable
135 , hashable
87 , hspec
136 , hspec
88 , hspec-core
137 , hspec-core
138+ , hspec-wai
89 , http-api-data
139 , http-api-data
140+ , http-client
141+ , http-types
90 , lifted-base
142 , lifted-base
91 , monad-control
143 , monad-control
92 , mtl
144 , mtl
@@ -101,4 +153,6 @@ test-suite roboservant-test
101 , time
153 , time
102 , unordered-containers
154 , unordered-containers
103 , vinyl
155 , vinyl
156+ , wai
157+ , warp
104 default-language: Haskell2010
158 default-language: Haskell2010
src/Roboservant.hs+5−2
@@ -1,5 +1,8 @@
1+module Roboservant
1−module Roboservant (module Roboservant.Direct
2+ ( module Roboservant.Direct,
2− ,module Roboservant.Types) where
3+ module Roboservant.Types,
4+ )
5+where
3
6
4import Roboservant.Direct
7import Roboservant.Direct
5import Roboservant.Types
8import Roboservant.Types
src/Roboservant/Client.hsnew file+127
@@ -0,0 +1,127 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE NamedFieldPuns #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE AllowAmbiguousTypes #-}
6+{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+
12+{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE FlexibleContexts #-}
15+-- should all the NormalizeFunction instances be in one place?
16+{-# OPTIONS_GHC -fno-warn-orphans #-}
17+module Roboservant.Client where
18+
19+import Data.Proxy
20+import Servant.Client
21+import Roboservant.Types
22+import Roboservant(Report, fuzz')
23+import Servant
24+import Data.Bifunctor
25+import Data.List.NonEmpty (NonEmpty)
26+import Data.Dynamic (Dynamic,Typeable)
27+import qualified Data.Vinyl.Curry as V
28+import qualified Data.Text as T
29+import Control.Monad.Reader
30+import Data.Hashable
31+import Network.HTTP.Types.Status
32+
33+-- fuzz :: forall api.
34+-- (FlattenServer api, ToReifiedApi (Endpoints api)) =>
35+-- Server api ->
36+-- Config ->
37+-- IO (Maybe Report)
38+-- fuzz s = fuzz' (reifyServer s)
39+-- -- todo: how do we pull reifyServer out?
40+-- where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
41+-- => Server api -> ReifiedApi
42+-- reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
43+
44+fuzz :: forall api . (ToReifiedClientApi (Endpoints api), FlattenClient api, HasClient ClientM api)
45+ => ClientEnv -> Config -> IO (Maybe Report)
46+fuzz clientEnv
47+ = fuzz'
48+ (toReifiedClientApi
49+ (flattenClient @api apiClient) (Proxy @(Endpoints api)) clientEnv)
50+ where apiClient = client (Proxy @api)
51+
52+
53+
54+class ToReifiedClientApi api where
55+ toReifiedClientApi :: ClientBundled api -> Proxy api -> ClientEnv -> ReifiedApi
56+
57+data ClientBundled endpoints where
58+ AClientEndpoint :: Client ClientM endpoint -> ClientBundled endpoints -> ClientBundled (endpoint ': endpoints)
59+ NoClientEndpoints :: ClientBundled '[]
60+
61+
62+class FlattenClient api where
63+ flattenClient :: Client ClientM api -> ClientBundled (Endpoints api)
64+
65+instance
66+ ( NormalizeFunction (Client ClientM endpoint)
67+ , Normal (Client ClientM endpoint) ~ V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))))
68+ , ToReifiedClientApi endpoints
69+ , V.RecordCurry' (EndpointArgs endpoint)
70+ , ToReifiedEndpoint endpoint) =>
71+ ToReifiedClientApi (endpoint : endpoints) where
72+ toReifiedClientApi (endpoint `AClientEndpoint` endpoints) _ clientEnv =
73+ (0, ReifiedEndpoint
74+ { reArguments = reifiedEndpointArguments @endpoint
75+ , reEndpointFunc = foo (normalize endpoint)
76+ }
77+ )
78+ : (map . first) (+1)
79+ (toReifiedClientApi endpoints (Proxy @endpoints) clientEnv)
80+ where
81+
82+ foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType)
83+ -> V.Curried (EndpointArgs endpoint) (IO ResultType)
84+ foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv)
85+
86+mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b
87+mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g
88+
89+type ResultType = Either InteractionError (NonEmpty (Dynamic,Int))
90+-- runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
91+
92+
93+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where
94+ type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int)))
95+ normalize c = ReaderT $
96+ fmap (bimap renderClientError breakdown) . runClientM c
97+ where
98+ renderClientError :: ClientError -> InteractionError
99+ renderClientError err = case err of
100+ FailureResponse _ Response{responseStatusCode} -> InteractionError textual (responseStatusCode == status500)
101+ _ -> InteractionError textual True
102+
103+ where textual = T.pack $ show err
104+instance ToReifiedClientApi '[] where
105+ toReifiedClientApi NoClientEndpoints _ _ = []
106+
107+
108+instance
109+ ( FlattenClient api,
110+ Endpoints endpoint ~ '[endpoint]
111+ ) =>
112+ FlattenClient (endpoint :<|> api)
113+ where
114+ flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c
115+
116+instance
117+ (
118+ Endpoints api ~ '[api]
119+ ) =>
120+ FlattenClient (x :> api)
121+ where
122+ flattenClient c = c `AClientEndpoint` NoClientEndpoints
123+
124+
125+instance FlattenClient (Verb method statusCode contentTypes responseType)
126+ where
127+ flattenClient c = c `AClientEndpoint` NoClientEndpoints
src/Roboservant/Direct.hs+121−180
@@ -2,104 +2,53 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TupleSections #-}
9{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11
10
11+{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
13
13
14module Roboservant.Direct
14module Roboservant.Direct
15+ ( fuzz',
15− ( fuzz, Config(..)
16+ Config (..),
16−
17− -- TODO come up with something smarter than exporting all this, we should
17+ -- TODO come up with something smarter than exporting all this, we should
18− -- have some nice error-display functions
18+ -- have some nice error-display functions
19− , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
19+ RoboservantException (..),
20+ FuzzState (..),
21+ FuzzOp (..),
22+ FailureType (..),
23+ Report (..),
20 )
24 )
21where
25where
22
26
23import Control.Exception.Lifted
27import Control.Exception.Lifted
24− ( throw,
25− handle,
26− Handler(..),
27− Exception,
28+ ( Exception,
28− SomeException,
29− SomeAsyncException,
30− catch,
31− catches )
32−import Control.Exception.Lifted
33− ( throw,
34− Handler(..),
29+ Handler (Handler),
35− Exception,
36− SomeException,
37− SomeAsyncException,
38− catch,
39− catches )
40−import Control.Exception.Lifted
41− ( Exception,
42− Handler(..),
43− SomeAsyncException,
30+ SomeAsyncException,
44− SomeException,
31+ SomeException,
45− catch,
32+ catch,
46− catches,
33+ catches,
47− handle,
34+ handle,
48− throw )
35+ throw,
49−
36+ )
50−import Control.Monad.State.Strict
51− ( MonadState, MonadIO, get, modify', liftIO, runStateT )
52−import Control.Monad.State.Strict
53− ( MonadState, MonadIO, get, modify', liftIO, execStateT )
54import Control.Monad.State.Strict
37import Control.Monad.State.Strict
55− ( MonadIO, MonadState, get, liftIO, modify', runStateT )
38+ ( MonadIO (..),
56−
39+ MonadState (get),
57−import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
40+ StateT (runStateT),
58−import Control.Monad(void,replicateM,forM_)
41+ modify',
59−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
42+ )
60−import Control.Monad.Trans.Control(MonadBaseControl)
61−import Data.Dependent.Map (DMap)
62−import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
63−import Data.List.NonEmpty (NonEmpty(..))
64−import Data.Map.Strict(Map)
65−import qualified Data.Set as Set
66−import Data.Maybe (mapMaybe)
67−import Data.Typeable (TypeRep)
68−import Servant ( Endpoints, Proxy(Proxy), Server, ServerError(..) )
69−import Servant ( Endpoints, Proxy(Proxy), Server, ServerError(..) )
70−
71−import System.Random ( StdGen, randomR, mkStdGen )
72−import System.Random ( StdGen, mkStdGen, randomR )
73−
74−import qualified Data.List.NonEmpty as NEL
75−import qualified Data.Map.Strict as Map
76−import Data.Time.Clock
77−import Data.Time.Clock
78−
79−import Data.List(sortOn)
80−import Control.Arrow(second)
81−import System.Timeout.Lifted(timeout)
82−import GHC.Generics ( (:*:)(..) )
83−import GHC.Generics ( (:*:)(..) )
84−
85−import qualified Data.Vinyl.Functor as V
86−import qualified Data.Vinyl.Functor as V
87−
88−import qualified Data.Vinyl.Curry as V
89−import qualified Data.Vinyl.Curry as V
90−
91−
92−
93−import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)
94−import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)
95import Control.Monad.Trans.Control (MonadBaseControl)
43import Control.Monad.Trans.Control (MonadBaseControl)
96import qualified Data.Dependent.Map as DM
44import qualified Data.Dependent.Map as DM
97−import Data.Dynamic (Dynamic (..), dynTypeRep)
45+import Data.Dynamic (Dynamic (..))
46+import qualified Data.IntSet as IntSet
98import Data.List.NonEmpty (NonEmpty (..))
47import Data.List.NonEmpty (NonEmpty (..))
99import qualified Data.List.NonEmpty as NEL
48import qualified Data.List.NonEmpty as NEL
100import Data.Maybe (mapMaybe)
49import Data.Maybe (mapMaybe)
101import qualified Data.Set as Set
50import qualified Data.Set as Set
102−import Data.Time.Clock
51+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
103import qualified Data.Vinyl as V
52import qualified Data.Vinyl as V
104import qualified Data.Vinyl.Curry as V
53import qualified Data.Vinyl.Curry as V
105import qualified Data.Vinyl.Functor as V
54import qualified Data.Vinyl.Functor as V
@@ -107,25 +56,26 @@ import GHC.Generics ((:*:) (..))
107import Roboservant.Types
56import Roboservant.Types
108 ( ApiOffset (..),
57 ( ApiOffset (..),
109 Argument (..),
58 Argument (..),
110− FlattenServer (..),
59+ InteractionError(..),
111 Provenance (..),
60 Provenance (..),
61+ ReifiedApi,
112 ReifiedEndpoint (..),
62 ReifiedEndpoint (..),
113 Stash (..),
63 Stash (..),
114 StashValue (..),
64 StashValue (..),
115− ToReifiedApi (..),
65+ TypedF,
116− TypedF
117 )
66 )
118−import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
67+import Roboservant.Types.Config
68+
119−import System.Random (StdGen, mkStdGen, randomR)
69+import System.Random (Random (randomR), StdGen, mkStdGen)
120import qualified Type.Reflection as R
70import qualified Type.Reflection as R
121−import qualified Data.IntSet as IntSet
122
71
123data RoboservantException
72data RoboservantException
124 = RoboservantException
73 = RoboservantException
125− { failureReason :: FailureType
74+ { failureReason :: FailureType,
126− , serverException :: Maybe SomeException
75+ serverException :: Maybe SomeException,
127− , fuzzState :: FuzzState
76+ fuzzState :: FuzzState
77+ }
128− } deriving (Show)
78+ deriving (Show)
129
79
130instance Exception RoboservantException
80instance Exception RoboservantException
131
81
@@ -134,7 +84,7 @@ data FailureType
134 | CheckerFailed
84 | CheckerFailed
135 | NoPossibleMoves
85 | NoPossibleMoves
136 | InsufficientCoverage Double
86 | InsufficientCoverage Double
137− deriving (Show,Eq)
87+ deriving (Show, Eq)
138
88
139data FuzzOp
89data FuzzOp
140 = FuzzOp
90 = FuzzOp
@@ -143,15 +93,6 @@ data FuzzOp
143 }
93 }
144 deriving (Show, Eq)
94 deriving (Show, Eq)
145
95
146−data Config
147− = Config
148− { seed :: [(Dynamic,Int)],
149− maxRuntime :: Double, -- seconds to test for
150− maxReps :: Integer,
151− rngSeed :: Int,
152− coverageThreshold :: Double
153− }
154−
155data FuzzState
96data FuzzState
156 = FuzzState
97 = FuzzState
157 { path :: [FuzzOp],
98 { path :: [FuzzOp],
@@ -164,7 +105,7 @@ data EndpointOption
164 = forall as.
105 = forall as.
165 (V.RecordToList as, V.RMap as) =>
106 (V.RecordToList as, V.RMap as) =>
166 EndpointOption
107 EndpointOption
167− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))),
108+ { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
168 eoArgs :: V.Rec (TypedF StashValue) as
109 eoArgs :: V.Rec (TypedF StashValue) as
169 }
110 }
170
111
@@ -173,19 +114,25 @@ data StopReason
173 | HitMaxIterations
114 | HitMaxIterations
174 deriving (Show, Eq)
115 deriving (Show, Eq)
175
116
176−data Report = Report
117+data Report
118+ = Report
177− { textual :: String
119+ { textual :: String,
178− , rsException :: RoboservantException}
120+ rsException :: RoboservantException
121+ }
179 deriving (Show)
122 deriving (Show)
180
123
124+
125+
126+-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
127+-- fuzzClient = undefined
128+
129+
130+
181−fuzz ::
131+fuzz' ::
182− forall api.
132+ ReifiedApi ->
183− (FlattenServer api, ToReifiedApi (Endpoints api)) =>
184− Server api ->
185 Config ->
133 Config ->
186− IO () ->
187 IO (Maybe Report)
134 IO (Maybe Report)
188−fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
135+fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
189 let path = []
136 let path = []
190 stash = addToStash seed mempty
137 stash = addToStash seed mempty
191 currentRng = mkStdGen rngSeed
138 currentRng = mkStdGen rngSeed
@@ -194,39 +141,36 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
194 runStateT
141 runStateT
195 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
142 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
196 FuzzState {..}
143 FuzzState {..}
197− print stopreason
144+ logInfo $ show stopreason
198 pure Nothing
145 pure Nothing
199 where
146 where
200 -- something less terrible later
147 -- something less terrible later
201 formatException :: RoboservantException -> Report
148 formatException :: RoboservantException -> Report
202− formatException r@(RoboservantException failureType exception _state) = Report
149+ formatException r@(RoboservantException failureType exception _state) =
150+ Report
203− (unlines [ show failureType , show exception ])
151+ (unlines [show failureType, show exception])
204− r
152+ r
205−
206− displayDiagnostics FuzzState{..} = liftIO $ do
153+ displayDiagnostics FuzzState {..} = liftIO $
154+ logInfo $ unlines $
207− putStrLn "api endpoints covered"
155+ ["api endpoints covered"]
208− mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
156+ <> (map show . Set.toList . Set.fromList $ map apiOffset path)
209− putStrLn ""
210− putStrLn "types in stash"
157+ <> ["", "types in stash"]
211− DM.forWithKey_ (getStash stash) $ \k v ->
212− print (NEL.length $ getStashValue v)
158+ <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)
213− -- mapM_
214− -- (print . second NEL.length)
215− -- (sortOn (show . fst) $ Map.toList $ getStash stash)
159+ -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
216−
160+ -- $ \_k v ->
217− -- evaluateCoverage :: FuzzState -> m ()
161+ -- (show . NEL.length $ getStashValue v))
162+
218− evaluateCoverage f@FuzzState{..}
163+ evaluateCoverage f@FuzzState {..}
219 | coverage > coverageThreshold = pure ()
164 | coverage > coverageThreshold = pure ()
220 | otherwise = do
165 | otherwise = do
221− displayDiagnostics f
166+ displayDiagnostics f
222− throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
167+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
168+ where
223− where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
169+ hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
224− totalRoutes = fromIntegral routeCount
170+ totalRoutes = fromIntegral routeCount
225− coverage = hitRoutes / totalRoutes
171+ coverage = hitRoutes / totalRoutes
226−
227−
228− untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
172+ untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
229− untilDone (0,_) _ = pure HitMaxIterations
173+ untilDone (0, _) _ = pure HitMaxIterations
230 untilDone (n, deadline) action = do
174 untilDone (n, deadline) action = do
231 now <- liftIO getCurrentTime
175 now <- liftIO getCurrentTime
232 if now > deadline
176 if now > deadline
@@ -234,12 +178,13 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
234 else do
178 else do
235 _ <- action
179 _ <- action
236 untilDone (n -1, deadline) action
180 untilDone (n -1, deadline) action
237− reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
238− routeCount = length reifiedApi
239
181
182+ routeCount = length reifiedApi
183+ elementOrFail ::
240− elementOrFail :: (MonadState FuzzState m, MonadIO m)
184+ (MonadState FuzzState m, MonadIO m) =>
185+ [a] ->
241− => [a] -> m a
186+ m a
242− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
187+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
243 elementOrFail l = do
188 elementOrFail l = do
244 st <- get
189 st <- get
245 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
190 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
@@ -250,7 +195,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
250 ( forall as.
195 ( forall as.
251 (V.RecordToList as, V.RMap as) =>
196 (V.RecordToList as, V.RMap as) =>
252 FuzzOp ->
197 FuzzOp ->
253− V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
198+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
254 V.Rec (TypedF V.Identity) as ->
199 V.Rec (TypedF V.Identity) as ->
255 m r
200 m r
256 ) ->
201 ) ->
@@ -291,57 +236,53 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
291 execute ::
236 execute ::
292 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
237 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
293 FuzzOp ->
238 FuzzOp ->
294− V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
239+ V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
295 V.Rec (TypedF V.Identity) as ->
240 V.Rec (TypedF V.Identity) as ->
296 m ()
241 m ()
297 execute fuzzop func args = do
242 execute fuzzop func args = do
298− (liftIO . print . (fuzzop,) . stash ) =<< get
243+ (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
299− st <- get
300− -- let showable = unlines $ ("args":map show argTypes)
301− -- <> ["fuzzop"
302− -- , show fuzzop
303− -- -- ,"dyncall"
304− -- -- ,show (dynTypeRep dyncall)
305− -- ,"state"
306− -- ]
307− -- liftIO $ putStrLn showable
308 liftIO (V.runcurry' func argVals) >>= \case
244 liftIO (V.runcurry' func argVals) >>= \case
309− -- parameterise this
245+ Left (e::InteractionError) ->
310− Left (serverError :: ServerError) ->
246+ if fatalError e
311− case errHTTPCode serverError of
247+ then throw e
312− 500 -> throw serverError
248+ else pure ()
313− _ -> do
314− liftIO $ print ("ignoring non-500 error", serverError)
315− Right (dyn :: NEL.NonEmpty (Dynamic,Int)) -> do
249+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
316− -- liftIO $ print ("storing", fmap dynTypeRep dyn)
250+ modify'
317− modify' (\fs@FuzzState{..} ->
251+ ( \fs@FuzzState {..} ->
318− fs { stash = addToStash (NEL.toList dyn) stash } )
252+ fs {stash = addToStash (NEL.toList dyn) stash}
253+ )
319 where
254 where
320 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
255 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
321− argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
256+ -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
322 go ::
257 go ::
323 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
258 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
324 m ()
259 m ()
325 go = withOp $ \op func args -> do
260 go = withOp $ \op func args -> do
261+ catches
326− catches (execute op func args)
262+ (execute op func args)
327− [ Handler (\(e :: SomeAsyncException) -> throw e)
263+ [ Handler (\(e :: SomeAsyncException) -> throw e),
264+ Handler
328− , Handler (\(e :: SomeException) -> do
265+ ( \(e :: SomeException) ->
329− displayDiagnostics =<< get
330− throw . RoboservantException ServerCrashed (Just e) =<< get)
266+ throw . RoboservantException ServerCrashed (Just e) =<< get
267+ )
331 ]
268 ]
332− catch (liftIO checker)
269+ catch
270+ (liftIO healthCheck)
333− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
271+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
334
272
335addToStash ::
273addToStash ::
336− [(Dynamic,Int)] ->
274+ [(Dynamic, Int)] ->
337 Stash ->
275 Stash ->
338 Stash
276 Stash
339addToStash result stash =
277addToStash result stash =
340 foldr
278 foldr
341− ( \(Dynamic tr x,hashed) (Stash dict) ->
279+ ( \(Dynamic tr x, hashed) (Stash dict) ->
342 Stash $
280 Stash $
343− DM.insertWith renumber tr
281+ DM.insertWith
282+ renumber
283+ tr
344− (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed)) dict
284+ (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))
285+ dict
345 )
286 )
346 stash
287 stash
347 result
288 result
@@ -354,11 +295,11 @@ addToStash result stash =
354 | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
295 | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
355 | otherwise =
296 | otherwise =
356 StashValue
297 StashValue
357− (case NEL.toList singleDyn of
298+ ( case NEL.toList singleDyn of
358− [([Provenance tr _], dyn)] ->
299+ [([Provenance tr _], dyn)] ->
359− l <> pure (([Provenance tr (length (NEL.last l) + 1)], dyn))
300+ l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
360− _ -> error "should be impossible")
301+ _ -> error "should be impossible"
361−
302+ )
362 (IntSet.union singleHash intSet)
303 (IntSet.union singleHash intSet)
363
304
364-- why isn't this in vinyl?
305-- why isn't this in vinyl?
src/Roboservant/Server.hsnew file+36
@@ -0,0 +1,36 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE PolyKinds #-}
8+
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+module Roboservant.Server (fuzz, module Roboservant.Types ) where
15+
16+import Roboservant.Direct(fuzz',Report)
17+import Roboservant.Types
18+ ( FlattenServer (..),
19+ ReifiedApi,
20+ )
21+import Roboservant.Types.ReifiedApi.Server(ToReifiedApi (..))
22+import Servant (Endpoints, Proxy (Proxy), Server)
23+import Roboservant.Types.Config
24+
25+fuzz :: forall api.
26+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>
27+ Server api ->
28+ Config ->
29+ IO (Maybe Report)
30+fuzz s = fuzz' (reifyServer s)
31+ -- todo: how do we pull reifyServer out?
32+ where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))
33+ => Server api -> ReifiedApi
34+ reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
35+-- reifyServer server = toReifiedApi server (Proxy @(Endpoints api))
36+
src/Roboservant/Types.hs+10−14
@@ -2,29 +2,25 @@
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE StandaloneDeriving #-}
10−{-# LANGUAGE TupleSections #-}
11−{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
8{-# LANGUAGE UndecidableInstances #-}
15
9
16module Roboservant.Types
10module Roboservant.Types
17− ( module Roboservant.Types.Breakdown
11+ ( module Roboservant.Types.Breakdown,
18− , module Roboservant.Types.BuildFrom
12+ module Roboservant.Types.BuildFrom,
19− , module Roboservant.Types.FlattenServer
13+ module Roboservant.Types.ReifiedApi,
20− , module Roboservant.Types.ReifiedApi
14+ module Roboservant.Types.ReifiedApi.Server,
21− , module Roboservant.Types.Internal
15+ module Roboservant.Types.Internal,
22−
16+ module Roboservant.Types.Config,
23 )
17 )
24where
18where
25
19
26import Roboservant.Types.Breakdown
20import Roboservant.Types.Breakdown
27import Roboservant.Types.BuildFrom
21import Roboservant.Types.BuildFrom
28−import Roboservant.Types.FlattenServer
22+import Roboservant.Types.Config
29−import Roboservant.Types.ReifiedApi
30import Roboservant.Types.Internal
23import Roboservant.Types.Internal
24+import Roboservant.Types.ReifiedApi
25+import Roboservant.Types.ReifiedApi.Server
26+import Roboservant.Types.Orphans()
src/Roboservant/Types/Breakdown.hs+54−32
@@ -1,59 +1,81 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE DerivingVia #-}
4{-# LANGUAGE DerivingVia #-}
4−{-# LANGUAGE DerivingVia #-}
5−
6−{-# LANGUAGE StandaloneDeriving #-}
7−{-# LANGUAGE StandaloneDeriving #-}
8−
9−{-# LANGUAGE FlexibleInstances #-}
10−{-# LANGUAGE FlexibleInstances #-}
11−
12−{-# LANGUAGE GADTs #-}
13−{-# LANGUAGE GADTs #-}
14−
15−{-# LANGUAGE DefaultSignatures #-}
16−{-# LANGUAGE DerivingStrategies #-}
17{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
18{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
19−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
20{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
21{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
22{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
24−{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE StandaloneDeriving #-}
25{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
26{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
27−{-# LANGUAGE StandaloneDeriving #-}
28−{-# LANGUAGE DerivingVia #-}
29−
30
15
31module Roboservant.Types.Breakdown where
16module Roboservant.Types.Breakdown where
32
17
33−import Data.Dynamic (Dynamic, fromDynamic, toDyn)
18+import Data.Dynamic (Dynamic)
19+import Data.Hashable
20+import Data.Kind
34import Data.List.NonEmpty (NonEmpty (..))
21import Data.List.NonEmpty (NonEmpty (..))
35import qualified Data.List.NonEmpty as NEL
22import qualified Data.List.NonEmpty as NEL
36−import Data.Maybe (fromMaybe)
37−import GHC.Generics(Generic)
38import Data.Typeable (Typeable)
23import Data.Typeable (Typeable)
24+import GHC.Generics
39import Roboservant.Types.Internal
25import Roboservant.Types.Internal
40−import Data.Hashable
26+import Servant
27+import Roboservant.Types.Orphans()
41
28
42−-- | only use this when we are using the internal typerep map.
29+breakdown ::
43−promisedDyn :: Typeable a => Dynamic -> a
30+ (Hashable x, Typeable x, Breakdown x) =>
44−promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
31+ x ->
32+ NonEmpty (Dynamic, Int)
33+breakdown x = hashedDyn x :| breakdownExtras x
45
34
46class Breakdown x where
35class Breakdown x where
47− breakdown :: x -> NonEmpty (Dynamic,Int)
36+ breakdownExtras :: x -> [(Dynamic, Int)]
48−-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
49−-- breakdown = pure . toDyn
50−
51
37
52instance (Hashable x, Typeable x) => Breakdown (Atom x) where
38instance (Hashable x, Typeable x) => Breakdown (Atom x) where
53− breakdown (Atom x) = pure (toDyn x, hash x)
39+ breakdownExtras _ = []
54
40
55deriving via (Atom ()) instance Breakdown ()
41deriving via (Atom ()) instance Breakdown ()
42+
56deriving via (Atom Int) instance Breakdown Int
43deriving via (Atom Int) instance Breakdown Int
44+deriving via (Atom Char) instance Breakdown Char
45+
46+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x)
47+
48+instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where
49+ breakdownExtras stash = concatMap (NEL.toList . breakdown) stash
50+
51+
52+class GBreakdown (f :: k -> Type) where
53+ gBreakdownExtras :: f a -> [(Dynamic, Int)]
54+
55+instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where
56+ breakdownExtras = gBreakdownExtras . from . unCompound
57+
58+instance GBreakdown f => GBreakdown (M1 S c f) where
59+ gBreakdownExtras (M1 f) = gBreakdownExtras f
60+
61+instance GBreakdown b => GBreakdown (M1 D a b) where
62+ gBreakdownExtras (M1 f) = gBreakdownExtras f
63+
64+instance GBreakdown b => GBreakdown (M1 C a b) where
65+ gBreakdownExtras (M1 f) = gBreakdownExtras f
66+
67+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :*: b) where
68+ gBreakdownExtras (a :*: b) = gBreakdownExtras a <> gBreakdownExtras b
69+
70+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where
71+ gBreakdownExtras = \case
72+ L1 a -> gBreakdownExtras a
73+ R1 a -> gBreakdownExtras a
74+
75+instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where
76+ gBreakdownExtras (K1 c) = NEL.toList $ breakdown c
77+
78+instance GBreakdown U1 where
79+ gBreakdownExtras U1 = []
57
80
58−-- instance (Typeable a, Breakdown a) => Breakdown [a] where
81+deriving via (Atom NoContent) instance Breakdown NoContent
59−-- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
src/Roboservant/Types/BuildFrom.hs+93−27
@@ -1,41 +1,107 @@
1−{-# LANGUAGE DefaultSignatures #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DerivingStrategies #-}
2+{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE PolyKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeApplications #-}
5{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE DerivingVia #-}
11+{-# LANGUAGE UndecidableInstances #-}
8−
9−
10
12
11module Roboservant.Types.BuildFrom where
13module Roboservant.Types.BuildFrom where
12
14
13−import Data.List.NonEmpty (NonEmpty(..))
15+import Data.List(nub)
14−import qualified Data.List.NonEmpty as NEL
15−import Data.Typeable (Typeable)
16import qualified Data.Dependent.Map as DM
16import qualified Data.Dependent.Map as DM
17−import qualified Type.Reflection as R
17+import Data.Hashable
18+import qualified Data.IntSet as IntSet
18import Data.Kind
19import Data.Kind
20+import Data.List.NonEmpty (NonEmpty (..))
21+import qualified Data.List.NonEmpty as NEL
22+import Data.Typeable (Typeable)
23+import GHC.Generics
19import Roboservant.Types.Internal
24import Roboservant.Types.Internal
20−import Data.Hashable
25+import qualified Type.Reflection as R
26+import Servant(NoContent)
27+import Roboservant.Types.Orphans()
28+
29+buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
30+buildFrom = buildStash . buildFrom'
31+ where
32+ buildStash :: [([Provenance], x)] -> Maybe (StashValue x)
33+ buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty
34+ promoteToStash :: ([Provenance], x) -> StashValue x
35+ promoteToStash (p, x) =
36+ StashValue
37+ (pure (p, x))
38+ (IntSet.singleton (hash x))
39+ addStash :: StashValue x -> StashValue x -> StashValue x
40+ addStash old (StashValue newVal _) =
41+ let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal
42+ in StashValue
43+ (addListToNE (getStashValue old) insertableVals)
44+ (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))
45+ addListToNE :: NonEmpty a -> [a] -> NonEmpty a
46+ addListToNE ne l = NEL.fromList (NEL.toList ne <> l)
21
47
22−class Typeable x => BuildFrom (x :: Type) where
48+buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]
23− buildFrom :: Stash -> Maybe (StashValue x)
49+buildFrom' stash =
50+ maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))
51+ <> extras stash
24
52
25−-- | this is a little esoteric: basically, we're always going to use this with
53+class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
26−-- deriving-via, so we need to look up the underlying `x` and then wrap it in Atom.
54+ extras :: Stash -> [([Provenance], x)]
55+
27−instance Typeable x => BuildFrom (Atom x) where
56+instance (Hashable x, Typeable x) => BuildFrom (Atom x) where
28− buildFrom = fmap (fmap Atom) <$> DM.lookup R.typeRep . getStash
57+ extras _ = []
29
58
30deriving via (Atom Bool) instance BuildFrom Bool
59deriving via (Atom Bool) instance BuildFrom Bool
31
60
32−-- instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x) where
61+deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)
33−-- buildFrom dict = Just options
62+
34−-- where options :: StashValue (Maybe x)
63+-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
35−-- options = StashValue
64+-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
36−-- ([],Nothing) :|
65+instance (Eq x, BuildFrom x) => BuildFrom [x] where
37−-- (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict
66+ extras stash =
38−-- )
67+ nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash
39−-- _
68+ where
40−-- -- instance (BuildFrom a) => BuildFrom [a] -- where
69+ -- powerset creates way too much stuff. something better here eventually.
41−-- --breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
70+ notpowerset xs = []:xs:map pure xs
71+
72+
73+instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where
74+ extras stash = fmap (Compound . to) <$> gExtras stash
75+
76+deriving via (Atom Int) instance BuildFrom Int
77+
78+deriving via (Atom Char) instance BuildFrom Char
79+
80+class GBuildFrom (f :: k -> Type) where
81+ gExtras :: Stash -> [([Provenance], f a)]
82+
83+instance GBuildFrom b => GBuildFrom (M1 D a b) where
84+ gExtras = fmap (fmap M1) . gExtras
85+
86+-- not recursion safe!
87+instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
88+ gExtras stash =
89+ (fmap L1 <$> gExtras stash)
90+ <> (fmap R1 <$> gExtras stash)
91+
92+instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
93+ gExtras stash = [(pa <> pb, a' :*: b') | (pa, a') <- gExtras stash, (pb, b') <- gExtras stash]
94+
95+instance GBuildFrom b => GBuildFrom (M1 C a b) where
96+ gExtras = fmap (fmap M1) . gExtras
97+
98+instance GBuildFrom b => GBuildFrom (M1 S a b) where
99+ gExtras = fmap (fmap M1) . gExtras
100+
101+instance BuildFrom a => GBuildFrom (K1 i a) where
102+ gExtras = fmap (fmap K1) . buildFrom'
103+
104+instance GBuildFrom U1 where
105+ gExtras _ = [([], U1)]
106+
107+deriving via (Atom NoContent) instance BuildFrom NoContent
src/Roboservant/Types/Config.hsnew file+29
@@ -0,0 +1,29 @@
1+module Roboservant.Types.Config where
2+
3+import Data.Dynamic
4+
5+data Config
6+ = Config
7+ { seed :: [(Dynamic, Int)],
8+ maxRuntime :: Double, -- seconds to test for
9+ maxReps :: Integer,
10+ rngSeed :: Int,
11+ coverageThreshold :: Double,
12+ logInfo :: String -> IO (),
13+ healthCheck :: IO ()
14+ }
15+
16+defaultConfig :: Config
17+defaultConfig =
18+ Config
19+ { seed = [],
20+ maxRuntime = 0.5,
21+ maxReps = 1000,
22+ rngSeed = 0,
23+ coverageThreshold = 0,
24+ logInfo = const (pure ()),
25+ healthCheck = pure ()
26+ }
27+
28+noisyConfig :: Config
29+noisyConfig = defaultConfig {logInfo = print}
src/Roboservant/Types/FlattenServer.hsdeleted−45
@@ -1,45 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE TypeOperators #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−module Roboservant.Types.FlattenServer where
11−
12−import Servant
13−
14−
15−data Bundled endpoints where
16− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
17− NoEndpoints :: Bundled '[]
18−
19−class FlattenServer api where
20− flattenServer :: Server api -> Bundled (Endpoints api)
21−
22−instance
23− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
24− Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
25− FlattenServer api
26− ) =>
27− FlattenServer (endpoint :<|> api)
28− where
29− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
30−
31−instance
32− ( HasServer (x :> api) '[],
33− Endpoints (x :> api) ~ '[x :> api]
34− ) =>
35− FlattenServer (x :> api)
36− where
37− flattenServer server = server `AnEndpoint` NoEndpoints
38−
39−instance
40− ( HasServer (Verb method statusCode contentTypes responseType) '[],
41− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
42− ) =>
43− FlattenServer (Verb method statusCode contentTypes responseType)
44− where
45− flattenServer server = server `AnEndpoint` NoEndpoints
src/Roboservant/Types/Internal.hs+30−13
@@ -1,36 +1,53 @@
1{-# LANGUAGE DeriveFunctor #-}
1{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3
5
4module Roboservant.Types.Internal where
6module Roboservant.Types.Internal where
5
7
6−import Data.List.NonEmpty (NonEmpty(..))
7−import qualified Data.Map.Strict as Map
8import qualified Data.Dependent.Map as DM
8import qualified Data.Dependent.Map as DM
9import Data.Dependent.Map (DMap)
9import Data.Dependent.Map (DMap)
10−import qualified Type.Reflection as R
11import Data.Dependent.Sum
10import Data.Dependent.Sum
11+import Data.Dynamic (Dynamic, toDyn)
12+import Data.Hashable (Hashable, hash)
12−import Data.IntSet(IntSet)
13+import Data.IntSet (IntSet)
14+import Data.List.NonEmpty (NonEmpty (..))
15+import qualified Data.Map.Strict as Map
16+import Data.Typeable (Typeable)
17+import GHC.Generics (Generic)
18+import qualified Type.Reflection as R
13
19
14data Provenance
20data Provenance
15 = Provenance R.SomeTypeRep Int
21 = Provenance R.SomeTypeRep Int
16− deriving (Show,Eq)
22+ deriving (Show, Eq, Generic)
23+
24+instance Hashable Provenance
17
25
26+data StashValue a
27+ = StashValue
18−data StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a)
28+ { getStashValue :: NonEmpty ([Provenance], a),
19− , stashHash :: IntSet
29+ stashHash :: IntSet
20− }
30+ }
21 deriving (Functor, Show)
31 deriving (Functor, Show)
22
32
23-- wrap in newtype to give a custom Show instance, since the normal
33-- wrap in newtype to give a custom Show instance, since the normal
24-- instance for DMap is not happy since StashValue needs Show a to show
34-- instance for DMap is not happy since StashValue needs Show a to show
25−newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
35+newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}
26 deriving (Semigroup, Monoid)
36 deriving (Semigroup, Monoid)
27
37
28instance Show Stash where
38instance Show Stash where
29− showsPrec i (Stash x) = showsPrec i $
39+ showsPrec i (Stash x) =
40+ showsPrec i
30− Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
41+ $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))
42+ $ DM.toList x
31
43
32-- | Can't be built up from parts, can't be broken down further.
44-- | Can't be built up from parts, can't be broken down further.
33−newtype Atom x = Atom { unAtom :: x }
45+newtype Atom x = Atom {unAtom :: x}
46+ deriving newtype (Hashable, Typeable,Eq)
34
47
35-- | can be broken down and built up from generic pieces
48-- | can be broken down and built up from generic pieces
36−newtype Compound x = Compound { unCompound :: x }
49+newtype Compound x = Compound {unCompound :: x}
50+ deriving newtype (Hashable, Typeable, Eq)
51+
52+hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)
53+hashedDyn a = (toDyn a, hash a)
src/Roboservant/Types/Orphans.hsnew file+7
@@ -0,0 +1,7 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module Roboservant.Types.Orphans where
3+
4+import Servant
5+import Data.Hashable
6+
7+instance Hashable NoContent
src/Roboservant/Types/ReifiedApi.hs+71−58
@@ -1,3 +1,7 @@
1+-- | Description: ways to build a reified api from a servant description.
2+--
3+-- arguably this could be more general and be abstracted away from even relying on servant
4+-- but that's future work.
1
5
2{-# LANGUAGE AllowAmbiguousTypes #-}
6{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
7{-# LANGUAGE DataKinds #-}
@@ -8,39 +12,31 @@
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
12{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE PolyKinds #-}
14{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE TupleSections #-}
15{-# LANGUAGE TypeApplications #-}
16{-# LANGUAGE TypeApplications #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE UndecidableInstances #-}
19−
20+{-# LANGUAGE CPP #-}
20module Roboservant.Types.ReifiedApi where
21module Roboservant.Types.ReifiedApi where
21
22
22−
23−import Control.Monad.Except (runExceptT)
24−import Data.Bifunctor
25−-- import Data.Dependent.Sum
26import Data.Dynamic (Dynamic)
23import Data.Dynamic (Dynamic)
27−import Data.Kind
24+import Control.Exception(Exception)
28import Data.List.NonEmpty (NonEmpty)
25import Data.List.NonEmpty (NonEmpty)
29import Data.Typeable (Typeable)
26import Data.Typeable (Typeable)
30import GHC.Generics ((:*:)(..))
27import GHC.Generics ((:*:)(..))
31−import GHC.TypeLits (Symbol)
32import Roboservant.Types.Internal
28import Roboservant.Types.Internal
33import Roboservant.Types.Breakdown
29import Roboservant.Types.Breakdown
34import Roboservant.Types.BuildFrom
30import Roboservant.Types.BuildFrom
35−import Roboservant.Types.FlattenServer
31+import Data.Kind(Type)
36import Servant
32import Servant
37import Servant.API.Modifiers(FoldRequired,FoldLenient)
33import Servant.API.Modifiers(FoldRequired,FoldLenient)
34+import GHC.TypeLits (Symbol)
38import qualified Data.Text as T
35import qualified Data.Text as T
39import qualified Data.Vinyl as V
36import qualified Data.Vinyl as V
40import qualified Data.Vinyl.Curry as V
37import qualified Data.Vinyl.Curry as V
41import qualified Type.Reflection as R
38import qualified Type.Reflection as R
42
39
43−
44newtype ApiOffset = ApiOffset Int
40newtype ApiOffset = ApiOffset Int
45 deriving (Eq, Show, Ord)
41 deriving (Eq, Show, Ord)
46 deriving newtype (Enum, Num)
42 deriving newtype (Enum, Num)
@@ -53,60 +49,32 @@ newtype Argument a = Argument
53
49
54data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
50data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
55 { reArguments :: V.Rec (TypedF Argument) as
51 { reArguments :: V.Rec (TypedF Argument) as
56− , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int))))
52+ , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
57 }
53 }
58
54
59−type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
55+instance Show ReifiedEndpoint where
60−
56+ show _ = "lol"
61−tagType :: Typeable a => f a -> TypedF f a
62−tagType = (R.typeRep :*:)
63−
64−class ToReifiedApi (endpoints :: [*]) where
65− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
66
57
67−class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint
68− , V.RecordToList (EndpointArgs endpoint)
58+class ( V.RecordToList (EndpointArgs endpoint)
69 , V.RMap (EndpointArgs endpoint)
59 , V.RMap (EndpointArgs endpoint)
70− ) => ToReifiedEndpoint (endpoint :: *) where
60+ ) => ToReifiedEndpoint (endpoint :: Type) where
71 type EndpointArgs endpoint :: [Type]
61 type EndpointArgs endpoint :: [Type]
72 type EndpointRes endpoint :: Type
62 type EndpointRes endpoint :: Type
73
63
74 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
64 reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
75
65
76−instance ToReifiedApi '[] where
77− toReifiedApi NoEndpoints _ = []
78
66
79−instance
67+tagType :: Typeable a => f a -> TypedF f a
80− ( Typeable (EndpointRes endpoint)
68+tagType = (R.typeRep :*:)
81− , NormalizeFunction (ServerT endpoint Handler)
69+
82− , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty (Dynamic,Int))))
70+data InteractionError = InteractionError
83− , ToReifiedEndpoint endpoint
71+ { errorMessage :: T.Text
84− , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)
72+ , fatalError :: Bool
85− ) =>
86− ToReifiedApi (endpoint : endpoints)
87− where
88− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
89− (0, ReifiedEndpoint
90− { reArguments = reifiedEndpointArguments @endpoint
91− , reEndpointFunc = normalize endpoint
92− }
73+ }
93− )
74+ deriving Show
94− : (map . first) (+1)
75+instance Exception InteractionError
95− (toReifiedApi endpoints (Proxy @endpoints))
76+
96−
77+
97−class NormalizeFunction m where
98− type Normal m
99− normalize :: m -> Normal m
100−
101−instance NormalizeFunction x => NormalizeFunction (r -> x) where
102− type Normal (r -> x) = r -> Normal x
103− normalize = fmap normalize
104−
105−instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
106− type Normal (Handler x) = IO (Either ServerError (NonEmpty (Dynamic,Int)))
107− normalize handler = (runExceptT . runHandler') handler >>= \case
108− Left serverError -> pure (Left serverError)
109− Right x -> pure $ Right $ breakdown x
110
78
111instance
79instance
112 (Typeable responseType, Breakdown responseType) =>
80 (Typeable responseType, Breakdown responseType) =>
@@ -116,6 +84,12 @@ instance
116 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
84 type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
117 reifiedEndpointArguments = V.RNil
85 reifiedEndpointArguments = V.RNil
118
86
87+instance ToReifiedEndpoint (NoContentVerb method)
88+ where
89+ type EndpointArgs (NoContentVerb method) = '[]
90+ type EndpointRes (NoContentVerb method) = NoContent
91+ reifiedEndpointArguments = V.RNil
92+
119instance
93instance
120 (ToReifiedEndpoint endpoint) =>
94 (ToReifiedEndpoint endpoint) =>
121 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
95 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
@@ -124,6 +98,16 @@ instance
124 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
98 type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
125 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
99 reifiedEndpointArguments = reifiedEndpointArguments @endpoint
126
100
101+instance
102+ (ToReifiedEndpoint endpoint) =>
103+ ToReifiedEndpoint (RemoteHost :> endpoint)
104+ where
105+ type EndpointArgs (RemoteHost :> endpoint) = EndpointArgs endpoint
106+ type EndpointRes (RemoteHost :> endpoint) = EndpointRes endpoint
107+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
108+
109+
110+
127instance
111instance
128 (ToReifiedEndpoint endpoint) =>
112 (ToReifiedEndpoint endpoint) =>
129 ToReifiedEndpoint (Description s :> endpoint)
113 ToReifiedEndpoint (Description s :> endpoint)
@@ -167,6 +151,23 @@ instance
167 V.:& reifiedEndpointArguments @endpoint
151 V.:& reifiedEndpointArguments @endpoint
168
152
169
153
154+instance
155+ ( BuildFrom paramType
156+ , ToReifiedEndpoint endpoint
157+ , Show paramType
158+ , Eq paramType
159+ ) =>
160+ ToReifiedEndpoint (QueryParams name paramType :> endpoint)
161+ where
162+ type EndpointArgs (QueryParams name paramType :> endpoint) = [paramType] ': EndpointArgs endpoint
163+ type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint
164+ reifiedEndpointArguments =
165+ tagType (Argument (buildFrom @[paramType]))
166+ V.:& reifiedEndpointArguments @endpoint
167+
168+
169+
170+
170instance
171instance
171 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
172 ( BuildFrom (IfRequiredLenient T.Text mods headerType)
172 , ToReifiedEndpoint endpoint
173 , ToReifiedEndpoint endpoint
@@ -179,8 +180,7 @@ instance
179 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
180 tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
180 V.:& reifiedEndpointArguments @endpoint
181 V.:& reifiedEndpointArguments @endpoint
181
182
182−
183+#if MIN_VERSION_servant(0,17,0)
183−-- this isn't happy in 0.16.2
184instance
184instance
185 ( BuildFrom (IfLenient String mods captureType)
185 ( BuildFrom (IfLenient String mods captureType)
186 , ToReifiedEndpoint endpoint) =>
186 , ToReifiedEndpoint endpoint) =>
@@ -191,6 +191,19 @@ instance
191 reifiedEndpointArguments =
191 reifiedEndpointArguments =
192 tagType (Argument (buildFrom @(IfLenient String mods captureType)))
192 tagType (Argument (buildFrom @(IfLenient String mods captureType)))
193 V.:& reifiedEndpointArguments @endpoint
193 V.:& reifiedEndpointArguments @endpoint
194+#else
195+instance
196+ ( BuildFrom captureType
197+ , ToReifiedEndpoint endpoint) =>
198+ ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
199+ where
200+ type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint
201+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
202+ reifiedEndpointArguments =
203+ tagType (Argument (buildFrom @(captureType)))
204+ V.:& reifiedEndpointArguments @endpoint
205+
206+#endif
194
207
195instance
208instance
196 ( BuildFrom (IfLenient String mods requestType)
209 ( BuildFrom (IfLenient String mods requestType)
src/Roboservant/Types/ReifiedApi/Server.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE PolyKinds #-}
9+
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeApplications #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+{-# LANGUAGE CPP #-}
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE FlexibleInstances #-}
18+{-# LANGUAGE MultiParamTypeClasses #-}
19+module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where
20+
21+import Servant
22+
23+import Control.Monad.Except (runExceptT)
24+import Data.Bifunctor
25+import Data.Dynamic (Dynamic)
26+import Data.List.NonEmpty (NonEmpty)
27+import Data.Typeable (Typeable)
28+import Roboservant.Types.Breakdown
29+import Roboservant.Types.ReifiedApi
30+
31+import qualified Data.Text as T
32+import qualified Data.Vinyl.Curry as V
33+import Data.Hashable(Hashable)
34+
35+type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]
36+
37+
38+class ToReifiedApi endpoints where
39+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
40+
41+instance ToReifiedApi '[] where
42+ toReifiedApi NoEndpoints _ = []
43+
44+instance
45+ ( NormalizeFunction (ServerT endpoint Handler)
46+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
47+ , ToReifiedEndpoint endpoint
48+ , ToReifiedApi endpoints
49+ ) =>
50+ ToReifiedApi (endpoint : endpoints)
51+ where
52+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
53+ (0, ReifiedEndpoint
54+ { reArguments = reifiedEndpointArguments @endpoint
55+ , reEndpointFunc = normalize endpoint
56+ }
57+ )
58+ : (map . first) (+1)
59+ (toReifiedApi endpoints (Proxy @endpoints))
60+
61+
62+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
63+ type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))
64+ normalize handler = (runExceptT . runHandler') handler >>= \case
65+ Left serverError -> pure (Left (renderServerError serverError))
66+ where
67+ -- | TODO improve this
68+ renderServerError :: ServerError -> InteractionError
69+ renderServerError s = InteractionError (T.pack $ show s) (errHTTPCode serverError == 500)
70+
71+ Right x -> pure $ Right $ breakdown x
72+
73+
74+-- case errHTTPCode serverError of
75+-- 500 -> throw serverError
76+-- _ ->
77+-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)
78+
79+
80+data Bundled endpoints where
81+ -- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
82+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
83+ NoEndpoints :: Bundled '[]
84+
85+class FlattenServer api where
86+ flattenServer :: Server api -> Bundled (Endpoints api)
87+
88+instance
89+ ( FlattenServer api,
90+ Endpoints endpoint ~ '[endpoint]
91+ ) =>
92+ FlattenServer (endpoint :<|> api)
93+ where
94+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
95+
96+instance
97+ (
98+ Endpoints api ~ '[api]
99+ ) =>
100+ FlattenServer (x :> api)
101+ where
102+ flattenServer server = server `AnEndpoint` NoEndpoints
103+
104+instance FlattenServer (Verb method statusCode contentTypes responseType)
105+ where
106+ flattenServer server = server `AnEndpoint` NoEndpoints
107+
108+class NormalizeFunction m where
109+ type Normal m
110+ normalize :: m -> Normal m
111+
112+instance NormalizeFunction x => NormalizeFunction (r -> x) where
113+ type Normal (r -> x) = r -> Normal x
114+ normalize = fmap normalize
stack.yaml+5−10
@@ -1,15 +1,10 @@
1−# nb: 16.8 doesn't work because the version of servant is too old to have FoldLenient', fixme.
2−resolver: lts-16.16
1+resolver: lts-20.4
3packages:
2packages:
4- .
3- .
5
4
6extra-deps:
5extra-deps:
6+# - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
7+# - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
7- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8−- vinyl-0.13.0
9+# - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
9−- dependent-sum-0.7.1.0
10+- some-1.0.3
10−- constraints-extras-0.3.0.2
11−- dependent-map-0.4.0.0
12−- servant-0.16.2
13−- servant-client-0.16.0.1
14−- servant-client-core-0.16
15−- servant-server-0.16.2
stack.yaml.lock+9−58
@@ -7,69 +7,20 @@ packages:
7- completed:
7- completed:
8 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
8 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
9 pantry-tree:
9 pantry-tree:
10− size: 325
11 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
10 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
11+ size: 325
12 original:
12 original:
13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
14- completed:
14- completed:
15− hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724
15+ hackage: some-1.0.3@sha256:938cec5fc0d3a08dde34cfc0acd5a0aa2e9fd489c9dbb64417f16588dfb47af0,2399
16− pantry-tree:
17− size: 1857
18− sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01
19− original:
20− hackage: vinyl-0.13.0
21−- completed:
22− hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
23− pantry-tree:
24− size: 290
25− sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50
26− original:
27− hackage: dependent-sum-0.7.1.0
28−- completed:
29− hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
30− pantry-tree:
31− size: 594
32− sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1
33− original:
34− hackage: constraints-extras-0.3.0.2
35−- completed:
36− hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
37− pantry-tree:
38− size: 551
39− sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5
40− original:
41− hackage: dependent-map-0.4.0.0
42−- completed:
43− hackage: servant-0.16.2@sha256:6c5d19d09a9dd2f2b2bf99193f944491f8374802678b79ec729e3f3ae51e216d,5867
44− pantry-tree:
45− size: 2604
46− sha256: bee4504840cf4836326e85f1cf02584bf898188b64d976dac6c6c6793d926794
47− original:
48− hackage: servant-0.16.2
49−- completed:
50− hackage: servant-client-0.16.0.1@sha256:f970ad4e927530b77f52b99a175c85cfdcd1ef988083d56a1f68c6a3dafe8d51,4376
51− pantry-tree:
52− size: 804
53− sha256: 3690a9c4dbdf8a502648c8c29029b1a0c78e53fd84db90ed388f7abbf5518c25
54− original:
55− hackage: servant-client-0.16.0.1
56−- completed:
57− hackage: servant-client-core-0.16@sha256:34e28b8d59b0b61fb3c97fb61043583538016898604a67bfa3bb35f02d8e4d9c,3545
58− pantry-tree:
59− size: 1365
60− sha256: d1a8c41b18e9648af8f1221c7747246ecde2a2ce2bae697c3c986f02a0caf857
61− original:
62− hackage: servant-client-core-0.16
63−- completed:
64− hackage: servant-server-0.16.2@sha256:f6b36df7c4f1688ff9d48d272e6cfc5f001b3221d2a732e73faf44e8b9e1ea04,5798
65 pantry-tree:
16 pantry-tree:
17+ sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8
66− size: 2517
18+ size: 709
67− sha256: 12330638c1b455050d19ad0797b35893efbb5cd233789581eae93cc8983a84c3
68 original:
19 original:
69− hackage: servant-server-0.16.2
20+ hackage: some-1.0.3
70snapshots:
21snapshots:
71- completed:
22- completed:
23+ sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94
72− size: 532380
24+ size: 648660
73− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml
25+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml
74− sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e
75− original: lts-16.16
26+ original: lts-20.4
test/Breakdown.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Breakdown where
9+
10+import Data.Aeson
11+import Data.Hashable
12+import Data.Typeable (Typeable)
13+import GHC.Generics (Generic)
14+import Servant
15+
16+data Foo = Foo Int String
17+ deriving (Generic, Eq, Show, Typeable)
18+
19+instance Hashable Foo
20+
21+instance ToJSON Foo
22+
23+instance FromJSON Foo
24+
25+data SomeSum = A Int | B String
26+ deriving (Generic, Eq, Show, Typeable)
27+
28+instance Hashable SomeSum
29+
30+instance ToJSON SomeSum
31+
32+instance FromJSON SomeSum
33+
34+type ProductApi =
35+ "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
36+ :<|> "getFoo" :> Get '[JSON] Foo
37+
38+eliminate :: Int -> Handler ()
39+eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
40+
41+productServer :: Server ProductApi
42+productServer = eliminate :<|> pure (Foo 12 "abc")
43+
44+type SumApi =
45+ "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
46+ :<|> "getFoo1" :> Get '[JSON] SomeSum
47+ :<|> "getFoo2" :> Get '[JSON] SomeSum
48+
49+sumServer :: Server SumApi
50+sumServer = eliminate :<|> pure (B "hi") :<|> pure (A 3)
test/Foo.hs+3−1
@@ -8,17 +8,19 @@
8module Foo where
8module Foo where
9
9
10import Data.Aeson
10import Data.Aeson
11+import Data.Hashable
11import Data.Typeable (Typeable)
12import Data.Typeable (Typeable)
12import GHC.Generics (Generic)
13import GHC.Generics (Generic)
13import Servant
14import Servant
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+
21instance ToJSON Foo
22instance ToJSON Foo
23+
22instance FromJSON Foo
24instance FromJSON Foo
23
25
24type Api =
26type Api =
test/Headers.hs+4−3
@@ -8,17 +8,19 @@
8module Headers where
8module Headers where
9
9
10import Data.Aeson
10import Data.Aeson
11+import Data.Hashable
11import Data.Typeable (Typeable)
12import Data.Typeable (Typeable)
12import GHC.Generics (Generic)
13import GHC.Generics (Generic)
13import Servant
14import Servant
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+
21instance ToJSON Foo
22instance ToJSON Foo
23+
22instance FromJSON Foo
24instance FromJSON Foo
23
25
24type Api =
26type Api =
@@ -33,8 +35,7 @@ combine :: Maybe Foo -> Maybe Foo -> Handler Foo
33combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
35combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
34combine (Just a) Nothing = pure a
36combine (Just a) Nothing = pure a
35combine Nothing (Just a) = pure a
37combine Nothing (Just a) = pure a
36−combine Nothing Nothing = pure (Foo 1)
38+combine Nothing Nothing = pure (Foo 1)
37−
38
39
39eliminate :: Foo -> Handler ()
40eliminate :: Foo -> Handler ()
40eliminate (Foo a)
41eliminate (Foo a)
test/Nested.hsnew file+23
@@ -0,0 +1,23 @@
1+{-# LANGUAGE DataKinds #-}
2+
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Nested where
9+
10+import Servant
11+import Servant.API.Flatten
12+
13+type Api =
14+ ( "one" :> Summary "foo" :> Post '[JSON] Int
15+ :<|> "two" :> Post '[JSON] Int
16+ )
17+ :<|> ( "three" :> Post '[JSON] Int
18+ )
19+
20+type FlatApi = Flat Api
21+
22+server :: Server FlatApi
23+server = pure 1 :<|> pure 2 :<|> pure 3
test/Post.hs+13−9
@@ -1,27 +1,31 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5−{-# LANGUAGE OverloadedStrings #-}
5+
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module Post where
8module Post where
9
9
10−import GHC.Generics (Generic)
11−import Servant
12import Data.Aeson
10import Data.Aeson
13import Data.Hashable
11import Data.Hashable
12+import GHC.Generics (Generic)
13+import Servant
14
14
15+type Api =
15−type Api = Get '[JSON] FooPost
16+ Get '[JSON] FooPost
16− :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
17+ :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
17
18
18data FooPost = FooPost
19data FooPost = FooPost
19− deriving (Eq,Show,Generic)
20+ deriving (Eq, Show, Generic)
20
21
21instance Hashable FooPost
22instance Hashable FooPost
23+
22instance ToJSON FooPost
24instance ToJSON FooPost
25+
23instance FromJSON FooPost
26instance FromJSON FooPost
24
27
25server :: Server Api
28server :: Server Api
29+server =
26−server = pure FooPost
30+ pure FooPost
27− :<|> const (pure ())
31+ :<|> const (pure ())
test/Product.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Product where
9+
10+import Data.Aeson
11+import Data.Hashable
12+import Data.Typeable (Typeable)
13+import GHC.Generics (Generic)
14+import Servant
15+
16+data Foo = Foo Int String
17+ deriving (Generic, Eq, Show, Typeable)
18+
19+instance Hashable Foo
20+
21+instance ToJSON Foo
22+
23+instance FromJSON Foo
24+
25+type Api = "item" :> ReqBody '[JSON] Foo :> Post '[JSON] ()
26+
27+eliminate :: Foo -> Handler ()
28+eliminate (Foo _a _b) = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
29+
30+server :: Server Api
31+server = eliminate
test/Put.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Put where
9+
10+import Data.Aeson
11+import Data.Hashable
12+import GHC.Generics (Generic)
13+import Servant
14+
15+type Api =
16+ Get '[JSON] Foo
17+ :<|> ReqBody '[JSON] Foo :> Put '[JSON] ()
18+ :<|> ReqBody '[JSON] Foo :> Put '[JSON] NoContent
19+
20+data Foo = Foo
21+ deriving (Eq, Show, Generic)
22+
23+instance Hashable Foo
24+
25+instance ToJSON Foo
26+
27+instance FromJSON Foo
28+
29+server :: Server Api
30+server =
31+ pure Foo
32+ :<|> const (pure ())
33+ :<|> const (pure NoContent)
test/QueryParams.hsnew file+15
@@ -0,0 +1,15 @@
1+{-# LANGUAGE DataKinds #-}
2+
3+{-# LANGUAGE DerivingStrategies #-}
4+
5+
6+{-# LANGUAGE TypeOperators #-}
7+
8+module QueryParams where
9+
10+import Servant
11+
12+type Api = QueryParams "ints" Int :> Get '[JSON] [Int]
13+
14+server :: Server Api
15+server = pure
test/Seeded.hs+9−5
@@ -8,22 +8,26 @@
8module Seeded where
8module Seeded where
9
9
10import Data.Aeson
10import Data.Aeson
11+import Data.Hashable
11import Data.Typeable (Typeable)
12import Data.Typeable (Typeable)
12import GHC.Generics (Generic)
13import GHC.Generics (Generic)
13import Servant
14import Servant
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+
21instance FromJSON Seed
22instance FromJSON Seed
23+
22instance Hashable Seed
24instance Hashable Seed
23
25
26+type Api =
24−type Api = Capture "seed" Seed :> Get '[JSON] ()
27+ Capture "seed" Seed :> Get '[JSON] ()
25− :<|> Get '[JSON] ()
28+ :<|> Get '[JSON] ()
26
29
27server :: Server Api
30server :: Server Api
31+server =
28−server = (\(Seed _) -> error "we blow up if we get here")
32+ (\(Seed _) -> error "we blow up if we get here")
29− :<|> pure ()
33+ :<|> pure ()
test/Spec.hs+127−101
@@ -1,144 +1,170 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE StandaloneDeriving #-}
3−{-# LANGUAGE StandaloneDeriving #-}
4−
5−{-# LANGUAGE DerivingVia #-}
6{-# LANGUAGE DerivingVia #-}
1{-# LANGUAGE DerivingVia #-}
7−
8−{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
10−{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE StandaloneDeriving #-}
5{-# LANGUAGE StandaloneDeriving #-}
12−
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE AllowAmbiguousTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE DataKinds #-}
13{-# OPTIONS_GHC -fno-warn-orphans #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-}
13+{-# LANGUAGE TypeFamilies #-}
14+
15+import qualified Breakdown
16+import Data.Dynamic (toDyn)
17+import Data.Hashable (Hashable (hash))
18+import Data.Maybe (isNothing)
19+import Data.Void (Void)
14import qualified Foo
20import qualified Foo
15−import qualified Seeded
16−import qualified Valid
17import qualified Headers
21import qualified Headers
22+import qualified Nested
18import qualified Post
23import qualified Post
19−import Test.Hspec.Core.Spec
24+import qualified Put
20−
25+import qualified Product
21−import Data.Dynamic(toDyn)
26+import qualified QueryParams
27+import qualified Roboservant as R
22−import qualified Roboservant as RS
28+import qualified Roboservant.Server as RS
29+import qualified Roboservant.Client as RC
30+import qualified Seeded
23import Test.Hspec
31import Test.Hspec
24−import Data.Void
32+import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
25−import Data.Maybe
33+import qualified Valid
26−import Data.Hashable
34+import Servant ( Server, Proxy(..), serve, Endpoints, HasServer )
35+
36+import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)
37+import Network.Wai(Application)
38+import qualified Network.Wai.Handler.Warp as Warp
39+import Network.HTTP.Client (newManager, defaultManagerSettings)
40+import Control.Monad((>=>))
27
41
28main :: IO ()
42main :: IO ()
29main = hspec spec
43main = hspec spec
30
44
31−noCheck :: IO ()
45+fuzzBoth
32−noCheck = pure ()
46+ :: forall a .
33−
47+ (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,
34−defaultConfig :: RS.Config
48+ HasClient ClientM a)
35−defaultConfig = RS.Config
49+ => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec
36− { RS.seed = []
50+fuzzBoth name server config condition = do
37− , RS.maxRuntime = 0.5
51+ it (name <> " via server") $
38− , RS.maxReps = 1000
52+ RS.fuzz @a server config >>= condition
39− , RS.rngSeed = 0
53+
40− , RS.coverageThreshold = 0
54+ around (withServer (serve (Proxy :: Proxy a) server)) $
41− }
55+ it (name <> " via client") $ \(clientEnv::ClientEnv) -> do
56+ RC.fuzz @a clientEnv config >>= condition
57+
58+withServer :: Application -> ActionWith ClientEnv -> IO ()
59+withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action)
60+ where genClientEnv port = do
61+ baseUrl <- parseBaseUrl "http://localhost"
62+ manager <- newManager defaultManagerSettings
63+ pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })
42
64
43spec :: Spec
65spec :: Spec
44spec = do
66spec = do
45 describe "Basic usage" $ do
67 describe "Basic usage" $ do
46 describe "noError" $ do
68 describe "noError" $ do
47− it "finds no error in a valid app" $ do
48− RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
49− >>= (`shouldSatisfy` isNothing)
69+ fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)
50− 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)
51− RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck
52− >>= (`shouldSatisfy` isNothing)
53−
54− it "does fail coverage check" $ do
55− r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
71+ fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}
72+ (\r ->
56− fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
73+ fmap (R.failureReason . R.rsException) r
57− (\case
74+ `shouldSatisfy` ( \case
58− Just (RS.InsufficientCoverage _) -> True
75+ Just (R.InsufficientCoverage _) -> True
59− _ -> False)
76+ _ -> False
60−
77+ ))
61− describe "posted body" $ do
78+ describe "posted body" $
62− it "passes a coverage check using a posted body" $ do
63− RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
79+ fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}
64− >>= (`shouldSatisfy` isNothing)
80+ (`shouldSatisfy` isNothing)
65
81
66− describe "seeded" $ do
67− shouldFail $
68− it "finds an error using information passed in" $
69− let res = Seeded.Seed 1 in
70− RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [(toDyn res,hash res) ] }) noCheck
71− >>= (`shouldSatisfy` isNothing)
72− describe "Foo" $ do
73− it "finds an error in a basic app" $
74− RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
75− >>= (`shouldSatisfy` isJust)
76
82
77− -- describe "headers" $ do
83+ describe "PUTted body" $
78− -- it "should find a failure that's dependent on using header info" $ do
84+ fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}
79− -- RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
80− -- >>= (`shouldSatisfy` isJust)
85+ (`shouldSatisfy` isNothing)
81
86
82− -- describe "can build from pieces" $ do
83− -- it "should find a failure that requires some assembly" $ do
84− -- RS.fuzz @RS.BuildFrom.Api RS.BuildFrom.server defaultConfig noCheck
85− -- >>= (`shouldSatisfy` isJust)
86
87
88+ describe "seeded" $ do
89+ let res = Seeded.Seed 1
90+ shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server
91+ (R.defaultConfig {R.seed = [(toDyn res, hash res)]})
92+ (`shouldSatisfy` isNothing)
87
93
94+ describe "Foo" $
95+ fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)
88
96
89− -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
97+ describe "QueryParams" $
90− -- -- -- could: it's mostly here to show how to test for concurrency problems.
98+ fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }
91− -- describe "concurrency bugs" $ do
99+ (`shouldSatisfy` isNothing)
92− -- before UnsafeIO.makeServer $ do
93− -- describe "sequential checking" $ do
94− -- it "safe use" $ \unsafeServer -> do
95− -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []
96
100
97− -- modifyMaxSuccess (const 10000) $
101+ describe "BuildFrom" $ do
98− -- shouldFail $
102+ describe "headers (and sum types)" $
103+ fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig
104+ (`shouldSatisfy` serverFailure)
99− -- describe "concurrent" $ do
105+ describe "product types" $
100− -- it "concurrent, dangerous use" $ \unsafeServer -> do
106+ fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server
101− -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
107+ R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}
108+ (`shouldSatisfy` serverFailure)
109+ describe "Breakdown" $ do
110+ fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig
111+ (`shouldSatisfy` serverFailure)
112+ fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig
113+ (`shouldSatisfy` serverFailure)
114+ describe "flattening" $
115+ fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}
116+ (`shouldSatisfy` isNothing)
102
117
118+serverFailure :: Maybe R.Report -> Bool
119+serverFailure = \case
120+ Just R.Report {..} ->
121+ let R.RoboservantException {..} = rsException
122+ in failureReason /= R.NoPossibleMoves
123+ _ -> False
103
124
104−deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
125+deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo
105−deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
106
126
107−deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
108−deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
127+deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo
109
128
110−deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
129+deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo
111−deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
112
130
131+deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo
113
132
114−-- instance RS.BuildFrom Seeded.Seed
133+deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed
115
134
116−deriving via (RS.Atom Void) instance RS.BuildFrom Void
135+deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed
117
136
118−deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
137+deriving via (R.Atom Void) instance R.BuildFrom Void
119−deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
120
138
139+deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost
140+deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost
121
141
122−--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped
142+deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo
123−--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.Breakdown RS.BuildFrom.Wrapped
143+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo
124
144
125
145
126
146
127−-- deriving via (RS.Atom Void) instance RS.BuildFrom Void
147+deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo
128
148
129−-- instance RS.Breakdown Post.FooPost
149+deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo
130−-- instance RS.BuildFrom Post.FooPost
131
150
151+deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum
132
152
133-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
153-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
134-- this is often useful when testing tests.
154-- this is often useful when testing tests.
135shouldFail :: SpecWith a -> SpecWith a
155shouldFail :: SpecWith a -> SpecWith a
156+shouldFail =
136−shouldFail = mapSpecItem_ (\i -> i {
157+ mapSpecItem_
158+ ( \i ->
159+ i
137− itemExample = \p a cb -> do
160+ { itemExample = \p a cb -> do
138− r <- (itemExample i) p a cb
161+ r <- itemExample i p a cb
162+ pure
163+ r
139− pure r {resultStatus = case resultStatus r of
164+ { resultStatus = case resultStatus r of
140− Success -> Failure Nothing (Reason "Unexpected success")
165+ Success -> Failure Nothing (Reason "Unexpected success")
141− Failure _ _ -> Success
166+ Failure _ _ -> Success
142− x -> x
167+ x -> x
143− }
168+ }
144− })
169+ }
170+ )
test/UnsafeIO.hs+13−15
@@ -1,41 +1,39 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
2+
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module UnsafeIO where
8module UnsafeIO where
9
9
10−import Data.Aeson()
11−import Servant
12−import Data.IORef (writeIORef, IORef, readIORef, newIORef)
13−import Control.Monad.Trans (MonadIO(liftIO))
10+import Control.Monad.Trans (MonadIO (liftIO))
11+import Data.Aeson ()
14import qualified Data.ByteString.Lazy.Char8 as BL8
12import qualified Data.ByteString.Lazy.Char8 as BL8
15−
13+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
14+import Servant
16
15
17type UnsafeApi =
16type UnsafeApi =
18 "add" :> Get '[JSON] ()
17 "add" :> Get '[JSON] ()
19− :<|> "healthcheck" :> Get '[JSON] ()
18+ :<|> "healthcheck" :> Get '[JSON] ()
20
19
21healthcheck :: IORef Int -> Handler ()
20healthcheck :: IORef Int -> Handler ()
22healthcheck ref = do
21healthcheck ref = do
23 t <- liftIO $ readIORef ref
22 t <- liftIO $ readIORef ref
24 case t of
23 case t of
25 0 -> pure ()
24 0 -> pure ()
26− n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}
25+ n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)}
27−
28−
29
26
30makeServer :: IO (Server UnsafeApi)
27makeServer :: IO (Server UnsafeApi)
31makeServer = do
28makeServer = do
32 ref <- newIORef 0
29 ref <- newIORef 0
30+ pure $
33− pure $ unsafeMunge ref
31+ unsafeMunge ref
34− :<|> healthcheck ref
32+ :<|> healthcheck ref
35
33
36unsafeMunge :: IORef Int -> Handler ()
34unsafeMunge :: IORef Int -> Handler ()
37unsafeMunge ref = liftIO $ do
35unsafeMunge ref = liftIO $ do
38 t <- readIORef ref
36 t <- readIORef ref
39− writeIORef ref (t+1)
37+ writeIORef ref (t + 1)
40 t2 <- readIORef ref
38 t2 <- readIORef ref
41− writeIORef ref (t2-1)
39+ writeIORef ref (t2 -1)
test/Valid.hs+18−14
@@ -1,28 +1,31 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8module Valid where
8module Valid where
9
9
10−import Servant
11import Data.Void
10import Data.Void
12import GHC.Generics
11import GHC.Generics
13−import Servant.API.Generic
12+import Servant
14import Servant.Server.Generic
13import Servant.Server.Generic
15
14
15+type Api =
16−type Api = Get '[JSON] Int
16+ 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 :: route :-
21+ { getInt ::
22+ route
22− Get '[JSON] Int
23+ :- Summary "i'm a summary!" :> Get '[JSON] Int,
23− , captureIt :: route :-
24+ captureIt ::
25+ route
24− Capture "void" Void :> Get '[JSON] ()
26+ :- Capture "void" Void :> Get '[JSON] ()
27+ }
25− } deriving Generic
28+ deriving (Generic)
26
29
27type RoutedApi = ToServantApi Routes
30type RoutedApi = ToServantApi Routes
28
31
@@ -31,10 +34,11 @@ routedServer :: Server RoutedApi
31routedServer = genericServer routes
34routedServer = genericServer routes
32
35
33routes :: Routes AsServer
36routes :: Routes AsServer
34−routes = Routes
37+routes =
38+ Routes
35− { getInt = pure 7
39+ { getInt = pure 7,
36− , captureIt = const (pure ())
40+ captureIt = const (pure ())
37− }
41+ }
38
42
39server :: Server Api
43server :: Server Api
40server = pure 7 :<|> const (pure ())
44server = pure 7 :<|> const (pure ())