@@ -1,311 +1,237 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DerivingStrategies #-}
24{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
36{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
48{-# LANGUAGE LambdaCase #-}
59{-# LANGUAGE PolyKinds #-}
610{-# LANGUAGE RankNTypes #-}
711{-# LANGUAGE RecordWildCards #-}
812{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE StandaloneDeriving #-}
914{-# LANGUAGE TupleSections #-}
10−
15+{-# LANGUAGE TypeApplications #-}
1116{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE TypeOperators #-}
1218{-# LANGUAGE UndecidableInstances #-}
1319
1420module Roboservant.Direct
15− ( fuzz',
16− Config (..),
17− -- TODO come up with something smarter than exporting all this, we should
18− -- have some nice error-display functions
19− RoboservantException (..),
20− FuzzState (..),
21− FuzzOp (..),
22− FailureType (..),
23− Report (..),
21+ ( fuzz, Config(..)
2422 )
2523where
2624
27−import Control.Exception.Lifted
28− ( Exception,
29− Handler (Handler),
30− SomeAsyncException,
31− SomeException,
32− catch,
33− catches,
34− handle,
35− throw,
36− )
37−import Control.Monad.State.Strict
38− ( MonadIO (..),
39− MonadState (get),
40− StateT (runStateT),
41− modify',
42− )
43−import Control.Monad.Trans.Control (MonadBaseControl)
44−import qualified Data.Dependent.Map as DM
45−import Data.Dynamic (Dynamic (..))
46−import qualified Data.IntSet as IntSet
47−import Data.List.NonEmpty (NonEmpty (..))
48−import qualified Data.List.NonEmpty as NEL
25+import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
26+import Control.Monad(void,replicateM,forM_)
27+import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
28+import Control.Monad.Trans.Control(MonadBaseControl)
29+import Data.Dependent.Map (DMap)
30+import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
31+import Data.List.NonEmpty (NonEmpty(..))
32+import Data.Map.Strict(Map)
4933import Data.Maybe (mapMaybe)
50−import qualified Data.Set as Set
51−import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
52−import qualified Data.Vinyl as V
53−import qualified Data.Vinyl.Curry as V
34+import Data.Typeable (TypeRep)
35+import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
36+import System.Random(StdGen,randomR,mkStdGen)
37+import System.Timeout.Lifted(timeout)
38+import GHC.Generics ((:*:)(..))
5439import qualified Data.Vinyl.Functor as V
55−import GHC.Generics ((:*:) (..))
40+import qualified Data.Vinyl.Curry as V
41+import qualified Data.Dependent.Map as DM
42+import qualified Data.Vinyl as V
43+import qualified Data.List.NonEmpty as NEL
44+import qualified Data.Map.Strict as Map
45+import qualified Type.Reflection as R
46+
47+import Roboservant.Types.Breakdown
5648import Roboservant.Types
5749 ( ApiOffset (..),
58− Argument (..),
59− InteractionError(..),
60− Provenance (..),
61− ReifiedApi,
62− ReifiedEndpoint (..),
63− Stash (..),
64− StashValue (..),
65− TypedF,
66− )
67−import Roboservant.Types.Config
50+ FlattenServer (..),
51+-- ReifiedApi,
52+ ToReifiedApi (..),
53+ ReifiedEndpoint(..),
54+ Argument(..),
55+ TypedF
6856
69−import System.Random (Random (randomR), StdGen, mkStdGen)
70−import qualified Type.Reflection as R
57+ )
7158
7259data RoboservantException
73− = RoboservantException
74− { failureReason :: FailureType,
75− serverException :: Maybe SomeException,
76− fuzzState :: FuzzState
77− }
60+ = RoboservantException FailureType (Maybe SomeException) FuzzState
7861 deriving (Show)
79−
62+-- we believe in nussink, lebowski
8063instance Exception RoboservantException
8164
8265data FailureType
8366 = ServerCrashed
8467 | CheckerFailed
8568 | NoPossibleMoves
86− | InsufficientCoverage Double
87− deriving (Show, Eq)
88−
89−data FuzzOp
90− = FuzzOp
91− { apiOffset :: ApiOffset,
92− provenance :: [Provenance]
93− }
94− deriving (Show, Eq)
95−
96−data FuzzState
97− = FuzzState
98− { path :: [FuzzOp],
99− stash :: Stash,
100− currentRng :: StdGen
101− }
102− deriving (Show)
103−
104−data EndpointOption
105− = forall as.
106− (V.RecordToList as, V.RMap as) =>
107− EndpointOption
108− { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
109− eoArgs :: V.Rec (TypedF StashValue) as
110− }
111−
112−data StopReason
113− = TimedOut
114− | HitMaxIterations
115− deriving (Show, Eq)
116−
117−data Report
118− = Report
119− { textual :: String,
120− rsException :: RoboservantException
121− }
122− deriving (Show)
123−
124−
125−
126−-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
127−-- fuzzClient = undefined
128−
129−
130−
131−fuzz' ::
132− ReifiedApi ->
133− Config ->
134− IO (Maybe Report)
135−fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
69+ deriving (Show,Eq)
70+
71+
72+data FuzzOp = FuzzOp ApiOffset [Provenance]
73+ deriving (Show,Eq)
74+
75+data Config
76+ = Config
77+ { seed :: [Dynamic]
78+ , maxRuntime :: Int -- seconds to test for
79+ , maxReps :: Int
80+ , rngSeed :: Int
81+ }
82+
83+data FuzzState = FuzzState
84+ { path :: [FuzzOp]
85+ , stash :: Stash
86+ , currentRng :: StdGen
87+ }
88+ deriving Show
89+
90+data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption
91+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
92+ , eoArgs :: V.Rec (TypedF StashValue) as
93+ }
94+
95+fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
96+ => Server api
97+ -> Config
98+ -> IO ()
99+ -> IO ()
100+fuzz server Config{..} checker = do
136101 let path = []
137102 stash = addToStash seed mempty
138103 currentRng = mkStdGen rngSeed
139− deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime
140− (stopreason, _fs) <-
141− runStateT
142− (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
143− FuzzState {..}
144− logInfo $ show stopreason
145− pure Nothing
104+ -- either we time out without finding an error, which is fine, or we find an error
105+ -- and throw an exception that propagates through this.
106+
107+ void $ timeout (maxRuntime * 1000000) ( execStateT (replicateM maxReps go) FuzzState{..})
108+ forM_ reifiedApi $ \(offset, ReifiedEndpoint{..}) ->
109+ print (
110+ offset
111+ , recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) reArguments
112+ )
146113 where
147− -- something less terrible later
148− formatException :: RoboservantException -> Report
149− formatException r@(RoboservantException failureType exception _state) =
150− Report
151− (unlines [show failureType, show exception])
152− r
153− displayDiagnostics FuzzState {..} = liftIO $
154− logInfo $ unlines $
155− ["api endpoints covered"]
156− <> (map show . Set.toList . Set.fromList $ map apiOffset path)
157− <> ["", "types in stash"]
158− <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)
159− -- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
160− -- $ \_k v ->
161− -- (show . NEL.length $ getStashValue v))
162114
163− evaluateCoverage f@FuzzState {..}
164− | coverage > coverageThreshold = pure ()
165− | otherwise = do
166− displayDiagnostics f
167− throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
168− where
169− hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
170− totalRoutes = fromIntegral routeCount
171− coverage = hitRoutes / totalRoutes
172− untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
173− untilDone (0, _) _ = pure HitMaxIterations
174− untilDone (n, deadline) action = do
175− now <- liftIO getCurrentTime
176− if now > deadline
177− then pure TimedOut
178− else do
179− _ <- action
180− untilDone (n -1, deadline) action
115+ reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
181116
182− routeCount = length reifiedApi
183− elementOrFail ::
184− (MonadState FuzzState m, MonadIO m) =>
185− [a] ->
186− m a
117+ elementOrFail :: (MonadState FuzzState m, MonadIO m)
118+ => [a] -> m a
187119 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
188120 elementOrFail l = do
189121 st <- get
190− let (index, newGen) = randomR (0, length l - 1) (currentRng st)
191− modify' $ \st' -> st' {currentRng = newGen}
122+ let (index,newGen) = randomR (0, length l - 1) (currentRng st)
123+ modify' $ \st' -> st' { currentRng = newGen }
192124 pure (l !! index)
193− withOp ::
194− (MonadState FuzzState m, MonadIO m) =>
195− ( forall as.
196− (V.RecordToList as, V.RMap as) =>
197− FuzzOp ->
198− V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
199− V.Rec (TypedF V.Identity) as ->
200− m r
201− ) ->
202− m r
125+
126+ withOp :: (MonadState FuzzState m, MonadIO m)
127+ => (forall as. (V.RecordToList as, V.RMap as)
128+ => FuzzOp
129+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
130+ -> V.Rec (TypedF V.Identity) as -> m r
131+ )
132+ -> m r
203133 withOp callback = do
204134 -- choose a call to make, from the endpoints with fillable arguments.
205− (offset, EndpointOption {..}) <- elementOrFail . options =<< get
206− r <-
207− V.rtraverse
208− ( \(tr :*: StashValue svs _) ->
209− elementOrFail $
210− zipWith
211− (\i xy -> V.Const i :*: tr :*: xy)
212− [0 ..]
213− (NEL.toList svs)
214− )
215− eoArgs
216− let pathSegment =
217− FuzzOp offset $
218− recordToList'
219− (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
220− r
221− argValues =
222− V.rmap
223− (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
135+ (offset, EndpointOption{..}) <- elementOrFail . options =<< get
136+ r <- V.rtraverse
137+ (\(tr :*: StashValue svs) -> elementOrFail $
138+ zipWith (\i xy -> V.Const i :*: tr :*: xy)
139+ [0..]
140+ (NEL.toList svs)
141+ )
142+ eoArgs
143+ let pathSegment = FuzzOp offset $
144+ recordToList'
145+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
224146 r
225− modify' (\f -> f {path = path f <> [pathSegment]})
147+ argValues = V.rmap
148+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
149+ r
150+ modify' (\f -> f { path = path f <> [pathSegment] })
226151 callback pathSegment eoCall argValues
227152 where
228153 options :: FuzzState -> [(ApiOffset, EndpointOption)]
229− options FuzzState {..} =
154+ options FuzzState{..} =
230155 mapMaybe
231− ( \(offset, ReifiedEndpoint {..}) -> do
232− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
233− pure (offset, EndpointOption reEndpointFunc args)
156+ ( \(offset, ReifiedEndpoint{..}) -> do
157+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
158+ pure (offset, EndpointOption reEndpointFunc args)
234159 )
235160 reifiedApi
236− execute ::
237− (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
238− FuzzOp ->
239− V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
240− V.Rec (TypedF V.Identity) as ->
241− m ()
161+
162+ execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)
163+ => FuzzOp
164+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
165+ -> V.Rec (TypedF V.Identity) as
166+ -> m ()
242167 execute fuzzop func args = do
243− (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
168+ liftIO $ print fuzzop
169+ st <- get
170+ let showable = unlines $ ("args":map show argTypes)
171+ <> ["fuzzop"
172+ , show fuzzop
173+ -- ,"dyncall"
174+ -- ,show (dynTypeRep dyncall)
175+ ,"state"
176+ ,show st]
177+ liftIO $ putStrLn showable
244178 liftIO (V.runcurry' func argVals) >>= \case
245− Left (e::InteractionError) ->
246− if fatalError e
247− then throw e
248− else pure ()
249− Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
250− modify'
251− ( \fs@FuzzState {..} ->
252− fs {stash = addToStash (NEL.toList dyn) stash}
253− )
179+ -- parameterise this
180+ Left (serverError :: ServerError) ->
181+ case errHTTPCode serverError of
182+ 500 -> throw serverError
183+ _ -> do
184+ liftIO $ print ("ignoring non-500 error" , serverError)
185+ Right (dyn :: NEL.NonEmpty Dynamic) -> do
186+ liftIO $ print ("storing", fmap dynTypeRep dyn)
187+ modify' (\fs@FuzzState{..} ->
188+ fs { stash = addToStash (NEL.toList dyn) stash } )
254189 where
255190 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
256− -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
257− go ::
258− (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
259− m ()
191+ argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
192+
193+ go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
194+ => m ()
260195 go = withOp $ \op func args -> do
261− catches
262− (execute op func args)
263− [ Handler (\(e :: SomeAsyncException) -> throw e),
264− Handler
265− ( \(e :: SomeException) ->
266− throw . RoboservantException ServerCrashed (Just e) =<< get
267− )
196+ catches (execute op func args)
197+ [ Handler (\(e :: SomeAsyncException) -> throw e)
198+ , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get)
268199 ]
269− catch
270− (liftIO healthCheck)
271− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
272−
273−addToStash ::
274− [(Dynamic, Int)] ->
275− Stash ->
276− Stash
200+ catch (liftIO checker)
201+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
202+
203+ -- actions <-
204+ -- forAll $ do
205+ -- Gen.sequential
206+ -- (Range.linear 1 100)
207+ -- emptyState
208+ -- (fmap preload seed <> [callEndpoint reifiedApi])
209+ -- executeSequential emptyState actions
210+addToStash :: [Dynamic]
211+ -> Stash
212+ -> Stash
277213addToStash result stash =
278− foldr
279− ( \(Dynamic tr x, hashed) (Stash dict) ->
280− Stash $
281− DM.insertWith
282− renumber
283− tr
284− (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))
285− dict
214+ foldr (\(Dynamic tr x) (Stash dict) -> Stash $
215+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict
216+ -- in DM.insertWith renumber _ (pure ([Provenance tr 0],x)) dict
286217 )
287218 stash
288219 result
220+-- Map.insertWith (flip (<>)) (dynTypeRep result) (_pure result) stash })
289221 where
290− renumber ::
291− StashValue a ->
292− StashValue a ->
293− StashValue a
294− renumber (StashValue singleDyn singleHash) orig@(StashValue l intSet)
295− | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
296− | otherwise =
297− StashValue
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− )
303− (IntSet.union singleHash intSet)
222+ renumber :: StashValue a
223+ -> StashValue a
224+ -> StashValue a
225+ renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
226+ [([Provenance tr _], dyn)] -> l
227+ <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
228+ _ -> error "should be impossible"
229+
304230
305231-- why isn't this in vinyl?
306−recordToList' ::
307− (V.RecordToList as, V.RMap as) =>
308− (forall x. f x -> a) ->
309− V.Rec f as ->
310− [a]
232+recordToList'
233+ :: (V.RecordToList as, V.RMap as)
234+ => (forall x. f x -> a)
235+ -> V.Rec f as
236+ -> [a]
311237recordToList' f = V.recordToList . V.rmap (V.Const . f)