roboservant 0.1.0.2 → 0.1.0.3

raw patch · 28 files changed

+1929/−360 lines, 28 filesdep +dependent-mapdep +dependent-sumdep +hashabledep −hedgehogdep ~servantdep ~servant-clientdep ~servant-serverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dependent-map, dependent-sum, hashable, hspec, hspec-core, hspec-wai, http-api-data, http-client, http-types, lifted-base, monad-control, random, text, time, unordered-containers, vinyl, wai, warp

Dependencies removed: hedgehog

Dependency ranges changed: servant, servant-client, servant-server

API changes (from Hackage documentation)

Files

• Example.lhs +143/−0
• README.md +81/−50
• roboservant.cabal +99/−15
• src/Roboservant.hs +7/−2
• src/Roboservant/Client.hs +127/−0
• src/Roboservant/Direct.hs +311/−0
• src/Roboservant/Server.hs +36/−0
• src/Roboservant/StateMachine.hs +0/−255
• src/Roboservant/Types.hs +26/−0
• src/Roboservant/Types/Breakdown.hs +81/−0
• src/Roboservant/Types/BuildFrom.hs +107/−0
• src/Roboservant/Types/Config.hs +29/−0
• src/Roboservant/Types/Internal.hs +53/−0
• src/Roboservant/Types/Orphans.hs +7/−0
• src/Roboservant/Types/ReifiedApi.hs +217/−0
• src/Roboservant/Types/ReifiedApi/Server.hs +114/−0
• test/Breakdown.hs +50/−0
• test/Foo.hs +6/−3
• test/Headers.hs +49/−0
• test/Nested.hs +23/−0
• test/Post.hs +31/−0
• test/Product.hs +31/−0
• test/Put.hs +33/−0
• test/QueryParams.hs +15/−0
• test/Seeded.hs +33/−0
• test/Spec.hs +163/−20
• test/UnsafeIO.hs +13/−15
• test/Valid.hs +44/−0

@@ -0,0 +1,143 @@+# Example++Our api under test:++``` haskell+-- Obligatory fancy-types pragma tax+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++import qualified Roboservant.Server as RS+import qualified Roboservant.Client as RC+import Servant.Client(ClientEnv, baseUrlPort, parseBaseUrl, mkClientEnv)+import Network.HTTP.Client       (newManager, defaultManagerSettings)+import Roboservant.Types+import Test.Hspec+import Servant+import GHC.Generics+import Data.Typeable+import Data.Hashable+import Data.Maybe(isNothing, isJust)+import qualified Network.Wai.Handler.Warp as Warp+import Data.Aeson(FromJSON,ToJSON)++newtype A = A Int+  deriving (Generic, Eq, Show, Typeable)+  deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)++instance FromJSON A+instance ToJSON A++newtype B = B Int+  deriving (Generic, Eq, Show, Typeable)+  deriving newtype (Hashable, FromHttpApiData, ToHttpApiData)++instance FromJSON B+instance ToJSON B++type Api =+  "item" :> Get '[JSON] A+    :<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B+    :<|> "item" :> Capture "itemId" B :> Get '[JSON] ()++server :: Handler A -> Server Api+server introduce = introduce :<|> combine :<|> eliminate+  where+    combine (B i) (B j) = pure $ B (i + j)+    eliminate (B i)+      | i > 10 = error "give up, eleven is way too big and probably not even real"+      | otherwise = pure ()+```++We have a "good" server, that never generates anything other than a 0. This means repeated application of+the combination/addition rule can never bring us to the dangerous state of numbers larger than 10.++``` haskell+goodServer, badServer :: Server Api+goodServer = server (pure $ A 0)+badServer = server (pure $ A 1)+```++In the test file, we first define the tests: the faulty server should fail and the good server should pass.++```haskell+main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "example" $ do+  it "good server should not fail" $ do+    RS.fuzz @Api goodServer config+      >>= (`shouldSatisfy` isNothing)+  it "bad server should fail" $ do+    RS.fuzz @Api badServer config+      >>= (`shouldSatisfy` isJust)+```++The previous test just picked apart the server and ran functions manually: sometimes, we want to test via+an honest-to-goodness network port, like so:++```haskell+  around (withServer (serve (Proxy :: Proxy Api) badServer)) $ do+    it "we should also be able to run the _client_ to an independent server (ignore server error messages)" $ \(clientEnv::ClientEnv) -> do+      RC.fuzz @Api clientEnv config >>= (`shouldSatisfy` isJust)+```++(we use withApplication rather than testWithApplication because we don't primarily care what the server does here:+we want to check what a client does when presented with a faulty server.)++We expect to be able to cover the whole api from our starting point, so let's set the coverage to 0.99.+There are other tweakable things in the config, like maximum runtime, reps,+per-request healthchecks, seeds, and verbose logging. Have a look at+Roboservant.Types.Config for details.++``` haskell+config :: Config+config = defaultConfig+  { coverageThreshold = 0.99+  }+```++Unless we want to ship roboservant and all its dependencies to production, we also need+some orphan instances: because As are the only value we can get without+an input, we need to be able to break them down.++``` haskell+deriving via (Compound A) instance Breakdown A+```++if we wanted to assemble As from parts as well, we'd derive using Compound, but in this case we don't care.++``` haskell+deriving via (Atom A) instance BuildFrom A++```++Similarly, to generate the first B from the Ints we got from inside the A, we need to be able to+build it up from components.++```haskell+deriving via (Compound B) instance BuildFrom B+deriving via (Atom B) instance Breakdown B+```+++test utilities:++``` haskell+withServer :: Application -> ActionWith ClientEnv -> IO ()+withServer app action = Warp.withApplication (pure app) (\p -> genClientEnv p >>= action)+  where genClientEnv port = do+          baseUrl <- parseBaseUrl "http://localhost"+          manager <- newManager defaultManagerSettings+          pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })+```

