├── .github └── workflows │ ├── cabal.yml │ └── ci.yml ├── .gitignore ├── ChangeLog.md ├── EXAMPLE.md ├── Example.lhs ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── TODO.md ├── app └── Main.hs ├── benchmarks ├── README.md ├── genFile.sh ├── prelude ├── runTiming.sh └── runTimingNoisy.sh ├── package.yaml ├── roboservant.cabal ├── scripts └── pre-commit.sh ├── src ├── Roboservant.hs └── Roboservant │ ├── Client.hs │ ├── Direct.hs │ ├── Server.hs │ ├── Types.hs │ └── Types │ ├── Breakdown.hs │ ├── BuildFrom.hs │ ├── Config.hs │ ├── Internal.hs │ ├── Orphans.hs │ ├── ReifiedApi.hs │ └── ReifiedApi │ └── Server.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Breakdown.hs ├── Foo.hs ├── Headers.hs ├── Nested.hs ├── Post.hs ├── Product.hs ├── Put.hs ├── QueryParams.hs ├── Seeded.hs ├── Spec.hs ├── UnsafeIO.hs └── Valid.hs /.github/workflows/cabal.yml: -------------------------------------------------------------------------------- 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 65 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Stack CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | 8 | jobs: 9 | stack: 10 | name: ${{ matrix.os }}-${{ matrix.ghc }}-stack 11 | runs-on: ${{ matrix.os }} 12 | strategy: 13 | matrix: 14 | stack: ["2.3.3"] 15 | ghc: ["8.10.4"] 16 | os: [ubuntu-latest] 17 | steps: 18 | - uses: actions/checkout@v2 19 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 20 | 21 | - uses: actions/setup-haskell@v1.1.4 22 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 23 | name: Setup Haskell Stack 24 | with: 25 | ghc-version: ${{ matrix.ghc }} 26 | stack-version: ${{ matrix.stack }} 27 | enable-stack: true 28 | 29 | - uses: actions/cache@v1 30 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 31 | name: Cache ~/.stack 32 | with: 33 | path: ~/.stack 34 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 35 | 36 | - name: Test 37 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 38 | run: | 39 | stack test 40 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | .stack-work/ 3 | *~ 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for roboservant 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /EXAMPLE.md: -------------------------------------------------------------------------------- 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 | ``` 144 | -------------------------------------------------------------------------------- /Example.lhs: -------------------------------------------------------------------------------- 1 | EXAMPLE.md -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | testwatch: 2 | ghcid -T main -c 'stack repl roboservant:lib roboservant:test:roboservant-test --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W 3 | pedanticwatch: 4 | ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # roboservant 2 | 3 | Automatically fuzz your servant apis in a contextually-aware way. 4 | 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) 7 | 8 | ## 9 | 10 | This is pretty much obsoleted by [schemathesis](https://schemathesis.readthedocs.io/en/stable/), at least once you 11 | have stateful testing going. 12 | 13 | ## example 14 | 15 | see full example [here](EXAMPLE.md) 16 | 17 | ## why? 18 | 19 | Servant gives us a lot of information about what a server can do. We 20 | use this information to generate arbitrarily long request/response 21 | sessions and verify properties that should hold over them. 22 | 23 | ## how? 24 | 25 | In essence, ```fuzz @Api yourServer config``` will make a bunch of 26 | calls to your API, and record the results in a type-indexed 27 | dictionary. This means that they are now available for the 28 | prerequisites of other calls, so as you proceed, more and more api 29 | calls become possible. 30 | 31 | We explicitly do not try to come up with plausible values that haven't 32 | somehow come back from the API. That's straying into QC/Hedgehog 33 | territory: if you want that, come up with the values on that side, and 34 | set them as seeds in the configuration. 35 | 36 | ### what does it mean to be "available"? 37 | 38 | In a simple API, you may make a call and get back a `Foo`, which will 39 | allow you to make another call that requires a `Foo`. In a more 40 | complicated app, it's likely that you'll send a request body that 41 | includes many subcomponents, and it's likely you'll get a response 42 | that needs to be broken down into pieces before it's useful. 43 | 44 | To cope with this, we have the typeclasses `BuildFrom` and 45 | `Breakdown`. You can write instances for them if you feel like it, and 46 | indeed it's currently required for recursive datatypes if you don't 47 | want the fuzzer to hang, but for the majority of your types it should 48 | be sufficient to derive them generically. (Sensible instances are 49 | provided for lists.) 50 | 51 | There are two basic strategies here. In some cases, you want to regard 52 | a type as indivisible: that's why we like newtypes, right? In this 53 | case, we can derive using the `Atom` strategy. 54 | 55 | ``` haskell 56 | deriving via (Atom NewtypedKey) instance Breakdown NewtypedKey 57 | deriving via (Atom NewtypedKey) instance BuildFrom NewtypedKey 58 | ``` 59 | 60 | This is saying "A can neither be built from components or broken down 61 | for spare parts. Hands off!". This is a good strategy for key types, 62 | for instance. 63 | 64 | If instead it's a big complicated thing with lots of juicy 65 | subcomponents, we want to rip it apart using Generics and feast on 66 | its succulent headmeats: 67 | 68 | ``` haskell 69 | deriving via (Compound Payload) instance Breakdown Payload 70 | deriving via (Compound Payload) instance BuildFrom Payload 71 | ``` 72 | 73 | ### priming the pump 74 | 75 | Sometimes there are values we'd like to smuggle into the API that are 76 | not derivable from within the API itself: sometimes this is a warning 77 | sign that your API is incomplete, but it can be quite reasonable to 78 | require identifying credentials within an API and not provide a way to 79 | get them. It might also be reasonable to have some sample values that 80 | the user is expected to come up with. 81 | 82 | For those cases, override the `seed` in the `Config` with a 83 | list of seed values, suitably hashed: 84 | 85 | ``` haskell 86 | defaultConfig { seed = [hashedDyn creds, hashedDyn userJwt]} 87 | ``` 88 | 89 | ## why not servant-quickcheck? 90 | 91 | [servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck) 92 | is a great package and I've learned a lot from it. Unfortunately, as mentioned previously, 93 | there's a lot of the state space you just can't explore without context: modern webapps are 94 | full of pointer-like structures, whether they're URLs or database 95 | keys/uuids, and servant-quickcheck requires that you be able to generate 96 | these without context via Arbitrary. 97 | 98 | ## limitations and future work 99 | 100 | Currently, the display of failing traces is pretty tragic, both in the 101 | formatting and in its non-minimality. This is pretty ticklish: 102 | arguably the right way to do this is to return a trace that we can 103 | also rerun, and let quickcheck or hedgehog a level up shrink it until 104 | it's satisfactorily short. In the interest of being useful earlier 105 | rather than later, I'm releasing v1.0 before I crack this particular 106 | nut. We do know which calls we made that led to the failing case, so 107 | we would want to show that distinction in a visible way: it's possible 108 | that other calls that don't have direct data dependencies were 109 | important, but we definitely know we need the direct data dependencies. 110 | 111 | The provenance stuff is a bit underbaked. It should at least pull a 112 | representation of the route chosen rather than just an integer index. 113 | 114 | It would also be nice to have a robust strategy for deriving recursive 115 | datatypes, or at least rejecting attempts to generate them that don't 116 | end in an infinite loop. 117 | 118 | Currently the `FlattenServer` instance for `:>` is quadratic. It would 119 | be nice to fix this but I lack the art. 120 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | ## extensions/todo 2 | 3 | - add some "starter" values to the store 4 | - there may be a JWT that's established outside the servant app, for instance. 5 | - `class Extras a where extras :: Gen [a]` 6 | - default implementation `pure []` 7 | - selectively allow some types to create values we haven't seen from the api. 8 | `newtype FirstName = FirstName Text`, say. 9 | - break down each response type into its components 10 | - if i have 11 | - `data Foo = FBar Bar | FBaz Baz` 12 | - an endpoint `foo` that returns a `Foo` 13 | - and an endpoint `bar` that takes a `Bar` 14 | - I should be able to call `foo` to get a `Foo`, and if it happens to be an `FBar Bar`, I 15 | should be able to use that `Bar` to call `bar`. 16 | - better handling of properties to be verified 17 | - some properties should always hold (no 500s): this already works. 18 | - to-do: there may be some other properties that hold contextually 19 | - healthcheck should be 200 20 | - test complex permissions/ownership/delegation logic - should never be able to 21 | get access to something you don't own or haven't been delegated access to. 22 | 23 | ## other possible applications 24 | 25 | - coverage 26 | - if you run the checker for a while and `hpc` suggests you still have bad coverage, 27 | your api is designed in a way that requires external manipulation and may be improvable. 28 | 29 | - benchmarking 30 | - we can generate "big-enough" call sequences, then save the database & a sample call for each 31 | endpoint that takes long enough to be a reasonable test. 32 | - from this we can generate tests that a given call on that setup never gets slower. 33 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | 5 | main :: IO () 6 | main = someFunc 7 | -------------------------------------------------------------------------------- /benchmarks/README.md: -------------------------------------------------------------------------------- 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. 31 | -------------------------------------------------------------------------------- /benchmarks/genFile.sh: -------------------------------------------------------------------------------- 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 | 27 | -------------------------------------------------------------------------------- /benchmarks/prelude: -------------------------------------------------------------------------------- 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 | 62 | -------------------------------------------------------------------------------- /benchmarks/runTiming.sh: -------------------------------------------------------------------------------- 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: //' 11 | -------------------------------------------------------------------------------- /benchmarks/runTimingNoisy.sh: -------------------------------------------------------------------------------- 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 11 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | 2 | name: roboservant 3 | version: 0.1.0.3 4 | github: "mwotton/roboservant" 5 | license: BSD3 6 | copyright: "2020 Mark Wotton, Samuel Schlesinger" 7 | synopsis: Automatic session-aware servant testing 8 | category: Web 9 | description: Please see the README on GitHub at 10 | 11 | extra-source-files: 12 | - README.md 13 | - ChangeLog.md 14 | 15 | dependencies: 16 | - base >= 4.7 && < 5 17 | 18 | - bytestring 19 | - containers 20 | - random 21 | - hashable 22 | - http-types 23 | - lifted-base 24 | - monad-control 25 | - mtl 26 | - servant # >= 0.17 27 | - servant-client # >= 0.17 28 | - servant-flatten 29 | - servant-server # >= 0.17 30 | - string-conversions 31 | - vinyl 32 | - dependent-sum 33 | - dependent-map 34 | - unordered-containers 35 | - text 36 | - time 37 | 38 | ghc-options: 39 | - -Wall 40 | - -fwrite-ide-info 41 | - -hiedir=.hie 42 | library: 43 | source-dirs: src 44 | 45 | tests: 46 | roboservant-test: 47 | main: Spec.hs 48 | source-dirs: test 49 | ghc-options: 50 | - -threaded 51 | - -rtsopts 52 | - -with-rtsopts=-N 53 | dependencies: 54 | - roboservant 55 | - aeson 56 | - hspec 57 | - hspec-core 58 | - http-api-data 59 | - http-client 60 | - hspec-wai 61 | - wai 62 | - warp 63 | example: 64 | main: Example.lhs 65 | source-dirs: . 66 | 67 | dependencies: 68 | - roboservant 69 | - hspec 70 | - warp 71 | - http-client 72 | - aeson 73 | - hspec-core 74 | ghc-options: -pgmL markdown-unlit 75 | 76 | build-tools: markdown-unlit 77 | -------------------------------------------------------------------------------- /roboservant.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 0c0c35e1dca1d6c52e5bc61591cbd8c0da9d811b83341bbc676c5f8b93b0b20d 8 | 9 | name: roboservant 10 | version: 0.1.0.3 11 | synopsis: Automatic session-aware servant testing 12 | description: Please see the README on GitHub at 13 | category: Web 14 | homepage: https://github.com/mwotton/roboservant#readme 15 | bug-reports: https://github.com/mwotton/roboservant/issues 16 | copyright: 2020 Mark Wotton, Samuel Schlesinger 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/mwotton/roboservant 27 | 28 | library 29 | exposed-modules: 30 | Roboservant 31 | Roboservant.Client 32 | Roboservant.Direct 33 | Roboservant.Server 34 | Roboservant.Types 35 | Roboservant.Types.Breakdown 36 | Roboservant.Types.BuildFrom 37 | Roboservant.Types.Config 38 | Roboservant.Types.Internal 39 | Roboservant.Types.Orphans 40 | Roboservant.Types.ReifiedApi 41 | Roboservant.Types.ReifiedApi.Server 42 | other-modules: 43 | Paths_roboservant 44 | hs-source-dirs: 45 | src 46 | ghc-options: -Wall -fwrite-ide-info -hiedir=.hie 47 | build-depends: 48 | base >=4.7 && <5 49 | , bytestring 50 | , containers 51 | , dependent-map 52 | , dependent-sum 53 | , hashable 54 | , http-types 55 | , lifted-base 56 | , monad-control 57 | , mtl 58 | , random 59 | , servant 60 | , servant-client 61 | , servant-flatten 62 | , servant-server 63 | , string-conversions 64 | , text 65 | , time 66 | , unordered-containers 67 | , vinyl 68 | default-language: Haskell2010 69 | 70 | test-suite example 71 | type: exitcode-stdio-1.0 72 | main-is: Example.lhs 73 | other-modules: 74 | Paths_roboservant 75 | hs-source-dirs: 76 | ./ 77 | ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit 78 | build-tool-depends: 79 | markdown-unlit:markdown-unlit 80 | build-depends: 81 | aeson 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 | 109 | test-suite roboservant-test 110 | type: exitcode-stdio-1.0 111 | main-is: Spec.hs 112 | other-modules: 113 | Breakdown 114 | Foo 115 | Headers 116 | Nested 117 | Post 118 | Product 119 | Put 120 | QueryParams 121 | Seeded 122 | UnsafeIO 123 | Valid 124 | Paths_roboservant 125 | hs-source-dirs: 126 | test 127 | ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N 128 | build-depends: 129 | aeson 130 | , base >=4.7 && <5 131 | , bytestring 132 | , containers 133 | , dependent-map 134 | , dependent-sum 135 | , hashable 136 | , hspec 137 | , hspec-core 138 | , hspec-wai 139 | , http-api-data 140 | , http-client 141 | , http-types 142 | , lifted-base 143 | , monad-control 144 | , mtl 145 | , random 146 | , roboservant 147 | , servant 148 | , servant-client 149 | , servant-flatten 150 | , servant-server 151 | , string-conversions 152 | , text 153 | , time 154 | , unordered-containers 155 | , vinyl 156 | , wai 157 | , warp 158 | default-language: Haskell2010 159 | -------------------------------------------------------------------------------- /scripts/pre-commit.sh: -------------------------------------------------------------------------------- 1 | #!/bin/env bash 2 | # 3 | # Remember to link me to .git/hooks/pre-commit 4 | 5 | set -euo pipefail 6 | 7 | files=$((git diff --cached --name-only --diff-filter=ACMR | grep -Ei "\.hs$") || true) 8 | if [ ! -z "${files}" ]; then 9 | echo "$files" 10 | echo "$files" | xargs ormolu --mode inplace 11 | git add $(echo "$files" | paste -s -d " " -) 12 | fi 13 | -------------------------------------------------------------------------------- /src/Roboservant.hs: -------------------------------------------------------------------------------- 1 | module Roboservant 2 | ( module Roboservant.Direct, 3 | module Roboservant.Types, 4 | ) 5 | where 6 | 7 | import Roboservant.Direct 8 | import Roboservant.Types 9 | -------------------------------------------------------------------------------- /src/Roboservant/Client.hs: -------------------------------------------------------------------------------- 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 128 | -------------------------------------------------------------------------------- /src/Roboservant/Direct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module Roboservant.Direct 15 | ( fuzz', 16 | Config (..), 17 | -- TODO come up with something smarter than exporting all this, we should 18 | -- have some nice error-display functions 19 | RoboservantException (..), 20 | FuzzState (..), 21 | FuzzOp (..), 22 | FailureType (..), 23 | Report (..), 24 | ) 25 | where 26 | 27 | import Control.Exception.Lifted 28 | ( Exception, 29 | Handler (Handler), 30 | SomeAsyncException, 31 | SomeException, 32 | catch, 33 | catches, 34 | handle, 35 | throw, 36 | ) 37 | import Control.Monad.State.Strict 38 | ( MonadIO (..), 39 | MonadState (get), 40 | StateT (runStateT), 41 | modify', 42 | ) 43 | import Control.Monad.Trans.Control (MonadBaseControl) 44 | import qualified Data.Dependent.Map as DM 45 | import Data.Dynamic (Dynamic (..)) 46 | import qualified Data.IntSet as IntSet 47 | import Data.List.NonEmpty (NonEmpty (..)) 48 | import qualified Data.List.NonEmpty as NEL 49 | import Data.Maybe (mapMaybe) 50 | import qualified Data.Set as Set 51 | import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) 52 | import qualified Data.Vinyl as V 53 | import qualified Data.Vinyl.Curry as V 54 | import qualified Data.Vinyl.Functor as V 55 | import GHC.Generics ((:*:) (..)) 56 | import Roboservant.Types 57 | ( ApiOffset (..), 58 | Argument (..), 59 | InteractionError(..), 60 | Provenance (..), 61 | ReifiedApi, 62 | ReifiedEndpoint (..), 63 | Stash (..), 64 | StashValue (..), 65 | TypedF, 66 | ) 67 | import Roboservant.Types.Config 68 | 69 | import System.Random (Random (randomR), StdGen, mkStdGen) 70 | import qualified Type.Reflection as R 71 | 72 | data RoboservantException 73 | = RoboservantException 74 | { failureReason :: FailureType, 75 | serverException :: Maybe SomeException, 76 | fuzzState :: FuzzState 77 | } 78 | deriving (Show) 79 | 80 | instance Exception RoboservantException 81 | 82 | data FailureType 83 | = ServerCrashed 84 | | CheckerFailed 85 | | NoPossibleMoves 86 | | InsufficientCoverage Double 87 | deriving (Show, Eq) 88 | 89 | data FuzzOp 90 | = FuzzOp 91 | { apiOffset :: ApiOffset, 92 | provenance :: [Provenance] 93 | } 94 | deriving (Show, Eq) 95 | 96 | data FuzzState 97 | = FuzzState 98 | { path :: [FuzzOp], 99 | stash :: Stash, 100 | currentRng :: StdGen 101 | } 102 | deriving (Show) 103 | 104 | data EndpointOption 105 | = forall as. 106 | (V.RecordToList as, V.RMap as) => 107 | EndpointOption 108 | { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))), 109 | eoArgs :: V.Rec (TypedF StashValue) as 110 | } 111 | 112 | data StopReason 113 | = TimedOut 114 | | HitMaxIterations 115 | deriving (Show, Eq) 116 | 117 | data Report 118 | = Report 119 | { textual :: String, 120 | rsException :: RoboservantException 121 | } 122 | deriving (Show) 123 | 124 | 125 | 126 | -- fuzzClient :: Client api -> Config -> IO (Maybe Report) 127 | -- fuzzClient = undefined 128 | 129 | 130 | 131 | fuzz' :: 132 | ReifiedApi -> 133 | Config -> 134 | IO (Maybe Report) 135 | fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do 136 | let path = [] 137 | stash = addToStash seed mempty 138 | currentRng = mkStdGen rngSeed 139 | deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime 140 | (stopreason, _fs) <- 141 | runStateT 142 | (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) 143 | FuzzState {..} 144 | logInfo $ show stopreason 145 | pure Nothing 146 | where 147 | -- something less terrible later 148 | formatException :: RoboservantException -> Report 149 | formatException r@(RoboservantException failureType exception _state) = 150 | Report 151 | (unlines [show failureType, show exception]) 152 | r 153 | displayDiagnostics FuzzState {..} = liftIO $ 154 | logInfo $ unlines $ 155 | ["api endpoints covered"] 156 | <> (map show . Set.toList . Set.fromList $ map apiOffset path) 157 | <> ["", "types in stash"] 158 | <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash) 159 | -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash)) 160 | -- $ \_k v -> 161 | -- (show . NEL.length $ getStashValue v)) 162 | 163 | evaluateCoverage f@FuzzState {..} 164 | | coverage > coverageThreshold = pure () 165 | | otherwise = do 166 | displayDiagnostics f 167 | throw $ RoboservantException (InsufficientCoverage coverage) Nothing f 168 | where 169 | hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path 170 | totalRoutes = fromIntegral routeCount 171 | coverage = hitRoutes / totalRoutes 172 | untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason 173 | untilDone (0, _) _ = pure HitMaxIterations 174 | untilDone (n, deadline) action = do 175 | now <- liftIO getCurrentTime 176 | if now > deadline 177 | then pure TimedOut 178 | else do 179 | _ <- action 180 | untilDone (n -1, deadline) action 181 | 182 | routeCount = length reifiedApi 183 | elementOrFail :: 184 | (MonadState FuzzState m, MonadIO m) => 185 | [a] -> 186 | m a 187 | elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get 188 | elementOrFail l = do 189 | st <- get 190 | let (index, newGen) = randomR (0, length l - 1) (currentRng st) 191 | modify' $ \st' -> st' {currentRng = newGen} 192 | pure (l !! index) 193 | withOp :: 194 | (MonadState FuzzState m, MonadIO m) => 195 | ( forall as. 196 | (V.RecordToList as, V.RMap as) => 197 | FuzzOp -> 198 | V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) -> 199 | V.Rec (TypedF V.Identity) as -> 200 | m r 201 | ) -> 202 | m r 203 | withOp callback = do 204 | -- choose a call to make, from the endpoints with fillable arguments. 205 | (offset, EndpointOption {..}) <- elementOrFail . options =<< get 206 | r <- 207 | V.rtraverse 208 | ( \(tr :*: StashValue svs _) -> 209 | elementOrFail $ 210 | zipWith 211 | (\i xy -> V.Const i :*: tr :*: xy) 212 | [0 ..] 213 | (NEL.toList svs) 214 | ) 215 | eoArgs 216 | let pathSegment = 217 | FuzzOp offset $ 218 | recordToList' 219 | (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index) 220 | r 221 | argValues = 222 | V.rmap 223 | (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x) 224 | r 225 | modify' (\f -> f {path = path f <> [pathSegment]}) 226 | callback pathSegment eoCall argValues 227 | where 228 | options :: FuzzState -> [(ApiOffset, EndpointOption)] 229 | options FuzzState {..} = 230 | mapMaybe 231 | ( \(offset, ReifiedEndpoint {..}) -> do 232 | args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments 233 | pure (offset, EndpointOption reEndpointFunc args) 234 | ) 235 | reifiedApi 236 | execute :: 237 | (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) => 238 | FuzzOp -> 239 | V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) -> 240 | V.Rec (TypedF V.Identity) as -> 241 | m () 242 | execute fuzzop func args = do 243 | (liftIO . logInfo . show . (fuzzop,) . stash) =<< get 244 | liftIO (V.runcurry' func argVals) >>= \case 245 | Left (e::InteractionError) -> 246 | if fatalError e 247 | then throw e 248 | else pure () 249 | Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> 250 | modify' 251 | ( \fs@FuzzState {..} -> 252 | fs {stash = addToStash (NEL.toList dyn) stash} 253 | ) 254 | where 255 | argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args 256 | -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args 257 | go :: 258 | (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) => 259 | m () 260 | go = withOp $ \op func args -> do 261 | catches 262 | (execute op func args) 263 | [ Handler (\(e :: SomeAsyncException) -> throw e), 264 | Handler 265 | ( \(e :: SomeException) -> 266 | throw . RoboservantException ServerCrashed (Just e) =<< get 267 | ) 268 | ] 269 | catch 270 | (liftIO healthCheck) 271 | (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get) 272 | 273 | addToStash :: 274 | [(Dynamic, Int)] -> 275 | Stash -> 276 | Stash 277 | addToStash result stash = 278 | foldr 279 | ( \(Dynamic tr x, hashed) (Stash dict) -> 280 | Stash $ 281 | DM.insertWith 282 | renumber 283 | tr 284 | (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed)) 285 | dict 286 | ) 287 | stash 288 | result 289 | where 290 | renumber :: 291 | StashValue a -> 292 | StashValue a -> 293 | StashValue a 294 | renumber (StashValue singleDyn singleHash) orig@(StashValue l intSet) 295 | | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig 296 | | otherwise = 297 | StashValue 298 | ( case NEL.toList singleDyn of 299 | [([Provenance tr _], dyn)] -> 300 | l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn) 301 | _ -> error "should be impossible" 302 | ) 303 | (IntSet.union singleHash intSet) 304 | 305 | -- why isn't this in vinyl? 306 | recordToList' :: 307 | (V.RecordToList as, V.RMap as) => 308 | (forall x. f x -> a) -> 309 | V.Rec f as -> 310 | [a] 311 | recordToList' f = V.recordToList . V.rmap (V.Const . f) 312 | -------------------------------------------------------------------------------- /src/Roboservant/Server.hs: -------------------------------------------------------------------------------- 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 | 37 | -------------------------------------------------------------------------------- /src/Roboservant/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Roboservant.Types 11 | ( module Roboservant.Types.Breakdown, 12 | module Roboservant.Types.BuildFrom, 13 | module Roboservant.Types.ReifiedApi, 14 | module Roboservant.Types.ReifiedApi.Server, 15 | module Roboservant.Types.Internal, 16 | module Roboservant.Types.Config, 17 | ) 18 | where 19 | 20 | import Roboservant.Types.Breakdown 21 | import Roboservant.Types.BuildFrom 22 | import Roboservant.Types.Config 23 | import Roboservant.Types.Internal 24 | import Roboservant.Types.ReifiedApi 25 | import Roboservant.Types.ReifiedApi.Server 26 | import Roboservant.Types.Orphans() 27 | -------------------------------------------------------------------------------- /src/Roboservant/Types/Breakdown.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | module Roboservant.Types.Breakdown where 17 | 18 | import Data.Dynamic (Dynamic) 19 | import Data.Hashable 20 | import Data.Kind 21 | import Data.List.NonEmpty (NonEmpty (..)) 22 | import qualified Data.List.NonEmpty as NEL 23 | import Data.Typeable (Typeable) 24 | import GHC.Generics 25 | import Roboservant.Types.Internal 26 | import Servant 27 | import Roboservant.Types.Orphans() 28 | 29 | breakdown :: 30 | (Hashable x, Typeable x, Breakdown x) => 31 | x -> 32 | NonEmpty (Dynamic, Int) 33 | breakdown x = hashedDyn x :| breakdownExtras x 34 | 35 | class Breakdown x where 36 | breakdownExtras :: x -> [(Dynamic, Int)] 37 | 38 | instance (Hashable x, Typeable x) => Breakdown (Atom x) where 39 | breakdownExtras _ = [] 40 | 41 | deriving via (Atom ()) instance Breakdown () 42 | 43 | deriving via (Atom Int) instance Breakdown Int 44 | deriving via (Atom Char) instance Breakdown Char 45 | 46 | deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x) 47 | 48 | instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where 49 | breakdownExtras stash = concatMap (NEL.toList . breakdown) stash 50 | 51 | 52 | class GBreakdown (f :: k -> Type) where 53 | gBreakdownExtras :: f a -> [(Dynamic, Int)] 54 | 55 | instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where 56 | breakdownExtras = gBreakdownExtras . from . unCompound 57 | 58 | instance GBreakdown f => GBreakdown (M1 S c f) where 59 | gBreakdownExtras (M1 f) = gBreakdownExtras f 60 | 61 | instance GBreakdown b => GBreakdown (M1 D a b) where 62 | gBreakdownExtras (M1 f) = gBreakdownExtras f 63 | 64 | instance GBreakdown b => GBreakdown (M1 C a b) where 65 | gBreakdownExtras (M1 f) = gBreakdownExtras f 66 | 67 | instance (GBreakdown a, GBreakdown b) => GBreakdown (a :*: b) where 68 | gBreakdownExtras (a :*: b) = gBreakdownExtras a <> gBreakdownExtras b 69 | 70 | instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where 71 | gBreakdownExtras = \case 72 | L1 a -> gBreakdownExtras a 73 | R1 a -> gBreakdownExtras a 74 | 75 | instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where 76 | gBreakdownExtras (K1 c) = NEL.toList $ breakdown c 77 | 78 | instance GBreakdown U1 where 79 | gBreakdownExtras U1 = [] 80 | 81 | deriving via (Atom NoContent) instance Breakdown NoContent 82 | -------------------------------------------------------------------------------- /src/Roboservant/Types/BuildFrom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module Roboservant.Types.BuildFrom where 14 | 15 | import Data.List(nub) 16 | import qualified Data.Dependent.Map as DM 17 | import Data.Hashable 18 | import qualified Data.IntSet as IntSet 19 | import Data.Kind 20 | import Data.List.NonEmpty (NonEmpty (..)) 21 | import qualified Data.List.NonEmpty as NEL 22 | import Data.Typeable (Typeable) 23 | import GHC.Generics 24 | import Roboservant.Types.Internal 25 | import qualified Type.Reflection as R 26 | import Servant(NoContent) 27 | import Roboservant.Types.Orphans() 28 | 29 | buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x) 30 | buildFrom = buildStash . buildFrom' 31 | where 32 | buildStash :: [([Provenance], x)] -> Maybe (StashValue x) 33 | buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty 34 | promoteToStash :: ([Provenance], x) -> StashValue x 35 | promoteToStash (p, x) = 36 | StashValue 37 | (pure (p, x)) 38 | (IntSet.singleton (hash x)) 39 | addStash :: StashValue x -> StashValue x -> StashValue x 40 | addStash old (StashValue newVal _) = 41 | let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal 42 | in StashValue 43 | (addListToNE (getStashValue old) insertableVals) 44 | (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old)) 45 | addListToNE :: NonEmpty a -> [a] -> NonEmpty a 46 | addListToNE ne l = NEL.fromList (NEL.toList ne <> l) 47 | 48 | buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)] 49 | buildFrom' stash = 50 | maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash)) 51 | <> extras stash 52 | 53 | class (Hashable x, Typeable x) => BuildFrom (x :: Type) where 54 | extras :: Stash -> [([Provenance], x)] 55 | 56 | instance (Hashable x, Typeable x) => BuildFrom (Atom x) where 57 | extras _ = [] 58 | 59 | deriving via (Atom Bool) instance BuildFrom Bool 60 | 61 | deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x) 62 | 63 | -- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now. 64 | -- with an arbitrary-ish interface, we could use a size parameter, rng access etc. 65 | instance (Eq x, BuildFrom x) => BuildFrom [x] where 66 | extras stash = 67 | nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash 68 | where 69 | -- powerset creates way too much stuff. something better here eventually. 70 | notpowerset xs = []:xs:map pure xs 71 | 72 | 73 | instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where 74 | extras stash = fmap (Compound . to) <$> gExtras stash 75 | 76 | deriving via (Atom Int) instance BuildFrom Int 77 | 78 | deriving via (Atom Char) instance BuildFrom Char 79 | 80 | class GBuildFrom (f :: k -> Type) where 81 | gExtras :: Stash -> [([Provenance], f a)] 82 | 83 | instance GBuildFrom b => GBuildFrom (M1 D a b) where 84 | gExtras = fmap (fmap M1) . gExtras 85 | 86 | -- not recursion safe! 87 | instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where 88 | gExtras stash = 89 | (fmap L1 <$> gExtras stash) 90 | <> (fmap R1 <$> gExtras stash) 91 | 92 | instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where 93 | gExtras stash = [(pa <> pb, a' :*: b') | (pa, a') <- gExtras stash, (pb, b') <- gExtras stash] 94 | 95 | instance GBuildFrom b => GBuildFrom (M1 C a b) where 96 | gExtras = fmap (fmap M1) . gExtras 97 | 98 | instance GBuildFrom b => GBuildFrom (M1 S a b) where 99 | gExtras = fmap (fmap M1) . gExtras 100 | 101 | instance BuildFrom a => GBuildFrom (K1 i a) where 102 | gExtras = fmap (fmap K1) . buildFrom' 103 | 104 | instance GBuildFrom U1 where 105 | gExtras _ = [([], U1)] 106 | 107 | deriving via (Atom NoContent) instance BuildFrom NoContent 108 | -------------------------------------------------------------------------------- /src/Roboservant/Types/Config.hs: -------------------------------------------------------------------------------- 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} 30 | -------------------------------------------------------------------------------- /src/Roboservant/Types/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | module Roboservant.Types.Internal where 7 | 8 | import qualified Data.Dependent.Map as DM 9 | import Data.Dependent.Map (DMap) 10 | import Data.Dependent.Sum 11 | import Data.Dynamic (Dynamic, toDyn) 12 | import Data.Hashable (Hashable, hash) 13 | import Data.IntSet (IntSet) 14 | import Data.List.NonEmpty (NonEmpty (..)) 15 | import qualified Data.Map.Strict as Map 16 | import Data.Typeable (Typeable) 17 | import GHC.Generics (Generic) 18 | import qualified Type.Reflection as R 19 | 20 | data Provenance 21 | = Provenance R.SomeTypeRep Int 22 | deriving (Show, Eq, Generic) 23 | 24 | instance Hashable Provenance 25 | 26 | data StashValue a 27 | = StashValue 28 | { getStashValue :: NonEmpty ([Provenance], a), 29 | stashHash :: IntSet 30 | } 31 | deriving (Functor, Show) 32 | 33 | -- wrap in newtype to give a custom Show instance, since the normal 34 | -- instance for DMap is not happy since StashValue needs Show a to show 35 | newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue} 36 | deriving (Semigroup, Monoid) 37 | 38 | instance Show Stash where 39 | showsPrec i (Stash x) = 40 | showsPrec i 41 | $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs)) 42 | $ DM.toList x 43 | 44 | -- | Can't be built up from parts, can't be broken down further. 45 | newtype Atom x = Atom {unAtom :: x} 46 | deriving newtype (Hashable, Typeable,Eq) 47 | 48 | -- | can be broken down and built up from generic pieces 49 | newtype Compound x = Compound {unCompound :: x} 50 | deriving newtype (Hashable, Typeable, Eq) 51 | 52 | hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int) 53 | hashedDyn a = (toDyn a, hash a) 54 | -------------------------------------------------------------------------------- /src/Roboservant/Types/Orphans.hs: -------------------------------------------------------------------------------- 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 8 | -------------------------------------------------------------------------------- /src/Roboservant/Types/ReifiedApi.hs: -------------------------------------------------------------------------------- 1 | -- | Description: ways to build a reified api from a servant description. 2 | -- 3 | -- arguably this could be more general and be abstracted away from even relying on servant 4 | -- but that's future work. 5 | 6 | {-# LANGUAGE AllowAmbiguousTypes #-} 7 | {-# LANGUAGE DataKinds #-} 8 | {-# LANGUAGE DerivingStrategies #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE TypeApplications #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | {-# LANGUAGE TypeOperators #-} 19 | {-# LANGUAGE UndecidableInstances #-} 20 | {-# LANGUAGE CPP #-} 21 | module Roboservant.Types.ReifiedApi where 22 | 23 | import Data.Dynamic (Dynamic) 24 | import Control.Exception(Exception) 25 | import Data.List.NonEmpty (NonEmpty) 26 | import Data.Typeable (Typeable) 27 | import GHC.Generics ((:*:)(..)) 28 | import Roboservant.Types.Internal 29 | import Roboservant.Types.Breakdown 30 | import Roboservant.Types.BuildFrom 31 | import Data.Kind(Type) 32 | import Servant 33 | import Servant.API.Modifiers(FoldRequired,FoldLenient) 34 | import GHC.TypeLits (Symbol) 35 | import qualified Data.Text as T 36 | import qualified Data.Vinyl as V 37 | import qualified Data.Vinyl.Curry as V 38 | import qualified Type.Reflection as R 39 | 40 | newtype ApiOffset = ApiOffset Int 41 | deriving (Eq, Show, Ord) 42 | deriving newtype (Enum, Num) 43 | 44 | type TypedF = (:*:) R.TypeRep 45 | 46 | newtype Argument a = Argument 47 | { getArgument :: Stash -> Maybe (StashValue a) 48 | } 49 | 50 | data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint 51 | { reArguments :: V.Rec (TypedF Argument) as 52 | , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int)))) 53 | } 54 | 55 | instance Show ReifiedEndpoint where 56 | show _ = "lol" 57 | 58 | class ( V.RecordToList (EndpointArgs endpoint) 59 | , V.RMap (EndpointArgs endpoint) 60 | ) => ToReifiedEndpoint (endpoint :: Type) where 61 | type EndpointArgs endpoint :: [Type] 62 | type EndpointRes endpoint :: Type 63 | 64 | reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint) 65 | 66 | 67 | tagType :: Typeable a => f a -> TypedF f a 68 | tagType = (R.typeRep :*:) 69 | 70 | data InteractionError = InteractionError 71 | { errorMessage :: T.Text 72 | , fatalError :: Bool 73 | } 74 | deriving Show 75 | instance Exception InteractionError 76 | 77 | 78 | 79 | instance 80 | (Typeable responseType, Breakdown responseType) => 81 | ToReifiedEndpoint (Verb method statusCode contentTypes responseType) 82 | where 83 | type EndpointArgs (Verb method statusCode contentTypes responseType) = '[] 84 | type EndpointRes (Verb method statusCode contentTypes responseType) = responseType 85 | reifiedEndpointArguments = V.RNil 86 | 87 | instance ToReifiedEndpoint (NoContentVerb method) 88 | where 89 | type EndpointArgs (NoContentVerb method) = '[] 90 | type EndpointRes (NoContentVerb method) = NoContent 91 | reifiedEndpointArguments = V.RNil 92 | 93 | instance 94 | (ToReifiedEndpoint endpoint) => 95 | ToReifiedEndpoint ((x :: Symbol) :> endpoint) 96 | where 97 | type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint 98 | type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint 99 | reifiedEndpointArguments = reifiedEndpointArguments @endpoint 100 | 101 | instance 102 | (ToReifiedEndpoint endpoint) => 103 | ToReifiedEndpoint (RemoteHost :> endpoint) 104 | where 105 | type EndpointArgs (RemoteHost :> endpoint) = EndpointArgs endpoint 106 | type EndpointRes (RemoteHost :> endpoint) = EndpointRes endpoint 107 | reifiedEndpointArguments = reifiedEndpointArguments @endpoint 108 | 109 | 110 | 111 | instance 112 | (ToReifiedEndpoint endpoint) => 113 | ToReifiedEndpoint (Description s :> endpoint) 114 | where 115 | type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint 116 | type EndpointRes (Description s :> endpoint) = EndpointRes endpoint 117 | reifiedEndpointArguments = reifiedEndpointArguments @endpoint 118 | 119 | instance 120 | (ToReifiedEndpoint endpoint) => 121 | ToReifiedEndpoint (Summary s :> endpoint) 122 | where 123 | type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint 124 | type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint 125 | reifiedEndpointArguments = reifiedEndpointArguments @endpoint 126 | 127 | instance 128 | (Typeable requestType 129 | ,BuildFrom requestType 130 | ,ToReifiedEndpoint endpoint) => 131 | ToReifiedEndpoint (QueryFlag name :> endpoint) 132 | where 133 | type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint 134 | type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint 135 | reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint 136 | 137 | type IfLenient s mods t = If (FoldLenient mods) (Either s t) t 138 | type IfRequired mods t = If (FoldRequired mods) t (Maybe t) 139 | type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t) 140 | 141 | instance 142 | ( BuildFrom (IfRequiredLenient T.Text mods paramType) 143 | , ToReifiedEndpoint endpoint 144 | ) => 145 | ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint) 146 | where 147 | type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint 148 | type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint 149 | reifiedEndpointArguments = 150 | tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType))) 151 | V.:& reifiedEndpointArguments @endpoint 152 | 153 | 154 | instance 155 | ( BuildFrom paramType 156 | , ToReifiedEndpoint endpoint 157 | , Show paramType 158 | , Eq paramType 159 | ) => 160 | ToReifiedEndpoint (QueryParams name paramType :> endpoint) 161 | where 162 | type EndpointArgs (QueryParams name paramType :> endpoint) = [paramType] ': EndpointArgs endpoint 163 | type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint 164 | reifiedEndpointArguments = 165 | tagType (Argument (buildFrom @[paramType])) 166 | V.:& reifiedEndpointArguments @endpoint 167 | 168 | 169 | 170 | 171 | instance 172 | ( BuildFrom (IfRequiredLenient T.Text mods headerType) 173 | , ToReifiedEndpoint endpoint 174 | ) => 175 | ToReifiedEndpoint (Header' mods headerName headerType :> endpoint) 176 | where 177 | type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint 178 | type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint 179 | reifiedEndpointArguments = 180 | tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType))) 181 | V.:& reifiedEndpointArguments @endpoint 182 | 183 | #if MIN_VERSION_servant(0,17,0) 184 | instance 185 | ( BuildFrom (IfLenient String mods captureType) 186 | , ToReifiedEndpoint endpoint) => 187 | ToReifiedEndpoint (Capture' mods name captureType :> endpoint) 188 | where 189 | type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint 190 | type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint 191 | reifiedEndpointArguments = 192 | tagType (Argument (buildFrom @(IfLenient String mods captureType))) 193 | V.:& reifiedEndpointArguments @endpoint 194 | #else 195 | instance 196 | ( BuildFrom captureType 197 | , ToReifiedEndpoint endpoint) => 198 | ToReifiedEndpoint (Capture' mods name captureType :> endpoint) 199 | where 200 | type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint 201 | type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint 202 | reifiedEndpointArguments = 203 | tagType (Argument (buildFrom @(captureType))) 204 | V.:& reifiedEndpointArguments @endpoint 205 | 206 | #endif 207 | 208 | instance 209 | ( BuildFrom (IfLenient String mods requestType) 210 | , ToReifiedEndpoint endpoint) => 211 | ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint) 212 | where 213 | type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint 214 | type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint 215 | reifiedEndpointArguments = 216 | tagType (Argument (buildFrom @(IfLenient String mods requestType))) 217 | V.:& reifiedEndpointArguments @endpoint 218 | -------------------------------------------------------------------------------- /src/Roboservant/Types/ReifiedApi/Server.hs: -------------------------------------------------------------------------------- 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 115 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.4 2 | packages: 3 | - . 4 | 5 | extra-deps: 6 | # - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 7 | # - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 8 | - servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 9 | # - constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853 10 | - some-1.0.3 11 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 9 | pantry-tree: 10 | sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3 11 | size: 325 12 | original: 13 | hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 14 | - completed: 15 | hackage: some-1.0.3@sha256:938cec5fc0d3a08dde34cfc0acd5a0aa2e9fd489c9dbb64417f16588dfb47af0,2399 16 | pantry-tree: 17 | sha256: b88dddc6b991cd570c6750f8d309a9feb76938b29a690abdabc4ababb8c7b2f8 18 | size: 709 19 | original: 20 | hackage: some-1.0.3 21 | snapshots: 22 | - completed: 23 | sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94 24 | size: 648660 25 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml 26 | original: lts-20.4 27 | -------------------------------------------------------------------------------- /test/Breakdown.hs: -------------------------------------------------------------------------------- 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) 51 | -------------------------------------------------------------------------------- /test/Foo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Foo where 9 | 10 | import Data.Aeson 11 | import Data.Hashable 12 | import Data.Typeable (Typeable) 13 | import GHC.Generics (Generic) 14 | import Servant 15 | 16 | newtype Foo = Foo Int 17 | deriving (Generic, Eq, Show, Typeable) 18 | deriving newtype (FromHttpApiData, ToHttpApiData) 19 | 20 | instance Hashable Foo 21 | 22 | instance ToJSON Foo 23 | 24 | instance FromJSON Foo 25 | 26 | type Api = 27 | "item" :> Get '[JSON] Foo 28 | :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo 29 | :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] () 30 | 31 | intro :: Handler Foo 32 | intro = pure (Foo 1) 33 | 34 | combine :: Foo -> Foo -> Handler Foo 35 | combine (Foo a) (Foo b) = pure (Foo (a + b)) 36 | 37 | eliminate :: Foo -> Handler () 38 | eliminate (Foo a) 39 | | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"} 40 | | otherwise = pure () 41 | 42 | server :: Server Api 43 | server = 44 | intro 45 | :<|> combine 46 | :<|> eliminate 47 | -------------------------------------------------------------------------------- /test/Headers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Headers where 9 | 10 | import Data.Aeson 11 | import Data.Hashable 12 | import Data.Typeable (Typeable) 13 | import GHC.Generics (Generic) 14 | import Servant 15 | 16 | newtype Foo = Foo Int 17 | deriving (Generic, Eq, Show, Typeable) 18 | deriving newtype (FromHttpApiData, ToHttpApiData) 19 | 20 | instance Hashable Foo 21 | 22 | instance ToJSON Foo 23 | 24 | instance FromJSON Foo 25 | 26 | type Api = 27 | "item" :> Get '[JSON] Foo 28 | :<|> "itemAdd" :> Header "one" Foo :> Header "two" Foo :> Get '[JSON] Foo 29 | :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] () 30 | 31 | intro :: Handler Foo 32 | intro = pure (Foo 1) 33 | 34 | combine :: Maybe Foo -> Maybe Foo -> Handler Foo 35 | combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b)) 36 | combine (Just a) Nothing = pure a 37 | combine Nothing (Just a) = pure a 38 | combine Nothing Nothing = pure (Foo 1) 39 | 40 | eliminate :: Foo -> Handler () 41 | eliminate (Foo a) 42 | | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"} 43 | | otherwise = pure () 44 | 45 | server :: Server Api 46 | server = 47 | intro 48 | :<|> combine 49 | :<|> eliminate 50 | -------------------------------------------------------------------------------- /test/Nested.hs: -------------------------------------------------------------------------------- 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 24 | -------------------------------------------------------------------------------- /test/Post.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | 5 | 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Post where 9 | 10 | import Data.Aeson 11 | import Data.Hashable 12 | import GHC.Generics (Generic) 13 | import Servant 14 | 15 | type Api = 16 | Get '[JSON] FooPost 17 | :<|> ReqBody '[JSON] FooPost :> Post '[JSON] () 18 | 19 | data FooPost = FooPost 20 | deriving (Eq, Show, Generic) 21 | 22 | instance Hashable FooPost 23 | 24 | instance ToJSON FooPost 25 | 26 | instance FromJSON FooPost 27 | 28 | server :: Server Api 29 | server = 30 | pure FooPost 31 | :<|> const (pure ()) 32 | -------------------------------------------------------------------------------- /test/Product.hs: -------------------------------------------------------------------------------- 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 32 | -------------------------------------------------------------------------------- /test/Put.hs: -------------------------------------------------------------------------------- 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) 34 | -------------------------------------------------------------------------------- /test/QueryParams.hs: -------------------------------------------------------------------------------- 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 16 | -------------------------------------------------------------------------------- /test/Seeded.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Seeded where 9 | 10 | import Data.Aeson 11 | import Data.Hashable 12 | import Data.Typeable (Typeable) 13 | import GHC.Generics (Generic) 14 | import Servant 15 | 16 | newtype Seed = Seed Int 17 | deriving (Generic, Eq, Show, Typeable) 18 | deriving newtype (FromHttpApiData, ToHttpApiData) 19 | 20 | instance ToJSON Seed 21 | 22 | instance FromJSON Seed 23 | 24 | instance Hashable Seed 25 | 26 | type Api = 27 | Capture "seed" Seed :> Get '[JSON] () 28 | :<|> Get '[JSON] () 29 | 30 | server :: Server Api 31 | server = 32 | (\(Seed _) -> error "we blow up if we get here") 33 | :<|> pure () 34 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE AllowAmbiguousTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE DataKinds #-} 12 | {-# OPTIONS_GHC -fno-warn-orphans #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | 15 | import qualified Breakdown 16 | import Data.Dynamic (toDyn) 17 | import Data.Hashable (Hashable (hash)) 18 | import Data.Maybe (isNothing) 19 | import Data.Void (Void) 20 | import qualified Foo 21 | import qualified Headers 22 | import qualified Nested 23 | import qualified Post 24 | import qualified Put 25 | import qualified Product 26 | import qualified QueryParams 27 | import qualified Roboservant as R 28 | import qualified Roboservant.Server as RS 29 | import qualified Roboservant.Client as RC 30 | import qualified Seeded 31 | import Test.Hspec 32 | import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus) 33 | import qualified Valid 34 | import Servant ( Server, Proxy(..), serve, Endpoints, HasServer ) 35 | 36 | import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM) 37 | import Network.Wai(Application) 38 | import qualified Network.Wai.Handler.Warp as Warp 39 | import Network.HTTP.Client (newManager, defaultManagerSettings) 40 | import Control.Monad((>=>)) 41 | 42 | main :: IO () 43 | main = hspec spec 44 | 45 | fuzzBoth 46 | :: forall a . 47 | (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a, 48 | HasClient ClientM a) 49 | => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec 50 | fuzzBoth name server config condition = do 51 | it (name <> " via server") $ 52 | RS.fuzz @a server config >>= condition 53 | 54 | around (withServer (serve (Proxy :: Proxy a) server)) $ 55 | it (name <> " via client") $ \(clientEnv::ClientEnv) -> do 56 | RC.fuzz @a clientEnv config >>= condition 57 | 58 | withServer :: Application -> ActionWith ClientEnv -> IO () 59 | withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action) 60 | where genClientEnv port = do 61 | baseUrl <- parseBaseUrl "http://localhost" 62 | manager <- newManager defaultManagerSettings 63 | pure $ mkClientEnv manager (baseUrl { baseUrlPort = port }) 64 | 65 | spec :: Spec 66 | spec = do 67 | describe "Basic usage" $ do 68 | describe "noError" $ do 69 | fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing) 70 | fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app" Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing) 71 | fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6} 72 | (\r -> 73 | fmap (R.failureReason . R.rsException) r 74 | `shouldSatisfy` ( \case 75 | Just (R.InsufficientCoverage _) -> True 76 | _ -> False 77 | )) 78 | describe "posted body" $ 79 | fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99} 80 | (`shouldSatisfy` isNothing) 81 | 82 | 83 | describe "PUTted body" $ 84 | fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99} 85 | (`shouldSatisfy` isNothing) 86 | 87 | 88 | describe "seeded" $ do 89 | let res = Seeded.Seed 1 90 | shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server 91 | (R.defaultConfig {R.seed = [(toDyn res, hash res)]}) 92 | (`shouldSatisfy` isNothing) 93 | 94 | describe "Foo" $ 95 | fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure) 96 | 97 | describe "QueryParams" $ 98 | fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] } 99 | (`shouldSatisfy` isNothing) 100 | 101 | describe "BuildFrom" $ do 102 | describe "headers (and sum types)" $ 103 | fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig 104 | (`shouldSatisfy` serverFailure) 105 | describe "product types" $ 106 | fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server 107 | R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]} 108 | (`shouldSatisfy` serverFailure) 109 | describe "Breakdown" $ do 110 | fuzzBoth @Breakdown.ProductApi "handles products" Breakdown.productServer R.defaultConfig 111 | (`shouldSatisfy` serverFailure) 112 | fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig 113 | (`shouldSatisfy` serverFailure) 114 | describe "flattening" $ 115 | fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99} 116 | (`shouldSatisfy` isNothing) 117 | 118 | serverFailure :: Maybe R.Report -> Bool 119 | serverFailure = \case 120 | Just R.Report {..} -> 121 | let R.RoboservantException {..} = rsException 122 | in failureReason /= R.NoPossibleMoves 123 | _ -> False 124 | 125 | deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo 126 | 127 | deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo 128 | 129 | deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo 130 | 131 | deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo 132 | 133 | deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed 134 | 135 | deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed 136 | 137 | deriving via (R.Atom Void) instance R.BuildFrom Void 138 | 139 | deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost 140 | deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost 141 | 142 | deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo 143 | deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo 144 | 145 | 146 | 147 | deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo 148 | 149 | deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo 150 | 151 | deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum 152 | 153 | -- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test. 154 | -- this is often useful when testing tests. 155 | shouldFail :: SpecWith a -> SpecWith a 156 | shouldFail = 157 | mapSpecItem_ 158 | ( \i -> 159 | i 160 | { itemExample = \p a cb -> do 161 | r <- itemExample i p a cb 162 | pure 163 | r 164 | { resultStatus = case resultStatus r of 165 | Success -> Failure Nothing (Reason "Unexpected success") 166 | Failure _ _ -> Success 167 | x -> x 168 | } 169 | } 170 | ) 171 | -------------------------------------------------------------------------------- /test/UnsafeIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | {-# LANGUAGE DerivingStrategies #-} 4 | 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module UnsafeIO where 9 | 10 | import Control.Monad.Trans (MonadIO (liftIO)) 11 | import Data.Aeson () 12 | import qualified Data.ByteString.Lazy.Char8 as BL8 13 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 14 | import Servant 15 | 16 | type UnsafeApi = 17 | "add" :> Get '[JSON] () 18 | :<|> "healthcheck" :> Get '[JSON] () 19 | 20 | healthcheck :: IORef Int -> Handler () 21 | healthcheck ref = do 22 | t <- liftIO $ readIORef ref 23 | case t of 24 | 0 -> pure () 25 | n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)} 26 | 27 | makeServer :: IO (Server UnsafeApi) 28 | makeServer = do 29 | ref <- newIORef 0 30 | pure $ 31 | unsafeMunge ref 32 | :<|> healthcheck ref 33 | 34 | unsafeMunge :: IORef Int -> Handler () 35 | unsafeMunge ref = liftIO $ do 36 | t <- readIORef ref 37 | writeIORef ref (t + 1) 38 | t2 <- readIORef ref 39 | writeIORef ref (t2 -1) 40 | -------------------------------------------------------------------------------- /test/Valid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Valid where 9 | 10 | import Data.Void 11 | import GHC.Generics 12 | import Servant 13 | import Servant.Server.Generic 14 | 15 | type Api = 16 | Get '[JSON] Int 17 | :<|> Capture "void" Void :> Get '[JSON] () 18 | 19 | data Routes route 20 | = Routes 21 | { getInt :: 22 | route 23 | :- Summary "i'm a summary!" :> Get '[JSON] Int, 24 | captureIt :: 25 | route 26 | :- Capture "void" Void :> Get '[JSON] () 27 | } 28 | deriving (Generic) 29 | 30 | type RoutedApi = ToServantApi Routes 31 | 32 | -- routedApi = genericApi (Proxy :: Proxy Routes) 33 | routedServer :: Server RoutedApi 34 | routedServer = genericServer routes 35 | 36 | routes :: Routes AsServer 37 | routes = 38 | Routes 39 | { getInt = pure 7, 40 | captureIt = const (pure ()) 41 | } 42 | 43 | server :: Server Api 44 | server = pure 7 :<|> const (pure ()) 45 | --------------------------------------------------------------------------------