diff --git a/Example.lhs b/Example.lhs new file mode 100644 --- /dev/null +++ b/Example.lhs @@ -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 }) +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/roboservant.cabal b/roboservant.cabal --- a/roboservant.cabal +++ b/roboservant.cabal @@ -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 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 diff --git a/src/Roboservant.hs b/src/Roboservant.hs --- a/src/Roboservant.hs +++ b/src/Roboservant.hs @@ -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 diff --git a/src/Roboservant/Client.hs b/src/Roboservant/Client.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Client.hs @@ -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 diff --git a/src/Roboservant/Direct.hs b/src/Roboservant/Direct.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Direct.hs @@ -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) diff --git a/src/Roboservant/Server.hs b/src/Roboservant/Server.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Server.hs @@ -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)) + diff --git a/src/Roboservant/StateMachine.hs b/src/Roboservant/StateMachine.hs deleted file mode 100644 --- a/src/Roboservant/StateMachine.hs +++ /dev/null @@ -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 diff --git a/src/Roboservant/Types.hs b/src/Roboservant/Types.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Types.hs @@ -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() diff --git a/src/Roboservant/Types/Breakdown.hs b/src/Roboservant/Types/Breakdown.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Types/Breakdown.hs @@ -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 diff --git a/src/Roboservant/Types/BuildFrom.hs b/src/Roboservant/Types/BuildFrom.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Types/BuildFrom.hs @@ -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 diff --git a/src/Roboservant/Types/Config.hs b/src/Roboservant/Types/Config.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Types/Config.hs @@ -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} diff --git a/src/Roboservant/Types/Internal.hs b/src/Roboservant/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Types/Internal.hs @@ -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) diff --git a/src/Roboservant/Types/Orphans.hs b/src/Roboservant/Types/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Types/Orphans.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Roboservant.Types.Orphans where + +import Servant +import Data.Hashable + +instance Hashable NoContent diff --git a/src/Roboservant/Types/ReifiedApi.hs b/src/Roboservant/Types/ReifiedApi.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Types/ReifiedApi.hs @@ -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 diff --git a/src/Roboservant/Types/ReifiedApi/Server.hs b/src/Roboservant/Types/ReifiedApi/Server.hs new file mode 100644 --- /dev/null +++ b/src/Roboservant/Types/ReifiedApi/Server.hs @@ -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 diff --git a/test/Breakdown.hs b/test/Breakdown.hs new file mode 100644 --- /dev/null +++ b/test/Breakdown.hs @@ -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) diff --git a/test/Foo.hs b/test/Foo.hs --- a/test/Foo.hs +++ b/test/Foo.hs @@ -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 diff --git a/test/Headers.hs b/test/Headers.hs new file mode 100644 --- /dev/null +++ b/test/Headers.hs @@ -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 diff --git a/test/Nested.hs b/test/Nested.hs new file mode 100644 --- /dev/null +++ b/test/Nested.hs @@ -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 diff --git a/test/Post.hs b/test/Post.hs new file mode 100644 --- /dev/null +++ b/test/Post.hs @@ -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 ()) diff --git a/test/Product.hs b/test/Product.hs new file mode 100644 --- /dev/null +++ b/test/Product.hs @@ -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 diff --git a/test/Put.hs b/test/Put.hs new file mode 100644 --- /dev/null +++ b/test/Put.hs @@ -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) diff --git a/test/QueryParams.hs b/test/QueryParams.hs new file mode 100644 --- /dev/null +++ b/test/QueryParams.hs @@ -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 diff --git a/test/Seeded.hs b/test/Seeded.hs new file mode 100644 --- /dev/null +++ b/test/Seeded.hs @@ -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 () diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 + } + } + ) diff --git a/test/UnsafeIO.hs b/test/UnsafeIO.hs --- a/test/UnsafeIO.hs +++ b/test/UnsafeIO.hs @@ -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) diff --git a/test/Valid.hs b/test/Valid.hs new file mode 100644 --- /dev/null +++ b/test/Valid.hs @@ -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 ())