@@ -2,46 +2,87 @@  Automatically fuzz your servant apis in a contextually-aware way. -![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)+[![Stack CI](https://github.com/mwotton/roboservant/actions/workflows/ci.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/ci.yml)+[![Cabal CI](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml/badge.svg)](https://github.com/mwotton/roboservant/actions/workflows/cabal.yml) +## example -# why?+see full example [here](EXAMPLE.md) +## why?+ Servant gives us a lot of information about what a server can do. We use this information to generate arbitrarily long request/response sessions and verify properties that should hold over them. -# example+## how? -Our api under test:+In essence, ```fuzz @Api yourServer config``` will make a bunch of+calls to your API, and record the results in a type-indexed+dictionary. This means that they are now available for the+prerequisites of other calls, so as you proceed, more and more api+calls become possible. -```-newtype Foo = Foo Int-  deriving (Generic, Eq, Show, Typeable)-  deriving newtype (FromHttpApiData, ToHttpApiData)+We explicitly do not try to come up with plausible values that haven't+somehow come back from the API. That's straying into QC/Hedgehog+territory: if you want that, come up with the values on that side, and+set them as seeds in the configuration. -type FooApi =-  "item" :> Get '[JSON] Foo-    :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo-    :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()-```+### what does it mean to be "available"? -From the tests:+In a simple API, you may make a call and get back a `Foo`, which will+allow you to make another call that requires a `Foo`. In a more+complicated app, it's likely that you'll send a request body that+includes many subcomponents, and it's likely you'll get a response+that needs to be broken down into pieces before it's useful. +To cope with this, we have the typeclasses `BuildFrom` and+`Breakdown`. You can write instances for them if you feel like it, and+indeed it's currently required for recursive datatypes if you don't+want the fuzzer to hang, but for the majority of your types it should+be sufficient to derive them generically. (Sensible instances are+provided for lists.)++There are two basic strategies here. In some cases, you want to regard+a type as indivisible: that's why we like newtypes, right? In this+case, we can derive using the `Atom` strategy.++``` haskell+deriving via (Atom NewtypedKey) instance Breakdown NewtypedKey+deriving via (Atom NewtypedKey) instance BuildFrom NewtypedKey ```-  assert "should find an error in Foo" . not-    =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential @Foo.FooApi Foo.fooServer)])++This is saying "A can neither be built from components or broken down+for spare parts. Hands off!". This is a good strategy for key types,+for instance.++If instead it's a big complicated thing with lots of juicy+subcomponents, we want to rip it apart using Generics and feast on+its succulent headmeats:++``` haskell+deriving via (Compound Payload) instance Breakdown Payload+deriving via (Compound Payload) instance BuildFrom Payload ``` -We have a server that blows up if the value of the int in a `Foo` ever gets above 10. Note:-there is no generator for `Foo` types: larger `Foo`s can only be made only by combining existing-`Foo`s with `itemAdd`. This is an important distinction, because many APIs will return UUIDs or-similar as keys, which make it impossible to cover a useful section of the state space without-using the values returned by the API+### priming the pump +Sometimes there are values we'd like to smuggle into the API that are+not derivable from within the API itself: sometimes this is a warning+sign that your API is incomplete, but it can be quite reasonable to+require identifying credentials within an API and not provide a way to+get them. It might also be reasonable to have some sample values that+the user is expected to come up with. -# why not servant-quickcheck?+For those cases, override the `seed` in the `Config` with a+list of seed values, suitably hashed: +``` haskell+defaultConfig { seed = [hashedDyn creds, hashedDyn userJwt]}+```++## why not servant-quickcheck?+ [servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck) is a great package and I've learned a lot from it. Unfortunately, as mentioned previously, there's a lot of the state space you just can't explore without context: modern webapps are@@ -49,35 +90,25 @@ keys/uuids, and servant-quickcheck requires that you be able to generate these without context via Arbitrary. -## extensions/todo+## limitations and future work -- add some "starter" values to the store-  - there may be a JWT that's established outside the servant app, for instance.-- `class Extras a where extras :: Gen [a]`-  - default implementation `pure []`-  - selectively allow some types to create values we haven't seen from the api.-	`newtype FirstName = FirstName Text`, say.-- break down each response type into its components-  - if i have-	- `data Foo = FBar Bar | FBaz Baz`-	- an endpoint `foo` that returns a `Foo`-	- and an endpoint `bar` that takes a `Bar`-  - I should be able to call `foo` to get a `Foo`, and if it happens to be an `FBar Bar`, I-	should be able to use that `Bar` to call `bar`.-- better handling of properties to be verified-  - some properties should always hold (no 500s): this already works.-  - to-do: there may be some other properties that hold contextually-	- healthcheck should be 200-	- test complex permissions/ownership/delegation logic - should never be able to-	  get access to something you don't own or haven't been delegated access to.+Currently, the display of failing traces is pretty tragic, both in the+formatting and in its non-minimality. This is pretty ticklish:+arguably the right way to do this is to return a trace that we can+also rerun, and let quickcheck or hedgehog a level up shrink it until+it's satisfactorily short. In the interest of being useful earlier+rather than later, I'm releasing v1.0 before I crack this particular+nut. We do know which calls we made that led to the failing case, so+we would want to show that distinction in a visible way: it's possible+that other calls that don't have direct data dependencies were+important, but we definitely know we need the direct data dependencies. -## other possible applications+The provenance stuff is a bit underbaked. It should at least pull a+representation of the route chosen rather than just an integer index. -- coverage-  - if you run the checker for a while and `hpc` suggests you still have bad coverage,-	your api is designed in a way that requires external manipulation and may be improvable.+It would also be nice to have a robust strategy for deriving recursive+datatypes, or at least rejecting attempts to generate them that don't+end in an infinite loop. -- benchmarking-  - we can generate "big-enough" call sequences, then save the database & a sample call for each-	endpoint that takes long enough to be a reasonable test.-  - from this we can generate tests that a given call on that setup never gets slower.+Currently the `FlattenServer` instance for `:>` is quadratic. It would+be nice to fix this but I lack the art.

@@ -1,19 +1,18 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack ----- hash: 179b83962de30f5bcf8b13d2f0648b301a753367094171f21a68e60b5cb4e4d5+-- hash: 9fb762faa0870b60a03c6e2ec00a2958457ab4a2951e16f4e589e183603afe47  name:           roboservant-version:        0.1.0.2+version:        0.1.0.3 synopsis:       Automatic session-aware servant testing description:    Please see the README on GitHub at <https://github.com/mwotton/roboservant#readme> category:       Web homepage:       https://github.com/mwotton/roboservant#readme bug-reports:    https://github.com/mwotton/roboservant/issues-author:         Mark Wotton, Samuel Schlesinger maintainer:     mwotton@gmail.com copyright:      2020 Mark Wotton, Samuel Schlesinger license:        BSD3@@ -30,46 +29,131 @@ library   exposed-modules:       Roboservant-      Roboservant.StateMachine+      Roboservant.Client+      Roboservant.Direct+      Roboservant.Server+      Roboservant.Types+      Roboservant.Types.Breakdown+      Roboservant.Types.BuildFrom+      Roboservant.Types.Config+      Roboservant.Types.Internal+      Roboservant.Types.Orphans+      Roboservant.Types.ReifiedApi+      Roboservant.Types.ReifiedApi.Server   other-modules:       Paths_roboservant   hs-source-dirs:       src-  ghc-options: -Wall+  ghc-options: -Wall -fwrite-ide-info -hiedir=.hie   build-depends:       base >=4.7 && <5     , bytestring     , containers-    , hedgehog+    , dependent-map+    , dependent-sum+    , hashable+    , http-types+    , lifted-base+    , monad-control     , mtl-    , servant >=0.17-    , servant-client >=0.17+    , random+    , servant+    , servant-client     , servant-flatten-    , servant-server >=0.17+    , servant-server     , string-conversions+    , text+    , time+    , unordered-containers+    , vinyl   default-language: Haskell2010 +test-suite example+  type: exitcode-stdio-1.0+  main-is: Example.lhs+  other-modules:+      Paths_roboservant+  hs-source-dirs:+      ./+  ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -pgmL markdown-unlit+  build-tool-depends:+      markdown-unlit:markdown-unlit+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , containers+    , dependent-map+    , dependent-sum+    , hashable+    , hspec+    , hspec-core+    , http-client+    , http-types+    , lifted-base+    , monad-control+    , mtl+    , random+    , roboservant+    , servant+    , servant-client+    , servant-flatten+    , servant-server+    , string-conversions+    , text+    , time+    , unordered-containers+    , vinyl+    , warp+  default-language: Haskell2010+ test-suite roboservant-test   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Breakdown       Foo+      Headers+      Nested+      Post+      Product+      Put+      QueryParams+      Seeded       UnsafeIO+      Valid       Paths_roboservant   hs-source-dirs:       test-  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N   build-depends:       aeson     , base >=4.7 && <5     , bytestring     , containers-    , hedgehog+    , dependent-map+    , dependent-sum+    , hashable+    , hspec+    , hspec-core+    , hspec-wai+    , http-api-data+    , http-client+    , http-types+    , lifted-base+    , monad-control     , mtl+    , random     , roboservant-    , servant >=0.17-    , servant-client >=0.17+    , servant+    , servant-client     , servant-flatten-    , servant-server >=0.17+    , servant-server     , string-conversions+    , text+    , time+    , unordered-containers+    , vinyl+    , wai+    , warp   default-language: Haskell2010

@@ -1,3 +1,8 @@-module Roboservant (module Roboservant.StateMachine) where+module Roboservant+  ( module Roboservant.Direct,+    module Roboservant.Types,+  )+where -import Roboservant.StateMachine+import Roboservant.Direct+import Roboservant.Types

@@ -0,0 +1,127 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+-- should all the NormalizeFunction instances be in one place?+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Roboservant.Client where++import Data.Proxy+import Servant.Client+import Roboservant.Types+import Roboservant(Report, fuzz')+import Servant+import Data.Bifunctor+import Data.List.NonEmpty (NonEmpty)+import Data.Dynamic (Dynamic,Typeable)+import qualified Data.Vinyl.Curry as V+import qualified Data.Text as T+import Control.Monad.Reader+import Data.Hashable+import Network.HTTP.Types.Status++-- fuzz :: forall api.+--               (FlattenServer api, ToReifiedApi (Endpoints api)) =>+--               Server api ->+--               Config ->+--               IO (Maybe Report)+-- fuzz s  = fuzz' (reifyServer s)+--   -- todo: how do we pull reifyServer out?+--   where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))+--                     => Server api -> ReifiedApi+--         reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))++fuzz :: forall api . (ToReifiedClientApi (Endpoints api), FlattenClient api, HasClient ClientM api)+     => ClientEnv -> Config -> IO (Maybe Report)+fuzz clientEnv+  = fuzz'+      (toReifiedClientApi+         (flattenClient @api apiClient) (Proxy @(Endpoints api)) clientEnv)+  where apiClient = client (Proxy @api)++++class ToReifiedClientApi api where+  toReifiedClientApi :: ClientBundled api -> Proxy api -> ClientEnv -> ReifiedApi++data ClientBundled endpoints where+  AClientEndpoint :: Client ClientM endpoint -> ClientBundled endpoints -> ClientBundled (endpoint ': endpoints)+  NoClientEndpoints :: ClientBundled '[]+++class FlattenClient api where+  flattenClient :: Client ClientM api  -> ClientBundled (Endpoints api)++instance+  ( NormalizeFunction (Client ClientM endpoint)+  , Normal (Client ClientM endpoint) ~ V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int))))+  , ToReifiedClientApi endpoints+  , V.RecordCurry' (EndpointArgs endpoint)+  , ToReifiedEndpoint endpoint) =>+  ToReifiedClientApi (endpoint : endpoints) where+  toReifiedClientApi (endpoint `AClientEndpoint` endpoints) _ clientEnv =+    (0, ReifiedEndpoint+        { reArguments    = reifiedEndpointArguments @endpoint+        , reEndpointFunc = foo (normalize endpoint)+        }+    )+    : (map . first) (+1)+    (toReifiedClientApi endpoints (Proxy @endpoints) clientEnv)+    where++      foo :: V.Curried (EndpointArgs endpoint) (ReaderT ClientEnv IO ResultType)+          -> V.Curried (EndpointArgs endpoint) (IO ResultType)+      foo = mapCurried @(EndpointArgs endpoint) @(ReaderT ClientEnv IO ResultType) (`runReaderT` clientEnv)++mapCurried :: forall ts a b. V.RecordCurry' ts => (a -> b) -> V.Curried ts a -> V.Curried ts b+mapCurried f g = V.rcurry' @ts $ f . V.runcurry' g++type ResultType = Either InteractionError (NonEmpty (Dynamic,Int))+-- runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)+++instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (ClientM x) where+  type Normal (ClientM x) = ReaderT ClientEnv IO (Either InteractionError (NonEmpty (Dynamic,Int)))+  normalize c = ReaderT $+    fmap (bimap renderClientError breakdown) . runClientM c+    where+      renderClientError :: ClientError -> InteractionError+      renderClientError err = case err of+        FailureResponse _ Response{responseStatusCode} -> InteractionError textual (responseStatusCode == status500)+        _ -> InteractionError textual True++        where textual = T.pack $ show err+instance ToReifiedClientApi '[] where+  toReifiedClientApi NoClientEndpoints _ _ = []+++instance+  ( FlattenClient api,+    Endpoints endpoint ~ '[endpoint]+  ) =>+  FlattenClient (endpoint :<|> api)+  where+  flattenClient (endpoint :<|> c) = endpoint `AClientEndpoint` flattenClient @api c++instance+ (+   Endpoints api ~ '[api]+ ) =>+  FlattenClient (x :> api)+  where+  flattenClient c = c `AClientEndpoint` NoClientEndpoints+++instance FlattenClient (Verb method statusCode contentTypes responseType)+  where+  flattenClient c = c `AClientEndpoint` NoClientEndpoints

