From 90f1621a7db81ec58bb84add466ded51b9b3b84e Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 17 Jun 2025 14:07:43 -0400 Subject: [PATCH] feat: include insert error messages in GenerationFailure This adds `*Either` versions of our two insert functions in the frontend class, which return `Left String` errors, rather than `Nothing`s. We define the maybe and either versions in terms of each other, making this a backwards-compatible change, and use `MINIMAL` to ensure one or the other always gets defined. Then, we update our own instance to define either variants, with informative messages for the failing cases. Lastly, by using those either variants within the main loop, we can collect (at least the final) `Left` value and report it as part of the `GenerationFailure`. The new README test confirms it works and shows what such an exception will look like now. Fixes #17. --- src/Graphula.hs | 40 +++++++++++++++++--------------- src/Graphula/Class.hs | 25 ++++++++++++++++++++ src/Graphula/Dependencies.hs | 20 ++++++++++++---- src/Graphula/Node.hs | 44 ++++++++++++++++-------------------- test/README.lhs | 24 ++++++++++++++++++++ 5 files changed, 107 insertions(+), 46 deletions(-) diff --git a/src/Graphula.hs b/src/Graphula.hs index 09532dc..3b60d3c 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -211,39 +211,43 @@ instance MonadIO m => MonadGraphulaBackend (GraphulaT n m) where logNode _ = pure () instance (MonadIO m, MonadIO n) => MonadGraphulaFrontend (GraphulaT n m) where - insert mKey n = do + insertEither mKey n = do RunDB runDB <- asks dbRunner lift . runDB $ case mKey of Nothing -> insertUnique n >>= \case - Nothing -> pure Nothing - Just key -> getEntity key + Nothing -> pure $ Left "entity violated a unique constraint" + Just key -> maybe (Left "inserted entity not found") Right <$> getEntity key Just key -> do existingKey <- get key - whenNothing existingKey $ do - existingUnique <- checkUnique n - whenNothing existingUnique $ do - Persist.insertKey key n - getEntity key + case existingKey of + Just _ -> pure $ Left "entity already exists by this key" + Nothing -> do + existingUnique <- checkUnique n + case existingUnique of + Just _ -> pure $ Left "entity would violate unique constraint" + Nothing -> do + Persist.insertKey key n + maybe (Left "inserted entity not found") Right <$> getEntity key - insertKeyed key n = do + insertKeyedEither key n = do RunDB runDB <- asks dbRunner lift . runDB $ do existingKey <- get key - whenNothing existingKey $ do - existingUnique <- checkUnique n - whenNothing existingUnique $ do - Persist.insertKey key n - getEntity key + case existingKey of + Just _ -> pure $ Left "entity already exists by this key" + Nothing -> do + existingUnique <- checkUnique n + case existingUnique of + Just _ -> pure $ Left "entity would violate unique constraint" + Nothing -> do + Persist.insertKey key n + maybe (Left "inserted entity not found") Right <$> getEntity key remove key = do RunDB runDB <- asks dbRunner lift . runDB $ delete key -whenNothing :: Applicative m => Maybe a -> m (Maybe b) -> m (Maybe b) -whenNothing Nothing f = f -whenNothing (Just _) _ = pure Nothing - runGraphulaT :: MonadUnliftIO m => Maybe Int diff --git a/src/Graphula/Class.hs b/src/Graphula/Class.hs index 491020d..3046a47 100644 --- a/src/Graphula/Class.hs +++ b/src/Graphula/Class.hs @@ -66,6 +66,18 @@ class MonadGraphulaFrontend m where => Maybe (Key a) -> a -> m (Maybe (Entity a)) + insert mk a = either (const Nothing) Just <$> insertEither mk a + + insertEither + :: ( PersistEntityBackend a ~ SqlBackend + , PersistEntity a + , Monad m + , GraphulaSafeToInsert a + ) + => Maybe (Key a) + -> a + -> m (Either String (Entity a)) + insertEither mk a = maybe (Left "Unable to insert entity") Right <$> insert mk a insertKeyed :: ( PersistEntityBackend a ~ SqlBackend @@ -75,12 +87,25 @@ class MonadGraphulaFrontend m where => Key a -> a -> m (Maybe (Entity a)) + insertKeyed k a = either (const Nothing) Just <$> insertKeyedEither k a + + insertKeyedEither + :: ( PersistEntityBackend a ~ SqlBackend + , PersistEntity a + , Monad m + ) + => Key a + -> a + -> m (Either String (Entity a)) + insertKeyedEither k a = maybe (Left "Unable to insert keyed entity") Right <$> insertKeyed k a remove :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) => Key a -> m () + {-# MINIMAL (insert | insertEither), (insertKeyed | insertKeyedEither), remove #-} + class MonadGraphulaBackend m where type Logging m :: Type -> Constraint askGen :: m (IORef QCGen) diff --git a/src/Graphula/Dependencies.hs b/src/Graphula/Dependencies.hs index d7e3193..be115ea 100644 --- a/src/Graphula/Dependencies.hs +++ b/src/Graphula/Dependencies.hs @@ -107,10 +107,10 @@ class HasDependencies a where :: ( HasEot a , HasEot (Dependencies a) , GHasDependencies - (Proxy a) - (Proxy (Dependencies a)) - (Eot a) - (Eot (Dependencies a)) + (Proxy a) + (Proxy (Dependencies a)) + (Eot a) + (Eot (Dependencies a)) ) => a -> Dependencies a @@ -177,16 +177,28 @@ class InsertWithPossiblyRequiredKey (requirement :: Type -> Type) where => requirement (Key record) -> record -> m (Maybe (Entity record)) + insertWithPossiblyRequiredKeyEither + :: ( PersistEntityBackend record ~ SqlBackend + , PersistEntity record + , Monad m + , MonadGraphulaFrontend m + , InsertConstraint requirement record + ) + => requirement (Key record) + -> record + -> m (Either String (Entity record)) justKey :: key -> requirement key instance InsertWithPossiblyRequiredKey Optional where type InsertConstraint Optional = GraphulaSafeToInsert insertWithPossiblyRequiredKey (Optional key) = MonadGraphulaFrontend.insert key + insertWithPossiblyRequiredKeyEither (Optional key) = MonadGraphulaFrontend.insertEither key justKey = Optional . Just instance InsertWithPossiblyRequiredKey Required where type InsertConstraint Required = NoConstraint insertWithPossiblyRequiredKey (Required key) = MonadGraphulaFrontend.insertKeyed key + insertWithPossiblyRequiredKeyEither (Required key) = MonadGraphulaFrontend.insertKeyedEither key justKey = Required -- | Abstract constraint that some @a@ can generate a key diff --git a/src/Graphula/Node.hs b/src/Graphula/Node.hs index a2d54eb..b9f5346 100644 --- a/src/Graphula/Node.hs +++ b/src/Graphula/Node.hs @@ -142,22 +142,20 @@ attempt -> Int -> m (Maybe (KeyForInsert a, a)) -> m (Entity a) -attempt maxEdits maxInserts source = loop 0 0 +attempt maxEdits maxInserts source = loop 0 0 Nothing where - loop :: Int -> Int -> m (Entity a) - loop numEdits numInserts - | numEdits >= maxEdits = die GenerationFailureMaxAttemptsToConstrain - | numInserts >= maxInserts = die GenerationFailureMaxAttemptsToInsert + loop :: Int -> Int -> Maybe String -> m (Entity a) + loop numEdits numInserts mmsg + | numEdits >= maxEdits = die $ GenerationFailureMaxAttemptsToConstrain mmsg + | numInserts >= maxInserts = die $ GenerationFailureMaxAttemptsToInsert mmsg | otherwise = source >>= \case - Nothing -> loop (succ numEdits) numInserts + Nothing -> loop (succ numEdits) numInserts Nothing -- ^ failed to edit, only increments this Just (mKey, value) -> - insertWithPossiblyRequiredKey mKey value >>= \case - Nothing -> loop (succ numEdits) (succ numInserts) - -- ^ failed to insert, but also increments this. Are we - -- sure that's what we want? - Just a -> pure a + insertWithPossiblyRequiredKeyEither mKey value >>= \case + Left msg -> loop (succ numEdits) (succ numInserts) $ Just msg + Right a -> pure a -- | Generate a node with an explictly-given key -- @@ -198,22 +196,20 @@ attempt' -> Key a -> m (Maybe a) -> m (Entity a) -attempt' maxEdits maxInserts key source = loop 0 0 +attempt' maxEdits maxInserts key source = loop 0 0 Nothing where - loop :: Int -> Int -> m (Entity a) - loop numEdits numInserts - | numEdits >= maxEdits = die GenerationFailureMaxAttemptsToConstrain - | numInserts >= maxInserts = die GenerationFailureMaxAttemptsToInsert + loop :: Int -> Int -> Maybe String -> m (Entity a) + loop numEdits numInserts mmsg + | numEdits >= maxEdits = die $ GenerationFailureMaxAttemptsToConstrain mmsg + | numInserts >= maxInserts = die $ GenerationFailureMaxAttemptsToInsert mmsg | otherwise = source >>= \case - Nothing -> loop (succ numEdits) numInserts + Nothing -> loop (succ numEdits) numInserts Nothing -- ^ failed to edit, only increments this Just value -> - insertKeyed key value >>= \case - Nothing -> loop (succ numEdits) (succ numInserts) - -- ^ failed to insert, but also increments this. Are we - -- sure that's what we want? - Just a -> pure a + insertKeyedEither key value >>= \case + Left msg -> loop (succ numEdits) (succ numInserts) $ Just msg + Right a -> pure a die :: forall a m @@ -224,9 +220,9 @@ die e = throwIO $ e $ typeRep $ Proxy @a data GenerationFailure = -- | Could not satisfy constraints defined using 'ensure' - GenerationFailureMaxAttemptsToConstrain TypeRep + GenerationFailureMaxAttemptsToConstrain (Maybe String) TypeRep | -- | Could not satisfy database constraints on 'insert' - GenerationFailureMaxAttemptsToInsert TypeRep + GenerationFailureMaxAttemptsToInsert (Maybe String) TypeRep deriving stock (Show, Eq) instance Exception GenerationFailure diff --git a/test/README.lhs b/test/README.lhs index 94b3ce0..fda2924 100644 --- a/test/README.lhs +++ b/test/README.lhs @@ -32,6 +32,7 @@ dependencies. We use this interface to generate fixtures for automated testing. module Main (module Main) where +import Control.Exception (try, Exception(..)) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger (NoLoggingT) @@ -170,6 +171,28 @@ loggingSpec = do n `shouldSatisfy` (not . null) ``` +## Generation Failures + +Generating the graph can fail if you ask it do impossible things, such as +generate entities that collide on a unique constraint. In such cases, you will +receive an informative error: + +```haskell +generationFailureSpec :: IO () +generationFailureSpec = do + result <- try $ runGraphulaT Nothing runDB $ do + school <- node @School () mempty + + -- collision that will never resolve + nodeKeyed @School (entityKey school) () mempty + + case result of + Left ex -> + displayException @GenerationFailure ex + `shouldBe` "GenerationFailureMaxAttemptsToInsert (Just \"entity already exists by this key\") School" + Right _ -> pure () +``` + ## Running It ```haskell @@ -202,6 +225,7 @@ main = hspec $ describe "graphula" . parallel $ do it "generates and links arbitrary graphs of data" simpleSpec it "allows logging graphs" loggingSpec + it "shows informative generation failures" generationFailureSpec runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a runDB f = runSqlite "test.db" $ do