@@ -7,6 +7,7 @@
77{-# LANGUAGE GeneralizedNewtypeDeriving #-}
88{-# LANGUAGE LambdaCase #-}
99{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE RankNTypes #-}
1011{-# LANGUAGE RecordWildCards #-}
1112{-# LANGUAGE ScopedTypeVariables #-}
1213{-# LANGUAGE StandaloneDeriving #-}
@@ -20,7 +21,7 @@ module Roboservant.Direct
2021 ( fuzz, Config(..)
2122
2223 -- TODO come up with something smarter than exporting all this, we should
23− -- have some nice error-display functions
24+ -- have some nice error-display functions
2425 , RoboservantException(..), FuzzState(..), FuzzOp(..)
2526 )
2627where
@@ -28,8 +29,13 @@ where
2829import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
2930import Control.Monad(void,replicateM)
3031import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
32+import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
33+import Control.Monad(void,replicateM,forM_)
34+import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
3135import Control.Monad.Trans.Control(MonadBaseControl)
32−import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
36+import Data.Dependent.Map (DMap)
37+import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
38+import Data.List.NonEmpty (NonEmpty(..))
3339import Data.Map.Strict(Map)
3440import qualified Data.Set as Set
3541import Data.Maybe (mapMaybe)
@@ -37,9 +43,15 @@ import Data.Typeable (TypeRep)
3743import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
3844import System.Random(StdGen,randomR,mkStdGen)
3945import System.Timeout.Lifted(timeout)
46+import GHC.Generics ((:*:)(..))
47+import qualified Data.Vinyl.Functor as V
48+import qualified Data.Vinyl.Curry as V
49+import qualified Data.Dependent.Map as DM
50+import qualified Data.Vinyl as V
4051import qualified Data.List.NonEmpty as NEL
4152import qualified Data.Map.Strict as Map
4253import Data.Time.Clock
54+import qualified Type.Reflection as R
4355
4456import Roboservant.Types.Breakdown
4557import Roboservant.Types
@@ -47,10 +59,14 @@ import Roboservant.Types
4759 FlattenServer (..),
4860-- ReifiedApi,
4961 ToReifiedApi (..),
62+ ReifiedEndpoint(..),
63+ Argument(..),
64+ TypedF
65+
5066 )
5167
5268data RoboservantException
53− = RoboservantException FailureType (Maybe SomeException) Int FuzzState
69+ = RoboservantException FailureType (Maybe SomeException) Int FuzzState
5470 deriving (Show)
5571-- we believe in nussink, lebowski
5672instance Exception RoboservantException
@@ -63,7 +79,7 @@ data FailureType
6379 deriving (Show,Eq)
6480
6581
66−data FuzzOp = FuzzOp
82+data FuzzOp = FuzzOp
6783 { apiOffset :: ApiOffset
6884 , provenance :: [Provenance]
6985 } deriving (Show,Eq)
@@ -82,7 +98,12 @@ data FuzzState = FuzzState
8298 , stash :: Stash
8399 , currentRng :: StdGen
84100 }
85− deriving (Show)
101+ deriving Show
102+
103+data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption
104+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
105+ , eoArgs :: V.Rec (TypedF StashValue) as
106+ }
86107
87108data StopReason
88109 = TimedOut
@@ -91,7 +112,7 @@ data StopReason
91112
92113data Report = Report
93114 { textual :: String }
94− deriving (Show,Eq)
115+ deriving (Show,Eq)
95116
96117fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
97118 => Server api
@@ -103,16 +124,23 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
103124 stash = addToStash seed mempty
104125 currentRng = mkStdGen rngSeed
105126
106−
127+
107128 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
108129 -- either we time out without finding an error, which is fine, or we find an error
109130 -- and throw an exception that propagates through this.
110−
131+
111132 (stopreason, fs ) <- runStateT
112133 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
113134 pure Nothing
114135 -- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
115136
137+
138+ -- void $ timeout (maxRuntime * 1000000) ( execStateT (replicateM maxReps go) FuzzState{..})
139+ -- forM_ reifiedApi $ \(offset, ReifiedEndpoint{..}) ->
140+ -- print (
141+ -- offset
142+ -- , recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) reArguments
143+ -- )
116144 where
117145 -- something less terrible later
118146 formatException :: RoboservantException -> Report
@@ -126,7 +154,7 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
126154 | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
127155 where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
128156 totalRoutes = (fromIntegral routeCount)
129−
157+
130158
131159 untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
132160 untilDone (0,_) _ = pure HitMaxIterations
@@ -137,10 +165,10 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
137165 else do
138166 action
139167 untilDone (n-1, deadline) action
140−
168+
141169 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
142170 routeCount = length reifiedApi
143−
171+
144172 elementOrFail :: (MonadState FuzzState m, MonadIO m)
145173 => [a] -> m a
146174 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
@@ -150,92 +178,108 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
150178 modify' $ \st' -> st' { currentRng = newGen }
151179 pure (l !! index)
152180
153− genOp :: (MonadState FuzzState m, MonadIO m)
154− => m (FuzzOp, Dynamic, [Dynamic])
155− genOp = do -- fs@FuzzState{..} = do
181+ withOp :: (MonadState FuzzState m, MonadIO m)
182+ => (forall as. (V.RecordToList as, V.RMap as)
183+ => FuzzOp
184+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
185+ -> V.Rec (TypedF V.Identity) as -> m r
186+ )
187+ -> m r
188+ withOp callback = do
156189 -- choose a call to make, from the endpoints with fillable arguments.
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)
190+ (offset, EndpointOption{..}) <- elementOrFail . options =<< get
191+ r <- V.rtraverse
192+ (\(tr :*: StashValue svs) -> elementOrFail $
193+ zipWith (\i xy -> V.Const i :*: tr :*: xy)
194+ [0..]
195+ (NEL.toList svs)
196+ )
197+ eoArgs
198+ let pathSegment = FuzzOp offset $
199+ recordToList'
200+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
201+ r
202+ argValues = V.rmap
203+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
204+ r
160205 modify' (\f -> f { path = path f <> [pathSegment] })
161− pure (pathSegment, dynCall, fmap (snd . snd) r)
162−
206+ callback pathSegment eoCall argValues
163207 where
164− options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]
208+ options :: FuzzState -> [(ApiOffset, EndpointOption)]
165209 options FuzzState{..} =
166210 mapMaybe
167− ( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$> do
168− mapM (\(_tr,bf) -> bf stash ) argreps
211+ ( \(offset, ReifiedEndpoint{..}) -> do
212+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
213+ pure (offset, EndpointOption reEndpointFunc args)
169214 )
170215 reifiedApi
171216
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)
217+ execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)
218+ => FuzzOp
219+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
220+ -> V.Rec (TypedF V.Identity) as
221+ -> m ()
222+ execute fuzzop func args = do
223+ liftIO $ print fuzzop
179224 st <- get
180− let showable = unlines $ ("args":map (show . dynTypeRep) args)
225+ let showable = unlines $ ("args":map show argTypes)
181226 <> ["fuzzop"
182227 , show fuzzop
183− ,"dyncall"
184− ,show (dynTypeRep dyncall)
228+ -- ,"dyncall"
229+ -- ,show (dynTypeRep dyncall)
185230 ,"state"
186231 ,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 ()
232+ liftIO $ putStrLn showable
233+ liftIO (V.runcurry' func argVals) >>= \case
234+ -- parameterise this
235+ Left (serverError :: ServerError) ->
236+ case errHTTPCode serverError of
237+ 500 -> throw serverError
238+ _ -> do
239+ liftIO $ print ("ignoring non-500 error" , serverError)
240+ Right (dyn :: NEL.NonEmpty Dynamic) -> do
241+ liftIO $ print ("storing", fmap dynTypeRep dyn)
242+ modify' (\fs@FuzzState{..} ->
243+ fs { stash = addToStash (NEL.toList dyn) stash } )
244+ where
245+ argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
246+ argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
208247
209248 go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
210249 => m ()
211− go = do
212− op <- genOp
213− catches (execute op)
250+ go = withOp $ \op func args -> do
251+ catches (execute op func args)
214252 [ Handler (\(e :: SomeAsyncException) -> throw e)
215253 , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
216254 ]
217255 catch (liftIO checker)
218256 (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
219257
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
227258addToStash :: [Dynamic]
228− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
229− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
259+ -> Stash
260+ -> Stash
230261addToStash result stash =
231− foldr (\dyn dict -> let tr = dynTypeRep dyn in
232− Map.insertWith renumber tr (pure ([Provenance tr 0],dyn)) dict) stash result
262+ foldr (\(Dynamic tr x) (Stash dict) -> Stash $
263+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict
264+ -- in DM.insertWith renumber _ (pure ([Provenance tr 0],x)) dict
265+ )
266+ stash
267+ result
233268-- Map.insertWith (flip (<>)) (dynTypeRep result) (_pure result) stash })
234269 where
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
270+ renumber :: StashValue a
271+ -> StashValue a
272+ -> StashValue a
273+ renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
239274 [([Provenance tr _], dyn)] -> l
240275 <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
241276 _ -> error "should be impossible"
277+
278+
279+-- why isn't this in vinyl?
280+recordToList'
281+ :: (V.RecordToList as, V.RMap as)
282+ => (forall x. f x -> a)
283+ -> V.Rec f as
284+ -> [a]
285+recordToList' f = V.recordToList . V.rmap (V.Const . f)