@@ -0,0 +1,311 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Roboservant.Direct+  ( fuzz',+    Config (..),+    -- TODO come up with something smarter than exporting all this, we should+    -- have some nice error-display functions+    RoboservantException (..),+    FuzzState (..),+    FuzzOp (..),+    FailureType (..),+    Report (..),+  )+where++import Control.Exception.Lifted+  ( Exception,+    Handler (Handler),+    SomeAsyncException,+    SomeException,+    catch,+    catches,+    handle,+    throw,+  )+import Control.Monad.State.Strict+  ( MonadIO (..),+    MonadState (get),+    StateT (runStateT),+    modify',+  )+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.Dependent.Map as DM+import Data.Dynamic (Dynamic (..))+import qualified Data.IntSet as IntSet+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NEL+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)+import qualified Data.Vinyl as V+import qualified Data.Vinyl.Curry as V+import qualified Data.Vinyl.Functor as V+import GHC.Generics ((:*:) (..))+import Roboservant.Types+  ( ApiOffset (..),+    Argument (..),+    InteractionError(..),+    Provenance (..),+    ReifiedApi,+    ReifiedEndpoint (..),+    Stash (..),+    StashValue (..),+    TypedF,+  )+import Roboservant.Types.Config++import System.Random (Random (randomR), StdGen, mkStdGen)+import qualified Type.Reflection as R++data RoboservantException+  = RoboservantException+      { failureReason :: FailureType,+        serverException :: Maybe SomeException,+        fuzzState :: FuzzState+      }+  deriving (Show)++instance Exception RoboservantException++data FailureType+  = ServerCrashed+  | CheckerFailed+  | NoPossibleMoves+  | InsufficientCoverage Double+  deriving (Show, Eq)++data FuzzOp+  = FuzzOp+      { apiOffset :: ApiOffset,+        provenance :: [Provenance]+      }+  deriving (Show, Eq)++data FuzzState+  = FuzzState+      { path :: [FuzzOp],+        stash :: Stash,+        currentRng :: StdGen+      }+  deriving (Show)++data EndpointOption+  = forall as.+    (V.RecordToList as, V.RMap as) =>+    EndpointOption+      { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),+        eoArgs :: V.Rec (TypedF StashValue) as+      }++data StopReason+  = TimedOut+  | HitMaxIterations+  deriving (Show, Eq)++data Report+  = Report+      { textual :: String,+        rsException :: RoboservantException+      }+  deriving (Show)++++-- fuzzClient :: Client api -> Config -> IO (Maybe Report)+-- fuzzClient = undefined++++fuzz' ::+  ReifiedApi ->+  Config ->+  IO (Maybe Report)+fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do+  let path = []+      stash = addToStash seed mempty+      currentRng = mkStdGen rngSeed+  deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime+  (stopreason, _fs) <-+    runStateT+      (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))+      FuzzState {..}+  logInfo $ show stopreason+  pure Nothing+  where+    -- something less terrible later+    formatException :: RoboservantException -> Report+    formatException r@(RoboservantException failureType exception _state) =+      Report+        (unlines [show failureType, show exception])+        r+    displayDiagnostics FuzzState {..} = liftIO $+      logInfo $ unlines $+      ["api endpoints covered"]+        <> (map show . Set.toList . Set.fromList $ map apiOffset path)+        <> ["", "types in stash"]+        <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)+    --        <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))+    --        $ \_k v ->+    --               (show . NEL.length $ getStashValue v))++    evaluateCoverage f@FuzzState {..}+      | coverage > coverageThreshold = pure ()+      | otherwise = do+        displayDiagnostics f+        throw $ RoboservantException (InsufficientCoverage coverage) Nothing f+      where+        hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path+        totalRoutes = fromIntegral routeCount+        coverage = hitRoutes / totalRoutes+    untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason+    untilDone (0, _) _ = pure HitMaxIterations+    untilDone (n, deadline) action = do+      now <- liftIO getCurrentTime+      if now > deadline+        then pure TimedOut+        else do+          _ <- action+          untilDone (n -1, deadline) action++    routeCount = length reifiedApi+    elementOrFail ::+      (MonadState FuzzState m, MonadIO m) =>+      [a] ->+      m a+    elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get+    elementOrFail l = do+      st <- get+      let (index, newGen) = randomR (0, length l - 1) (currentRng st)+      modify' $ \st' -> st' {currentRng = newGen}+      pure (l !! index)+    withOp ::+      (MonadState FuzzState m, MonadIO m) =>+      ( forall as.+        (V.RecordToList as, V.RMap as) =>+        FuzzOp ->+        V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->+        V.Rec (TypedF V.Identity) as ->+        m r+      ) ->+      m r+    withOp callback = do+      -- choose a call to make, from the endpoints with fillable arguments.+      (offset, EndpointOption {..}) <- elementOrFail . options =<< get+      r <-+        V.rtraverse+          ( \(tr :*: StashValue svs _) ->+              elementOrFail $+                zipWith+                  (\i xy -> V.Const i :*: tr :*: xy)+                  [0 ..]+                  (NEL.toList svs)+          )+          eoArgs+      let pathSegment =+            FuzzOp offset $+              recordToList'+                (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)+                r+          argValues =+            V.rmap+              (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)+              r+      modify' (\f -> f {path = path f <> [pathSegment]})+      callback pathSegment eoCall argValues+      where+        options :: FuzzState -> [(ApiOffset, EndpointOption)]+        options FuzzState {..} =+          mapMaybe+            ( \(offset, ReifiedEndpoint {..}) -> do+                args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments+                pure (offset, EndpointOption reEndpointFunc args)+            )+            reifiedApi+    execute ::+      (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>+      FuzzOp ->+      V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->+      V.Rec (TypedF V.Identity) as ->+      m ()+    execute fuzzop func args = do+      (liftIO . logInfo . show . (fuzzop,) . stash) =<< get+      liftIO (V.runcurry' func argVals) >>= \case+        Left (e::InteractionError) ->+          if fatalError e+          then throw e+          else pure ()+        Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->+          modify'+          ( \fs@FuzzState {..} ->+              fs {stash = addToStash (NEL.toList dyn) stash}+          )+      where+        argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args+    -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args+    go ::+      (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>+      m ()+    go = withOp $ \op func args -> do+      catches+        (execute op func args)+        [ Handler (\(e :: SomeAsyncException) -> throw e),+          Handler+            ( \(e :: SomeException) -> +                throw . RoboservantException ServerCrashed (Just e) =<< get+            )+        ]+      catch+        (liftIO healthCheck)+        (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)++addToStash ::+  [(Dynamic, Int)] ->+  Stash ->+  Stash+addToStash result stash =+  foldr+    ( \(Dynamic tr x, hashed) (Stash dict) ->+        Stash $+          DM.insertWith+            renumber+            tr+            (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))+            dict+    )+    stash+    result+  where+    renumber ::+      StashValue a ->+      StashValue a ->+      StashValue a+    renumber (StashValue singleDyn singleHash) orig@(StashValue l intSet)+      | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig+      | otherwise =+        StashValue+          ( case NEL.toList singleDyn of+              [([Provenance tr _], dyn)] ->+                l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)+              _ -> error "should be impossible"+          )+          (IntSet.union singleHash intSet)++-- why isn't this in vinyl?+recordToList' ::+  (V.RecordToList as, V.RMap as) =>+  (forall x. f x -> a) ->+  V.Rec f as ->+  [a]+recordToList' f = V.recordToList . V.rmap (V.Const . f)

@@ -0,0 +1,36 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Roboservant.Server (fuzz, module Roboservant.Types ) where++import Roboservant.Direct(fuzz',Report)+import Roboservant.Types+  ( FlattenServer (..),+    ReifiedApi,+  )+import Roboservant.Types.ReifiedApi.Server(ToReifiedApi (..))+import Servant (Endpoints, Proxy (Proxy), Server)+import Roboservant.Types.Config++fuzz :: forall api.+              (FlattenServer api, ToReifiedApi (Endpoints api)) =>+              Server api ->+              Config ->+              IO (Maybe Report)+fuzz s  = fuzz' (reifyServer s)+  -- todo: how do we pull reifyServer out?+  where reifyServer :: (FlattenServer api, ToReifiedApi (Endpoints api))+                    => Server api -> ReifiedApi+        reifyServer server = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))+--        reifyServer server = toReifiedApi server (Proxy @(Endpoints api))+

