@@ -1,311 +1,229 @@
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
2421 )
2522where
2623
27−import Control.Exception.Lifted
28− ( Exception,
29− Handler (Handler),
30− SomeAsyncException,
31− SomeException,
32− catch,
33− catches,
34− handle,
35− throw,
36− )
24+import Control.Monad.Trans.Control
3725import 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 (..))
26+import Control.Exception.Lifted(throw,Exception,SomeException,catch)
27+import System.Random
28+import System.Timeout.Lifted
29+import Control.Monad (guard)
30+import Control.Monad.IO.Class (MonadIO, liftIO)
31+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
4832import qualified Data.List.NonEmpty as NEL
33+import qualified Data.Map.Strict as Map
34+import Data.Map.Strict(Map)
4935import 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 ((:*:) (..))
36+import Data.Typeable (TypeRep)
37+import Hedgehog
38+ ( Callback (Update),
39+ Command (Command),
40+ Concrete,
41+ MonadGen,
42+ Opaque (Opaque),
43+ PropertyT,
44+ Symbolic,
45+ Var,
46+ executeSequential,
47+ forAll,
48+ opaque,
49+ )
50+import qualified Hedgehog.Gen as Gen
51+import qualified Hedgehog.Range as Range
52+import Roboservant.Hedgehog (elementOrFail)
5653import Roboservant.Types
5754 ( ApiOffset (..),
58− Argument (..),
59− InteractionError(..),
60− Provenance (..),
55+ FlattenServer (..),
56+ Op (..),
6157 ReifiedApi,
62− ReifiedEndpoint (..),
63− Stash (..),
64− StashValue (..),
65− TypedF,
58+ State (..),
59+ ToReifiedApi (..),
60+ emptyState,
6661 )
67−import Roboservant.Types.Config
62+import Servant (Endpoints, Proxy (Proxy), Server, ServerError)
63+import Type.Reflection (SomeTypeRep)
6864
69−import System.Random (Random (randomR), StdGen, mkStdGen)
70−import qualified Type.Reflection as R
65+-- prop_concurrent,
66+import Control.Monad (guard)
67+import Control.Monad.IO.Class (MonadIO, liftIO)
68+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
69+import qualified Data.List.NonEmpty as NEL
70+import qualified Data.Map.Strict as Map
71+import Data.Maybe (mapMaybe)
72+import Data.Typeable (TypeRep)
73+import qualified Hedgehog.Gen as Gen
74+import qualified Hedgehog.Range as Range
75+import Roboservant.Hedgehog (elementOrFail)
76+import Roboservant.Types
77+ ( ApiOffset (..),
78+ FlattenServer (..),
79+ Op (..),
80+ ReifiedApi,
81+ State (..),
82+ ToReifiedApi (..),
83+ emptyState,
84+ )
85+import Servant (Endpoints, Proxy (Proxy), Server, ServerError)
86+import Type.Reflection (SomeTypeRep)
7187
7288data RoboservantException
73− = RoboservantException
74− { failureReason :: FailureType,
75− serverException :: Maybe SomeException,
76− fuzzState :: FuzzState
77− }
89+ = RoboservantException FailureType SomeException FuzzOp FuzzState
7890 deriving (Show)
79−
91+-- we believe in nussink, lebowski
8092instance Exception RoboservantException
8193
8294data FailureType
8395 = ServerCrashed
8496 | CheckerFailed
8597 | 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− }
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− }
98+ deriving (Show,Eq)
99+
100+-- update :: Callback Op (Opaque (NEL.NonEmpty Dynamic)) State
101+-- update = Update $ \s@State {..} op o' ->
102+-- case op of
103+-- Chewable offset tr v -> case _extract offset trs chewable of
104+-- Nothing -> error "internal error"
105+-- Just (tr, _extracted, rest) ->
106+-- s
107+-- { stateRefs =
108+-- -- so, what's going on here... we need to be able to grab and merge
109+-- -- a list of (typeref, var). this means that we need to be able to pull
110+-- -- out typereps symbolically too, we can't just rely on the dynamic being there.
111+-- -- Map.insertWith (<>) (dynTypeRep v) _ (pure o') stateRefs,
112+-- Map.insertWith (<>) tr (_ o') stateRefs,
113+-- chewable = rest
114+-- }
115+-- (Op (ApiOffset _offset) _args) ->
116+-- s
117+-- { chewable = _ o' : chewable
118+-- -- Map.insertWith
119+-- -- (<>)
120+-- -- tr
121+-- -- (pure o')
122+-- -- stateRefs
123+-- }
124+
125+
126+data Reference = Reference
127+ { tr :: TypeRep
128+ , offset :: Int
129+ } deriving (Show,Eq)
130+
131+data FuzzOp = FuzzOp ApiOffset [Reference]
132+ deriving (Show,Eq)
133+
134+data Config
135+ = Config
136+ { seed :: [Dynamic]
137+ , maxRuntime :: Int -- seconds to test for
138+ , rngSeed :: Int
139+ , currentRng :: StdGen
140+ }
141+
142+data FuzzState = FuzzState
143+ { path :: [FuzzOp]
144+ , stash :: Map TypeRep (NEL.NonEmpty (Reference,Dynamic))
145+ }
122146 deriving (Show)
123147
148+fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
149+ => Server api
150+ -> Config
151+ -> IO ()
152+ -> IO ()
153+fuzz server Config{..} checker =
154+ -- either we time out without finding an error, which is fine, or we find an error
155+ -- and throw an exception that propagates through this.
156+ void $ timeout (maxRuntime * 1000000) ( execStateT (forever go) FuzzState{..})
124157
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
136− let path = []
137− stash = addToStash seed mempty
138− 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
145− pure Nothing
146158 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))
162159
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
160+ reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
161+
162+ elementOrFail :: MonadState FuzzState m
163+ => [a] -> m a
164+ elementOrFail = undefined
181165
182− routeCount = length reifiedApi
183− elementOrFail ::
184− (MonadState FuzzState m, MonadIO m) =>
185− [a] ->
186− m a
187− elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
188− elementOrFail l = do
189− st <- get
190− let (index, newGen) = randomR (0, length l - 1) (currentRng st)
191− modify' $ \st' -> st' {currentRng = newGen}
192− 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
166+ genOp :: MonadState FuzzState m
167+ => m FuzzOp
168+ genOp = do -- fs@FuzzState{..} = do
204169 -- 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
170+ (offset, args) <- elementOrFail . options =<< get
171+ -- choose a (symbolic) argument from each. we drop the Dynamic here because it's
172+ -- not showable, which is no good for tests - though possibly it would make sense
173+ -- to use the constrained-dynamic stuff here? (or even just stash the string form)
174+ r <- (FuzzOp offset) <$> mapM (elementOrFail . fmap fst . NEL.toList) args
175+ modify' (\f -> f { path = r:path f })
176+ pure r
177+
178+
179+-- chooseOne opts = do
180+--
181+-- (offset,) <$> mapM elementOrFail args
227182 where
228− options :: FuzzState -> [(ApiOffset, EndpointOption)]
229− options FuzzState {..} =
183+ options :: FuzzState -> [(ApiOffset, [NEL.NonEmpty (Reference, Dynamic)])]
184+ options FuzzState{..} =
230185 mapMaybe
231− ( \(offset, ReifiedEndpoint {..}) -> do
232− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
233− pure (offset, EndpointOption reEndpointFunc args)
186+ ( \(offset, (argreps, _dynCall)) -> (offset,) <$> do
187+ mapM (flip Map.lookup stash) argreps
234188 )
235189 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)
272−
273−addToStash ::
274− [(Dynamic, Int)] ->
275− Stash ->
276− Stash
277−addToStash 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
289− 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)
190+ execute :: MonadState FuzzState m
191+ => FuzzOp -> m ()
192+ execute = undefined
193+
194+
195+
196+ -- execute (Op (ApiOffset offset) args) = do
197+ -- fmap Opaque . liftIO $ do
198+ -- let realArgs = map opaque args
199+ -- let (_offset, (_staticArgs, endpoint)) = staticRoutes !! offset
200+ -- -- now, magic happens: we apply some dynamic arguments to a dynamic
201+ -- -- function and hopefully something useful pops out the end.
202+ -- func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
203+ -- let showable = "blah" -- map dynTypeRep (_endpoint : realArgs)
204+ -- case func of
205+ -- Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
206+ -- Just (f') -> do
207+ -- case fromDynamic f' of
208+ -- Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
209+ -- Just f -> liftIO f >>= \case
210+ -- Left (serverError :: ServerError) -> error (show serverError)
211+ -- Right (_typeRep :: SomeTypeRep, (dyn :: NEL.NonEmpty Dynamic)) -> pure dyn
212+
213+
214+ go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
215+ => m ()
216+ go = do
217+ fuzzOp <- genOp
218+ catch (execute fuzzOp)
219+ (\(e :: SomeException) -> throw . RoboservantException ServerCrashed e fuzzOp =<< get)
220+ catch (liftIO checker)
221+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed e fuzzOp =<< get)
222+
223+ -- actions <-
224+ -- forAll $ do
225+ -- Gen.sequential
226+ -- (Range.linear 1 100)
227+ -- emptyState
228+ -- (fmap preload seed <> [callEndpoint reifiedApi])
229+ -- executeSequential emptyState actions