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