git.iko.soy/roboservant
on master help sign in
new test, better diagnostic display
commit7f36587ba32f385c7075eb6a61da0a2396229ac0 authorMark Wotton <mwotton@gmail.com> dateWed 18 Nov 2020, 13:04 (6 years ago) parent288f801
4 files changed+60−12
compare with master
unifiedsplit
roboservant.cabal+2−1 src/Roboservant/Direct.hs+15−9 test/Post.hs+25 test/Spec.hs+18−2
roboservant.cabal+2−1
@@ -4,7 +4,7 @@ cabal-version: 1.12
44--
55-- see: https://github.com/sol/hpack
66--
7−-- hash: 838fa22fc3ea6673432f485653caaca6c43bccce724777fafbb903dad8ce30cd
7+-- hash: d00686eca2b790a054d75ee02699e0505188e10e975cd6ebc7b06eeeb82923b4
88
99name: roboservant
1010version: 0.1.0.2
@@ -62,6 +62,7 @@ test-suite roboservant-test
6262 other-modules:
6363 Foo
6464 Headers
65+ Post
6566 Seeded
6667 UnsafeIO
6768 Valid
src/Roboservant/Direct.hs+15−9
@@ -39,6 +39,7 @@ import System.Random(StdGen,randomR,mkStdGen)
3939import qualified Data.List.NonEmpty as NEL
4040import qualified Data.Map.Strict as Map
4141import Data.Time.Clock
42+import Data.List(sortOn)
4243
4344import Roboservant.Types.Breakdown
4445import Roboservant.Types
@@ -108,9 +109,6 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
108109
109110
110111 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
111− -- either we time out without finding an error, which is fine, or we find an error
112− -- and throw an exception that propagates through this.
113−
114112 (stopreason, fs ) <- runStateT
115113 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
116114 pure Nothing
@@ -122,13 +120,19 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
122120 formatException r@(RoboservantException failureType exception _state) = Report
123121 (unlines [ show failureType , show exception ])
124122 r
125−
123+
124+ displayDiagnostics FuzzState{..} = liftIO $ do
125+ putStrLn "api endpoints covered"
126+ mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
127+ putStrLn ""
128+ putStrLn "types in stash"
129+ mapM_ print (map (\x -> (fst x, NEL.length (snd x))) . sortOn fst . Map.toList $ stash)
130+
126131 -- evaluateCoverage :: FuzzState -> m ()
127132 evaluateCoverage f@FuzzState{..}
128133 | coverage > coverageThreshold = pure ()
129134 | otherwise = do
130− liftIO $ do putStrLn "api endpoints covered"
131− mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
135+ displayDiagnostics f
132136 throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
133137 where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
134138 totalRoutes = (fromIntegral routeCount)
@@ -213,13 +217,15 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
213217 fs { stash = addToStash (NEL.toList dyn) stash } )
214218 pure ()
215219
216− go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
217− => m ()
220+-- go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
221+-- => m ()
218222 go = do
219223 op <- genOp
220224 catches (execute op)
221225 [ Handler (\(e :: SomeAsyncException) -> throw e)
222− , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get)
226+ , Handler (\(e :: SomeException) -> do
227+ displayDiagnostics =<< get
228+ throw . RoboservantException ServerCrashed (Just e) =<< get)
223229 ]
224230 catch (liftIO checker)
225231 (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
test/Post.hsnew file+25
@@ -0,0 +1,25 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Post where
9+
10+import GHC.Generics (Generic)
11+import Servant
12+import Data.Aeson
13+
14+type Api = Get '[JSON] FooPost
15+ :<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
16+
17+data FooPost = FooPost
18+ deriving (Eq,Show,Generic)
19+
20+instance ToJSON FooPost
21+instance FromJSON FooPost
22+
23+server :: Server Api
24+server = pure FooPost
25+ :<|> const (pure ())
test/Spec.hs+18−2
@@ -1,11 +1,13 @@
11
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE TypeApplications #-}
4+{-# LANGUAGE LambdaCase #-}
45{-# OPTIONS_GHC -fno-warn-orphans #-}
56import qualified Foo
67import qualified Seeded
78import qualified Valid
89import qualified Headers
10+import qualified Post
911-- import qualified UnsafeIO
1012
1113import Data.Dynamic(toDyn)
@@ -34,16 +36,27 @@ spec = do
3436 >>= (`shouldSatisfy` isNothing)
3537 it "does fail coverage check" $ do
3638 r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
37− fmap (RS.failureReason . RS.rsException) r `shouldBe` Just RS.InsufficientCoverage
39+ fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
40+ (\case
41+ Just (RS.InsufficientCoverage _) -> True
42+ _ -> False)
43+
44+ describe "posted body" $ do
45+ it "passes a coverage check using a posted body" $ do
46+ RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
47+ >>= (`shouldSatisfy` isNothing)
48+
3849 describe "seeded" $ do
3950 shouldFail $
4051 it "finds an error using information passed in" $
4152 RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
4253 >>= (`shouldSatisfy` isNothing)
54+ describe "Foo" $ do
4355 shouldFail $ it "finds an error in a basic app" $
4456 RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
4557 >>= (`shouldSatisfy` isNothing)
46−
58+
59+ describe "headers" $ do
4760 shouldFail $ it "should find a failure that's dependent on using header info" $ do
4861 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
4962 >>= (`shouldSatisfy` isNothing)
@@ -77,3 +90,6 @@ instance RS.BuildFrom Headers.Foo
7790instance RS.BuildFrom Seeded.Seed
7891
7992instance RS.BuildFrom Void
93+
94+instance RS.Breakdown Post.FooPost
95+instance RS.BuildFrom Post.FooPost