From 7478a6919a1d3bb785a65ea7d40b00c3733377bc Mon Sep 17 00:00:00 2001 From: Chris Martin Date: Wed, 13 Dec 2023 13:32:48 -0700 Subject: [PATCH] lift inappropriate SafeToInsert constraints (#73) --- CHANGELOG.md | 10 ++- graphula.cabal | 4 +- package.yaml | 3 +- src/Graphula.hs | 14 ++++- src/Graphula/Class.hs | 9 +++ src/Graphula/Dependencies.hs | 84 +++++++++++++++++++++++--- src/Graphula/Idempotent.hs | 6 ++ src/Graphula/Logged.hs | 1 + src/Graphula/Node.hs | 114 +++++++++++++++++++++-------------- 9 files changed, 184 insertions(+), 61 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 38aedcc..a2888d4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,12 @@ -## [*Unreleased*](https://github.com/freckle/graphula/compare/v2.0.2.1...main) +## [_Unreleased_](https://github.com/freckle/graphula/compare/v2.1.0.0...main) -None +## [v2.1.0.0](https://github.com/freckle/graphula/compare/v2.0.2.2...v2.1.0.0) + +- Some unnecessary `SafeToInsert` have been removed from `node` and `nodeKeyed`. + - `node` only requires `SafeToInsert` when the `KeySource` is `SourceDefault`, + not when the `KeySource` is `KeyArbitrary`. + - `nodeKeyed` no longer ever requires `SafeToInsert` +- `MonadGraphulaFrontend` has a new `insertKeyed` method. ## [v2.0.2.2](https://github.com/freckle/graphula/compare/v2.0.2.1...v2.0.2.2) diff --git a/graphula.cabal b/graphula.cabal index 61b0936..a80cf85 100644 --- a/graphula.cabal +++ b/graphula.cabal @@ -4,10 +4,10 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ca3c9631f0eb250d085bf4e69cf99d4cd5d82c6c7975a14ce18b57fc549575c5 +-- hash: 77f36204ab2afc392bf0f4eb7413aaf8ff36c25b86f28dde5747f3ed9121f0d4 name: graphula -version: 2.0.2.2 +version: 2.1.0.0 synopsis: A simple interface for generating persistent data and linking its dependencies description: Please see README.md category: Network diff --git a/package.yaml b/package.yaml index 80f5dfc..1d49f8e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,12 +1,11 @@ name: graphula -version: 2.0.2.2 +version: 2.1.0.0 maintainer: Freckle Education category: Network github: freckle/graphula synopsis: >- A simple interface for generating persistent data and linking its dependencies description: Please see README.md - extra-source-files: - README.md - CHANGELOG.md diff --git a/src/Graphula.hs b/src/Graphula.hs index 4ba4c6b..09532dc 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -150,9 +150,9 @@ import Database.Persist , delete , get , getEntity - , insertKey , insertUnique ) +import qualified Database.Persist as Persist import Database.Persist.Sql (SqlBackend) import Graphula.Class import Graphula.Dependencies @@ -223,9 +223,19 @@ instance (MonadIO m, MonadIO n) => MonadGraphulaFrontend (GraphulaT n m) where whenNothing existingKey $ do existingUnique <- checkUnique n whenNothing existingUnique $ do - insertKey key n + Persist.insertKey key n getEntity key + insertKeyed 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 + remove key = do RunDB runDB <- asks dbRunner lift . runDB $ delete key diff --git a/src/Graphula/Class.hs b/src/Graphula/Class.hs index 199de82..491020d 100644 --- a/src/Graphula/Class.hs +++ b/src/Graphula/Class.hs @@ -67,6 +67,15 @@ class MonadGraphulaFrontend m where -> a -> m (Maybe (Entity a)) + insertKeyed + :: ( PersistEntityBackend a ~ SqlBackend + , PersistEntity a + , Monad m + ) + => Key a + -> a + -> m (Maybe (Entity a)) + remove :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) => Key a diff --git a/src/Graphula/Dependencies.hs b/src/Graphula/Dependencies.hs index c62a457..d7e3193 100644 --- a/src/Graphula/Dependencies.hs +++ b/src/Graphula/Dependencies.hs @@ -24,18 +24,29 @@ module Graphula.Dependencies -- * Non-serial keys , KeySourceType (..) + , KeySourceTypeM + , KeyForInsert + , KeyRequirementForInsert + , InsertWithPossiblyRequiredKey (..) + , Required (..) + , Optional (..) , GenerateKey , generateKey ) where import Prelude -import Data.Kind (Constraint) +import Data.Kind (Constraint, Type) import Data.Proxy (Proxy (..)) -import Database.Persist (Key) +import Database.Persist (Entity (..), Key, PersistEntity, PersistEntityBackend) +import Database.Persist.Sql (SqlBackend) import GHC.Generics (Generic) import GHC.TypeLits (ErrorMessage (..), TypeError) import Generics.Eot (Eot, HasEot, fromEot, toEot) +import Graphula.Class (GraphulaSafeToInsert, MonadGraphulaFrontend) +import qualified Graphula.Class as MonadGraphulaFrontend + ( MonadGraphulaFrontend (..) + ) import Graphula.Dependencies.Generic import Graphula.NoConstraint import Test.QuickCheck.Arbitrary (Arbitrary (..)) @@ -129,28 +140,85 @@ data KeySourceType -- See 'nodeKeyed'. SourceExternal +newtype Required a = Required a + +newtype Optional a = Optional (Maybe a) + +-- | When a user of Graphula inserts, this wraps the key they provide. +-- For 'SourceExternal' a key is required; for others it's optional. +type family KeySourceTypeM (t :: KeySourceType) :: Type -> Type where + KeySourceTypeM 'SourceExternal = Required + KeySourceTypeM _ = Optional + +type KeyRequirementForInsert record = KeySourceTypeM (KeySource record) + +-- | When Graphula inserts into Persistent, this wraps the key is provides. +-- For 'SourceDefault', a key is optional; for others it has always been +-- generated. +type family KeySourceTypeInternalM (t :: KeySourceType) :: Type -> Type where + KeySourceTypeInternalM 'SourceDefault = Optional + KeySourceTypeInternalM _ = Required + +type KeyRequirementForInsertInternal record = + KeySourceTypeInternalM (KeySource record) + +-- | When Graphula inserts into Persistent, this is the record's key. +type KeyForInsert record = KeyRequirementForInsertInternal record (Key record) + +class InsertWithPossiblyRequiredKey (requirement :: Type -> Type) where + type InsertConstraint requirement :: Type -> Constraint + insertWithPossiblyRequiredKey + :: ( PersistEntityBackend record ~ SqlBackend + , PersistEntity record + , Monad m + , MonadGraphulaFrontend m + , InsertConstraint requirement record + ) + => requirement (Key record) + -> record + -> m (Maybe (Entity record)) + justKey :: key -> requirement key + +instance InsertWithPossiblyRequiredKey Optional where + type InsertConstraint Optional = GraphulaSafeToInsert + insertWithPossiblyRequiredKey (Optional key) = MonadGraphulaFrontend.insert key + justKey = Optional . Just + +instance InsertWithPossiblyRequiredKey Required where + type InsertConstraint Required = NoConstraint + insertWithPossiblyRequiredKey (Required key) = MonadGraphulaFrontend.insertKeyed key + justKey = Required + -- | Abstract constraint that some @a@ can generate a key -- -- This is part of ensuring better error messages. class - (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => + ( GenerateKeyInternal (KeySource a) a + , KeyConstraint (KeySource a) a + , InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a)) + , InsertConstraint (KeySourceTypeInternalM (KeySource a)) a + ) => GenerateKey a instance - (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) + ( GenerateKeyInternal (KeySource a) a + , KeyConstraint (KeySource a) a + , InsertWithPossiblyRequiredKey (KeySourceTypeInternalM (KeySource a)) + , InsertConstraint (KeySourceTypeInternalM (KeySource a)) a + ) => GenerateKey a class GenerateKeyInternal (s :: KeySourceType) a where type KeyConstraint s a :: Constraint - generateKey :: KeyConstraint s a => Gen (Maybe (Key a)) + generateKey :: KeyConstraint s a => Gen (KeySourceTypeInternalM s (Key a)) instance GenerateKeyInternal 'SourceDefault a where - type KeyConstraint 'SourceDefault a = NoConstraint a - generateKey = pure Nothing + type KeyConstraint 'SourceDefault a = GraphulaSafeToInsert a + generateKey = pure (Optional Nothing) instance GenerateKeyInternal 'SourceArbitrary a where type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a) - generateKey = Just <$> arbitrary + generateKey = Required <$> arbitrary -- Rendered: -- diff --git a/src/Graphula/Idempotent.hs b/src/Graphula/Idempotent.hs index 3243db3..d7a7fa6 100644 --- a/src/Graphula/Idempotent.hs +++ b/src/Graphula/Idempotent.hs @@ -61,6 +61,12 @@ instance for_ (entityKey <$> mEnt) $ \key -> liftIO $ modifyIORef' finalizersRef (remove key >>) pure mEnt + insertKeyed key n = do + finalizersRef <- ask + mEnt <- lift $ insertKeyed key n + for_ (entityKey <$> mEnt) $ + \key' -> liftIO $ modifyIORef' finalizersRef (remove key' >>) + pure mEnt remove = lift . remove runGraphulaIdempotentT :: MonadUnliftIO m => GraphulaIdempotentT m a -> m a diff --git a/src/Graphula/Logged.hs b/src/Graphula/Logged.hs index b56ac95..e47a9a3 100644 --- a/src/Graphula/Logged.hs +++ b/src/Graphula/Logged.hs @@ -73,6 +73,7 @@ instance (MonadGraphulaBackend m, MonadIO m) => MonadGraphulaBackend (GraphulaLo instance (Monad m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaLoggedT m) where insert mKey = lift . insert mKey + insertKeyed key = lift . insertKeyed key remove = lift . remove -- | Run the graph while logging to a temporary file diff --git a/src/Graphula/Node.hs b/src/Graphula/Node.hs index 9b8cf24..863f4ff 100644 --- a/src/Graphula/Node.hs +++ b/src/Graphula/Node.hs @@ -47,6 +47,7 @@ import Graphula.Arbitrary import Graphula.Class import Graphula.Dependencies import Test.QuickCheck (Arbitrary (..)) +import UnliftIO (MonadIO) import UnliftIO.Exception (Exception, throwIO) -- | Options for generating an individual node @@ -97,7 +98,7 @@ edit f = mempty {nodeOptionsEdit = Kendo $ Just . f} ensure :: (a -> Bool) -> NodeOptions a ensure f = mempty {nodeOptionsEdit = Kendo $ \a -> a <$ guard (f a)} --- | Generate a node with a default (Database-provided) key +-- | Generate a node with a default (Arbitrary or database-provided) key -- -- > a <- node @A () mempty node @@ -110,35 +111,55 @@ node , PersistEntityBackend a ~ SqlBackend , PersistEntity a , Typeable a - , GraphulaSafeToInsert a ) => Dependencies a -> NodeOptions a -> m (Entity a) -node = nodeImpl $ generate $ generateKey @(KeySource a) @a +node dependencies NodeOptions {..} = + let genKey = generate $ generateKey @(KeySource a) @a + in attempt 100 10 $ do + initial <- generate arbitrary + for (appKendo nodeOptionsEdit initial) $ \edited -> do + -- N.B. dependencies setting always overrules edits + let hydrated = edited `dependsOn` dependencies + logNode hydrated + mKey <- genKey + pure (mKey, hydrated) --- | Generate a node with an explictly-given key --- --- > let someKey = UUID.fromString "..." --- > a <- nodeKeyed @A someKey () mempty -nodeKeyed +attempt :: forall a m . ( MonadGraphula m - , Logging m a - , Arbitrary a - , HasDependencies a , PersistEntityBackend a ~ SqlBackend , PersistEntity a + , GenerateKey a , Typeable a - , GraphulaSafeToInsert a ) - => Key a - -> Dependencies a - -> NodeOptions a + => Int + -> Int + -> m (Maybe (KeyForInsert a, a)) -> m (Entity a) -nodeKeyed key = nodeImpl $ pure $ Just key +attempt maxEdits maxInserts source = loop 0 0 + where + loop :: Int -> Int -> m (Entity a) + loop numEdits numInserts + | numEdits >= maxEdits = die GenerationFailureMaxAttemptsToConstrain + | numInserts >= maxInserts = die GenerationFailureMaxAttemptsToInsert + | otherwise = + source >>= \case + Nothing -> loop (succ numEdits) numInserts + -- ^ 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 -nodeImpl +-- | Generate a node with an explictly-given key +-- +-- > let someKey = UUID.fromString "..." +-- > a <- nodeKeyed @A someKey () mempty +nodeKeyed :: forall a m . ( MonadGraphula m , Logging m a @@ -147,43 +168,33 @@ nodeImpl , PersistEntityBackend a ~ SqlBackend , PersistEntity a , Typeable a - , GraphulaSafeToInsert a ) - => m (Maybe (Key a)) + => Key a -> Dependencies a -> NodeOptions a -> m (Entity a) -nodeImpl genKey dependencies NodeOptions {..} = attempt 100 10 $ do - initial <- generate arbitrary - for (appKendo nodeOptionsEdit initial) $ \edited -> do - -- N.B. dependencies setting always overrules edits - let hydrated = edited `dependsOn` dependencies - logNode hydrated - mKey <- genKey - pure (mKey, hydrated) - -data GenerationFailure - = -- | Could not satisfy constraints defined using 'ensure' - GenerationFailureMaxAttemptsToConstrain TypeRep - | -- | Could not satisfy database constraints on 'insert' - GenerationFailureMaxAttemptsToInsert TypeRep - deriving stock (Show, Eq) - -instance Exception GenerationFailure - -attempt +nodeKeyed key dependencies NodeOptions {..} = + attempt' 100 10 key $ do + initial <- generate arbitrary + for (appKendo nodeOptionsEdit initial) $ \edited -> do + -- N.B. dependencies setting always overrules edits + let hydrated = edited `dependsOn` dependencies + logNode hydrated + pure hydrated + +attempt' :: forall a m . ( MonadGraphula m , PersistEntityBackend a ~ SqlBackend , PersistEntity a , Typeable a - , GraphulaSafeToInsert a ) => Int -> Int - -> m (Maybe (Maybe (Key a), a)) + -> Key a + -> m (Maybe a) -> m (Entity a) -attempt maxEdits maxInserts source = loop 0 0 +attempt' maxEdits maxInserts key source = loop 0 0 where loop :: Int -> Int -> m (Entity a) loop numEdits numInserts @@ -193,12 +204,25 @@ attempt maxEdits maxInserts source = loop 0 0 source >>= \case Nothing -> loop (succ numEdits) numInserts -- ^ failed to edit, only increments this - Just (mKey, value) -> - insert mKey value >>= \case + 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 - die :: (TypeRep -> GenerationFailure) -> m (Entity a) - die e = throwIO $ e $ typeRep (Proxy :: Proxy a) +die + :: forall a m + . (MonadIO m, Typeable a) + => (TypeRep -> GenerationFailure) + -> m (Entity a) +die e = throwIO $ e $ typeRep $ Proxy @a + +data GenerationFailure + = -- | Could not satisfy constraints defined using 'ensure' + GenerationFailureMaxAttemptsToConstrain TypeRep + | -- | Could not satisfy database constraints on 'insert' + GenerationFailureMaxAttemptsToInsert TypeRep + deriving stock (Show, Eq) + +instance Exception GenerationFailure