@@ -4,16 +4,14 @@
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
87{-# LANGUAGE LambdaCase #-}
98{-# LANGUAGE PolyKinds #-}
109{-# LANGUAGE RecordWildCards #-}
1110{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE StandaloneDeriving #-}
1311{-# LANGUAGE TupleSections #-}
1412{-# LANGUAGE TypeApplications #-}
1513{-# LANGUAGE TypeFamilies #-}
16−{-# LANGUAGE TypeOperators #-}
14+
1715{-# LANGUAGE UndecidableInstances #-}
1816
1917module Roboservant.Direct
@@ -26,9 +24,7 @@ module Roboservant.Direct
2624where
2725
2826import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
29−import Control.Monad(void,replicateM)
3027import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
31−import Control.Monad.Trans.Control(MonadBaseControl)
3228import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
3329import Data.Map.Strict(Map)
3430import qualified Data.Set as Set
@@ -40,6 +36,7 @@ import qualified Data.List.NonEmpty as NEL
4036import qualified Data.Map.Strict as Map
4137import Data.Time.Clock
4238import Data.List(sortOn)
39+import Control.Arrow(second)
4340
4441import Roboservant.Types.Breakdown
4542import Roboservant.Types
@@ -47,8 +44,7 @@ import Roboservant.Types
4744 FlattenServer (..),
4845-- ReifiedApi,
4946 ToReifiedApi (..),
50− )
51−
47+ ))
5248data RoboservantException
5349 = RoboservantException
5450 { failureReason :: FailureType
@@ -66,7 +62,7 @@ data FailureType
6662 deriving (Show,Eq)
6763
6864
69−data FuzzOp = FuzzOp
65+data FuzzOp = FuzzOp
7066 { apiOffset :: ApiOffset
7167 , provenance :: [Provenance]
7268 } deriving (Show,Eq)
@@ -95,7 +91,7 @@ data StopReason
9591data Report = Report
9692 { textual :: String
9793 , rsException :: RoboservantException}
98− deriving (Show)
94+ deriving (Show)
9995
10096fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
10197 => Server api
@@ -107,7 +103,7 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
107103 stash = addToStash seed mempty
108104 currentRng = mkStdGen rngSeed
109105
110−
106+
111107 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
112108 (stopreason, fs ) <- runStateT
113109 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
@@ -126,7 +122,9 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
126122 mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
127123 putStrLn ""
128124 putStrLn "types in stash"
129− mapM_ print (map (\x -> (fst x, NEL.length (snd x))) . sortOn (show . fst) . Map.toList $ stash)
125+ mapM_
126+ (print . second NEL.length)
127+ (sortOn (show . fst) . Map.toList stash)
130128
131129 -- evaluateCoverage :: FuzzState -> m ()
132130 evaluateCoverage f@FuzzState{..}
@@ -134,10 +132,10 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
134132 | otherwise = do
135133 displayDiagnostics f
136134 throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
137− where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
138− totalRoutes = (fromIntegral routeCount)
135+ where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
136+ totalRoutes = fromIntegral routeCount
139137 coverage = hitRoutes / totalRoutes
140−
138+
141139
142140 untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
143141 untilDone (0,_) _ = pure HitMaxIterations
@@ -148,10 +146,10 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
148146 else do
149147 action
150148 untilDone (n-1, deadline) action
151−
149+
152150 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
153151 routeCount = length reifiedApi
154−
152+
155153 elementOrFail :: (MonadState FuzzState m, MonadIO m)
156154 => [a] -> m a
157155 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
@@ -175,7 +173,7 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
175173 options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]
176174 options FuzzState{..} =
177175 mapMaybe
178− ( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$> do
176+ ( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$>
179177 mapM (\(_tr,bf) -> bf stash ) argreps
180178 )
181179 reifiedApi
@@ -196,19 +194,19 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
196194 ,"state"
197195 ,show st]
198196 -- liftIO $ putStrLn showable
199−
197+
200198 case func of
201199 Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
202− Just (f') -> do
200+ Just f' -> do
203201 -- liftIO $ print
204202 case fromDynamic f' of
205203 Nothing -> error ("all screwed up 2: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
206− Just (f) -> liftIO f >>= \case
204+ Just f -> liftIO f >>= \case
207205 -- parameterise this
208206 Left (serverError :: ServerError) ->
209207 case errHTTPCode serverError of
210208 500 -> throw serverError
211− _ -> do
209+ _ ->
212210 liftIO $ print ("ignoring non-500 error" , serverError)
213211
214212 Right (dyn :: NEL.NonEmpty Dynamic) -> do