@@ -1,237 +1,311 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DerivingStrategies #-}
42{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
63{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
84{-# LANGUAGE LambdaCase #-}
95{-# LANGUAGE PolyKinds #-}
106{-# LANGUAGE RankNTypes #-}
117{-# LANGUAGE RecordWildCards #-}
128{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
149{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE TypeApplications #-}
10+
1611{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
1812{-# LANGUAGE UndecidableInstances #-}
1913
2014module Roboservant.Direct
21− ( fuzz, Config(..)
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 (..),
2224 )
2325where
2426
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)
33−import Data.Maybe (mapMaybe)
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 ((:*:)(..))
39−import qualified Data.Vinyl.Functor as V
40−import qualified Data.Vinyl.Curry as V
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)
4144import qualified Data.Dependent.Map as DM
42−import qualified Data.Vinyl as V
45+import Data.Dynamic (Dynamic (..))
46+import qualified Data.IntSet as IntSet
47+import Data.List.NonEmpty (NonEmpty (..))
4348import 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
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 ((:*:) (..))
4856import Roboservant.Types
4957 ( ApiOffset (..),
50− FlattenServer (..),
51−-- ReifiedApi,
52− ToReifiedApi (..),
53− ReifiedEndpoint(..),
54− Argument(..),
55− TypedF
56−
58+ Argument (..),
59+ InteractionError(..),
60+ Provenance (..),
61+ ReifiedApi,
62+ ReifiedEndpoint (..),
63+ Stash (..),
64+ StashValue (..),
65+ TypedF,
5766 )
67+import Roboservant.Types.Config
68+
69+import System.Random (Random (randomR), StdGen, mkStdGen)
70+import qualified Type.Reflection as R
5871
5972data RoboservantException
60− = RoboservantException FailureType (Maybe SomeException) FuzzState
73+ = RoboservantException
74+ { failureReason :: FailureType,
75+ serverException :: Maybe SomeException,
76+ fuzzState :: FuzzState
77+ }
6178 deriving (Show)
62−-- we believe in nussink, lebowski
79+
6380instance Exception RoboservantException
6481
6582data FailureType
6683 = ServerCrashed
6784 | CheckerFailed
6885 | NoPossibleMoves
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
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
101136 let path = []
102137 stash = addToStash seed mempty
103138 currentRng = mkStdGen rngSeed
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− )
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
113146 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))
114162
115− reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
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
116181
117− elementOrFail :: (MonadState FuzzState m, MonadIO m)
118− => [a] -> m a
182+ routeCount = length reifiedApi
183+ elementOrFail ::
184+ (MonadState FuzzState m, MonadIO m) =>
185+ [a] ->
186+ m a
119187 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
120188 elementOrFail l = do
121189 st <- get
122− let (index,newGen) = randomR (0, length l - 1) (currentRng st)
123− modify' $ \st' -> st' { currentRng = newGen }
190+ let (index, newGen) = randomR (0, length l - 1) (currentRng st)
191+ modify' $ \st' -> st' {currentRng = newGen}
124192 pure (l !! index)
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
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
133203 withOp callback = do
134204 -- choose a call to make, from the endpoints with fillable arguments.
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)
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)
146224 r
147− argValues = V.rmap
148− (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
149− r
150− modify' (\f -> f { path = path f <> [pathSegment] })
225+ modify' (\f -> f {path = path f <> [pathSegment]})
151226 callback pathSegment eoCall argValues
152227 where
153228 options :: FuzzState -> [(ApiOffset, EndpointOption)]
154− options FuzzState{..} =
229+ options FuzzState {..} =
155230 mapMaybe
156− ( \(offset, ReifiedEndpoint{..}) -> do
157− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
158− pure (offset, EndpointOption reEndpointFunc args)
231+ ( \(offset, ReifiedEndpoint {..}) -> do
232+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
233+ pure (offset, EndpointOption reEndpointFunc args)
159234 )
160235 reifiedApi
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 ()
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 ()
167242 execute fuzzop func args = do
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
243+ (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
178244 liftIO (V.runcurry' func argVals) >>= \case
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 } )
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+ )
189254 where
190255 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
191− argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
192−
193− go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
194− => m ()
256+ -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
257+ go ::
258+ (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
259+ m ()
195260 go = withOp $ \op func args -> do
196− catches (execute op func args)
197− [ Handler (\(e :: SomeAsyncException) -> throw e)
198− , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get)
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+ )
199268 ]
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
269+ catch
270+ (liftIO healthCheck)
271+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
272+
273+addToStash ::
274+ [(Dynamic, Int)] ->
275+ Stash ->
276+ Stash
213277addToStash result stash =
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
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
217286 )
218287 stash
219288 result
220−-- Map.insertWith (flip (<>)) (dynTypeRep result) (_pure result) stash })
221289 where
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−
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)
230304
231305-- why isn't this in vinyl?
232−recordToList'
233− :: (V.RecordToList as, V.RMap as)
234− => (forall x. f x -> a)
235− -> V.Rec f as
236− -> [a]
306+recordToList' ::
307+ (V.RecordToList as, V.RMap as) =>
308+ (forall x. f x -> a) ->
309+ V.Rec f as ->
310+ [a]
237311recordToList' f = V.recordToList . V.rmap (V.Const . f)