cleanup and example

EXAMPLE.md

@@ -0,0 +1 @@
+Example.lhs

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
+```

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,

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

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

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

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
 

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
 

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 '[]

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)

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