@@ -1,20 +1,14 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DerivingStrategies #-}
42{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
63{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
84{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE PolyKinds #-}
105{-# LANGUAGE RankNTypes #-}
116{-# LANGUAGE RecordWildCards #-}
127{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
148{-# LANGUAGE TupleSections #-}
159{-# LANGUAGE TypeApplications #-}
1610{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
11+
1812{-# LANGUAGE UndecidableInstances #-}
1913
2014module Roboservant.Direct
@@ -22,13 +16,44 @@ module Roboservant.Direct
2216
2317 -- TODO come up with something smarter than exporting all this, we should
2418 -- have some nice error-display functions
25− , RoboservantException(..), FuzzState(..), FuzzOp(..)
19+ , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
2620 )
2721where
2822
29−import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
30−import Control.Monad(void,replicateM)
31−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
23+import Control.Exception.Lifted
24+ ( throw,
25+ handle,
26+ Handler(..),
27+ Exception,
28+ SomeException,
29+ SomeAsyncException,
30+ catch,
31+ catches )
32+import Control.Exception.Lifted
33+ ( throw,
34+ Handler(..),
35+ Exception,
36+ SomeException,
37+ SomeAsyncException,
38+ catch,
39+ catches )
40+import Control.Exception.Lifted
41+ ( Exception,
42+ Handler(..),
43+ SomeAsyncException,
44+ SomeException,
45+ catch,
46+ catches,
47+ handle,
48+ throw )
49+
50+import Control.Monad.State.Strict
51+ ( MonadState, MonadIO, get, modify', liftIO, runStateT )
52+import Control.Monad.State.Strict
53+ ( MonadState, MonadIO, get, modify', liftIO, execStateT )
54+import Control.Monad.State.Strict
55+ ( MonadIO, MonadState, get, liftIO, modify', runStateT )
56+
3257import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
3358import Control.Monad(void,replicateM,forM_)
3459import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
@@ -40,109 +65,164 @@ import Data.Map.Strict(Map)
4065import qualified Data.Set as Set
4166import Data.Maybe (mapMaybe)
4267import Data.Typeable (TypeRep)
43−import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
44−import System.Random(StdGen,randomR,mkStdGen)
68+import Servant ( Endpoints, Proxy(Proxy), Server, ServerError(..) )
69+import Servant ( Endpoints, Proxy(Proxy), Server, ServerError(..) )
70+
71+import System.Random ( StdGen, randomR, mkStdGen )
72+import System.Random ( StdGen, mkStdGen, randomR )
73+
74+import qualified Data.List.NonEmpty as NEL
75+import qualified Data.Map.Strict as Map
76+import Data.Time.Clock
77+import Data.Time.Clock
78+
79+import Data.List(sortOn)
80+import Control.Arrow(second)
4581import System.Timeout.Lifted(timeout)
46−import GHC.Generics ((:*:)(..))
82+import GHC.Generics ( (:*:)(..) )
83+import GHC.Generics ( (:*:)(..) )
84+
4785import qualified Data.Vinyl.Functor as V
86+import qualified Data.Vinyl.Functor as V
87+
88+import qualified Data.Vinyl.Curry as V
4889import qualified Data.Vinyl.Curry as V
90+
91+
92+
93+import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)
94+import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)
95+import Control.Monad.Trans.Control (MonadBaseControl)
4996import qualified Data.Dependent.Map as DM
50−import qualified Data.Vinyl as V
97+import Data.Dynamic (Dynamic (..), dynTypeRep)
98+import Data.List.NonEmpty (NonEmpty (..))
5199import qualified Data.List.NonEmpty as NEL
52−import qualified Data.Map.Strict as Map
100+import Data.Maybe (mapMaybe)
101+import qualified Data.Set as Set
53102import Data.Time.Clock
54−import qualified Type.Reflection as R
55−
56−import Roboservant.Types.Breakdown
103+import qualified Data.Vinyl as V
104+import qualified Data.Vinyl.Curry as V
105+import qualified Data.Vinyl.Functor as V
106+import GHC.Generics ((:*:) (..))
57107import Roboservant.Types
58108 ( ApiOffset (..),
109+ Argument (..),
59110 FlattenServer (..),
60−-- ReifiedApi,
111+ Provenance (..),
112+ ReifiedEndpoint (..),
113+ Stash (..),
114+ StashValue (..),
61115 ToReifiedApi (..),
62− ReifiedEndpoint(..),
63− Argument(..),
64116 TypedF
65−
66117 )
118+import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
119+import System.Random (StdGen, mkStdGen, randomR)
120+import qualified Type.Reflection as R
121+import qualified Data.IntSet as IntSet
67122
68123data RoboservantException
69− = RoboservantException FailureType (Maybe SomeException) Int FuzzState
70− deriving (Show)
71−-- we believe in nussink, lebowski
124+ = RoboservantException
125+ { failureReason :: FailureType
126+ , serverException :: Maybe SomeException
127+ , fuzzState :: FuzzState
128+ } deriving (Show)
129+
72130instance Exception RoboservantException
73131
74132data FailureType
75133 = ServerCrashed
76134 | CheckerFailed
77135 | NoPossibleMoves
78− | InsufficientCoverage
136+ | InsufficientCoverage Double
79137 deriving (Show,Eq)
80138
81−
82−data FuzzOp = FuzzOp
83− { apiOffset :: ApiOffset
84− , provenance :: [Provenance]
85− } deriving (Show,Eq)
139+data FuzzOp
140+ = FuzzOp
141+ { apiOffset :: ApiOffset,
142+ provenance :: [Provenance]
143+ }
144+ deriving (Show, Eq)
86145
87146data Config
88147 = Config
89− { seed :: [Dynamic]
90− , maxRuntime :: Integer -- seconds to test for
91− , maxReps :: Integer
92− , rngSeed :: Int
93− , coverageThreshold :: Double
94− }
95−
96−data FuzzState = FuzzState
97− { path :: [FuzzOp]
98− , stash :: Stash
99− , currentRng :: StdGen
100− }
101− deriving Show
102−
103−data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption
104− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
105− , eoArgs :: V.Rec (TypedF StashValue) as
106− }
148+ { seed :: [(Dynamic,Int)],
149+ maxRuntime :: Double, -- seconds to test for
150+ maxReps :: Integer,
151+ rngSeed :: Int,
152+ coverageThreshold :: Double
153+ }
154+
155+data FuzzState
156+ = FuzzState
157+ { path :: [FuzzOp],
158+ stash :: Stash,
159+ currentRng :: StdGen
160+ }
161+ deriving (Show)
162+
163+data EndpointOption
164+ = forall as.
165+ (V.RecordToList as, V.RMap as) =>
166+ EndpointOption
167+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))),
168+ eoArgs :: V.Rec (TypedF StashValue) as
169+ }
107170
108171data StopReason
109172 = TimedOut
110173 | HitMaxIterations
111− deriving (Show,Eq)
174+ deriving (Show, Eq)
112175
113176data Report = Report
114− { textual :: String }
115− deriving (Show,Eq)
177+ { textual :: String
178+ , rsException :: RoboservantException}
179+ deriving (Show)
116180
117−fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
118− => Server api
119− -> Config
120− -> IO ()
121− -> IO (Maybe Report)
122−fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
181+fuzz ::
182+ forall api.
183+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>
184+ Server api ->
185+ Config ->
186+ IO () ->
187+ IO (Maybe Report)
188+fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
123189 let path = []
124190 stash = addToStash seed mempty
125191 currentRng = mkStdGen rngSeed
126−
127−
128− deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
129− (stopreason, fs ) <- runStateT
130− (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
192+ deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime
193+ (stopreason, _fs) <-
194+ runStateT
195+ (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
196+ FuzzState {..}
131197 print stopreason
132198 pure Nothing
133199 where
134200 -- something less terrible later
135201 formatException :: RoboservantException -> Report
136− formatException = Report . show
202+ formatException r@(RoboservantException failureType exception _state) = Report
203+ (unlines [ show failureType , show exception ])
204+ r
205+
206+ displayDiagnostics FuzzState{..} = liftIO $ do
207+ putStrLn "api endpoints covered"
208+ mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
209+ putStrLn ""
210+ putStrLn "types in stash"
211+ DM.forWithKey_ (getStash stash) $ \k v ->
212+ print (NEL.length $ getStashValue v)
213+ -- mapM_
214+ -- (print . second NEL.length)
215+ -- (sortOn (show . fst) $ Map.toList $ getStash stash)
137216
138217 -- evaluateCoverage :: FuzzState -> m ()
139218 evaluateCoverage f@FuzzState{..}
140− | hitRoutes / totalRoutes > coverageThreshold = do
141− liftIO $ print ("passed coverage", hitRoutes, totalRoutes)
142− pure ()
143− | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
144− where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
145− totalRoutes = (fromIntegral routeCount)
219+ | coverage > coverageThreshold = pure ()
220+ | otherwise = do
221+ displayDiagnostics f
222+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
223+ where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
224+ totalRoutes = fromIntegral routeCount
225+ coverage = hitRoutes / totalRoutes
146226
147227
148228 untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
@@ -152,121 +232,140 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
152232 if now > deadline
153233 then pure TimedOut
154234 else do
155− action
156− untilDone (n-1, deadline) action
157−
235+ _ <- action
236+ untilDone (n -1, deadline) action
158237 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
159238 routeCount = length reifiedApi
160239
161240 elementOrFail :: (MonadState FuzzState m, MonadIO m)
162241 => [a] -> m a
163− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
242+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
164243 elementOrFail l = do
165244 st <- get
166− let (index,newGen) = randomR (0, length l - 1) (currentRng st)
167− modify' $ \st' -> st' { currentRng = newGen }
245+ let (index, newGen) = randomR (0, length l - 1) (currentRng st)
246+ modify' $ \st' -> st' {currentRng = newGen}
168247 pure (l !! index)
169−
170− withOp :: (MonadState FuzzState m, MonadIO m)
171− => (forall as. (V.RecordToList as, V.RMap as)
172− => FuzzOp
173− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
174− -> V.Rec (TypedF V.Identity) as -> m r
175− )
176− -> m r
248+ withOp ::
249+ (MonadState FuzzState m, MonadIO m) =>
250+ ( forall as.
251+ (V.RecordToList as, V.RMap as) =>
252+ FuzzOp ->
253+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
254+ V.Rec (TypedF V.Identity) as ->
255+ m r
256+ ) ->
257+ m r
177258 withOp callback = do
178259 -- choose a call to make, from the endpoints with fillable arguments.
179− (offset, EndpointOption{..}) <- elementOrFail . options =<< get
180− r <- V.rtraverse
181− (\(tr :*: StashValue svs) -> elementOrFail $
182− zipWith (\i xy -> V.Const i :*: tr :*: xy)
183− [0..]
184− (NEL.toList svs)
185− )
186− eoArgs
187− let pathSegment = FuzzOp offset $
188− recordToList'
189− (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
260+ (offset, EndpointOption {..}) <- elementOrFail . options =<< get
261+ r <-
262+ V.rtraverse
263+ ( \(tr :*: StashValue svs _) ->
264+ elementOrFail $
265+ zipWith
266+ (\i xy -> V.Const i :*: tr :*: xy)
267+ [0 ..]
268+ (NEL.toList svs)
269+ )
270+ eoArgs
271+ let pathSegment =
272+ FuzzOp offset $
273+ recordToList'
274+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
275+ r
276+ argValues =
277+ V.rmap
278+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
190279 r
191− argValues = V.rmap
192− (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
193− r
194− modify' (\f -> f { path = path f <> [pathSegment] })
280+ modify' (\f -> f {path = path f <> [pathSegment]})
195281 callback pathSegment eoCall argValues
196282 where
197283 options :: FuzzState -> [(ApiOffset, EndpointOption)]
198− options FuzzState{..} =
284+ options FuzzState {..} =
199285 mapMaybe
200− ( \(offset, ReifiedEndpoint{..}) -> do
201− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
202− pure (offset, EndpointOption reEndpointFunc args)
286+ ( \(offset, ReifiedEndpoint {..}) -> do
287+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
288+ pure (offset, EndpointOption reEndpointFunc args)
203289 )
204290 reifiedApi
205−
206− execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)
207− => FuzzOp
208− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
209− -> V.Rec (TypedF V.Identity) as
210− -> m ()
291+ execute ::
292+ (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
293+ FuzzOp ->
294+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
295+ V.Rec (TypedF V.Identity) as ->
296+ m ()
211297 execute fuzzop func args = do
212− liftIO $ print fuzzop
298+ (liftIO . print . (fuzzop,) . stash ) =<< get
213299 st <- get
214− let showable = unlines $ ("args":map show argTypes)
215− <> ["fuzzop"
216− , show fuzzop
217− -- ,"dyncall"
218− -- ,show (dynTypeRep dyncall)
219− ,"state"
220− ,show st]
221− liftIO $ putStrLn showable
300+ -- let showable = unlines $ ("args":map show argTypes)
301+ -- <> ["fuzzop"
302+ -- , show fuzzop
303+ -- -- ,"dyncall"
304+ -- -- ,show (dynTypeRep dyncall)
305+ -- ,"state"
306+ -- ]
307+ -- liftIO $ putStrLn showable
222308 liftIO (V.runcurry' func argVals) >>= \case
223309 -- parameterise this
224310 Left (serverError :: ServerError) ->
225311 case errHTTPCode serverError of
226312 500 -> throw serverError
227313 _ -> do
228− liftIO $ print ("ignoring non-500 error" , serverError)
229− Right (dyn :: NEL.NonEmpty Dynamic) -> do
230− liftIO $ print ("storing", fmap dynTypeRep dyn)
314+ liftIO $ print ("ignoring non-500 error", serverError)
315+ Right (dyn :: NEL.NonEmpty (Dynamic,Int)) -> do
316+ -- liftIO $ print ("storing", fmap dynTypeRep dyn)
231317 modify' (\fs@FuzzState{..} ->
232318 fs { stash = addToStash (NEL.toList dyn) stash } )
233319 where
234320 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
235321 argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
236−
237− go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
238− => m ()
322+ go ::
323+ (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
324+ m ()
239325 go = withOp $ \op func args -> do
240326 catches (execute op func args)
241327 [ Handler (\(e :: SomeAsyncException) -> throw e)
242− , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
328+ , Handler (\(e :: SomeException) -> do
329+ displayDiagnostics =<< get
330+ throw . RoboservantException ServerCrashed (Just e) =<< get)
243331 ]
244332 catch (liftIO checker)
245− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
333+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
246334
247−addToStash :: [Dynamic]
248− -> Stash
249− -> Stash
335+addToStash ::
336+ [(Dynamic,Int)] ->
337+ Stash ->
338+ Stash
250339addToStash result stash =
251− foldr (\(Dynamic tr x) (Stash dict) -> Stash $
252− DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict
340+ foldr
341+ ( \(Dynamic tr x,hashed) (Stash dict) ->
342+ Stash $
343+ DM.insertWith renumber tr
344+ (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed)) dict
253345 )
254346 stash
255347 result
256348 where
257− renumber :: StashValue a
258− -> StashValue a
259− -> StashValue a
260− renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
261− [([Provenance tr _], dyn)] -> l
262− <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
263− _ -> error "should be impossible"
349+ renumber ::
350+ StashValue a ->
351+ StashValue a ->
352+ StashValue a
353+ renumber (StashValue singleDyn singleHash) orig@(StashValue l intSet)
354+ | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
355+ | otherwise =
356+ StashValue
357+ (case NEL.toList singleDyn of
358+ [([Provenance tr _], dyn)] ->
359+ l
360+(([Provenance tr (length (NEL.last l) + 1)], dyn))
361+ _ -> error "should be impossible")
264362
363+ (IntSet.union singleHash intSet)
265364
266365-- why isn't this in vinyl?
267−recordToList'
268− :: (V.RecordToList as, V.RMap as)
269− => (forall x. f x -> a)
270− -> V.Rec f as
271− -> [a]
366+recordToList' ::
367+ (V.RecordToList as, V.RMap as) =>
368+ (forall x. f x -> a) ->
369+ V.Rec f as ->
370+ [a]
272371recordToList' f = V.recordToList . V.rmap (V.Const . f)