@@ -1,311 +1,241 @@
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 #-}
6−{-# LANGUAGE RankNTypes #-}
710{-# LANGUAGE RecordWildCards #-}
811{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE StandaloneDeriving #-}
913{-# LANGUAGE TupleSections #-}
10−
14+{-# LANGUAGE TypeApplications #-}
1115{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeOperators #-}
1217{-# LANGUAGE UndecidableInstances #-}
1318
1419module 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 (..),
20+ ( 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(..)
2425 )
2526where
2627
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
49−import Data.Maybe (mapMaybe)
28+import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
29+import Control.Monad(void,replicateM)
30+import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
31+import Control.Monad.Trans.Control(MonadBaseControl)
32+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
33+import Data.Map.Strict(Map)
5034import 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 ((:*:) (..))
35+import Data.Maybe (mapMaybe)
36+import Data.Typeable (TypeRep)
37+import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
38+import System.Random(StdGen,randomR,mkStdGen)
39+import System.Timeout.Lifted(timeout)
40+import qualified Data.List.NonEmpty as NEL
41+import qualified Data.Map.Strict as Map
42+import Data.Time.Clock
43+
44+import Roboservant.Types.Breakdown
5645import Roboservant.Types
5746 ( ApiOffset (..),
58− Argument (..),
59− InteractionError(..),
60− Provenance (..),
61− ReifiedApi,
62− ReifiedEndpoint (..),
63− Stash (..),
64− StashValue (..),
65− TypedF,
47+ FlattenServer (..),
48+-- ReifiedApi,
49+ ToReifiedApi (..),
6650 )
67−import Roboservant.Types.Config
68−
69−import System.Random (Random (randomR), StdGen, mkStdGen)
70−import qualified Type.Reflection as R
7151
7252data RoboservantException
73− = RoboservantException
74− { failureReason :: FailureType,
75− serverException :: Maybe SomeException,
76− fuzzState :: FuzzState
77− }
53+ = RoboservantException FailureType (Maybe SomeException) Int FuzzState
7854 deriving (Show)
79−
55+-- we believe in nussink, lebowski
8056instance Exception RoboservantException
8157
8258data FailureType
8359 = ServerCrashed
8460 | CheckerFailed
8561 | 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− }
62+ | InsufficientCoverage
63+ deriving (Show,Eq)
64+
65+
66+data FuzzOp = FuzzOp
67+ { apiOffset :: ApiOffset
68+ , provenance :: [Provenance]
69+ } deriving (Show,Eq)
70+
71+data Config
72+ = Config
73+ { seed :: [Dynamic]
74+ , maxRuntime :: Integer -- seconds to test for
75+ , maxReps :: Integer
76+ , rngSeed :: Int
77+ , coverageThreshold :: Double
78+ }
79+
80+data FuzzState = FuzzState
81+ { path :: [FuzzOp]
82+ , stash :: Stash
83+ , currentRng :: StdGen
84+ }
10285 deriving (Show)
10386
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−
11287data StopReason
11388 = TimedOut
11489 | 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
90+ deriving (Show,Eq)
91+
92+data Report = Report
93+ { textual :: String }
94+ deriving (Show,Eq)
95+
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
136102 let path = []
137103 stash = addToStash seed mempty
138104 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
105+
106+
107+ deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
108+ -- either we time out without finding an error, which is fine, or we find an error
109+ -- and throw an exception that propagates through this.
110+
111+ (stopreason, fs ) <- runStateT
112+ (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
145113 pure Nothing
114+ -- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
115+
146116 where
147117 -- something less terrible later
148118 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))
162−
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
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
174133 untilDone (n, deadline) action = do
175134 now <- liftIO getCurrentTime
176135 if now > deadline
177136 then pure TimedOut
178137 else do
179− _ <- action
180− untilDone (n -1, deadline) action
181−
138+ action
139+ untilDone (n-1, deadline) action
140+
141+ reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
182142 routeCount = length reifiedApi
183− elementOrFail ::
184− (MonadState FuzzState m, MonadIO m) =>
185− [a] ->
186− m a
187− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
143+
144+ elementOrFail :: (MonadState FuzzState m, MonadIO m)
145+ => [a] -> m a
146+ elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
188147 elementOrFail l = do
189148 st <- get
190− let (index, newGen) = randomR (0, length l - 1) (currentRng st)
191− modify' $ \st' -> st' {currentRng = newGen}
149+ let (index,newGen) = randomR (0, length l - 1) (currentRng st)
150+ modify' $ \st' -> st' { currentRng = newGen }
192151 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
203− withOp callback = do
152+
153+ genOp :: (MonadState FuzzState m, MonadIO m)
154+ => m (FuzzOp, Dynamic, [Dynamic])
155+ genOp = do -- fs@FuzzState{..} = do
204156 -- 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)
224− r
225− modify' (\f -> f {path = path f <> [pathSegment]})
226− callback pathSegment eoCall argValues
157+ (offset, dynCall, args) <- elementOrFail . options =<< get
158+ r <- mapM (elementOrFail . zip [0..] . NEL.toList) args
159+ let pathSegment = FuzzOp offset (map (\(index,(_,dyn) ) -> Provenance (dynTypeRep dyn) index) r)
160+ modify' (\f -> f { path = path f <> [pathSegment] })
161+ pure (pathSegment, dynCall, fmap (snd . snd) r)
162+
227163 where
228− options :: FuzzState -> [(ApiOffset, EndpointOption)]
229− options FuzzState {..} =
164+ options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]
165+ options FuzzState{..} =
230166 mapMaybe
231− ( \(offset, ReifiedEndpoint {..}) -> do
232− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
233− pure (offset, EndpointOption reEndpointFunc args)
167+ ( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$> do
168+ mapM (\(_tr,bf) -> bf stash ) argreps
234169 )
235170 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 ()
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− )
268− ]
269− catch
270− (liftIO healthCheck)
271− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
272171
273−addToStash ::
274− [(Dynamic, Int)] ->
275− Stash ->
276− Stash
172+ execute :: (MonadState FuzzState m, MonadIO m)
173+ => (FuzzOp,Dynamic,[Dynamic]) -> m ()
174+ execute (fuzzop, dyncall, args) = do
175+ -- liftIO $ print fuzzop
176+ -- now, magic happens: we apply some dynamic arguments to a dynamic
177+ -- function and hopefully something useful pops out the end.
178+ let func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just dyncall) (reverse args)
179+ st <- get
180+ let showable = unlines $ ("args":map (show . dynTypeRep) args)
181+ <> ["fuzzop"
182+ , show fuzzop
183+ ,"dyncall"
184+ ,show (dynTypeRep dyncall)
185+ ,"state"
186+ ,show st]
187+ -- liftIO $ putStrLn showable
188+
189+ case func of
190+ Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
191+ Just (f') -> do
192+ -- liftIO $ print
193+ case fromDynamic f' of
194+ Nothing -> error ("all screwed up 2: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
195+ Just (f) -> liftIO f >>= \case
196+ -- parameterise this
197+ Left (serverError :: ServerError) ->
198+ case errHTTPCode serverError of
199+ 500 -> throw serverError
200+ _ -> do
201+ liftIO $ print ("ignoring non-500 error" , serverError)
202+
203+ Right (dyn :: NEL.NonEmpty Dynamic) -> do
204+ -- liftIO $ print ("storing", fmap dynTypeRep dyn)
205+ modify' (\fs@FuzzState{..} ->
206+ fs { stash = addToStash (NEL.toList dyn) stash } )
207+ pure ()
208+
209+ go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
210+ => m ()
211+ go = do
212+ op <- genOp
213+ catches (execute op)
214+ [ Handler (\(e :: SomeAsyncException) -> throw e)
215+ , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
216+ ]
217+ catch (liftIO checker)
218+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
219+
220+ -- actions <-
221+ -- forAll $ do
222+ -- Gen.sequential
223+ -- (Range.linear 1 100)
224+ -- emptyState
225+ -- (fmap preload seed <> [callEndpoint reifiedApi])
226+ -- executeSequential emptyState actions
227+addToStash :: [Dynamic]
228+ -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
229+ -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
277230addToStash 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
231+ foldr (\dyn dict -> let tr = dynTypeRep dyn in
232+ Map.insertWith renumber tr (pure ([Provenance tr 0],dyn)) dict) stash result
233+-- Map.insertWith (flip (<>)) (dynTypeRep result) (_pure result) stash })
289234 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)
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)
235+ renumber :: NEL.NonEmpty ([Provenance],Dynamic)
236+ -> NEL.NonEmpty ([Provenance],Dynamic)
237+ -> NEL.NonEmpty ([Provenance],Dynamic)
238+ renumber singleDyn l = case NEL.toList singleDyn of
239+ [([Provenance tr _], dyn)] -> l
240+ <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
241+ _ -> error "should be impossible"