@@ -1,255 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Roboservant.StateMachine-( prop_sequential-, prop_concurrent-) where--import Control.Monad.Except (runExceptT)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic, toDyn)-import Data.Function ((&))-import Data.IORef (IORef, newIORef)-import qualified Data.List.NonEmpty as NEL-import Data.List.NonEmpty (NonEmpty)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Maybe (mapMaybe)-import Data.Typeable (TypeRep, Typeable, typeRep)-import GHC.IORef (readIORef)-import GHC.TypeLits (Symbol)-import Hedgehog-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range-import Servant-import Type.Reflection (SomeTypeRep)--data State v-  = State-      { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))-      }--class FlattenServer api where-  flattenServer :: Server api -> Bundled (Endpoints api)--instance-  ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),-    Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),-    FlattenServer api-  ) =>-  FlattenServer (endpoint :<|> api)-  where-  flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server--instance-  ( HasServer (x :> api) '[],-    Endpoints (x :> api) ~ '[x :> api]-  ) =>-  FlattenServer (x :> api)-  where-  flattenServer server = server `AnEndpoint` NoEndpoints--instance-  ( HasServer (Verb method statusCode contentTypes responseType) '[],-    Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]-  ) =>-  FlattenServer (Verb method statusCode contentTypes responseType)-  where-  flattenServer server = server `AnEndpoint` NoEndpoints--type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)--type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]--data Bundled endpoints where-  AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)-  NoEndpoints :: Bundled '[]--class ToReifiedApi (endpoints :: [*]) where-  toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi--class ToReifiedEndpoint (endpoint :: *) where-  toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint--instance ToReifiedApi '[] where-  toReifiedApi NoEndpoints _ = []--instance-  (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>-  ToReifiedApi (endpoint : endpoints)-  where-  toReifiedApi (endpoint `AnEndpoint` endpoints) _ =-    withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))-      : map-        (\(n, x, y, z) -> (n + 1, x, y, z))-        (toReifiedApi endpoints (Proxy @endpoints))-    where-      withOffset (x, y, z) = (0, x, y, z)--class NormalizeFunction m where-  type Normal m-  normalize :: m -> Normal m--instance NormalizeFunction x => NormalizeFunction (r -> x) where-  type Normal (r -> x) = r -> Normal x-  normalize = fmap normalize--instance Typeable x => NormalizeFunction (Handler x) where-  type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))-  normalize handler = (runExceptT . runHandler') handler >>= \case-    Left serverError -> pure (Left serverError)-    Right x -> pure (Right (typeRep (Proxy @x), toDyn x))--instance-  Typeable responseType =>-  ToReifiedEndpoint (Verb method statusCode contentTypes responseType)-  where-  toReifiedEndpoint endpoint _ =-    ([], typeRep (Proxy @responseType), endpoint)--instance-  (ToReifiedEndpoint endpoint) =>-  ToReifiedEndpoint ((x :: Symbol) :> endpoint)-  where-  toReifiedEndpoint endpoint _ =-    toReifiedEndpoint endpoint (Proxy @endpoint)--instance-  (Typeable requestType, ToReifiedEndpoint endpoint) =>-  ToReifiedEndpoint (Capture name requestType :> endpoint)-  where-  toReifiedEndpoint endpoint _ =-    toReifiedEndpoint endpoint (Proxy @endpoint)-      & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)--instance-  (Typeable requestType, ToReifiedEndpoint endpoint) =>-  ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)-  where-  toReifiedEndpoint endpoint _ =-    toReifiedEndpoint endpoint (Proxy @endpoint)-      & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)--newtype ApiOffset = ApiOffset Int-  deriving (Eq, Show)-  deriving newtype (Enum, Num)---- | we need to specify an offset because it's entirely possible to have two---   functions with the same arguments that do different things.-data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]--deriving instance Show (Op Symbolic)--instance HTraversable Op where-  htraverse r (Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args--callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State-callEndpoint staticRoutes =-  let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))-      gen State {..}-        | any null options = Nothing-        | otherwise = Just $ do-          uncurry Op <$> chooseOne options-        where-          chooseOne ::-            MonadGen n =>-            [ ( ApiOffset,-                [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]-              )-            ] ->-            n-              ( ApiOffset,-                [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]-              )-          chooseOne opts = do-            (offset, args) <- Gen.element opts-            (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> Gen.element argOpts) args-          options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]-          options =-            mapMaybe-              ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do-                  mapM (\x -> (x,) <$> fillableWith x) argreps-              )-              staticRoutes-          fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]-          fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs-      execute ::-        (MonadIO m) =>-        Op Concrete ->-        m (Opaque (IORef Dynamic))-      execute (Op (ApiOffset offset) args) = do-        --        traceM (show (offset, args))-        fmap Opaque . liftIO $ do-          realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args-          let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset-              -- now, magic happens: we apply some dynamic arguments to a dynamic-              -- function and hopefully somtehing useful pops out the end.-              func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs-          let showable = map dynTypeRep (endpoint : realArgs)-          case func of-            Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)-            Just (f') -> do-              case fromDynamic f' of-                Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)-                Just f -> liftIO f >>= \case-                  Left (serverError :: ServerError) -> error (show serverError)-                  Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn-   in Command-        gen-        execute-        [ Update $ \s@State {..} (Op (ApiOffset offset) _args) o' ->-            s-              { stateRefs =-                  let (_, _, tr, _) = staticRoutes !! offset-                   in Map.insertWith-                        (<>)-                        tr-                        (pure o')-                        stateRefs-              }-          -- , Ensure (no-500 here)-        ]--prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Property-prop_sequential server = do-  let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))-  property $ do-    let initialState = State mempty-    actions <--      forAll $-        Gen.sequential-          (Range.linear 1 100)-          initialState-          [callEndpoint reifiedApi]-    executeSequential initialState actions--prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Property-prop_concurrent server =-  let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) in-  let initialState = State mempty-   in withTests 1000 . withRetries 10 . property $ do-        actions <--          forAll $-            Gen.parallel-              (Range.linear 1 50)-              (Range.linear 1 10)-              initialState-              [callEndpoint reifiedApi]-        test $-          executeParallel initialState actions

@@ -0,0 +1,26 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Roboservant.Types+  ( module Roboservant.Types.Breakdown,+    module Roboservant.Types.BuildFrom,+    module Roboservant.Types.ReifiedApi,+    module Roboservant.Types.ReifiedApi.Server,+    module Roboservant.Types.Internal,+    module Roboservant.Types.Config,+  )+where++import Roboservant.Types.Breakdown+import Roboservant.Types.BuildFrom+import Roboservant.Types.Config+import Roboservant.Types.Internal+import Roboservant.Types.ReifiedApi+import Roboservant.Types.ReifiedApi.Server+import Roboservant.Types.Orphans()

@@ -0,0 +1,81 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Roboservant.Types.Breakdown where++import Data.Dynamic (Dynamic)+import Data.Hashable+import Data.Kind+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NEL+import Data.Typeable (Typeable)+import GHC.Generics+import Roboservant.Types.Internal+import Servant+import Roboservant.Types.Orphans()++breakdown ::+  (Hashable x, Typeable x, Breakdown x) =>+  x ->+  NonEmpty (Dynamic, Int)+breakdown x = hashedDyn x :| breakdownExtras x++class Breakdown x where+  breakdownExtras :: x -> [(Dynamic, Int)]++instance (Hashable x, Typeable x) => Breakdown (Atom x) where+  breakdownExtras _ = []++deriving via (Atom ()) instance Breakdown ()++deriving via (Atom Int) instance Breakdown Int+deriving via (Atom Char) instance Breakdown Char++deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, Breakdown x) => Breakdown (Maybe x)++instance (Hashable x, Typeable x, Breakdown x) => Breakdown [x] where+  breakdownExtras stash =  concatMap (NEL.toList . breakdown) stash+++class GBreakdown (f :: k -> Type) where+  gBreakdownExtras :: f a -> [(Dynamic, Int)]++instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where+  breakdownExtras = gBreakdownExtras . from . unCompound++instance GBreakdown f => GBreakdown (M1 S c f) where+  gBreakdownExtras (M1 f) = gBreakdownExtras f++instance GBreakdown b => GBreakdown (M1 D a b) where+  gBreakdownExtras (M1 f) = gBreakdownExtras f++instance GBreakdown b => GBreakdown (M1 C a b) where+  gBreakdownExtras (M1 f) = gBreakdownExtras f++instance (GBreakdown a, GBreakdown b) => GBreakdown (a :*: b) where+  gBreakdownExtras (a :*: b) = gBreakdownExtras a <> gBreakdownExtras b++instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where+  gBreakdownExtras = \case+    L1 a -> gBreakdownExtras a+    R1 a -> gBreakdownExtras a++instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where+  gBreakdownExtras (K1 c) = NEL.toList $ breakdown c++instance GBreakdown U1 where+  gBreakdownExtras U1 = []++deriving via (Atom NoContent) instance Breakdown NoContent

@@ -0,0 +1,107 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Roboservant.Types.BuildFrom where++import Data.List(nub)+import qualified Data.Dependent.Map as DM+import Data.Hashable+import qualified Data.IntSet as IntSet+import Data.Kind+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NEL+import Data.Typeable (Typeable)+import GHC.Generics+import Roboservant.Types.Internal+import qualified Type.Reflection as R+import Servant(NoContent)+import Roboservant.Types.Orphans()++buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)+buildFrom = buildStash . buildFrom'+  where+    buildStash :: [([Provenance], x)] -> Maybe (StashValue x)+    buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty+    promoteToStash :: ([Provenance], x) -> StashValue x+    promoteToStash (p, x) =+      StashValue+        (pure (p, x))+        (IntSet.singleton (hash x))+    addStash :: StashValue x -> StashValue x -> StashValue x+    addStash old (StashValue newVal _) =+      let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal+       in StashValue+            (addListToNE (getStashValue old) insertableVals)+            (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))+    addListToNE :: NonEmpty a -> [a] -> NonEmpty a+    addListToNE ne l = NEL.fromList (NEL.toList ne <> l)++buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]+buildFrom' stash =+  maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))+    <> extras stash++class (Hashable x, Typeable x) => BuildFrom (x :: Type) where+  extras :: Stash -> [([Provenance], x)]++instance (Hashable x, Typeable x) => BuildFrom (Atom x) where+  extras _ = []++deriving via (Atom Bool) instance BuildFrom Bool++deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)++-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.+-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.+instance (Eq x, BuildFrom x) => BuildFrom [x] where+  extras stash =+    nub $ map (\xs -> (concatMap fst xs, map snd xs)) $ notpowerset $ buildFrom' @x stash+    where+      -- powerset creates way too much stuff. something better here eventually.+      notpowerset xs = []:xs:map pure xs+++instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where+  extras stash = fmap (Compound . to) <$> gExtras stash++deriving via (Atom Int) instance BuildFrom Int++deriving via (Atom Char) instance BuildFrom Char++class GBuildFrom (f :: k -> Type) where+  gExtras :: Stash -> [([Provenance], f a)]++instance GBuildFrom b => GBuildFrom (M1 D a b) where+  gExtras = fmap (fmap M1) . gExtras++-- not recursion safe!+instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where+  gExtras stash =+    (fmap L1 <$> gExtras stash)+      <> (fmap R1 <$> gExtras stash)++instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where+  gExtras stash = [(pa <> pb, a' :*: b') | (pa, a') <- gExtras stash, (pb, b') <- gExtras stash]++instance GBuildFrom b => GBuildFrom (M1 C a b) where+  gExtras = fmap (fmap M1) . gExtras++instance GBuildFrom b => GBuildFrom (M1 S a b) where+  gExtras = fmap (fmap M1) . gExtras++instance BuildFrom a => GBuildFrom (K1 i a) where+  gExtras = fmap (fmap K1) . buildFrom'++instance GBuildFrom U1 where+  gExtras _ = [([], U1)]++deriving via (Atom NoContent) instance BuildFrom NoContent

@@ -0,0 +1,29 @@+module Roboservant.Types.Config where++import Data.Dynamic++data Config+  = Config+      { seed :: [(Dynamic, Int)],+        maxRuntime :: Double, -- seconds to test for+        maxReps :: Integer,+        rngSeed :: Int,+        coverageThreshold :: Double,+        logInfo :: String -> IO (),+        healthCheck :: IO ()+      }++defaultConfig :: Config+defaultConfig =+  Config+    { seed = [],+      maxRuntime = 0.5,+      maxReps = 1000,+      rngSeed = 0,+      coverageThreshold = 0,+      logInfo = const (pure ()),+      healthCheck = pure ()+    }++noisyConfig :: Config+noisyConfig = defaultConfig {logInfo = print}

@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Roboservant.Types.Internal where++import qualified Data.Dependent.Map as DM+import Data.Dependent.Map (DMap)+import Data.Dependent.Sum+import Data.Dynamic (Dynamic, toDyn)+import Data.Hashable (Hashable, hash)+import Data.IntSet (IntSet)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import qualified Type.Reflection as R++data Provenance+  = Provenance R.SomeTypeRep Int+  deriving (Show, Eq, Generic)++instance Hashable Provenance++data StashValue a+  = StashValue+      { getStashValue :: NonEmpty ([Provenance], a),+        stashHash :: IntSet+      }+  deriving (Functor, Show)++-- wrap in newtype to give a custom Show instance, since the normal+-- instance for DMap is not happy since StashValue needs Show a to show+newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}+  deriving (Semigroup, Monoid)++instance Show Stash where+  showsPrec i (Stash x) =+    showsPrec i+      $ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))+      $ DM.toList x++-- | Can't be built up from parts, can't be broken down further.+newtype Atom x = Atom {unAtom :: x}+  deriving newtype (Hashable, Typeable,Eq)++-- | can be broken down and built up from generic pieces+newtype Compound x = Compound {unCompound :: x}+  deriving newtype (Hashable, Typeable, Eq)++hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)+hashedDyn a = (toDyn a, hash a)

