@@ -8,98 +8,41 @@
88{-# LANGUAGE TupleSections #-}
99{-# LANGUAGE TypeApplications #-}
1010{-# LANGUAGE TypeFamilies #-}
11−
1211{-# LANGUAGE UndecidableInstances #-}
1312
1413module Roboservant.Direct
15− ( fuzz, Config(..)
16−
17− -- TODO come up with something smarter than exporting all this, we should
18− -- have some nice error-display functions
19− , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
14+ ( fuzz,
15+ Config (..),
16+ -- TODO come up with something smarter than exporting all this, we should
17+ -- have some nice error-display functions
18+ RoboservantException (..),
19+ FuzzState (..),
20+ FuzzOp (..),
21+ FailureType (..),
22+ Report (..),
2023 )
2124where
2225
2326import 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(..),
27+ ( SomeException,
28+ throw,
3529 Exception,
36− SomeException,
37− SomeAsyncException,
38− catch,
39− catches )
40−import Control.Exception.Lifted
41− ( Exception,
42− Handler(..),
4330 SomeAsyncException,
44− SomeException,
4531 catch,
4632 catches,
4733 handle,
48− throw )
49−
50−import Control.Monad.State.Strict
51− ( MonadState, MonadIO, get, modify', liftIO, runStateT )
34+ Handler(Handler) )
5235import 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−
57−import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
58−import Control.Monad(void,replicateM,forM_)
59−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
60−import Control.Monad.Trans.Control(MonadBaseControl)
61−import Data.Dependent.Map (DMap)
62−import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
63−import Data.List.NonEmpty (NonEmpty(..))
64−import Data.Map.Strict(Map)
65−import qualified Data.Set as Set
66−import Data.Maybe (mapMaybe)
67−import Data.Typeable (TypeRep)
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)
81−import System.Timeout.Lifted(timeout)
82−import GHC.Generics ( (:*:)(..) )
83−import GHC.Generics ( (:*:)(..) )
84−
85−import qualified Data.Vinyl.Functor as V
86−import qualified Data.Vinyl.Functor as V
87−
88−import qualified Data.Vinyl.Curry as V
89−import 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)
36+ ( MonadIO(..), StateT(runStateT), modify', MonadState(get) )
9537import Control.Monad.Trans.Control (MonadBaseControl)
9638import qualified Data.Dependent.Map as DM
97−import Data.Dynamic (Dynamic (..), dynTypeRep)
39+import Data.Dynamic ( Dynamic(..) )
40+import qualified Data.IntSet as IntSet
9841import Data.List.NonEmpty (NonEmpty (..))
9942import qualified Data.List.NonEmpty as NEL
10043import Data.Maybe (mapMaybe)
10144import qualified Data.Set as Set
102−import Data.Time.Clock
45+import Data.Time.Clock ( addUTCTime, getCurrentTime, UTCTime )
10346import qualified Data.Vinyl as V
10447import qualified Data.Vinyl.Curry as V
10548import qualified Data.Vinyl.Functor as V
@@ -113,19 +56,19 @@ import Roboservant.Types
11356 Stash (..),
11457 StashValue (..),
11558 ToReifiedApi (..),
116− TypedF
59+ TypedF,
11760 )
11861import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
119−import System.Random (StdGen, mkStdGen, randomR)
62+import System.Random ( mkStdGen, Random(randomR), StdGen )
12063import qualified Type.Reflection as R
121−import qualified Data.IntSet as IntSet
12264
12365data RoboservantException
12466 = RoboservantException
125− { failureReason :: FailureType
126− , serverException :: Maybe SomeException
127− , fuzzState :: FuzzState
128− } deriving (Show)
67+ { failureReason :: FailureType,
68+ serverException :: Maybe SomeException,
69+ fuzzState :: FuzzState
70+ }
71+ deriving (Show)
12972
13073instance Exception RoboservantException
13174
@@ -134,7 +77,7 @@ data FailureType
13477 | CheckerFailed
13578 | NoPossibleMoves
13679 | InsufficientCoverage Double
137− deriving (Show,Eq)
80+ deriving (Show, Eq)
13881
13982data FuzzOp
14083 = FuzzOp
@@ -145,7 +88,7 @@ data FuzzOp
14588
14689data Config
14790 = Config
148− { seed :: [(Dynamic,Int)],
91+ { seed :: [(Dynamic, Int)],
14992 maxRuntime :: Double, -- seconds to test for
15093 maxReps :: Integer,
15194 rngSeed :: Int,
@@ -164,7 +107,7 @@ data EndpointOption
164107 = forall as.
165108 (V.RecordToList as, V.RMap as) =>
166109 EndpointOption
167− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))),
110+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))),
168111 eoArgs :: V.Rec (TypedF StashValue) as
169112 }
170113
@@ -173,9 +116,11 @@ data StopReason
173116 | HitMaxIterations
174117 deriving (Show, Eq)
175118
176−data Report = Report
177− { textual :: String
178− , rsException :: RoboservantException}
119+data Report
120+ = Report
121+ { textual :: String,
122+ rsException :: RoboservantException
123+ }
179124 deriving (Show)
180125
181126fuzz ::
@@ -199,34 +144,29 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
199144 where
200145 -- something less terrible later
201146 formatException :: RoboservantException -> Report
202− formatException r@(RoboservantException failureType exception _state) = Report
203− (unlines [ show failureType , show exception ])
204− r
205−
206− displayDiagnostics FuzzState{..} = liftIO $ do
147+ formatException r@(RoboservantException failureType exception _state) =
148+ Report
149+ (unlines [show failureType, show exception])
150+ r
151+ displayDiagnostics FuzzState {..} = liftIO $ do
207152 putStrLn "api endpoints covered"
208153 mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
209154 putStrLn ""
210155 putStrLn "types in stash"
211− DM.forWithKey_ (getStash stash) $ \k v ->
156+ DM.forWithKey_ (getStash stash) $ \_k v ->
212157 print (NEL.length $ getStashValue v)
213− -- mapM_
214− -- (print . second NEL.length)
215− -- (sortOn (show . fst) $ Map.toList $ getStash stash)
216158
217− -- evaluateCoverage :: FuzzState -> m ()
218− evaluateCoverage f@FuzzState{..}
159+ evaluateCoverage f@FuzzState {..}
219160 | coverage > coverageThreshold = pure ()
220161 | 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
226−
227−
228− untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
229− untilDone (0,_) _ = pure HitMaxIterations
162+ displayDiagnostics f
163+ throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
164+ where
165+ hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
166+ totalRoutes = fromIntegral routeCount
167+ coverage = hitRoutes / totalRoutes
168+ untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
169+ untilDone (0, _) _ = pure HitMaxIterations
230170 untilDone (n, deadline) action = do
231171 now <- liftIO getCurrentTime
232172 if now > deadline
@@ -236,10 +176,11 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
236176 untilDone (n -1, deadline) action
237177 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
238178 routeCount = length reifiedApi
239−
240− elementOrFail :: (MonadState FuzzState m, MonadIO m)
241− => [a] -> m a
242− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
179+ elementOrFail ::
180+ (MonadState FuzzState m, MonadIO m) =>
181+ [a] ->
182+ m a
183+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
243184 elementOrFail l = do
244185 st <- get
245186 let (index, newGen) = randomR (0, length l - 1) (currentRng st)
@@ -250,7 +191,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
250191 ( forall as.
251192 (V.RecordToList as, V.RMap as) =>
252193 FuzzOp ->
253− V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
194+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) ->
254195 V.Rec (TypedF V.Identity) as ->
255196 m r
256197 ) ->
@@ -291,57 +232,57 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
291232 execute ::
292233 (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
293234 FuzzOp ->
294− V.Curried as (IO (Either ServerError (NonEmpty (Dynamic,Int)))) ->
235+ V.Curried as (IO (Either ServerError (NonEmpty (Dynamic, Int)))) ->
295236 V.Rec (TypedF V.Identity) as ->
296237 m ()
297238 execute fuzzop func args = do
298− (liftIO . print . (fuzzop,) . stash ) =<< get
299− st <- get
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
239+ (liftIO . print . (fuzzop,) . stash) =<< get
308240 liftIO (V.runcurry' func argVals) >>= \case
309241 -- parameterise this
310242 Left (serverError :: ServerError) ->
311243 case errHTTPCode serverError of
312244 500 -> throw serverError
313− _ -> do
245+ _ ->
314246 liftIO $ print ("ignoring non-500 error", serverError)
315− Right (dyn :: NEL.NonEmpty (Dynamic,Int)) -> do
247+ Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> do
316248 -- liftIO $ print ("storing", fmap dynTypeRep dyn)
317− modify' (\fs@FuzzState{..} ->
318− fs { stash = addToStash (NEL.toList dyn) stash } )
249+ modify'
250+ ( \fs@FuzzState {..} ->
251+ fs {stash = addToStash (NEL.toList dyn) stash}
252+ )
319253 where
320254 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
321− argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
255+ -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
322256 go ::
323257 (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
324258 m ()
325259 go = withOp $ \op func args -> do
326− catches (execute op func args)
327− [ Handler (\(e :: SomeAsyncException) -> throw e)
328− , Handler (\(e :: SomeException) -> do
329− displayDiagnostics =<< get
330− throw . RoboservantException ServerCrashed (Just e) =<< get)
260+ catches
261+ (execute op func args)
262+ [ Handler (\(e :: SomeAsyncException) -> throw e),
263+ Handler
264+ ( \(e :: SomeException) -> do
265+ displayDiagnostics =<< get
266+ throw . RoboservantException ServerCrashed (Just e) =<< get
267+ )
331268 ]
332− catch (liftIO checker)
333− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
269+ catch
270+ (liftIO checker)
271+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
334272
335273addToStash ::
336− [(Dynamic,Int)] ->
274+ [(Dynamic, Int)] ->
337275 Stash ->
338276 Stash
339277addToStash result stash =
340278 foldr
341− ( \(Dynamic tr x,hashed) (Stash dict) ->
279+ ( \(Dynamic tr x, hashed) (Stash dict) ->
342280 Stash $
343− DM.insertWith renumber tr
344− (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed)) dict
281+ DM.insertWith
282+ renumber
283+ tr
284+ (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))
285+ dict
345286 )
346287 stash
347288 result
@@ -354,11 +295,11 @@ addToStash result stash =
354295 | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
355296 | otherwise =
356297 StashValue
357− (case NEL.toList singleDyn of
358− [([Provenance tr _], dyn)] ->
359− l <> pure (([Provenance tr (length (NEL.last l) + 1)], dyn))
360− _ -> error "should be impossible")
361−
298+ ( case NEL.toList singleDyn of
299+ [([Provenance tr _], dyn)] ->
300+ l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
301+ _ -> error "should be impossible"
302+ )
362303 (IntSet.union singleHash intSet)
363304
364305-- why isn't this in vinyl?