git.iko.soy/roboservant
on master help sign in
coverage
288f801Mark Wotton
src/Roboservant/Direct.hs+24−17
compare with master
unifiedsplit
@@ -21,7 +21,7 @@ module Roboservant.Direct
21
21
22 -- TODO come up with something smarter than exporting all this, we should
22 -- TODO come up with something smarter than exporting all this, we should
23 -- have some nice error-display functions
23 -- have some nice error-display functions
24− , RoboservantException(..), FuzzState(..), FuzzOp(..)
24+ , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
25 )
25 )
26where
26where
27
27
@@ -36,7 +36,6 @@ import Data.Maybe (mapMaybe)
36import Data.Typeable (TypeRep)
36import Data.Typeable (TypeRep)
37import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
37import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
38import System.Random(StdGen,randomR,mkStdGen)
38import System.Random(StdGen,randomR,mkStdGen)
39−import System.Timeout.Lifted(timeout)
40import qualified Data.List.NonEmpty as NEL
39import qualified Data.List.NonEmpty as NEL
41import qualified Data.Map.Strict as Map
40import qualified Data.Map.Strict as Map
42import Data.Time.Clock
41import Data.Time.Clock
@@ -50,16 +49,19 @@ import Roboservant.Types
50 )
49 )
51
50
52data RoboservantException
51data RoboservantException
53− = RoboservantException FailureType (Maybe SomeException) Int FuzzState
52+ = RoboservantException
53+ { failureReason :: FailureType
54+ , serverException :: Maybe SomeException
55+ , fuzzState :: FuzzState
54− deriving (Show)
56+ } deriving (Show)
55−-- we believe in nussink, lebowski
57+
56instance Exception RoboservantException
58instance Exception RoboservantException
57
59
58data FailureType
60data FailureType
59 = ServerCrashed
61 = ServerCrashed
60 | CheckerFailed
62 | CheckerFailed
61 | NoPossibleMoves
63 | NoPossibleMoves
62− | InsufficientCoverage
64+ | InsufficientCoverage Double
63 deriving (Show,Eq)
65 deriving (Show,Eq)
64
66
65
67
@@ -90,8 +92,9 @@ data StopReason
90 deriving (Show,Eq)
92 deriving (Show,Eq)
91
93
92data Report = Report
94data Report = Report
93− { textual :: String }
95+ { textual :: String
96+ , rsException :: RoboservantException}
94− deriving (Show,Eq)
97+ deriving (Show)
95
98
96fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
99fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
97 => Server api
100 => Server api
@@ -116,16 +119,20 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
116 where
119 where
117 -- something less terrible later
120 -- something less terrible later
118 formatException :: RoboservantException -> Report
121 formatException :: RoboservantException -> Report
119− formatException = Report . show
122+ formatException r@(RoboservantException failureType exception _state) = Report
120−
123+ (unlines [ show failureType , show exception ])
124+ r
125+
121 -- evaluateCoverage :: FuzzState -> m ()
126 -- evaluateCoverage :: FuzzState -> m ()
122 evaluateCoverage f@FuzzState{..}
127 evaluateCoverage f@FuzzState{..}
123− | hitRoutes / totalRoutes > coverageThreshold = do
128+ | coverage > coverageThreshold = pure ()
124− liftIO $ print ("passed coverage", hitRoutes, totalRoutes)
129+ | otherwise = do
125− pure ()
130+ liftIO $ do putStrLn "api endpoints covered"
131+ mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
126− | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
132+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
127 where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
133 where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
128 totalRoutes = (fromIntegral routeCount)
134 totalRoutes = (fromIntegral routeCount)
135+ coverage = hitRoutes / totalRoutes
129
136
130
137
131 untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
138 untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
@@ -143,7 +150,7 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
143
150
144 elementOrFail :: (MonadState FuzzState m, MonadIO m)
151 elementOrFail :: (MonadState FuzzState m, MonadIO m)
145 => [a] -> m a
152 => [a] -> m a
146− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
153+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
147 elementOrFail l = do
154 elementOrFail l = do
148 st <- get
155 st <- get
149 let (index,newGen) = randomR (0, length l - 1) (currentRng st)
156 let (index,newGen) = randomR (0, length l - 1) (currentRng st)
@@ -212,10 +219,10 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
212 op <- genOp
219 op <- genOp
213 catches (execute op)
220 catches (execute op)
214 [ Handler (\(e :: SomeAsyncException) -> throw e)
221 [ Handler (\(e :: SomeAsyncException) -> throw e)
215− , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
222+ , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get)
216 ]
223 ]
217 catch (liftIO checker)
224 catch (liftIO checker)
218− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
225+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
219
226
220 -- actions <-
227 -- actions <-
221 -- forAll $ do
228 -- forAll $ do
test/Spec.hs+8−5
@@ -30,21 +30,24 @@ spec = do
30 describe "Basic usage" $ do
30 describe "Basic usage" $ do
31 describe "noError" $ do
31 describe "noError" $ do
32 it "finds no error in a valid app" $ do
32 it "finds no error in a valid app" $ do
33− RS.fuzz @Valid.Api Valid.server defaultConfig noCheck `shouldReturn` Nothing
33+ RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
34+ >>= (`shouldSatisfy` isNothing)
34 it "does fail coverage check" $ do
35 it "does fail coverage check" $ do
35 r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
36 r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
36− r `shouldSatisfy` isJust
37+ fmap (RS.failureReason . RS.rsException) r `shouldBe` Just RS.InsufficientCoverage
37 describe "seeded" $ do
38 describe "seeded" $ do
38 shouldFail $
39 shouldFail $
39 it "finds an error using information passed in" $
40 it "finds an error using information passed in" $
40 RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
41 RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
41− `shouldReturn` Nothing
42+ >>= (`shouldSatisfy` isNothing)
42 shouldFail $ it "finds an error in a basic app" $
43 shouldFail $ it "finds an error in a basic app" $
43 RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
44 RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
44− `shouldReturn` Nothing
45+ >>= (`shouldSatisfy` isNothing)
46+
45 shouldFail $ it "should find a failure that's dependent on using header info" $ do
47 shouldFail $ it "should find a failure that's dependent on using header info" $ do
46 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
48 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
47− `shouldReturn` Nothing
49+ >>= (`shouldSatisfy` isNothing)
50+
48 -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
51 -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
49 -- -- -- could: it's mostly here to show how to test for concurrency problems.
52 -- -- -- could: it's mostly here to show how to test for concurrency problems.
50 -- describe "concurrency bugs" $ do
53 -- describe "concurrency bugs" $ do