@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Roboservant.Types.Orphans where++import Servant+import Data.Hashable++instance Hashable NoContent

@@ -0,0 +1,217 @@+-- | Description: ways to build a reified api from a servant description.+--+--   arguably this could be more general and be abstracted away from even relying on servant+--   but that's future work.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+module Roboservant.Types.ReifiedApi where++import Data.Dynamic (Dynamic)+import Control.Exception(Exception)+import Data.List.NonEmpty (NonEmpty)+import Data.Typeable (Typeable)+import GHC.Generics ((:*:)(..))+import Roboservant.Types.Internal+import Roboservant.Types.Breakdown+import Roboservant.Types.BuildFrom+import Data.Kind(Type)+import Servant+import Servant.API.Modifiers(FoldRequired,FoldLenient)+import GHC.TypeLits (Symbol)+import qualified Data.Text as T+import qualified Data.Vinyl as V+import qualified Data.Vinyl.Curry as V+import qualified Type.Reflection as R++newtype ApiOffset = ApiOffset Int+  deriving (Eq, Show, Ord)+  deriving newtype (Enum, Num)++type TypedF = (:*:) R.TypeRep++newtype Argument a = Argument+    { getArgument :: Stash -> Maybe (StashValue a)+    }++data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint+    { reArguments    :: V.Rec (TypedF Argument) as+    , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))+    }++instance Show ReifiedEndpoint where+  show _ = "lol"++class ( V.RecordToList (EndpointArgs endpoint)+      , V.RMap (EndpointArgs endpoint)+      ) => ToReifiedEndpoint (endpoint :: Type) where+  type EndpointArgs endpoint :: [Type]+  type EndpointRes endpoint :: Type++  reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)+++tagType :: Typeable a => f a -> TypedF f a+tagType = (R.typeRep :*:)++data InteractionError = InteractionError+  { errorMessage :: T.Text+  , fatalError :: Bool+  }+  deriving Show+instance Exception InteractionError++++instance+  (Typeable responseType, Breakdown responseType) =>+  ToReifiedEndpoint (Verb method statusCode contentTypes responseType)+  where+  type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]+  type EndpointRes (Verb method statusCode contentTypes responseType) = responseType+  reifiedEndpointArguments = V.RNil++instance ToReifiedEndpoint (NoContentVerb method)+  where+  type EndpointArgs (NoContentVerb method) = '[]+  type EndpointRes (NoContentVerb method) = NoContent+  reifiedEndpointArguments = V.RNil++instance+  (ToReifiedEndpoint endpoint) =>+  ToReifiedEndpoint ((x :: Symbol) :> endpoint)+  where+  type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint+  type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments = reifiedEndpointArguments @endpoint++instance+  (ToReifiedEndpoint endpoint) =>+  ToReifiedEndpoint (RemoteHost :> endpoint)+  where+  type EndpointArgs (RemoteHost :> endpoint) = EndpointArgs endpoint+  type EndpointRes (RemoteHost :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments = reifiedEndpointArguments @endpoint++++instance+  (ToReifiedEndpoint endpoint) =>+  ToReifiedEndpoint (Description s :> endpoint)+  where+  type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint+  type EndpointRes (Description s :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments = reifiedEndpointArguments @endpoint++instance+  (ToReifiedEndpoint endpoint) =>+  ToReifiedEndpoint (Summary s :> endpoint)+  where+  type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint+  type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments = reifiedEndpointArguments @endpoint++instance+  (Typeable requestType+  ,BuildFrom requestType+  ,ToReifiedEndpoint endpoint) =>+  ToReifiedEndpoint (QueryFlag name :> endpoint)+  where+  type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint+  type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint++type IfLenient s mods t  = If (FoldLenient mods) (Either s t) t+type IfRequired mods t = If (FoldRequired mods) t (Maybe t)+type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)++instance+  ( BuildFrom (IfRequiredLenient T.Text mods paramType)+  , ToReifiedEndpoint endpoint+  ) =>+  ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)+  where+  type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint+  type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments =+   tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))+      V.:& reifiedEndpointArguments @endpoint+++instance+  ( BuildFrom paramType+  , ToReifiedEndpoint endpoint+  , Show paramType+  , Eq paramType+  ) =>+  ToReifiedEndpoint (QueryParams name paramType :> endpoint)+  where+  type EndpointArgs (QueryParams name paramType :> endpoint) =  [paramType] ': EndpointArgs endpoint+  type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments =+    tagType (Argument (buildFrom @[paramType]))+      V.:& reifiedEndpointArguments @endpoint+++++instance+  ( BuildFrom (IfRequiredLenient T.Text mods headerType)+  , ToReifiedEndpoint endpoint+  ) =>+  ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)+  where+  type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint+  type EndpointRes  (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments =+   tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))+      V.:& reifiedEndpointArguments @endpoint++#if MIN_VERSION_servant(0,17,0)+instance+  ( BuildFrom (IfLenient String mods captureType)+  , ToReifiedEndpoint endpoint) =>+  ToReifiedEndpoint (Capture' mods name captureType :> endpoint)+  where+  type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint+  type EndpointRes  (Capture' mods name captureType :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments =+   tagType (Argument (buildFrom @(IfLenient String mods captureType)))+      V.:& reifiedEndpointArguments @endpoint+#else+instance+  ( BuildFrom captureType+  , ToReifiedEndpoint endpoint) =>+  ToReifiedEndpoint (Capture' mods name captureType :> endpoint)+  where+  type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint+  type EndpointRes  (Capture' mods name captureType :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments =+   tagType (Argument (buildFrom @(captureType)))+      V.:& reifiedEndpointArguments @endpoint++#endif++instance+  ( BuildFrom (IfLenient String mods requestType)+  , ToReifiedEndpoint endpoint) =>+  ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)+  where+  type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint+  type EndpointRes  (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint+  reifiedEndpointArguments =+   tagType (Argument (buildFrom @(IfLenient String mods requestType)))+      V.:& reifiedEndpointArguments @endpoint

@@ -0,0 +1,114 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where++import Servant++import Control.Monad.Except (runExceptT)+import Data.Bifunctor+import Data.Dynamic (Dynamic)+import Data.List.NonEmpty (NonEmpty)+import Data.Typeable (Typeable)+import Roboservant.Types.Breakdown+import Roboservant.Types.ReifiedApi++import qualified Data.Text as T+import qualified Data.Vinyl.Curry as V+import Data.Hashable(Hashable)++type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]+++class ToReifiedApi endpoints where+  toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi++instance ToReifiedApi '[] where+  toReifiedApi NoEndpoints _ = []++instance+  ( NormalizeFunction (ServerT endpoint Handler)+  , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))+  , ToReifiedEndpoint endpoint+  , ToReifiedApi endpoints+  ) =>+  ToReifiedApi (endpoint : endpoints)+  where+  toReifiedApi (endpoint `AnEndpoint` endpoints) _ =+    (0, ReifiedEndpoint+         { reArguments    = reifiedEndpointArguments @endpoint+         , reEndpointFunc = normalize endpoint+         }+    )+      : (map . first) (+1)+        (toReifiedApi endpoints (Proxy @endpoints))+++instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where+  type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))+  normalize handler = (runExceptT . runHandler') handler >>= \case+    Left serverError -> pure (Left (renderServerError serverError))+      where+        -- | TODO improve this+        renderServerError :: ServerError -> InteractionError+        renderServerError s = InteractionError (T.pack $ show s) (errHTTPCode serverError == 500)++    Right x -> pure $ Right $ breakdown x+++--          case errHTTPCode serverError of+--            500 -> throw serverError+--            _ ->+--              liftIO . logInfo . show $ ("ignoring non-500 error", serverError)+++data Bundled endpoints where+  -- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)+  AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)+  NoEndpoints :: Bundled '[]++class FlattenServer api where+  flattenServer :: Server api -> Bundled (Endpoints api)++instance+  ( FlattenServer api,+    Endpoints endpoint ~ '[endpoint]+  ) =>+  FlattenServer (endpoint :<|> api)+  where+  flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server++instance+ (+   Endpoints api ~ '[api]+ ) =>+  FlattenServer (x :> api)+  where+  flattenServer server = server `AnEndpoint` NoEndpoints++instance FlattenServer (Verb method statusCode contentTypes responseType)+  where+  flattenServer server = server `AnEndpoint` NoEndpoints++class NormalizeFunction m where+  type Normal m+  normalize :: m -> Normal m++instance NormalizeFunction x => NormalizeFunction (r -> x) where+  type Normal (r -> x) = r -> Normal x+  normalize = fmap normalize

@@ -0,0 +1,50 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Breakdown where++import Data.Aeson+import Data.Hashable+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Servant++data Foo = Foo Int String+  deriving (Generic, Eq, Show, Typeable)++instance Hashable Foo++instance ToJSON Foo++instance FromJSON Foo++data SomeSum = A Int | B String+  deriving (Generic, Eq, Show, Typeable)++instance Hashable SomeSum++instance ToJSON SomeSum++instance FromJSON SomeSum++type ProductApi =+  "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()+    :<|> "getFoo" :> Get '[JSON] Foo++eliminate :: Int -> Handler ()+eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}++productServer :: Server ProductApi+productServer = eliminate :<|> pure (Foo 12 "abc")++type SumApi =+  "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()+    :<|> "getFoo1" :> Get '[JSON] SomeSum+    :<|> "getFoo2" :> Get '[JSON] SomeSum++sumServer :: Server SumApi+sumServer = eliminate :<|> pure (B "hi") :<|> pure (A 3)

@@ -8,6 +8,7 @@ module Foo where  import Data.Aeson+import Data.Hashable import Data.Typeable (Typeable) import GHC.Generics (Generic) import Servant@@ -16,11 +17,13 @@   deriving (Generic, Eq, Show, Typeable)   deriving newtype (FromHttpApiData, ToHttpApiData) +instance Hashable Foo+ instance ToJSON Foo  instance FromJSON Foo -type FooApi =+type Api =   "item" :> Get '[JSON] Foo     :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo     :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()@@ -36,8 +39,8 @@   | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"}   | otherwise = pure () -fooServer :: Server FooApi-fooServer =+server :: Server Api+server =   intro     :<|> combine     :<|> eliminate

@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Headers where++import Data.Aeson+import Data.Hashable+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Servant++newtype Foo = Foo Int+  deriving (Generic, Eq, Show, Typeable)+  deriving newtype (FromHttpApiData, ToHttpApiData)++instance Hashable Foo++instance ToJSON Foo++instance FromJSON Foo++type Api =+  "item" :> Get '[JSON] Foo+    :<|> "itemAdd" :> Header "one" Foo :> Header "two" Foo :> Get '[JSON] Foo+    :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()++intro :: Handler Foo+intro = pure (Foo 1)++combine :: Maybe Foo -> Maybe Foo -> Handler Foo+combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))+combine (Just a) Nothing = pure a+combine Nothing (Just a) = pure a+combine Nothing Nothing = pure (Foo 1)++eliminate :: Foo -> Handler ()+eliminate (Foo a)+  | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"}+  | otherwise = pure ()++server :: Server Api+server =+  intro+    :<|> combine+    :<|> eliminate

