@@ -18,15 +18,20 @@
1818
1919module Roboservant.Direct
2020 ( fuzz, Config(..)
21+
22+ -- TODO come up with something smarter than exporting all this, we should
23+ -- have some nice error-display functions
24+ , RoboservantException(..), FuzzState(..), FuzzOp(..)
2125 )
2226where
2327
24−import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
28+import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
2529import Control.Monad(void,replicateM)
26−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
30+import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
2731import Control.Monad.Trans.Control(MonadBaseControl)
2832import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
2933import Data.Map.Strict(Map)
34+import qualified Data.Set as Set
3035import Data.Maybe (mapMaybe)
3136import Data.Typeable (TypeRep)
3237import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
@@ -34,6 +39,7 @@ import System.Random(StdGen,randomR,mkStdGen)
3439import System.Timeout.Lifted(timeout)
3540import qualified Data.List.NonEmpty as NEL
3641import qualified Data.Map.Strict as Map
42+import Data.Time.Clock
3743
3844import Roboservant.Types.Breakdown
3945import Roboservant.Types
@@ -44,7 +50,7 @@ import Roboservant.Types
4450 )
4551
4652data RoboservantException
47− = RoboservantException FailureType (Maybe SomeException) FuzzState
53+ = RoboservantException FailureType (Maybe SomeException) Int FuzzState
4854 deriving (Show)
4955-- we believe in nussink, lebowski
5056instance Exception RoboservantException
@@ -53,18 +59,22 @@ data FailureType
5359 = ServerCrashed
5460 | CheckerFailed
5561 | NoPossibleMoves
62+ | InsufficientCoverage
5663 deriving (Show,Eq)
5764
5865
59−data FuzzOp = FuzzOp ApiOffset [Provenance]
60− deriving (Show,Eq)
66+data FuzzOp = FuzzOp
67+ { apiOffset :: ApiOffset
68+ , provenance :: [Provenance]
69+ } deriving (Show,Eq)
6170
6271data Config
6372 = Config
6473 { seed :: [Dynamic]
65− , maxRuntime :: Int -- seconds to test for
66− , maxReps :: Int
74+ , maxRuntime :: Integer -- seconds to test for
75+ , maxReps :: Integer
6776 , rngSeed :: Int
77+ , coverageThreshold :: Double
6878 }
6979
7080data FuzzState = FuzzState
@@ -74,28 +84,66 @@ data FuzzState = FuzzState
7484 }
7585 deriving (Show)
7686
87+data StopReason
88+ = TimedOut
89+ | HitMaxIterations
90+ deriving (Show,Eq)
91+
92+data Report = Report
93+ { textual :: String }
94+ deriving (Show,Eq)
95+
7796fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
7897 => Server api
7998 -> Config
8099 -> IO ()
81− -> IO ()
82−fuzz server Config{..} checker = do
100+ -> IO (Maybe Report)
101+fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
83102 let path = []
84103 stash = addToStash seed mempty
85104 currentRng = mkStdGen rngSeed
105+
106+
107+ deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
86108 -- either we time out without finding an error, which is fine, or we find an error
87109 -- and throw an exception that propagates through this.
88−
89− void $ timeout (maxRuntime * 1000000) ( execStateT (replicateM maxReps go) FuzzState{..})
90− mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
110+
111+ (stopreason, fs ) <- runStateT
112+ (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
113+ pure Nothing
114+ -- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
91115
92116 where
93−
117+ -- something less terrible later
118+ formatException :: RoboservantException -> Report
119+ formatException = Report . show
120+
121+ -- evaluateCoverage :: FuzzState -> m ()
122+ evaluateCoverage f@FuzzState{..}
123+ | hitRoutes / totalRoutes > coverageThreshold = do
124+ liftIO $ print ("passed coverage", hitRoutes, totalRoutes)
125+ pure ()
126+ | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
127+ where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
128+ totalRoutes = (fromIntegral routeCount)
129+
130+
131+ untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
132+ untilDone (0,_) _ = pure HitMaxIterations
133+ untilDone (n, deadline) action = do
134+ now <- liftIO getCurrentTime
135+ if now > deadline
136+ then pure TimedOut
137+ else do
138+ action
139+ untilDone (n-1, deadline) action
140+
94141 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
95−
142+ routeCount = length reifiedApi
143+
96144 elementOrFail :: (MonadState FuzzState m, MonadIO m)
97145 => [a] -> m a
98− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
146+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
99147 elementOrFail l = do
100148 st <- get
101149 let (index,newGen) = randomR (0, length l - 1) (currentRng st)
@@ -124,7 +172,7 @@ fuzz server Config{..} checker = do
124172 execute :: (MonadState FuzzState m, MonadIO m)
125173 => (FuzzOp,Dynamic,[Dynamic]) -> m ()
126174 execute (fuzzop, dyncall, args) = do
127− liftIO $ print fuzzop
175+ -- liftIO $ print fuzzop
128176 -- now, magic happens: we apply some dynamic arguments to a dynamic
129177 -- function and hopefully something useful pops out the end.
130178 let func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just dyncall) (reverse args)
@@ -136,7 +184,7 @@ fuzz server Config{..} checker = do
136184 ,show (dynTypeRep dyncall)
137185 ,"state"
138186 ,show st]
139− liftIO $ putStrLn showable
187+ -- liftIO $ putStrLn showable
140188
141189 case func of
142190 Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
@@ -153,7 +201,7 @@ fuzz server Config{..} checker = do
153201 liftIO $ print ("ignoring non-500 error" , serverError)
154202
155203 Right (dyn :: NEL.NonEmpty Dynamic) -> do
156− liftIO $ print ("storing", fmap dynTypeRep dyn)
204+ -- liftIO $ print ("storing", fmap dynTypeRep dyn)
157205 modify' (\fs@FuzzState{..} ->
158206 fs { stash = addToStash (NEL.toList dyn) stash } )
159207 pure ()
@@ -164,10 +212,10 @@ fuzz server Config{..} checker = do
164212 op <- genOp
165213 catches (execute op)
166214 [ Handler (\(e :: SomeAsyncException) -> throw e)
167− , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get)
215+ , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
168216 ]
169217 catch (liftIO checker)
170− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
218+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
171219
172220 -- actions <-
173221 -- forAll $ do