diff --git a/package.yaml b/package.yaml index 544507f..f6114a7 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,7 @@ dependencies: - servant-flatten - servant-server # >= 0.17 - string-conversions +- time ghc-options: - -Wall diff --git a/roboservant.cabal b/roboservant.cabal index e34756b..49650fb 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 8359b70b81d2fdfc7001a1f607745da953f6e8f7b8188a54857d658406c238a2 +-- hash: 838fa22fc3ea6673432f485653caaca6c43bccce724777fafbb903dad8ce30cd name: roboservant version: 0.1.0.2 @@ -53,6 +53,7 @@ library , servant-flatten , servant-server , string-conversions + , time default-language: Haskell2010 test-suite roboservant-test @@ -85,4 +86,5 @@ test-suite roboservant-test , servant-flatten , servant-server , string-conversions + , time default-language: Haskell2010 diff --git a/src/Roboservant/Direct.hs b/src/Roboservant/Direct.hs index 73cf64a..64d2c6f 100644 --- a/src/Roboservant/Direct.hs +++ b/src/Roboservant/Direct.hs @@ -18,15 +18,20 @@ module Roboservant.Direct ( fuzz, Config(..) + + -- TODO come up with something smarter than exporting all this, we should + -- have some nice error-display functions + , RoboservantException(..), FuzzState(..), FuzzOp(..) ) where -import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches) +import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches) import Control.Monad(void,replicateM) -import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT) +import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT) import Control.Monad.Trans.Control(MonadBaseControl) import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic) import Data.Map.Strict(Map) +import qualified Data.Set as Set import Data.Maybe (mapMaybe) import Data.Typeable (TypeRep) import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..)) @@ -34,6 +39,7 @@ import System.Random(StdGen,randomR,mkStdGen) import System.Timeout.Lifted(timeout) import qualified Data.List.NonEmpty as NEL import qualified Data.Map.Strict as Map +import Data.Time.Clock import Roboservant.Types.Breakdown import Roboservant.Types @@ -44,7 +50,7 @@ import Roboservant.Types ) data RoboservantException - = RoboservantException FailureType (Maybe SomeException) FuzzState + = RoboservantException FailureType (Maybe SomeException) Int FuzzState deriving (Show) -- we believe in nussink, lebowski instance Exception RoboservantException @@ -53,18 +59,22 @@ data FailureType = ServerCrashed | CheckerFailed | NoPossibleMoves + | InsufficientCoverage deriving (Show,Eq) -data FuzzOp = FuzzOp ApiOffset [Provenance] - deriving (Show,Eq) +data FuzzOp = FuzzOp + { apiOffset :: ApiOffset + , provenance :: [Provenance] + } deriving (Show,Eq) data Config = Config { seed :: [Dynamic] - , maxRuntime :: Int -- seconds to test for - , maxReps :: Int + , maxRuntime :: Integer -- seconds to test for + , maxReps :: Integer , rngSeed :: Int + , coverageThreshold :: Double } data FuzzState = FuzzState @@ -74,28 +84,66 @@ data FuzzState = FuzzState } deriving (Show) +data StopReason + = TimedOut + | HitMaxIterations + deriving (Show,Eq) + +data Report = Report + { textual :: String } + deriving (Show,Eq) + fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> Config -> IO () - -> IO () -fuzz server Config{..} checker = do + -> IO (Maybe Report) +fuzz server Config{..} checker = handle (pure . Just . formatException) $ do let path = [] stash = addToStash seed mempty currentRng = mkStdGen rngSeed + + + deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime -- either we time out without finding an error, which is fine, or we find an error -- and throw an exception that propagates through this. - - void $ timeout (maxRuntime * 1000000) ( execStateT (replicateM maxReps go) FuzzState{..}) - mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi + + (stopreason, fs ) <- runStateT + (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..} + pure Nothing + -- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi where + -- something less terrible later + formatException :: RoboservantException -> Report + formatException = Report . show + -- evaluateCoverage :: FuzzState -> m () + evaluateCoverage f@FuzzState{..} + | hitRoutes / totalRoutes > coverageThreshold = do + liftIO $ print ("passed coverage", hitRoutes, totalRoutes) + pure () + | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f + where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path) + totalRoutes = (fromIntegral routeCount) + + + untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason + untilDone (0,_) _ = pure HitMaxIterations + untilDone (n, deadline) action = do + now <- liftIO getCurrentTime + if now > deadline + then pure TimedOut + else do + action + untilDone (n-1, deadline) action + reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) - + routeCount = length reifiedApi + elementOrFail :: (MonadState FuzzState m, MonadIO m) => [a] -> m a - elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get + elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get elementOrFail l = do st <- get let (index,newGen) = randomR (0, length l - 1) (currentRng st) @@ -124,7 +172,7 @@ fuzz server Config{..} checker = do execute :: (MonadState FuzzState m, MonadIO m) => (FuzzOp,Dynamic,[Dynamic]) -> m () execute (fuzzop, dyncall, args) = do - liftIO $ print fuzzop + -- liftIO $ print fuzzop -- now, magic happens: we apply some dynamic arguments to a dynamic -- function and hopefully something useful pops out the end. let func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just dyncall) (reverse args) @@ -136,7 +184,7 @@ fuzz server Config{..} checker = do ,show (dynTypeRep dyncall) ,"state" ,show st] - liftIO $ putStrLn showable + -- liftIO $ putStrLn showable case func of Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func) @@ -153,7 +201,7 @@ fuzz server Config{..} checker = do liftIO $ print ("ignoring non-500 error" , serverError) Right (dyn :: NEL.NonEmpty Dynamic) -> do - liftIO $ print ("storing", fmap dynTypeRep dyn) + -- liftIO $ print ("storing", fmap dynTypeRep dyn) modify' (\fs@FuzzState{..} -> fs { stash = addToStash (NEL.toList dyn) stash } ) pure () @@ -164,10 +212,10 @@ fuzz server Config{..} checker = do op <- genOp catches (execute op) [ Handler (\(e :: SomeAsyncException) -> throw e) - , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get) + , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get) ] catch (liftIO checker) - (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get) + (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get) -- actions <- -- forAll $ do diff --git a/src/Roboservant/Types/ReifiedApi.hs b/src/Roboservant/Types/ReifiedApi.hs index 3413321..3399136 100644 --- a/src/Roboservant/Types/ReifiedApi.hs +++ b/src/Roboservant/Types/ReifiedApi.hs @@ -30,10 +30,12 @@ import Data.List.NonEmpty (NonEmpty) newtype ApiOffset = ApiOffset Int - deriving (Eq, Show) + deriving (Eq, Show, Ord) deriving newtype (Enum, Num) -type ReifiedEndpoint = ([(TypeRep, Stash -> Maybe (NonEmpty ([Provenance], Dynamic)))], Dynamic) +type ReifiedEndpoint = ([(TypeRep + , Stash -> Maybe (NonEmpty ([Provenance], Dynamic)))] + , Dynamic) type ReifiedApi = [(ApiOffset, ReifiedEndpoint)] diff --git a/test/Spec.hs b/test/Spec.hs index 35adccc..e171bf1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -13,7 +13,8 @@ import qualified Roboservant as RS import Test.Hspec import Test.Hspec.Core.Spec(shouldFail) - +import Data.Void +import Data.Maybe main :: IO () main = hspec spec @@ -21,23 +22,29 @@ main = hspec spec noCheck :: IO () noCheck = pure () +defaultConfig :: RS.Config +defaultConfig = RS.Config [] 1 1000 1 0 + spec :: Spec spec = do describe "Basic usage" $ do describe "noError" $ do it "finds no error in a valid app" $ do - RS.fuzz @Valid.Api Valid.server (RS.Config [toDyn $ Seeded.Seed 1] 1 1000 1) noCheck + RS.fuzz @Valid.Api Valid.server defaultConfig noCheck `shouldReturn` Nothing + it "does fail coverage check" $ do + r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck + r `shouldSatisfy` isJust describe "seeded" $ do shouldFail $ it "finds an error using information passed in" $ - RS.fuzz @Seeded.Api Seeded.server (RS.Config [toDyn $ Seeded.Seed 1] 5 1000 1) noCheck - + RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck + `shouldReturn` Nothing shouldFail $ it "finds an error in a basic app" $ - RS.fuzz @Foo.Api Foo.server (RS.Config [] 5 1000 1) noCheck - + RS.fuzz @Foo.Api Foo.server defaultConfig noCheck + `shouldReturn` Nothing shouldFail $ it "should find a failure that's dependent on using header info" $ do - RS.fuzz @Headers.Api Headers.server (RS.Config [] 5 10000 1) noCheck - + RS.fuzz @Headers.Api Headers.server defaultConfig noCheck + `shouldReturn` Nothing -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it -- -- -- could: it's mostly here to show how to test for concurrency problems. -- describe "concurrency bugs" $ do @@ -65,3 +72,5 @@ instance RS.BuildFrom Foo.Foo instance RS.BuildFrom Headers.Foo instance RS.BuildFrom Seeded.Seed + +instance RS.BuildFrom Void diff --git a/test/Valid.hs b/test/Valid.hs index 77e54f0..dfb8832 100644 --- a/test/Valid.hs +++ b/test/Valid.hs @@ -8,8 +8,10 @@ module Valid where import Servant +import Data.Void type Api = Get '[JSON] Int - + :<|> Capture "void" Void :> Get '[JSON] () + server :: Server Api -server = pure 7 +server = pure 7 :<|> const (pure ())