@@ -1,56 +1,81 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DerivingStrategies #-}
42{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
63{-# LANGUAGE GADTs #-}
74{-# LANGUAGE LambdaCase #-}
85{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE RankNTypes #-}
97{-# LANGUAGE RecordWildCards #-}
108{-# LANGUAGE ScopedTypeVariables #-}
119{-# LANGUAGE TupleSections #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
1410
11+{-# LANGUAGE TypeFamilies #-}
1512{-# LANGUAGE UndecidableInstances #-}
1613
1714module Roboservant.Direct
18− ( fuzz, Config(..)
19−
20− -- TODO come up with something smarter than exporting all this, we should
21− -- have some nice error-display functions
22− , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
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 (..),
2324 )
2425where
2526
26−import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
27−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
28−import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
29−import Data.Map.Strict(Map)
30−import qualified Data.Set as Set
31−import Data.Maybe (mapMaybe)
32−import Data.Typeable (TypeRep)
33−import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
34−import System.Random(StdGen,randomR,mkStdGen)
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 (..))
3548import qualified Data.List.NonEmpty as NEL
36−import qualified Data.Map.Strict as Map
37−import Data.Time.Clock
38−import Data.List(sortOn)
39−import Control.Arrow(second)
40−
41−import Roboservant.Types.Breakdown
49+import 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
54+import qualified Data.Vinyl.Functor as V
55+import GHC.Generics ((:*:) (..))
4256import Roboservant.Types
4357 ( ApiOffset (..),
44− FlattenServer (..),
45−-- ReifiedApi,
46− ToReifiedApi (..),
47− ))
58+ Argument (..),
59+ InteractionError(..),
60+ Provenance (..),
61+ ReifiedApi,
62+ ReifiedEndpoint (..),
63+ Stash (..),
64+ StashValue (..),
65+ TypedF,
66+ )
67+import Roboservant.Types.Config
68+
69+import System.Random (Random (randomR), StdGen, mkStdGen)
70+import qualified Type.Reflection as R
71+
4872data RoboservantException
4973 = RoboservantException
50− { failureReason :: FailureType
51− , serverException :: Maybe SomeException
52− , fuzzState :: FuzzState
53− } deriving (Show)
74+ { failureReason :: FailureType,
75+ serverException :: Maybe SomeException,
76+ fuzzState :: FuzzState
77+ }
78+ deriving (Show)
5479
5580instance Exception RoboservantException
5681
@@ -59,194 +84,228 @@ data FailureType
5984 | CheckerFailed
6085 | NoPossibleMoves
6186 | InsufficientCoverage Double
62− deriving (Show,Eq)
63−
64−
65−data FuzzOp = FuzzOp
66− { apiOffset :: ApiOffset
67− , provenance :: [Provenance]
68− } deriving (Show,Eq)
69−
70−data Config
71− = Config
72− { seed :: [Dynamic]
73− , maxRuntime :: Integer -- seconds to test for
74− , maxReps :: Integer
75− , rngSeed :: Int
76− , coverageThreshold :: Double
77− }
78−
79−data FuzzState = FuzzState
80− { path :: [FuzzOp]
81− , stash :: Stash
82− , currentRng :: StdGen
83− }
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+ }
84102 deriving (Show)
85103
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+
86112data StopReason
87113 = TimedOut
88114 | HitMaxIterations
89− deriving (Show,Eq)
115+ deriving (Show, Eq)
90116
91−data Report = Report
92− { textual :: String
93− , rsException :: RoboservantException}
117+data Report
118+ = Report
119+ { textual :: String,
120+ rsException :: RoboservantException
121+ }
94122 deriving (Show)
95123
96−fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
97− => Server api
98− -> Config
99− -> IO ()
100− -> IO (Maybe Report)
101−fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
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
102136 let path = []
103137 stash = addToStash seed mempty
104138 currentRng = mkStdGen rngSeed
105−
106−
107− deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
108− (stopreason, fs ) <- runStateT
109− (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
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
110145 pure Nothing
111− -- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
112−
113146 where
114147 -- something less terrible later
115148 formatException :: RoboservantException -> Report
116− formatException r@(RoboservantException failureType exception _state) = Report
117− (unlines [ show failureType , show exception ])
118− r
119−
120− displayDiagnostics FuzzState{..} = liftIO $ do
121− putStrLn "api endpoints covered"
122− mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
123− putStrLn ""
124− putStrLn "types in stash"
125− mapM_
126− (print . second NEL.length)
127− (sortOn (show . fst) . Map.toList stash)
128−
129− -- evaluateCoverage :: FuzzState -> m ()
130− evaluateCoverage f@FuzzState{..}
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))
162+
163+ evaluateCoverage f@FuzzState {..}
131164 | coverage > coverageThreshold = pure ()
132165 | otherwise = do
133− displayDiagnostics f
134− throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
135− where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
136− totalRoutes = fromIntegral routeCount
137− coverage = hitRoutes / totalRoutes
138−
139−
140− untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
141− untilDone (0,_) _ = pure HitMaxIterations
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
142174 untilDone (n, deadline) action = do
143175 now <- liftIO getCurrentTime
144176 if now > deadline
145177 then pure TimedOut
146178 else do
147− action
148− untilDone (n-1, deadline) action
179+ _ <- action
180+ untilDone (n -1, deadline) action
149181
150− reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
151182 routeCount = length reifiedApi
152−
153− elementOrFail :: (MonadState FuzzState m, MonadIO m)
154− => [a] -> m a
155− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
183+ elementOrFail ::
184+ (MonadState FuzzState m, MonadIO m) =>
185+ [a] ->
186+ m a
187+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
156188 elementOrFail l = do
157189 st <- get
158− let (index,newGen) = randomR (0, length l - 1) (currentRng st)
159− modify' $ \st' -> st' { currentRng = newGen }
190+ let (index, newGen) = randomR (0, length l - 1) (currentRng st)
191+ modify' $ \st' -> st' {currentRng = newGen}
160192 pure (l !! index)
161−
162− genOp :: (MonadState FuzzState m, MonadIO m)
163− => m (FuzzOp, Dynamic, [Dynamic])
164− genOp = do -- fs@FuzzState{..} = do
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
203+ withOp callback = do
165204 -- choose a call to make, from the endpoints with fillable arguments.
166− (offset, dynCall, args) <- elementOrFail . options =<< get
167− r <- mapM (elementOrFail . zip [0..] . NEL.toList) args
168− let pathSegment = FuzzOp offset (map (\(index,(_,dyn) ) -> Provenance (dynTypeRep dyn) index) r)
169− modify' (\f -> f { path = path f <> [pathSegment] })
170− pure (pathSegment, dynCall, fmap (snd . snd) r)
171−
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)
224+ r
225+ modify' (\f -> f {path = path f <> [pathSegment]})
226+ callback pathSegment eoCall argValues
172227 where
173− options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]
174− options FuzzState{..} =
228+ options :: FuzzState -> [(ApiOffset, EndpointOption)]
229+ options FuzzState {..} =
175230 mapMaybe
176− ( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$>
177− mapM (\(_tr,bf) -> bf stash ) argreps
231+ ( \(offset, ReifiedEndpoint {..}) -> do
232+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
233+ pure (offset, EndpointOption reEndpointFunc args)
178234 )
179235 reifiedApi
180−
181− execute :: (MonadState FuzzState m, MonadIO m)
182− => (FuzzOp,Dynamic,[Dynamic]) -> m ()
183− execute (fuzzop, dyncall, args) = do
184− -- liftIO $ print fuzzop
185− -- now, magic happens: we apply some dynamic arguments to a dynamic
186− -- function and hopefully something useful pops out the end.
187− let func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just dyncall) (reverse args)
188− st <- get
189− let showable = unlines $ ("args":map (show . dynTypeRep) args)
190− <> ["fuzzop"
191− , show fuzzop
192− ,"dyncall"
193− ,show (dynTypeRep dyncall)
194− ,"state"
195− ,show st]
196− -- liftIO $ putStrLn showable
197−
198− case func of
199− Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
200− Just f' -> do
201− -- liftIO $ print
202− case fromDynamic f' of
203− Nothing -> error ("all screwed up 2: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
204− Just f -> liftIO f >>= \case
205− -- parameterise this
206− Left (serverError :: ServerError) ->
207− case errHTTPCode serverError of
208− 500 -> throw serverError
209− _ ->
210− liftIO $ print ("ignoring non-500 error" , serverError)
211−
212− Right (dyn :: NEL.NonEmpty Dynamic) -> do
213− -- liftIO $ print ("storing", fmap dynTypeRep dyn)
214− modify' (\fs@FuzzState{..} ->
215− fs { stash = addToStash (NEL.toList dyn) stash } )
216− pure ()
217−
218−-- go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
219−-- => m ()
220− go = do
221− op <- genOp
222− catches (execute op)
223− [ Handler (\(e :: SomeAsyncException) -> throw e)
224− , Handler (\(e :: SomeException) -> do
225− displayDiagnostics =<< get
226− throw . RoboservantException ServerCrashed (Just e) =<< get)
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 ()
242+ execute fuzzop func args = do
243+ (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
244+ 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+ )
254+ where
255+ 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 ()
260+ 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+ )
227268 ]
228− catch (liftIO checker)
229− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
230−
231− -- actions <-
232− -- forAll $ do
233− -- Gen.sequential
234− -- (Range.linear 1 100)
235− -- emptyState
236− -- (fmap preload seed <> [callEndpoint reifiedApi])
237− -- executeSequential emptyState actions
238−addToStash :: [Dynamic]
239− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
240− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
269+ catch
270+ (liftIO healthCheck)
271+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
272+
273+addToStash ::
274+ [(Dynamic, Int)] ->
275+ Stash ->
276+ Stash
241277addToStash result stash =
242− foldr (\dyn dict -> let tr = dynTypeRep dyn in
243− Map.insertWith renumber tr (pure ([Provenance tr 0],dyn)) dict) stash result
244−-- Map.insertWith (flip (<>)) (dynTypeRep result) (_pure 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
286+ )
287+ stash
288+ result
245289 where
246− renumber :: NEL.NonEmpty ([Provenance],Dynamic)
247− -> NEL.NonEmpty ([Provenance],Dynamic)
248− -> NEL.NonEmpty ([Provenance],Dynamic)
249− renumber singleDyn l = case NEL.toList singleDyn of
250− [([Provenance tr _], dyn)] -> l
251− <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
252− _ -> error "should be impossible"
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)
304+
305+-- 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]
311+recordToList' f = V.recordToList . V.rmap (V.Const . f)