wip

package.yaml

@@ -49,4 +49,4 @@ tests:
     - aeson
     - hspec
     - hspec-core
-
+    - http-api-data

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

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)
+      where hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
-            totalRoutes = (fromIntegral routeCount)
+            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

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)
 

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