From f686505db5856ca15904cd79449f65bcb1a58aaa Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Thu, 26 Nov 2020 13:21:49 -0500 Subject: [PATCH] wip --- package.yaml | 2 +- roboservant.cabal | 4 ++- src/Roboservant/Direct.hs | 40 ++++++++++++++---------------- src/Roboservant/Types/Breakdown.hs | 27 ++++++++++---------- test/Spec.hs | 14 +++++++++++ 5 files changed, 51 insertions(+), 36 deletions(-) diff --git a/package.yaml b/package.yaml index f6114a7..cb5a3f4 100644 --- a/package.yaml +++ b/package.yaml @@ -49,4 +49,4 @@ tests: - aeson - hspec - hspec-core - + - http-api-data diff --git a/roboservant.cabal b/roboservant.cabal index 2b1b335..eba2da9 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -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 diff --git a/src/Roboservant/Direct.hs b/src/Roboservant/Direct.hs index 14bb922..b573f66 100644 --- a/src/Roboservant/Direct.hs +++ b/src/Roboservant/Direct.hs @@ -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 diff --git a/src/Roboservant/Types/Breakdown.hs b/src/Roboservant/Types/Breakdown.hs index b6f22b7..ee4710a 100644 --- a/src/Roboservant/Types/Breakdown.hs +++ b/src/Roboservant/Types/Breakdown.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs index c6304a5..d731324 100644 --- a/test/Spec.hs +++ b/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