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