mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
some coverage code
This commit is contained in:
parent
c9076d7cf5
commit
3aec8c1870
@ -27,6 +27,7 @@ dependencies:
|
|||||||
- servant-flatten
|
- servant-flatten
|
||||||
- servant-server # >= 0.17
|
- servant-server # >= 0.17
|
||||||
- string-conversions
|
- string-conversions
|
||||||
|
- time
|
||||||
|
|
||||||
ghc-options:
|
ghc-options:
|
||||||
- -Wall
|
- -Wall
|
||||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 8359b70b81d2fdfc7001a1f607745da953f6e8f7b8188a54857d658406c238a2
|
-- hash: 838fa22fc3ea6673432f485653caaca6c43bccce724777fafbb903dad8ce30cd
|
||||||
|
|
||||||
name: roboservant
|
name: roboservant
|
||||||
version: 0.1.0.2
|
version: 0.1.0.2
|
||||||
@ -53,6 +53,7 @@ library
|
|||||||
, servant-flatten
|
, servant-flatten
|
||||||
, servant-server
|
, servant-server
|
||||||
, string-conversions
|
, string-conversions
|
||||||
|
, time
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite roboservant-test
|
test-suite roboservant-test
|
||||||
@ -85,4 +86,5 @@ test-suite roboservant-test
|
|||||||
, servant-flatten
|
, servant-flatten
|
||||||
, servant-server
|
, servant-server
|
||||||
, string-conversions
|
, string-conversions
|
||||||
|
, time
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -18,15 +18,20 @@
|
|||||||
|
|
||||||
module Roboservant.Direct
|
module Roboservant.Direct
|
||||||
( fuzz, Config(..)
|
( fuzz, Config(..)
|
||||||
|
|
||||||
|
-- TODO come up with something smarter than exporting all this, we should
|
||||||
|
-- have some nice error-display functions
|
||||||
|
, RoboservantException(..), FuzzState(..), FuzzOp(..)
|
||||||
)
|
)
|
||||||
where
|
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(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 Control.Monad.Trans.Control(MonadBaseControl)
|
||||||
import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
|
import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
|
||||||
import Data.Map.Strict(Map)
|
import Data.Map.Strict(Map)
|
||||||
|
import qualified Data.Set as Set
|
||||||
import Data.Maybe (mapMaybe)
|
import Data.Maybe (mapMaybe)
|
||||||
import Data.Typeable (TypeRep)
|
import Data.Typeable (TypeRep)
|
||||||
import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
|
import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
|
||||||
@ -34,6 +39,7 @@ import System.Random(StdGen,randomR,mkStdGen)
|
|||||||
import System.Timeout.Lifted(timeout)
|
import System.Timeout.Lifted(timeout)
|
||||||
import qualified Data.List.NonEmpty as NEL
|
import qualified Data.List.NonEmpty as NEL
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Time.Clock
|
||||||
|
|
||||||
import Roboservant.Types.Breakdown
|
import Roboservant.Types.Breakdown
|
||||||
import Roboservant.Types
|
import Roboservant.Types
|
||||||
@ -44,7 +50,7 @@ import Roboservant.Types
|
|||||||
)
|
)
|
||||||
|
|
||||||
data RoboservantException
|
data RoboservantException
|
||||||
= RoboservantException FailureType (Maybe SomeException) FuzzState
|
= RoboservantException FailureType (Maybe SomeException) Int FuzzState
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
-- we believe in nussink, lebowski
|
-- we believe in nussink, lebowski
|
||||||
instance Exception RoboservantException
|
instance Exception RoboservantException
|
||||||
@ -53,18 +59,22 @@ data FailureType
|
|||||||
= ServerCrashed
|
= ServerCrashed
|
||||||
| CheckerFailed
|
| CheckerFailed
|
||||||
| NoPossibleMoves
|
| NoPossibleMoves
|
||||||
|
| InsufficientCoverage
|
||||||
deriving (Show,Eq)
|
deriving (Show,Eq)
|
||||||
|
|
||||||
|
|
||||||
data FuzzOp = FuzzOp ApiOffset [Provenance]
|
data FuzzOp = FuzzOp
|
||||||
deriving (Show,Eq)
|
{ apiOffset :: ApiOffset
|
||||||
|
, provenance :: [Provenance]
|
||||||
|
} deriving (Show,Eq)
|
||||||
|
|
||||||
data Config
|
data Config
|
||||||
= Config
|
= Config
|
||||||
{ seed :: [Dynamic]
|
{ seed :: [Dynamic]
|
||||||
, maxRuntime :: Int -- seconds to test for
|
, maxRuntime :: Integer -- seconds to test for
|
||||||
, maxReps :: Int
|
, maxReps :: Integer
|
||||||
, rngSeed :: Int
|
, rngSeed :: Int
|
||||||
|
, coverageThreshold :: Double
|
||||||
}
|
}
|
||||||
|
|
||||||
data FuzzState = FuzzState
|
data FuzzState = FuzzState
|
||||||
@ -74,28 +84,66 @@ data FuzzState = FuzzState
|
|||||||
}
|
}
|
||||||
deriving (Show)
|
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))
|
fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
|
||||||
=> Server api
|
=> Server api
|
||||||
-> Config
|
-> Config
|
||||||
-> IO ()
|
-> IO ()
|
||||||
-> IO ()
|
-> IO (Maybe Report)
|
||||||
fuzz server Config{..} checker = do
|
fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||||
let path = []
|
let path = []
|
||||||
stash = addToStash seed mempty
|
stash = addToStash seed mempty
|
||||||
currentRng = mkStdGen rngSeed
|
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
|
-- either we time out without finding an error, which is fine, or we find an error
|
||||||
-- and throw an exception that propagates through this.
|
-- and throw an exception that propagates through this.
|
||||||
|
|
||||||
void $ timeout (maxRuntime * 1000000) ( execStateT (replicateM maxReps go) FuzzState{..})
|
(stopreason, fs ) <- runStateT
|
||||||
mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
|
(untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
|
||||||
|
pure Nothing
|
||||||
|
-- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
|
||||||
|
|
||||||
where
|
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))
|
reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
|
||||||
|
routeCount = length reifiedApi
|
||||||
|
|
||||||
elementOrFail :: (MonadState FuzzState m, MonadIO m)
|
elementOrFail :: (MonadState FuzzState m, MonadIO m)
|
||||||
=> [a] -> m a
|
=> [a] -> m a
|
||||||
elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
|
elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
|
||||||
elementOrFail l = do
|
elementOrFail l = do
|
||||||
st <- get
|
st <- get
|
||||||
let (index,newGen) = randomR (0, length l - 1) (currentRng st)
|
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)
|
execute :: (MonadState FuzzState m, MonadIO m)
|
||||||
=> (FuzzOp,Dynamic,[Dynamic]) -> m ()
|
=> (FuzzOp,Dynamic,[Dynamic]) -> m ()
|
||||||
execute (fuzzop, dyncall, args) = do
|
execute (fuzzop, dyncall, args) = do
|
||||||
liftIO $ print fuzzop
|
-- liftIO $ print fuzzop
|
||||||
-- now, magic happens: we apply some dynamic arguments to a dynamic
|
-- now, magic happens: we apply some dynamic arguments to a dynamic
|
||||||
-- function and hopefully something useful pops out the end.
|
-- function and hopefully something useful pops out the end.
|
||||||
let func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just dyncall) (reverse args)
|
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)
|
,show (dynTypeRep dyncall)
|
||||||
,"state"
|
,"state"
|
||||||
,show st]
|
,show st]
|
||||||
liftIO $ putStrLn showable
|
-- liftIO $ putStrLn showable
|
||||||
|
|
||||||
case func of
|
case func of
|
||||||
Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
|
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)
|
liftIO $ print ("ignoring non-500 error" , serverError)
|
||||||
|
|
||||||
Right (dyn :: NEL.NonEmpty Dynamic) -> do
|
Right (dyn :: NEL.NonEmpty Dynamic) -> do
|
||||||
liftIO $ print ("storing", fmap dynTypeRep dyn)
|
-- liftIO $ print ("storing", fmap dynTypeRep dyn)
|
||||||
modify' (\fs@FuzzState{..} ->
|
modify' (\fs@FuzzState{..} ->
|
||||||
fs { stash = addToStash (NEL.toList dyn) stash } )
|
fs { stash = addToStash (NEL.toList dyn) stash } )
|
||||||
pure ()
|
pure ()
|
||||||
@ -164,10 +212,10 @@ fuzz server Config{..} checker = do
|
|||||||
op <- genOp
|
op <- genOp
|
||||||
catches (execute op)
|
catches (execute op)
|
||||||
[ Handler (\(e :: SomeAsyncException) -> throw e)
|
[ 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)
|
catch (liftIO checker)
|
||||||
(\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
|
(\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
|
||||||
|
|
||||||
-- actions <-
|
-- actions <-
|
||||||
-- forAll $ do
|
-- forAll $ do
|
||||||
|
@ -30,10 +30,12 @@ import Data.List.NonEmpty (NonEmpty)
|
|||||||
|
|
||||||
|
|
||||||
newtype ApiOffset = ApiOffset Int
|
newtype ApiOffset = ApiOffset Int
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show, Ord)
|
||||||
deriving newtype (Enum, Num)
|
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)]
|
type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
|
||||||
|
|
||||||
|
25
test/Spec.hs
25
test/Spec.hs
@ -13,7 +13,8 @@ import qualified Roboservant as RS
|
|||||||
|
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.Hspec.Core.Spec(shouldFail)
|
import Test.Hspec.Core.Spec(shouldFail)
|
||||||
|
import Data.Void
|
||||||
|
import Data.Maybe
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = hspec spec
|
main = hspec spec
|
||||||
@ -21,23 +22,29 @@ main = hspec spec
|
|||||||
noCheck :: IO ()
|
noCheck :: IO ()
|
||||||
noCheck = pure ()
|
noCheck = pure ()
|
||||||
|
|
||||||
|
defaultConfig :: RS.Config
|
||||||
|
defaultConfig = RS.Config [] 1 1000 1 0
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
describe "Basic usage" $ do
|
describe "Basic usage" $ do
|
||||||
describe "noError" $ do
|
describe "noError" $ do
|
||||||
it "finds no error in a valid app" $ 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
|
describe "seeded" $ do
|
||||||
shouldFail $
|
shouldFail $
|
||||||
it "finds an error using information passed in" $
|
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" $
|
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
|
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
|
-- -- -- 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.
|
-- -- -- could: it's mostly here to show how to test for concurrency problems.
|
||||||
-- describe "concurrency bugs" $ do
|
-- describe "concurrency bugs" $ do
|
||||||
@ -65,3 +72,5 @@ instance RS.BuildFrom Foo.Foo
|
|||||||
instance RS.BuildFrom Headers.Foo
|
instance RS.BuildFrom Headers.Foo
|
||||||
|
|
||||||
instance RS.BuildFrom Seeded.Seed
|
instance RS.BuildFrom Seeded.Seed
|
||||||
|
|
||||||
|
instance RS.BuildFrom Void
|
||||||
|
@ -8,8 +8,10 @@
|
|||||||
module Valid where
|
module Valid where
|
||||||
|
|
||||||
import Servant
|
import Servant
|
||||||
|
import Data.Void
|
||||||
|
|
||||||
type Api = Get '[JSON] Int
|
type Api = Get '[JSON] Int
|
||||||
|
:<|> Capture "void" Void :> Get '[JSON] ()
|
||||||
|
|
||||||
server :: Server Api
|
server :: Server Api
|
||||||
server = pure 7
|
server = pure 7 :<|> const (pure ())
|
||||||
|
Loading…
Reference in New Issue
Block a user