diff --git a/EXAMPLE.md b/EXAMPLE.md new file mode 120000 index 0000000..3ba15dc --- /dev/null +++ b/EXAMPLE.md @@ -0,0 +1 @@ +Example.lhs \ No newline at end of file diff --git a/Example.lhs b/Example.lhs new file mode 100644 index 0000000..ee4cf0b --- /dev/null +++ b/Example.lhs @@ -0,0 +1,112 @@ +# 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 #-} + +import Roboservant +import Test.Hspec +import Servant +import GHC.Generics +import Data.Typeable +import Data.Hashable + +newtype A = A Int + deriving (Generic, Eq, Show, Typeable) + deriving newtype (Hashable, FromHttpApiData, ToHttpApiData) + +newtype B = B Int + deriving (Generic, Eq, Show, Typeable) + deriving newtype (Hashable, FromHttpApiData, ToHttpApiData) + +type Api = + "item" :> Get '[JSON] A + :<|> "itemAdd" :> Capture "one" B :> Capture "two" B :> Get '[JSON] B + :<|> "item" :> Capture "itemId" B :> Get '[JSON] () + +goodServer = server (pure $ A 0) +badServer = server (pure $ A 1) + +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 () +``` + +Our tests would usually be in a separate file: + +```haskell + + +defaultConfig :: Config +defaultConfig = Config { + -- you can pass extra values in using the seed argument. This can be useful + -- for things that might not be produceable within the api, like auth tokens. + seed = [] + , maxRuntime = 0.5 + -- if we get to 1000 interactions with the api, call it quits. + , maxReps = 1000 + -- if you're using this inside quickcheck or hedgehog, you might want to set this + -- from their seed to make sure it stays deterministic + , rngSeed = 0 + -- 0 to 100: fail tests if we hit less than this percentage of endpoints. + , coverageThreshold = 0 + } + +spec = describe "example" $ do + it "good server should not fail" $ do + fuzz @Api goodServer defaultConfig { coverageThreshold = 0.99 } (pure ()) + >>= (`shouldSatisfy` isNothing) + it "bad server should fail" $ do + fuzz @Api badServer defaultConfig { coverageThreshold = 0.99 } (pure ()) + >>= (`shouldSatisfy` serverFailure) +``` + +And 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 +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 + + +main = hspec spec +``` + +finally some uninteresting utilities + +```haskell +serverFailure :: Maybe Report -> Bool +serverFailure c = case c of + Just Report{..} -> + let RoboservantException{..} = rsException + in failureReason /= NoPossibleMoves + _ -> False + +isNothing x = case x of + Nothing -> True + _ -> False +``` diff --git a/README.md b/README.md index 8ab58bd..01da707 100644 --- a/README.md +++ b/README.md @@ -4,43 +4,18 @@ Automatically fuzz your servant apis in a contextually-aware way. ![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg) +## 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 -Our api under test: - -``` -newtype Foo = Foo Int - deriving (Generic, Eq, Show, Typeable) - deriving newtype (FromHttpApiData, ToHttpApiData) - -type FooApi = - "item" :> Get '[JSON] Foo - :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo - :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] () -``` - -From the tests: - -``` - assert "should find an error in Foo" . not - =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential @Foo.FooApi Foo.fooServer)]) -``` - -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 - - -# why not servant-quickcheck? +## 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, diff --git a/package.yaml b/package.yaml index b717f7c..6f86f55 100644 --- a/package.yaml +++ b/package.yaml @@ -54,3 +54,13 @@ tests: - hspec - hspec-core - http-api-data + + example: + main: Example.lhs + source-dirs: . + + dependencies: + - roboservant + - hspec + build-depends: base, markdown-unlit + ghc-options: -pgmL markdown-unlit diff --git a/roboservant.cabal b/roboservant.cabal index 481558e..c83d25a 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 3b8eaf26233853cd94e20de7f84c25d6124cd919072681c3287a761526f82b9e +-- hash: 8de468df6e784f3723af9155bba9da9f43659b7d4e8e465fdac26eafcb0d4306 name: roboservant version: 0.1.0.2 @@ -62,6 +62,38 @@ library , 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-depends: + base >=4.7 && <5 + , bytestring + , containers + , dependent-map + , dependent-sum + , hashable + , hspec + , lifted-base + , monad-control + , mtl + , random + , roboservant + , servant + , servant-client + , servant-flatten + , servant-server + , string-conversions + , text + , time + , unordered-containers + , vinyl + default-language: Haskell2010 + test-suite roboservant-test type: exitcode-stdio-1.0 main-is: Spec.hs diff --git a/src/Roboservant/Types.hs b/src/Roboservant/Types.hs index 3f5b4e9..865dd02 100644 --- a/src/Roboservant/Types.hs +++ b/src/Roboservant/Types.hs @@ -2,15 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Roboservant.Types diff --git a/src/Roboservant/Types/Breakdown.hs b/src/Roboservant/Types/Breakdown.hs index c842423..9d6c632 100644 --- a/src/Roboservant/Types/Breakdown.hs +++ b/src/Roboservant/Types/Breakdown.hs @@ -31,7 +31,7 @@ class Breakdown x where breakdownExtras :: x -> [(Dynamic,Int)] instance (Hashable x, Typeable x) => Breakdown (Atom x) where - breakdownExtras (Atom x) = [(toDyn x, hash x)] + breakdownExtras _ = [] deriving via (Atom ()) instance Breakdown () deriving via (Atom Int) instance Breakdown Int @@ -49,7 +49,6 @@ instance GBreakdown f => GBreakdown (M1 S c f ) where 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 diff --git a/src/Roboservant/Types/BuildFrom.hs b/src/Roboservant/Types/BuildFrom.hs index 8f6f5d5..8933cf4 100644 --- a/src/Roboservant/Types/BuildFrom.hs +++ b/src/Roboservant/Types/BuildFrom.hs @@ -9,13 +9,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} - - - - - - - module Roboservant.Types.BuildFrom where import Control.Monad(filterM) @@ -29,8 +22,6 @@ import Roboservant.Types.Internal import Data.Hashable import qualified Data.IntSet as IntSet import GHC.Generics --- import Roboservant.Types.GBuildFrom(GBuildFrom(..)) - buildFrom :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x) buildFrom = buildStash . buildFrom' @@ -73,9 +64,9 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom 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 (BuildFrom x) => BuildFrom [x] where - extras stash = map (\xs -> (concatMap fst xs,map snd xs)) $ powerset $ take 3 $ extras @x stash + extras stash = map (\xs -> (concatMap fst xs,map snd xs)) $ powerset $ extras @x stash where - powerset xs = filterM (\_ -> [True, False]) xs + powerset xs = filterM (const [True, False]) xs instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x::Type)) where extras stash = fmap (Compound . to) <$> gExtras stash @@ -83,14 +74,13 @@ instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (C deriving via (Atom Int) instance BuildFrom Int deriving via (Atom Char) instance BuildFrom Char - class GBuildFrom (f :: k -> *) 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) @@ -98,9 +88,6 @@ instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where 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 diff --git a/src/Roboservant/Types/FlattenServer.hs b/src/Roboservant/Types/FlattenServer.hs index ddf0026..48d4b09 100644 --- a/src/Roboservant/Types/FlattenServer.hs +++ b/src/Roboservant/Types/FlattenServer.hs @@ -11,7 +11,6 @@ module Roboservant.Types.FlattenServer where import Servant - data Bundled endpoints where AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints) NoEndpoints :: Bundled '[] diff --git a/src/Roboservant/Types/ReifiedApi.hs b/src/Roboservant/Types/ReifiedApi.hs index 9d43dc2..036a0bf 100644 --- a/src/Roboservant/Types/ReifiedApi.hs +++ b/src/Roboservant/Types/ReifiedApi.hs @@ -7,10 +7,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -18,10 +15,8 @@ {-# LANGUAGE CPP #-} module Roboservant.Types.ReifiedApi where - import Control.Monad.Except (runExceptT) import Data.Bifunctor --- import Data.Dependent.Sum import Data.Dynamic (Dynamic) import Data.Kind import Data.List.NonEmpty (NonEmpty) @@ -165,7 +160,6 @@ instance tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType))) V.:& reifiedEndpointArguments @endpoint - instance ( BuildFrom (IfRequiredLenient T.Text mods headerType) , ToReifiedEndpoint endpoint @@ -178,8 +172,6 @@ instance tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType))) V.:& reifiedEndpointArguments @endpoint - --- this isn't happy in 0.16.2 #if MIN_VERSION_servant(0,17,0) instance ( BuildFrom (IfLenient String mods captureType) @@ -204,7 +196,6 @@ instance V.:& reifiedEndpointArguments @endpoint #endif --- caching for merge instance ( BuildFrom (IfLenient String mods requestType) diff --git a/test/Spec.hs b/test/Spec.hs index 5985930..4438363 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DerivingVia #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DerivingVia #-} @@ -15,14 +14,13 @@ import qualified Post import qualified Product import qualified Breakdown -import Test.Hspec.Core.Spec - -import Data.Dynamic(toDyn,Typeable,Dynamic) +import Test.Hspec.Core.Spec(ResultStatus(Failure,Success),resultStatus,itemExample,FailureReason(Reason),mapSpecItem_) +import Data.Dynamic(toDyn) import qualified Roboservant as RS import Test.Hspec -import Data.Void -import Data.Maybe -import Data.Hashable +import Data.Void ( Void ) +import Data.Maybe ( isNothing ) +import Data.Hashable ( Hashable(hash) ) main :: IO () main = hspec spec @@ -101,27 +99,6 @@ serverFailure = \case in failureReason /= RS.NoPossibleMoves _ -> False - -- describe "can build from pieces" $ do - -- it "should find a failure that requires some assembly" $ do - -- RS.fuzz @RS.BuildFrom.Api RS.BuildFrom.server defaultConfig noCheck - -- >>= (`shouldSatisfy` isJust) - - - - -- -- -- 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. - -- describe "concurrency bugs" $ do - -- before UnsafeIO.makeServer $ do - -- describe "sequential checking" $ do - -- it "safe use" $ \unsafeServer -> do - -- hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer [] - - -- modifyMaxSuccess (const 10000) $ - -- shouldFail $ - -- describe "concurrent" $ do - -- it "concurrent, dangerous use" $ \unsafeServer -> do - -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer [] - deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo @@ -144,19 +121,6 @@ deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum - - ---deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped ---deriving via (Compound RS.BuildFrom.Wrapped) instance RS.Breakdown RS.BuildFrom.Wrapped - - - --- deriving via (RS.Atom Void) instance RS.BuildFrom Void - --- instance RS.Breakdown Post.FooPost --- instance RS.BuildFrom Post.FooPost - - -- | `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