@@ -0,0 +1,23 @@+{-# LANGUAGE DataKinds #-}++{-# LANGUAGE DerivingStrategies #-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Nested where++import Servant+import Servant.API.Flatten++type Api =+  ( "one" :> Summary "foo" :> Post '[JSON] Int+      :<|> "two" :> Post '[JSON] Int+  )+    :<|> ( "three" :> Post '[JSON] Int+         )++type FlatApi = Flat Api++server :: Server FlatApi+server = pure 1 :<|> pure 2 :<|> pure 3

@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+++{-# LANGUAGE TypeOperators #-}++module Post where++import Data.Aeson+import Data.Hashable+import GHC.Generics (Generic)+import Servant++type Api =+  Get '[JSON] FooPost+    :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()++data FooPost = FooPost+  deriving (Eq, Show, Generic)++instance Hashable FooPost++instance ToJSON FooPost++instance FromJSON FooPost++server :: Server Api+server =+  pure FooPost+    :<|> const (pure ())

@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Product where++import Data.Aeson+import Data.Hashable+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Servant++data Foo = Foo Int String+  deriving (Generic, Eq, Show, Typeable)++instance Hashable Foo++instance ToJSON Foo++instance FromJSON Foo++type Api = "item" :> ReqBody '[JSON] Foo :> Post '[JSON] ()++eliminate :: Foo -> Handler ()+eliminate (Foo _a _b) = throwError $ err500 {errBody = "eliminate blew up, oh no!"}++server :: Server Api+server = eliminate

@@ -0,0 +1,33 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+++{-# LANGUAGE TypeOperators #-}++module Put where++import Data.Aeson+import Data.Hashable+import GHC.Generics (Generic)+import Servant++type Api =+  Get '[JSON] Foo+    :<|> ReqBody '[JSON] Foo :> Put '[JSON] ()+    :<|> ReqBody '[JSON] Foo :> Put '[JSON] NoContent++data Foo = Foo+  deriving (Eq, Show, Generic)++instance Hashable Foo++instance ToJSON Foo++instance FromJSON Foo++server :: Server Api+server =+  pure Foo+    :<|> const (pure ())+    :<|> const (pure NoContent)

@@ -0,0 +1,15 @@+{-# LANGUAGE DataKinds #-}++{-# LANGUAGE DerivingStrategies #-}+++{-# LANGUAGE TypeOperators #-}++module QueryParams where++import Servant++type Api = QueryParams "ints" Int :> Get '[JSON] [Int]++server :: Server Api+server  = pure

@@ -0,0 +1,33 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Seeded where++import Data.Aeson+import Data.Hashable+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Servant++newtype Seed = Seed Int+  deriving (Generic, Eq, Show, Typeable)+  deriving newtype (FromHttpApiData, ToHttpApiData)++instance ToJSON Seed++instance FromJSON Seed++instance Hashable Seed++type Api =+  Capture "seed" Seed :> Get '[JSON] ()+    :<|> Get '[JSON] ()++server :: Server Api+server =+  (\(Seed _) -> error "we blow up if we get here")+    :<|> pure ()

@@ -1,27 +1,170 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeFamilies #-} +import qualified Breakdown+import Data.Dynamic (toDyn)+import Data.Hashable (Hashable (hash))+import Data.Maybe (isNothing)+import Data.Void (Void) import qualified Foo-import Hedgehog (Group (..), checkSequential, withTests)-import qualified Roboservant as RS-import qualified UnsafeIO+import qualified Headers+import qualified Nested+import qualified Post+import qualified Put+import qualified Product+import qualified QueryParams+import qualified Roboservant as R+import qualified Roboservant.Server as RS+import qualified Roboservant.Client as RC+import qualified Seeded+import Test.Hspec+import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)+import qualified Valid+import Servant ( Server, Proxy(..), serve, Endpoints, HasServer ) --- | this is pretty bad. hopefully Jacob knows a better way of doing this.---   https://twitter.com/mwotton/status/1305189249646460933-assert :: String -> Bool -> IO ()-assert _ True = pure ()-assert err False = ioError $ userError err+import Servant.Client(ClientEnv, mkClientEnv, baseUrlPort, parseBaseUrl,HasClient,ClientM)+import Network.Wai(Application)+import qualified Network.Wai.Handler.Warp as Warp+import           Network.HTTP.Client       (newManager, defaultManagerSettings)+import Control.Monad((>=>)) --- | This is horribly laid out, sorry. Will fix at some point. main :: IO ()-main = do-  assert "should find an error in Foo" . not-    =<< checkSequential (Group "Foo" [("Foo", withTests 1000 $ RS.prop_sequential @Foo.FooApi Foo.fooServer)])-  -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it-  -- could: it's mostly here to show how to test for concurrency problems.-  unsafeServer <- UnsafeIO.makeServer-  -- this will not detect the error, as it requires concurrency.-  assert "should find nothing" =<< checkSequential (Group "Unsafe" [("Sequential", RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer)])-  -- this will!-  assert "should find with parallel check" . not-    =<< checkSequential (Group "Unsafe" [("Parallel", withTests 100000 $ RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer)])+main = hspec spec++fuzzBoth+  :: forall a .+     (R.ToReifiedApi (Endpoints a), HasServer a '[], RS.FlattenServer a, RC.ToReifiedClientApi (Endpoints a), RC.FlattenClient a,+     HasClient ClientM a)+  => String -> Server a -> R.Config -> (Maybe R.Report -> IO ()) -> Spec+fuzzBoth name server config condition = do+  it (name <> " via server") $+    RS.fuzz @a server config >>= condition++  around (withServer (serve (Proxy :: Proxy a) server)) $+    it (name <> " via client") $ \(clientEnv::ClientEnv) -> do+    RC.fuzz @a clientEnv config >>= condition++withServer :: Application -> ActionWith ClientEnv -> IO ()+withServer app action = Warp.testWithApplication (pure app) (genClientEnv >=> action)+  where genClientEnv port = do+          baseUrl <- parseBaseUrl "http://localhost"+          manager <- newManager defaultManagerSettings+          pure $ mkClientEnv manager (baseUrl { baseUrlPort = port })++spec :: Spec+spec = do+  describe "Basic usage" $ do+    describe "noError" $ do+      fuzzBoth @Valid.Api "find no error in a basic app" Valid.server R.defaultConfig (`shouldSatisfy` isNothing)+      fuzzBoth @Valid.RoutedApi "finds no error in a valid generic app"   Valid.routedServer R.defaultConfig (`shouldSatisfy` isNothing)+      fuzzBoth @Valid.Api "fails coverage check" Valid.server R.defaultConfig {R.coverageThreshold = 0.6}+        (\r ->+           fmap (R.failureReason . R.rsException) r+           `shouldSatisfy` ( \case+                               Just (R.InsufficientCoverage _) -> True+                               _ -> False+                           ))+    describe "posted body" $+      fuzzBoth @Post.Api "passes a coverage check using a posted body" Post.server R.defaultConfig {R.coverageThreshold = 0.99}+      (`shouldSatisfy` isNothing)+++    describe "PUTted body" $+      fuzzBoth @Put.Api "passes a coverage check using a posted body" Put.server R.defaultConfig {R.coverageThreshold = 0.99}+      (`shouldSatisfy` isNothing)+++    describe "seeded" $ do+      let res = Seeded.Seed 1+      shouldFail $ fuzzBoth @Seeded.Api "finds an error using information passed in" Seeded.server+        (R.defaultConfig {R.seed = [(toDyn res, hash res)]})+        (`shouldSatisfy` isNothing)++    describe "Foo" $+      fuzzBoth @Foo.Api "finds an error in a basic app" Foo.server R.defaultConfig (`shouldSatisfy` serverFailure)++    describe "QueryParams" $+      fuzzBoth @QueryParams.Api "can handle query params" QueryParams.server R.defaultConfig { R.seed = [R.hashedDyn (12::Int)] }+      (`shouldSatisfy` isNothing)++  describe "BuildFrom" $ do+    describe "headers (and sum types)" $+      fuzzBoth @Headers.Api "should find a failure that's dependent on using header info" Headers.server R.defaultConfig+      (`shouldSatisfy` serverFailure)+    describe "product types" $+      fuzzBoth @Product.Api "should find a failure that's dependent on creating a product" Product.server+      R.defaultConfig {R.seed = [R.hashedDyn 'a', R.hashedDyn (1 :: Int)]}+      (`shouldSatisfy` serverFailure)+  describe "Breakdown" $ do+    fuzzBoth @Breakdown.ProductApi "handles products"  Breakdown.productServer R.defaultConfig+      (`shouldSatisfy` serverFailure)+    fuzzBoth @Breakdown.SumApi "handles sums" Breakdown.sumServer R.defaultConfig+      (`shouldSatisfy` serverFailure)+  describe "flattening" $+    fuzzBoth @Nested.FlatApi "can handle nested apis" Nested.server R.defaultConfig {R.coverageThreshold = 0.99}+    (`shouldSatisfy` isNothing)++serverFailure :: Maybe R.Report -> Bool+serverFailure = \case+  Just R.Report {..} ->+    let R.RoboservantException {..} = rsException+     in failureReason /= R.NoPossibleMoves+  _ -> False++deriving via (R.Atom Foo.Foo) instance R.Breakdown Foo.Foo++deriving via (R.Atom Foo.Foo) instance R.BuildFrom Foo.Foo++deriving via (R.Atom Headers.Foo) instance R.Breakdown Headers.Foo++deriving via (R.Atom Headers.Foo) instance R.BuildFrom Headers.Foo++deriving via (R.Atom Seeded.Seed) instance R.Breakdown Seeded.Seed++deriving via (R.Atom Seeded.Seed) instance R.BuildFrom Seeded.Seed++deriving via (R.Atom Void) instance R.BuildFrom Void++deriving via (R.Atom Post.FooPost) instance R.Breakdown Post.FooPost+deriving via (R.Atom Post.FooPost) instance R.BuildFrom Post.FooPost++deriving via (R.Atom Put.Foo) instance R.Breakdown Put.Foo+deriving via (R.Atom Put.Foo) instance R.BuildFrom Put.Foo++++deriving via (R.Compound Breakdown.Foo) instance R.Breakdown Breakdown.Foo++deriving via (R.Compound Product.Foo) instance R.BuildFrom Product.Foo++deriving via (R.Compound Breakdown.SomeSum) instance R.Breakdown Breakdown.SomeSum++-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.+--   this is often useful when testing tests.+shouldFail :: SpecWith a -> SpecWith a+shouldFail =+  mapSpecItem_+    ( \i ->+        i+          { itemExample = \p a cb -> do+              r <- itemExample i p a cb+              pure+                r+                  { resultStatus = case resultStatus r of+                      Success -> Failure Nothing (Reason "Unexpected success")+                      Failure _ _ -> Success+                      x -> x+                  }+          }+    )

@@ -1,41 +1,39 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}+ {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-}  module UnsafeIO where -import Data.Aeson()-import Servant-import Data.IORef (writeIORef, IORef, readIORef, newIORef)-import Control.Monad.Trans (MonadIO(liftIO))+import Control.Monad.Trans (MonadIO (liftIO))+import Data.Aeson () import qualified Data.ByteString.Lazy.Char8 as BL8-+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Servant  type UnsafeApi =   "add" :> Get '[JSON] ()-  :<|> "healthcheck" :> Get '[JSON] ()+    :<|> "healthcheck" :> Get '[JSON] ()  healthcheck :: IORef Int -> Handler () healthcheck ref = do   t <- liftIO $ readIORef ref   case t of     0 -> pure ()-    n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}--+    n -> throwError $ err500 {errBody = "observed inconsistency: " <> BL8.pack (show n)}  makeServer :: IO (Server UnsafeApi) makeServer = do   ref <- newIORef 0-  pure $ unsafeMunge ref-    :<|> healthcheck ref+  pure $+    unsafeMunge ref+      :<|> healthcheck ref  unsafeMunge :: IORef Int -> Handler () unsafeMunge ref = liftIO $ do   t <- readIORef ref-  writeIORef ref (t+1)+  writeIORef ref (t + 1)   t2 <- readIORef ref-  writeIORef ref (t2-1)+  writeIORef ref (t2 -1)

@@ -0,0 +1,44 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Valid where++import Data.Void+import GHC.Generics+import Servant+import Servant.Server.Generic++type Api =+  Get '[JSON] Int+    :<|> Capture "void" Void :> Get '[JSON] ()++data Routes route+  = Routes+      { getInt ::+          route+            :- Summary "i'm a summary!" :> Get '[JSON] Int,+        captureIt ::+          route+            :- Capture "void" Void :> Get '[JSON] ()+      }+  deriving (Generic)++type RoutedApi = ToServantApi Routes++-- routedApi = genericApi (Proxy :: Proxy Routes)+routedServer :: Server RoutedApi+routedServer = genericServer routes++routes :: Routes AsServer+routes =+  Routes+    { getInt = pure 7,+      captureIt = const (pure ())+    }++server :: Server Api+server = pure 7 :<|> const (pure ())