@@ -1,73 +1,57 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DerivingStrategies #-}
42{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
63{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
84{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE PolyKinds #-}
105{-# LANGUAGE RankNTypes #-}
116{-# LANGUAGE RecordWildCards #-}
127{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
148{-# LANGUAGE TupleSections #-}
159{-# LANGUAGE TypeApplications #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
18−{-# LANGUAGE UndecidableInstances #-}
1910
2011module Roboservant.Direct
21− ( fuzz, Config(..)
22−
23− -- TODO come up with something smarter than exporting all this, we should
24− -- have some nice error-display functions
25− , RoboservantException(..), FuzzState(..), FuzzOp(..)
12+ ( fuzz,
13+ Config (..),
14+ -- TODO come up with something smarter than exporting all this, we should
15+ -- have some nice error-display functions
16+ RoboservantException (..),
17+ FuzzState (..),
18+ FuzzOp (..),
2619 )
2720where
2821
29−import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
30−import Control.Monad(void,replicateM)
31−import 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)
35−import Control.Monad.Trans.Control(MonadBaseControl)
36−import Data.Dependent.Map (DMap)
37−import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
38−import Data.List.NonEmpty (NonEmpty(..))
39−import Data.Map.Strict(Map)
40−import qualified Data.Set as Set
41−import Data.Maybe (mapMaybe)
42−import Data.Typeable (TypeRep)
43−import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
44−import System.Random(StdGen,randomR,mkStdGen)
45−import System.Timeout.Lifted(timeout)
46−import GHC.Generics ((:*:)(..))
47−import qualified Data.Vinyl.Functor as V
48−import qualified Data.Vinyl.Curry as V
22+import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)
23+import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)
24+import Control.Monad.Trans.Control (MonadBaseControl)
4925import qualified Data.Dependent.Map as DM
50−import qualified Data.Vinyl as V
26+import Data.Dynamic (Dynamic (..), dynTypeRep)
27+import Data.List.NonEmpty (NonEmpty (..))
5128import qualified Data.List.NonEmpty as NEL
52−import qualified Data.Map.Strict as Map
29+import Data.Maybe (mapMaybe)
30+import qualified Data.Set as Set
5331import Data.Time.Clock
54−import qualified Type.Reflection as R
55−
56−import Roboservant.Types.Breakdown
32+import qualified Data.Vinyl as V
33+import qualified Data.Vinyl.Curry as V
34+import qualified Data.Vinyl.Functor as V
35+import GHC.Generics ((:*:) (..))
5736import Roboservant.Types
5837 ( ApiOffset (..),
38+ Argument (..),
5939 FlattenServer (..),
60−-- ReifiedApi,
40+ Provenance (..),
41+ ReifiedEndpoint (..),
42+ Stash (..),
43+ StashValue (..),
6144 ToReifiedApi (..),
62− ReifiedEndpoint(..),
63− Argument(..),
64− TypedF
65−
45+ TypedF,
6646 )
47+import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
48+import System.Random (StdGen, mkStdGen, randomR)
49+import qualified Type.Reflection as R
6750
6851data RoboservantException
6952 = RoboservantException FailureType (Maybe SomeException) Int FuzzState
7053 deriving (Show)
54+
7155-- we believe in nussink, lebowski
7256instance Exception RoboservantException
7357
@@ -76,148 +60,164 @@ data FailureType
7660 | CheckerFailed
7761 | NoPossibleMoves
7862 | InsufficientCoverage
79− deriving (Show,Eq)
63+ deriving (Show, Eq)
8064
81−
82−data FuzzOp = FuzzOp
83− { apiOffset :: ApiOffset
84− , provenance :: [Provenance]
85− } deriving (Show,Eq)
65+data FuzzOp
66+ = FuzzOp
67+ { apiOffset :: ApiOffset,
68+ provenance :: [Provenance]
69+ }
70+ deriving (Show, Eq)
8671
8772data Config
8873 = Config
89− { seed :: [Dynamic]
90− , maxRuntime :: Integer -- seconds to test for
91− , maxReps :: Integer
92− , rngSeed :: Int
93− , coverageThreshold :: Double
94− }
74+ { seed :: [Dynamic],
75+ maxRuntime :: Integer, -- seconds to test for
76+ maxReps :: Integer,
77+ rngSeed :: Int,
78+ coverageThreshold :: Double
79+ }
9580
96−data FuzzState = FuzzState
97− { path :: [FuzzOp]
98− , stash :: Stash
99− , currentRng :: StdGen
100− }
101− deriving Show
81+data FuzzState
82+ = FuzzState
83+ { path :: [FuzzOp],
84+ stash :: Stash,
85+ currentRng :: StdGen
86+ }
87+ deriving (Show)
10288
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− }
89+data EndpointOption
90+ = forall as.
91+ (V.RecordToList as, V.RMap as) =>
92+ EndpointOption
93+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic))),
94+ eoArgs :: V.Rec (TypedF StashValue) as
95+ }
10796
10897data StopReason
10998 = TimedOut
11099 | HitMaxIterations
111− deriving (Show,Eq)
100+ deriving (Show, Eq)
112101
113−data Report = Report
114− { textual :: String }
115− deriving (Show,Eq)
102+data Report
103+ = Report
104+ {textual :: String}
105+ deriving (Show, Eq)
116106
117−fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
118− => Server api
119− -> Config
120− -> IO ()
121− -> IO (Maybe Report)
122−fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
107+fuzz ::
108+ forall api.
109+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>
110+ Server api ->
111+ Config ->
112+ IO () ->
113+ IO (Maybe Report)
114+fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
123115 let path = []
124116 stash = addToStash seed mempty
125117 currentRng = mkStdGen rngSeed
126−
127−
128118 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
129− (stopreason, fs ) <- runStateT
130− (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
119+ (stopreason, _fs) <-
120+ runStateT
121+ (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
122+ FuzzState {..}
131123 print stopreason
132124 pure Nothing
133125 where
134126 -- something less terrible later
135127 formatException :: RoboservantException -> Report
136128 formatException = Report . show
137−
138− -- evaluateCoverage :: FuzzState -> m ()
139− evaluateCoverage f@FuzzState{..}
129+ -- evaluateCoverage :: FuzzState -> m ()
130+ evaluateCoverage f@FuzzState {..}
140131 | hitRoutes / totalRoutes > coverageThreshold = do
141− liftIO $ print ("passed coverage", hitRoutes, totalRoutes)
142− pure ()
132+ liftIO $ print ("passed coverage", hitRoutes, totalRoutes)
133+ pure ()
143134 | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
144− where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
145− totalRoutes = (fromIntegral routeCount)
146−
147−
148− untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
149− untilDone (0,_) _ = pure HitMaxIterations
135+ where
136+ hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
137+ totalRoutes = (fromIntegral routeCount)
138+ untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
139+ untilDone (0, _) _ = pure HitMaxIterations
150140 untilDone (n, deadline) action = do
151141 now <- liftIO getCurrentTime
152142 if now > deadline
153143 then pure TimedOut
154144 else do
155− action
156− untilDone (n-1, deadline) action
157−
145+ _ <- action
146+ untilDone (n -1, deadline) action
158147 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
159148 routeCount = length reifiedApi
160−
161− elementOrFail :: (MonadState FuzzState m, MonadIO m)
162− => [a] -> m a
149+ elementOrFail ::
150+ (MonadState FuzzState m, MonadIO m) =>
151+ [a] ->
152+ m a
163153 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
164154 elementOrFail l = do
165155 st <- get
166− let (index,newGen) = randomR (0, length l - 1) (currentRng st)
167− modify' $ \st' -> st' { currentRng = newGen }
156+ let (index, newGen) = randomR (0, length l - 1) (currentRng st)
157+ modify' $ \st' -> st' {currentRng = newGen}
168158 pure (l !! index)
169−
170− withOp :: (MonadState FuzzState m, MonadIO m)
171− => (forall as. (V.RecordToList as, V.RMap as)
172− => FuzzOp
173− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
174− -> V.Rec (TypedF V.Identity) as -> m r
175− )
176− -> m r
159+ withOp ::
160+ (MonadState FuzzState m, MonadIO m) =>
161+ ( forall as.
162+ (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 r
167+ ) ->
168+ m r
177169 withOp callback = do
178170 -- choose a call to make, from the endpoints with fillable arguments.
179− (offset, EndpointOption{..}) <- elementOrFail . options =<< get
180− r <- V.rtraverse
181− (\(tr :*: StashValue svs) -> elementOrFail $
182− zipWith (\i xy -> V.Const i :*: tr :*: xy)
183− [0..]
184− (NEL.toList svs)
185− )
186− eoArgs
187− let pathSegment = FuzzOp offset $
188− recordToList'
189− (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
171+ (offset, EndpointOption {..}) <- elementOrFail . options =<< get
172+ r <-
173+ V.rtraverse
174+ ( \(tr :*: StashValue svs) ->
175+ elementOrFail $
176+ zipWith
177+ (\i xy -> V.Const i :*: tr :*: xy)
178+ [0 ..]
179+ (NEL.toList svs)
180+ )
181+ eoArgs
182+ let pathSegment =
183+ FuzzOp offset $
184+ recordToList'
185+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
186+ r
187+ argValues =
188+ V.rmap
189+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
190190 r
191− argValues = V.rmap
192− (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
193− r
194− modify' (\f -> f { path = path f <> [pathSegment] })
191+ modify' (\f -> f {path = path f <> [pathSegment]})
195192 callback pathSegment eoCall argValues
196193 where
197194 options :: FuzzState -> [(ApiOffset, EndpointOption)]
198− options FuzzState{..} =
195+ options FuzzState {..} =
199196 mapMaybe
200− ( \(offset, ReifiedEndpoint{..}) -> do
201− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
202− pure (offset, EndpointOption reEndpointFunc args)
197+ ( \(offset, ReifiedEndpoint {..}) -> do
198+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
199+ pure (offset, EndpointOption reEndpointFunc args)
203200 )
204201 reifiedApi
205−
206− execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)
207− => FuzzOp
208− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
209− -> V.Rec (TypedF V.Identity) as
210− -> m ()
202+ execute ::
203+ (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
204+ FuzzOp ->
205+ V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
206+ V.Rec (TypedF V.Identity) as ->
207+ m ()
211208 execute fuzzop func args = do
212209 liftIO $ print fuzzop
213210 st <- get
214− let showable = unlines $ ("args":map show argTypes)
215− <> ["fuzzop"
216− , show fuzzop
217− -- ,"dyncall"
218− -- ,show (dynTypeRep dyncall)
219− ,"state"
220− ,show st]
211+ let showable =
212+ unlines $
213+ ("args" : map show argTypes)
214+ <> [ "fuzzop",
215+ show fuzzop,
216+ -- ,"dyncall"
217+ -- ,show (dynTypeRep dyncall)
218+ "state",
219+ show st
220+ ]
221221 liftIO $ putStrLn showable
222222 liftIO (V.runcurry' func argVals) >>= \case
223223 -- parameterise this
@@ -225,48 +225,56 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
225225 case errHTTPCode serverError of
226226 500 -> throw serverError
227227 _ -> do
228− liftIO $ print ("ignoring non-500 error" , serverError)
228+ liftIO $ print ("ignoring non-500 error", serverError)
229229 Right (dyn :: NEL.NonEmpty Dynamic) -> do
230230 liftIO $ print ("storing", fmap dynTypeRep dyn)
231− modify' (\fs@FuzzState{..} ->
232− fs { stash = addToStash (NEL.toList dyn) stash } )
231+ modify'
232+ ( \fs@FuzzState {..} ->
233+ fs {stash = addToStash (NEL.toList dyn) stash}
234+ )
233235 where
234236 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
235237 argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
236−
237− go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
238− => m ()
238+ go ::
239+ (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
240+ m ()
239241 go = withOp $ \op func args -> do
240− catches (execute op func args)
241− [ Handler (\(e :: SomeAsyncException) -> throw e)
242− , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
242+ catches
243+ (execute op func args)
244+ [ Handler (\(e :: SomeAsyncException) -> throw e),
245+ Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
243246 ]
244− catch (liftIO checker)
245− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
247+ catch
248+ (liftIO checker)
249+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
246250
247−addToStash :: [Dynamic]
248− -> Stash
249− -> Stash
251+addToStash ::
252+ [Dynamic] ->
253+ Stash ->
254+ Stash
250255addToStash result stash =
251− foldr (\(Dynamic tr x) (Stash dict) -> Stash $
252− DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict
256+ foldr
257+ ( \(Dynamic tr x) (Stash dict) ->
258+ Stash $
259+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| [])) dict
253260 )
254261 stash
255262 result
256263 where
257− renumber :: StashValue a
258− -> StashValue a
259− -> StashValue a
264+ renumber ::
265+ StashValue a ->
266+ StashValue a ->
267+ StashValue a
260268 renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
261− [([Provenance tr _], dyn)] -> l
262− <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
269+ [([Provenance tr _], dyn)] ->
270+ l
271+ <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
263272 _ -> error "should be impossible"
264273
265−
266274-- why isn't this in vinyl?
267−recordToList'
268− :: (V.RecordToList as, V.RMap as)
269− => (forall x. f x -> a)
270− -> V.Rec f as
271− -> [a]
275+recordToList' ::
276+ (V.RecordToList as, V.RMap as) =>
277+ (forall x. f x -> a) ->
278+ V.Rec f as ->
279+ [a]
272280recordToList' f = V.recordToList . V.rmap (V.Const . f)