@@ -6,6 +6,7 @@
66{-# LANGUAGE GADTs #-}
77{-# LANGUAGE LambdaCase #-}
88{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE RankNTypes #-}
910{-# LANGUAGE RecordWildCards #-}
1011{-# LANGUAGE ScopedTypeVariables #-}
1112{-# LANGUAGE TupleSections #-}
@@ -18,14 +19,20 @@ module Roboservant.Direct
1819 ( fuzz, Config(..)
1920
2021 -- TODO come up with something smarter than exporting all this, we should
21− -- have some nice error-display functions
22+ -- have some nice error-display functions
2223 , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)
2324 )
2425where
2526
2627import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
2728import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
28−import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
29+import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
30+import Control.Monad(void,replicateM,forM_)
31+import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
32+import Control.Monad.Trans.Control(MonadBaseControl)
33+import Data.Dependent.Map (DMap)
34+import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
35+import Data.List.NonEmpty (NonEmpty(..))
2936import Data.Map.Strict(Map)
3037import qualified Data.Set as Set
3138import Data.Maybe (mapMaybe)
@@ -37,6 +44,16 @@ import qualified Data.Map.Strict as Map
3744import Data.Time.Clock
3845import Data.List(sortOn)
3946import Control.Arrow(second)
47+import System.Timeout.Lifted(timeout)
48+import GHC.Generics ((:*:)(..))
49+import qualified Data.Vinyl.Functor as V
50+import qualified Data.Vinyl.Curry as V
51+import qualified Data.Dependent.Map as DM
52+import qualified Data.Vinyl as V
53+import qualified Data.List.NonEmpty as NEL
54+import qualified Data.Map.Strict as Map
55+import Data.Time.Clock
56+import qualified Type.Reflection as R
4057
4158import Roboservant.Types.Breakdown
4259import Roboservant.Types
@@ -44,11 +61,19 @@ import Roboservant.Types
4461 FlattenServer (..),
4562-- ReifiedApi,
4663 ToReifiedApi (..),
47− ))
64+
65+ ReifiedEndpoint(..),
66+ Argument(..),
67+ TypedF
68+
69+ )
70+
71+
4872data RoboservantException
4973 = RoboservantException
5074 { failureReason :: FailureType
5175 , serverException :: Maybe SomeException
76+ , something :: Int
5277 , fuzzState :: FuzzState
5378 } deriving (Show)
5479
@@ -81,7 +106,12 @@ data FuzzState = FuzzState
81106 , stash :: Stash
82107 , currentRng :: StdGen
83108 }
84− deriving (Show)
109+ deriving Show
110+
111+data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption
112+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
113+ , eoArgs :: V.Rec (TypedF StashValue) as
114+ }
85115
86116data StopReason
87117 = TimedOut
@@ -107,9 +137,8 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
107137 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
108138 (stopreason, fs ) <- runStateT
109139 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
140+ print stopreason
110141 pure Nothing
111− -- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
112−
113142 where
114143 -- something less terrible later
115144 formatException :: RoboservantException -> Report
@@ -159,67 +188,77 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
159188 modify' $ \st' -> st' { currentRng = newGen }
160189 pure (l !! index)
161190
162− genOp :: (MonadState FuzzState m, MonadIO m)
163− => m (FuzzOp, Dynamic, [Dynamic])
164− genOp = do -- fs@FuzzState{..} = do
191+ withOp :: (MonadState FuzzState m, MonadIO m)
192+ => (forall as. (V.RecordToList as, V.RMap as)
193+ => FuzzOp
194+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
195+ -> V.Rec (TypedF V.Identity) as -> m r
196+ )
197+ -> m r
198+ withOp callback = do
165199 -- 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)
200+ (offset, EndpointOption{..}) <- elementOrFail . options =<< get
201+ r <- V.rtraverse
202+ (\(tr :*: StashValue svs) -> elementOrFail $
203+ zipWith (\i xy -> V.Const i :*: tr :*: xy)
204+ [0..]
205+ (NEL.toList svs)
206+ )
207+ eoArgs
208+ let pathSegment = FuzzOp offset $
209+ recordToList'
210+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
211+ r
212+ argValues = V.rmap
213+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
214+ r
169215 modify' (\f -> f { path = path f <> [pathSegment] })
170− pure (pathSegment, dynCall, fmap (snd . snd) r)
171−
216+ callback pathSegment eoCall argValues
172217 where
173− options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]
218+ options :: FuzzState -> [(ApiOffset, EndpointOption)]
174219 options FuzzState{..} =
175220 mapMaybe
176− ( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$>
177− mapM (\(_tr,bf) -> bf stash ) argreps
221+ ( \(offset, ReifiedEndpoint{..}) -> do
222+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
223+ pure (offset, EndpointOption reEndpointFunc args)
178224 )
179225 reifiedApi
180226
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)
227+ execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)
228+ => FuzzOp
229+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
230+ -> V.Rec (TypedF V.Identity) as
231+ -> m ()
232+ execute fuzzop func args = do
233+ liftIO $ print fuzzop
188234 st <- get
189− let showable = unlines $ ("args":map (show . dynTypeRep) args)
235+ let showable = unlines $ ("args":map show argTypes)
190236 <> ["fuzzop"
191237 , show fuzzop
192− ,"dyncall"
193− ,show (dynTypeRep dyncall)
238+ -- ,"dyncall"
239+ -- ,show (dynTypeRep dyncall)
194240 ,"state"
195241 ,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)
242+ liftIO $ putStrLn showable
243+ liftIO (V.runcurry' func argVals) >>= \case
244+ -- parameterise this
245+ Left (serverError :: ServerError) ->
246+ case errHTTPCode serverError of
247+ 500 -> throw serverError
248+ _ -> do
249+ liftIO $ print ("ignoring non-500 error" , serverError)
250+ Right (dyn :: NEL.NonEmpty Dynamic) -> do
251+ liftIO $ print ("storing", fmap dynTypeRep dyn)
252+ modify' (\fs@FuzzState{..} ->
253+ fs { stash = addToStash (NEL.toList dyn) stash } )
254+ where
255+ argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
256+ argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
257+
258+ go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
259+ => m ()
260+ go = withOp $ \op func args -> do
261+ catches (execute op func args)
223262 [ Handler (\(e :: SomeAsyncException) -> throw e)
224263 , Handler (\(e :: SomeException) -> do
225264 displayDiagnostics =<< get
@@ -228,25 +267,29 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
228267 catch (liftIO checker)
229268 (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
230269
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
238270addToStash :: [Dynamic]
239− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
240− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
271+ -> Stash
272+ -> Stash
241273addToStash 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 })
274+ foldr (\(Dynamic tr x) (Stash dict) -> Stash $
275+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict
276+ )
277+ stash
278+ result
245279 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
280+ renumber :: StashValue a
281+ -> StashValue a
282+ -> StashValue a
283+ renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
250284 [([Provenance tr _], dyn)] -> l
251285 <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
252286 _ -> error "should be impossible"
287+
288+
289+-- why isn't this in vinyl?
290+recordToList'
291+ :: (V.RecordToList as, V.RMap as)
292+ => (forall x. f x -> a)
293+ -> V.Rec f as
294+ -> [a]
295+recordToList' f = V.recordToList . V.rmap (V.Const . f)