mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-08-15 19:10:24 +03:00
wip
This commit is contained in:
parent
67d88d2ef5
commit
f686505db5
@ -49,4 +49,4 @@ tests:
|
||||
- aeson
|
||||
- hspec
|
||||
- hspec-core
|
||||
|
||||
- http-api-data
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: d00686eca2b790a054d75ee02699e0505188e10e975cd6ebc7b06eeeb82923b4
|
||||
-- hash: 4774250c208a2100460b0df7518257286ca38d8612b517ddcbf3e37678b598cf
|
||||
|
||||
name: roboservant
|
||||
version: 0.1.0.2
|
||||
@ -60,6 +60,7 @@ test-suite roboservant-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
BuildFrom
|
||||
Foo
|
||||
Headers
|
||||
Post
|
||||
@ -77,6 +78,7 @@ test-suite roboservant-test
|
||||
, containers
|
||||
, hspec
|
||||
, hspec-core
|
||||
, http-api-data
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, mtl
|
||||
|
@ -4,16 +4,14 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Roboservant.Direct
|
||||
@ -26,9 +24,7 @@ module Roboservant.Direct
|
||||
where
|
||||
|
||||
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,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
|
||||
@ -40,6 +36,7 @@ import qualified Data.List.NonEmpty as NEL
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Time.Clock
|
||||
import Data.List(sortOn)
|
||||
import Control.Arrow(second)
|
||||
|
||||
import Roboservant.Types.Breakdown
|
||||
import Roboservant.Types
|
||||
@ -47,8 +44,7 @@ import Roboservant.Types
|
||||
FlattenServer (..),
|
||||
-- ReifiedApi,
|
||||
ToReifiedApi (..),
|
||||
)
|
||||
|
||||
))
|
||||
data RoboservantException
|
||||
= RoboservantException
|
||||
{ failureReason :: FailureType
|
||||
@ -66,7 +62,7 @@ data FailureType
|
||||
deriving (Show,Eq)
|
||||
|
||||
|
||||
data FuzzOp = FuzzOp
|
||||
data FuzzOp = FuzzOp
|
||||
{ apiOffset :: ApiOffset
|
||||
, provenance :: [Provenance]
|
||||
} deriving (Show,Eq)
|
||||
@ -95,7 +91,7 @@ data StopReason
|
||||
data Report = Report
|
||||
{ textual :: String
|
||||
, rsException :: RoboservantException}
|
||||
deriving (Show)
|
||||
deriving (Show)
|
||||
|
||||
fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
|
||||
=> Server api
|
||||
@ -107,7 +103,7 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
stash = addToStash seed mempty
|
||||
currentRng = mkStdGen rngSeed
|
||||
|
||||
|
||||
|
||||
deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
|
||||
(stopreason, fs ) <- runStateT
|
||||
(untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
|
||||
@ -126,7 +122,9 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
|
||||
putStrLn ""
|
||||
putStrLn "types in stash"
|
||||
mapM_ print (map (\x -> (fst x, NEL.length (snd x))) . sortOn (show . fst) . Map.toList $ stash)
|
||||
mapM_
|
||||
(print . second NEL.length)
|
||||
(sortOn (show . fst) . Map.toList stash)
|
||||
|
||||
-- evaluateCoverage :: FuzzState -> m ()
|
||||
evaluateCoverage f@FuzzState{..}
|
||||
@ -134,10 +132,10 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
| otherwise = do
|
||||
displayDiagnostics f
|
||||
throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
|
||||
where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
|
||||
totalRoutes = (fromIntegral routeCount)
|
||||
where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
|
||||
totalRoutes = fromIntegral routeCount
|
||||
coverage = hitRoutes / totalRoutes
|
||||
|
||||
|
||||
|
||||
untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
|
||||
untilDone (0,_) _ = pure HitMaxIterations
|
||||
@ -148,10 +146,10 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
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
|
||||
@ -175,7 +173,7 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]
|
||||
options FuzzState{..} =
|
||||
mapMaybe
|
||||
( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$> do
|
||||
( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$>
|
||||
mapM (\(_tr,bf) -> bf stash ) argreps
|
||||
)
|
||||
reifiedApi
|
||||
@ -196,19 +194,19 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
,"state"
|
||||
,show st]
|
||||
-- liftIO $ putStrLn showable
|
||||
|
||||
|
||||
case func of
|
||||
Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
|
||||
Just (f') -> do
|
||||
Just f' -> do
|
||||
-- liftIO $ print
|
||||
case fromDynamic f' of
|
||||
Nothing -> error ("all screwed up 2: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
|
||||
Just (f) -> liftIO f >>= \case
|
||||
Just f -> liftIO f >>= \case
|
||||
-- parameterise this
|
||||
Left (serverError :: ServerError) ->
|
||||
case errHTTPCode serverError of
|
||||
500 -> throw serverError
|
||||
_ -> do
|
||||
_ ->
|
||||
liftIO $ print ("ignoring non-500 error" , serverError)
|
||||
|
||||
Right (dyn :: NEL.NonEmpty Dynamic) -> do
|
||||
|
@ -23,14 +23,22 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.Typeable (TypeRep, Typeable, typeRep)
|
||||
import GHC.Generics(Generic)
|
||||
import qualified GHC.Generics as Generics
|
||||
|
||||
data Provenance
|
||||
= Provenance TypeRep Int
|
||||
deriving (Show,Eq)
|
||||
type Stash = Map TypeRep (NonEmpty ([Provenance], Dynamic))
|
||||
|
||||
|
||||
class Breakdown x where
|
||||
breakdown :: x -> NonEmpty Dynamic
|
||||
-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
|
||||
-- breakdown = pure . toDyn
|
||||
|
||||
class Typeable x => BuildFrom x where
|
||||
buildFrom :: Stash -> Maybe (NonEmpty ([Provenance],Dynamic))
|
||||
|
||||
-- default buildFrom :: Stash -> Maybe (NonEmpty ([Provenance], Dynamic))
|
||||
-- buildFrom = Map.lookup (typeRep (Proxy @x))
|
||||
|
||||
@ -41,11 +49,15 @@ newtype Atom x = Atom { unAtom :: x }
|
||||
-- | can be broken down and built up from generic pieces
|
||||
newtype Compound x = Compound { unCompound :: x }
|
||||
|
||||
-- | so, this is quite tricky. we need to witness the structure of `x`, but
|
||||
-- we don't have an example of it yet. not entirely sure where to go.
|
||||
instance (Typeable x, Generic x) => BuildFrom (Compound x) where
|
||||
buildFrom = error "buildfrom"
|
||||
buildFrom stash = error "oops"
|
||||
-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from
|
||||
|
||||
-- | this should be a bit more tractable.
|
||||
instance (Typeable x, Generic x) => Breakdown (Compound x) where
|
||||
breakdown = error "breakdown"
|
||||
breakdown x = _ . Generics.from . unCompound $ x
|
||||
|
||||
instance Typeable x => BuildFrom (Atom x) where
|
||||
buildFrom = Map.lookup (typeRep (Proxy @x))
|
||||
@ -72,11 +84,6 @@ instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
|
||||
(maybe [] (NEL.toList . (fmap (fmap (Just . promisedDyn @x))))
|
||||
$ buildFrom @x dict)
|
||||
|
||||
class Breakdown x where
|
||||
breakdown :: x -> NonEmpty Dynamic
|
||||
-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
|
||||
-- breakdown = pure . toDyn
|
||||
|
||||
instance Typeable a => Breakdown (Atom a) where
|
||||
breakdown = pure . toDyn . unAtom
|
||||
|
||||
@ -84,12 +91,6 @@ deriving via (Atom ()) instance Breakdown ()
|
||||
deriving via (Atom Int) instance Breakdown Int
|
||||
|
||||
|
||||
--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
|
||||
|
||||
-- instance (Typeable x, Generic x) => Breakdown x where
|
||||
-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from
|
||||
|
||||
|
||||
instance (Typeable a, Breakdown a) => Breakdown [a] where
|
||||
breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
|
||||
|
||||
|
14
test/Spec.hs
14
test/Spec.hs
@ -9,6 +9,7 @@ import qualified Seeded
|
||||
import qualified Valid
|
||||
import qualified Headers
|
||||
import qualified Post
|
||||
import qualified BuildFrom
|
||||
-- import qualified UnsafeIO
|
||||
|
||||
import Data.Dynamic(toDyn)
|
||||
@ -62,6 +63,13 @@ spec = do
|
||||
RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
|
||||
>>= (`shouldSatisfy` isJust)
|
||||
|
||||
describe "can build from pieces" $ do
|
||||
it "should find a failure that requires some assembly" $ do
|
||||
RS.fuzz @BuildFrom.Api BuildFrom.server defaultConfig noCheck
|
||||
>>= (`shouldSatisfy` isJust)
|
||||
|
||||
|
||||
|
||||
-- -- -- 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
|
||||
@ -94,6 +102,12 @@ deriving via (Atom Void) instance RS.BuildFrom Void
|
||||
deriving via (Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
|
||||
deriving via (Atom Post.FooPost) instance RS.Breakdown Post.FooPost
|
||||
|
||||
|
||||
deriving via (Compound BuildFrom.Wrapped) instance RS.BuildFrom BuildFrom.Wrapped
|
||||
deriving via (Compound BuildFrom.Wrapped) instance RS.Breakdown BuildFrom.Wrapped
|
||||
|
||||
|
||||
|
||||
-- deriving via (Atom Void) instance RS.BuildFrom Void
|
||||
|
||||
-- instance RS.Breakdown Post.FooPost
|
||||
|
Loading…
Reference in New Issue
Block a user