diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +## [*Unreleased*](https://github.com/freckle/graphula/compare/v2.0.0.1...main) + +None + +## [v2.0.0.1](https://github.com/faktory/graphula/tree/v2.0.0.1) + +First tagged release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2020 Renaissance Learning Inc + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,267 @@ +# Graphula Core + +Graphula is a simple interface for generating persistent data and linking its dependencies. We use this interface to generate fixtures for automated testing. The interface is extensible and supports pluggable front-ends. + + + + +## Arbitrary Data + +Graphula utilizes `QuickCheck` to generate random data. We need to declare `Arbitrary` instances for our types. + +```haskell +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +A + a String + b Int + deriving Show Eq Generic + +B + a AId + b String + deriving Show Eq Generic + +C + a AId + b BId + c String + deriving Show Eq Generic + +D + Id UUIDKey + a Int + b String + deriving Show Eq Generic + +E + Id DId sqltype=uuid + a String + deriving Show Eq Generic + +F + a Bool + UniqueFA a + deriving Show Eq Generic +|] + +instance Arbitrary A where + arbitrary = A <$> arbitrary <*> arbitrary + +instance Arbitrary B where + arbitrary = B <$> arbitrary <*> arbitrary + +instance Arbitrary C where + arbitrary = C <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary D where + arbitrary = D <$> arbitrary <*> arbitrary + +instance Arbitrary E where + arbitrary = E <$> arbitrary + +instance Arbitrary F where + arbitrary = F <$> arbitrary +``` + +## Dependencies + +We declare dependencies via the `HasDependencies` typeclass and its associated type `Dependencies`. + +By default a type does not have any dependencies. We only need to declare an empty instance. + +```haskell +instance HasDependencies A +instance HasDependencies F +``` + +For single dependencies we use the `Only` type. + +```haskell +instance HasDependencies B where + type Dependencies B = Only AId +``` + +Groups of dependencies use tuples. Declare these dependencies in the order they appear in the type. `HasDependencies` leverages generic programming to inject dependencies for you. + +```haskell +instance HasDependencies C where + type Dependencies C = (AId, BId) +``` + +## Non Sequential Keys + +Graphula supports non-sequential keys with the `KeySource` associated type. To generate a key using +its `Arbitrary` instance, use `'SourceArbitrary`. Non-serial keys will need to also derive +an overlapping `Arbitrary` instance. + +```haskell +instance HasDependencies D where + type KeySource D = 'SourceArbitrary + +deriving newtype instance {-# OVERLAPPING #-} Arbitrary (Key D) +``` + +You can also elect to always specify an external key using `'SourceExternal`. This means that +this type cannot be constructed with `node`; use `nodeKeyed` instead. + +```haskell +instance HasDependencies E where + type KeySource E = 'SourceExternal +``` + +By default, `HasDependencies` instances use `type KeySource _ = 'SourceDefault`, which means +that graphula will expect the database to provide a key. + +## Serialization + +Graphula allows logging of graphs via `runGraphulaLogged`. Graphula dumps graphs +to a temp file on test failure. + +```haskell +loggingSpec :: IO () +loggingSpec = do + let + logFile :: FilePath + logFile = "test.graphula" + + -- We'd typically use `runGraphulaLogged` which utilizes a temp file. + failingGraph :: IO () + failingGraph = runGraphulaT Nothing runDB . runGraphulaLoggedWithFileT logFile $ do + Entity _ a <- node @A () $ edit $ \n -> + n {aA = "success"} + liftIO $ aA a `shouldBe` "failed" + + failingGraph + `shouldThrow` anyException + + n <- lines <$> readFile "test.graphula" + n `shouldSatisfy` (not . null) +``` + +## Running It + +```haskell +simpleSpec :: IO () +simpleSpec = + runGraphulaT Nothing runDB $ do + -- Type application is not necessary, but recommended for clarity. + Entity aId _ <- node @A () mempty + Entity bId b <- node @B (only aId) mempty + Entity _ c <- node @C (aId, bId) $ edit $ \n -> n { cC = "edited" } + Entity dId _ <- node @D () mempty + Entity eId _ <- nodeKeyed @E (EKey dId) () mempty + + -- Do something with your data + liftIO $ do + cC c `shouldBe` "edited" + cA c `shouldBe` bA b + unEKey eId `shouldBe` dId +``` + +`runGraphulaT` carries frontend instructions. If we'd like to override them we need to declare our own frontend. + +For example, a front-end that always fails to insert. + +```haskell +newtype GraphulaFailT m a = GraphulaFailT { runGraphulaFailT :: m a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadGraphulaBackend) + +instance MonadGraphulaFrontend (GraphulaFailT m) where + insert _ _ = pure Nothing + remove = const (pure ()) + +insertionFailureSpec :: IO () +insertionFailureSpec = do + let + failingGraph :: IO () + failingGraph = runGraphulaT Nothing runDB . runGraphulaFailT $ do + Entity _ _ <- node @A () mempty + pure () + failingGraph + `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @A))) +``` + +Note that graphula can fail naturally if we define a graph that violates unique constraints +in the database: + +```haskell +constraintFailureSpec :: IO () +constraintFailureSpec = do + let + failingGraph :: IO () + failingGraph = runGraphulaT Nothing runDB $ + replicateM_ 3 $ node @F () mempty + failingGraph + `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @F))) +``` + +or if we define a graph with an unsatisfiable predicates: + +```haskell +ensureFailureSpec :: IO () +ensureFailureSpec = do + let + failingGraph :: IO () + failingGraph = runGraphulaT Nothing runDB $ do + Entity _ _ <- node @A () $ ensure $ \a -> a /= a + pure () + failingGraph + `shouldThrow` (== (GenerationFailureMaxAttemptsToConstrain (typeRep $ Proxy @A))) +``` + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/graphula-core.cabal b/graphula-core.cabal new file mode 100644 --- /dev/null +++ b/graphula-core.cabal @@ -0,0 +1,87 @@ +cabal-version: 1.12 +name: graphula-core +version: 2.0.0.1 +license: MIT +license-file: LICENSE +maintainer: Freckle Education +homepage: https://github.com/freckle/graphula#readme +bug-reports: https://github.com/freckle/graphula/issues +synopsis: + A declarative library for describing dependencies between data + +description: Please see README.md +category: Network +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/graphula + +library + exposed-modules: + Graphula + Graphula.Arbitrary + Graphula.Internal + Graphula.Key + + hs-source-dirs: src + other-modules: Paths_graphula_core + default-language: Haskell2010 + ghc-options: + -Weverything -Wno-unsafe -Wno-safe -Wno-missing-import-lists + -Wno-implicit-prelude + + build-depends: + HUnit >=1.6.1.0 && <1.7, + QuickCheck >=2.13.2 && <2.14, + base >=4.13.0.0 && <4.14, + containers >=0.6.2.1 && <0.7, + directory >=1.3.6.0 && <1.4, + generics-eot >=0.4.0.1 && <0.5, + mtl >=2.2.2 && <2.3, + persistent >=2.10.5.3 && <2.11, + random ==1.1.*, + semigroups >=0.19.1 && <0.20, + temporary ==1.3.*, + text >=1.2.4.0 && <1.3, + transformers >=0.5.6.2 && <0.6, + unliftio >=0.2.13.1 && <0.3, + unliftio-core >=0.1.2.0 && <0.2 + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + hs-source-dirs: test + other-modules: + Graphula.UUIDKey + Paths_graphula_core + + default-language: Haskell2010 + ghc-options: + -Weverything -Wno-unsafe -Wno-safe -Wno-missing-import-lists + -Wno-implicit-prelude -pgmL markdown-unlit + + build-depends: + QuickCheck >=2.13.2 && <2.14, + aeson >=1.4.7.1 && <1.5, + base >=4.13.0.0 && <4.14, + bytestring >=0.10.10.1 && <0.11, + containers >=0.6.2.1 && <0.7, + graphula-core -any, + hspec >=2.7.4 && <2.8, + http-api-data >=0.4.1.1 && <0.5, + markdown-unlit >=0.5.0 && <0.6, + monad-logger >=0.3.35 && <0.4, + path-pieces >=0.2.1 && <0.3, + persistent >=2.10.5.3 && <2.11, + persistent-sqlite >=2.10.6.2 && <2.11, + persistent-template >=2.8.2.3 && <2.9, + resourcet >=1.2.4.2 && <1.3, + semigroups >=0.19.1 && <0.20, + text >=1.2.4.0 && <1.3, + transformers >=0.5.6.2 && <0.6, + unliftio-core >=0.1.2.0 && <0.2, + uuid >=1.3.13 && <1.4 diff --git a/src/Graphula.hs b/src/Graphula.hs new file mode 100644 --- /dev/null +++ b/src/Graphula.hs @@ -0,0 +1,558 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | +-- +-- Graphula is a compact interface for generating data and linking its +-- dependencies. You can use this interface to generate fixtures for automated +-- testing. +-- +-- The interface is extensible and supports pluggable front-ends. +-- +-- @ +-- runGraphIdentity . runGraphulaT $ do +-- -- Compose dependencies at the value level +-- Identity vet <- node @Veterinarian () mempty +-- Identity owner <- node @Owner (only vet) mempty +-- -- TypeApplications is not necessary, but recommended for clarity. +-- Identity dog <- node @Dog (owner, vet) $ edit $ \d -> d { name = "fido" } +-- @ +-- +module Graphula + ( -- * Graph Declaration + node + , nodeKeyed + , GraphulaNode + , GraphulaContext + -- ** Node options + , NodeOptions + , edit + , ensure + -- * Declaring Dependencies and key source + , HasDependencies(..) + , KeySourceType(..) + -- * Abstract over how keys are generated using 'SourceDefault' or + -- 'SourceArbitrary' + , GenerateKey + -- ** Singular Dependencies + , Only(..) + , only + -- * The Graph Monad + -- ** Type Classes + , MonadGraphula + , MonadGraphulaBackend(..) + , MonadGraphulaFrontend(..) + -- ** Backends + , runGraphulaT + , GraphulaT + , runGraphulaLoggedT + , runGraphulaLoggedWithFileT + , GraphulaLoggedT + -- ** Frontends + , runGraphulaIdempotentT + , GraphulaIdempotentT + -- * Extras + , NoConstraint + -- * Exceptions + , GenerationFailure(..) + ) +where + +import Prelude hiding (readFile) + +import Control.Monad (guard, (<=<)) +import Control.Monad.IO.Unlift +import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT) +import Control.Monad.Trans (MonadTrans, lift) +import Data.Foldable (for_, traverse_) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy(..)) +import Data.Semigroup.Generic (gmappend, gmempty) +import Data.Sequence (Seq, empty, (|>)) +import Data.Text (Text, pack) +import qualified Data.Text.IO as T +import Data.Traversable (for) +import Data.Typeable (TypeRep, Typeable, typeRep) +import Database.Persist + ( Entity(..) + , Key + , PersistEntity + , PersistEntityBackend + , checkUnique + , delete + , entityKey + , get + , getEntity + , insertKey + , insertUnique + ) +import Database.Persist.Sql (SqlBackend) +import Generics.Eot (Eot, HasEot, fromEot, toEot) +import GHC.Generics (Generic) +import Graphula.Arbitrary (generate) +import Graphula.Internal +import System.Directory (createDirectoryIfMissing, getTemporaryDirectory) +import System.IO (Handle, IOMode(..), hClose, openFile) +import System.IO.Temp (openTempFile) +import System.Random (randomIO) +import Test.HUnit.Lang + (FailureReason(..), HUnitFailure(..), formatFailureReason) +import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck.Random (QCGen, mkQCGen) +import UnliftIO.Exception + (Exception, SomeException, bracket, catch, mask, throwIO) + +type MonadGraphula m + = (Monad m, MonadGraphulaBackend m, MonadGraphulaFrontend m, MonadIO m) + +-- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'. +-- +-- Helpful for defining utility functions over many nodes. +-- +-- @ +-- mkABC :: (GraphulaContext m '[A, B, C]) => m (Node m C) +-- mkABC = do +-- a <- node @A () mempty +-- b <- node @B (only a) mempty +-- node @C (a, b) $ edit $ \n -> +-- n { cc = "spanish" } +-- @ +-- +type family GraphulaContext (m :: Type -> Type) (ts :: [Type]) :: Constraint where + GraphulaContext m '[] = MonadGraphula m + GraphulaContext m (t ': ts) = (GraphulaNode m t, GraphulaContext m ts) + +class MonadGraphulaFrontend m where + insert + :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) + => Maybe (Key a) -> a -> m (Maybe (Entity a)) + remove :: (PersistEntityBackend a ~ SqlBackend, PersistEntity a, Monad m) => Key a -> m () + +data Args backend n m = Args + { dbRunner :: RunDB backend n m + , gen :: IORef QCGen + } + +newtype RunDB backend n m = RunDB (forall b. ReaderT backend n b -> m b) + +newtype GraphulaT n m a = + GraphulaT { runGraphulaT' :: ReaderT (Args SqlBackend n m) m a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Args SqlBackend n m)) + +instance MonadTrans (GraphulaT n) where + lift = GraphulaT . lift + +instance MonadUnliftIO m => MonadUnliftIO (GraphulaT n m) where + {-# INLINE askUnliftIO #-} + askUnliftIO = GraphulaT $ withUnliftIO $ \u -> + return $ UnliftIO $ unliftIO u . runGraphulaT' + {-# INLINE withRunInIO #-} + withRunInIO inner = + GraphulaT $ withRunInIO $ \run -> inner $ run . runGraphulaT' + +instance MonadIO m => MonadGraphulaBackend (GraphulaT n m) where + type Logging (GraphulaT n m) = NoConstraint + askGen = asks gen + logNode _ = pure () + +instance (MonadIO m, Applicative n, MonadIO n) => MonadGraphulaFrontend (GraphulaT n m) where + insert mKey n = do + RunDB runDB <- asks dbRunner + lift . runDB $ case mKey of + Nothing -> insertUnique n >>= \case + Nothing -> pure Nothing + Just key -> getEntity key + Just key -> do + existingKey <- get key + whenNothing existingKey $ do + existingUnique <- checkUnique n + whenNothing existingUnique $ do + insertKey key n + 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 -- ^ Optional seed + -> (forall b . ReaderT SqlBackend n b -> m b) -- ^ Database runner + -> GraphulaT n m a + -> m a +runGraphulaT mSeed runDB action = do + seed <- maybe (liftIO randomIO) pure mSeed + qcGen <- liftIO $ newIORef $ mkQCGen seed + runReaderT (runGraphulaT' action) (Args (RunDB runDB) qcGen) + `catch` logFailingSeed seed + +logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a +logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed) + +newtype GraphulaIdempotentT m a = + GraphulaIdempotentT {runGraphulaIdempotentT' :: ReaderT (IORef (m ())) m a} + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (m ()))) + +instance MonadUnliftIO m => MonadUnliftIO (GraphulaIdempotentT m) where + {-# INLINE askUnliftIO #-} + askUnliftIO = GraphulaIdempotentT $ withUnliftIO $ \u -> + return $ UnliftIO $ unliftIO u . runGraphulaIdempotentT' + {-# INLINE withRunInIO #-} + withRunInIO inner = GraphulaIdempotentT $ withRunInIO $ \run -> + inner $ run . runGraphulaIdempotentT' + +instance MonadTrans GraphulaIdempotentT where + lift = GraphulaIdempotentT . lift + +instance (MonadIO m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaIdempotentT m) where + insert mKey n = do + finalizersRef <- ask + mEnt <- lift $ insert mKey n + for_ (entityKey <$> mEnt) + $ \key -> liftIO $ modifyIORef' finalizersRef (remove key >>) + pure mEnt + remove = lift . remove + +-- | A wrapper around a graphula frontend that produces finalizers to remove +-- graph nodes on error or completion. An idempotent graph produces no data +-- outside of its own closure. +-- +-- @ +-- runGraphIdentity . runGraphulaIdempotentT . runGraphulaT $ do +-- node @PancakeBreakfast () mempty +-- @ +-- +runGraphulaIdempotentT :: (MonadUnliftIO m) => GraphulaIdempotentT m a -> m a +runGraphulaIdempotentT action = mask $ \unmasked -> do + finalizersRef <- liftIO . newIORef $ pure () + x <- + unmasked + $ runReaderT (runGraphulaIdempotentT' action) finalizersRef + `catch` rollbackRethrow finalizersRef + rollback finalizersRef $ pure x + where + rollback :: MonadIO m => IORef (m a) -> m b -> m b + rollback finalizersRef x = do + finalizers <- liftIO $ readIORef finalizersRef + finalizers >> x + + rollbackRethrow :: MonadIO m => IORef (m a) -> SomeException -> m b + rollbackRethrow finalizersRef (e :: SomeException) = + rollback finalizersRef (throwIO e) + +newtype GraphulaLoggedT m a = + GraphulaLoggedT {runGraphulaLoggedT' :: ReaderT (IORef (Seq Text)) m a} + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (IORef (Seq Text))) + +instance MonadTrans GraphulaLoggedT where + lift = GraphulaLoggedT . lift + +instance (MonadGraphulaBackend m, MonadIO m) => MonadGraphulaBackend (GraphulaLoggedT m) where + type Logging (GraphulaLoggedT m) = Show + askGen = lift askGen + logNode n = do + graphLog <- ask + liftIO $ modifyIORef' graphLog (|> pack (show n)) + +instance (Monad m, MonadGraphulaFrontend m) => MonadGraphulaFrontend (GraphulaLoggedT m) where + insert mKey = lift . insert mKey + remove = lift . remove + +-- | An extension of 'runGraphulaT' that logs all nodes to a temporary file on +-- 'Exception' and re-throws the 'Exception'. +runGraphulaLoggedT :: MonadUnliftIO m => GraphulaLoggedT m a -> m a +runGraphulaLoggedT = runGraphulaLoggedUsingT logFailTemp + +-- | A variant of 'runGraphulaLoggedT' that accepts a file path to logged to +-- instead of utilizing a temp file. +runGraphulaLoggedWithFileT + :: MonadUnliftIO m => FilePath -> GraphulaLoggedT m a -> m a +runGraphulaLoggedWithFileT = runGraphulaLoggedUsingT . logFailFile + +runGraphulaLoggedUsingT + :: MonadUnliftIO m + => (IORef (Seq Text) -> HUnitFailure -> m a) + -> GraphulaLoggedT m a + -> m a +runGraphulaLoggedUsingT logFail action = do + graphLog <- liftIO $ newIORef empty + runReaderT (runGraphulaLoggedT' action) graphLog `catch` logFail graphLog + +logFailUsing + :: MonadIO m + => IO (FilePath, Handle) + -> IORef (Seq Text) + -> HUnitFailure + -> m a +logFailUsing f graphLog hunitfailure = + flip rethrowHUnitLogged hunitfailure =<< logGraphToHandle graphLog f + +logFailFile :: MonadIO m => FilePath -> IORef (Seq Text) -> HUnitFailure -> m a +logFailFile path = logFailUsing ((path, ) <$> openFile path WriteMode) + +logFailTemp :: MonadIO m => IORef (Seq Text) -> HUnitFailure -> m a +logFailTemp = logFailUsing $ do + tmp <- (++ "/graphula") <$> getTemporaryDirectory + createDirectoryIfMissing True tmp + openTempFile tmp "fail-.graphula" + +logGraphToHandle + :: (MonadIO m) => IORef (Seq Text) -> IO (FilePath, Handle) -> m FilePath +logGraphToHandle graphLog openHandle = liftIO $ bracket + openHandle + (hClose . snd) + (\(path, handle) -> do + nodes <- readIORef graphLog + path <$ traverse_ (T.hPutStrLn handle) nodes + ) + +rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a +rethrowHUnitWith message (HUnitFailure l r) = + throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r + +rethrowHUnitLogged :: MonadIO m => FilePath -> HUnitFailure -> m a +rethrowHUnitLogged path = + rethrowHUnitWith ("Graph dumped in temp file: " ++ path) + +class HasDependencies a where + -- | A data type that contains values to be injected into @a@ via + -- `dependsOn`. The default generic implementation of `dependsOn` supports + -- tuples as 'Dependencies'. Data types with a single dependency should use + -- 'Only' as a 1-tuple. + -- + -- note: The contents of a tuple must be ordered as they appear in the + -- definition of @a@. + type Dependencies a + type instance Dependencies a = () + + -- | Specify the method for resolving a node's key + -- + -- This can be + -- + -- @ + -- 'SourceDefault -- automatically generate keys from the database + -- 'SourceArbitrary -- automatically generate keys using @'Arbitrary'@ + -- 'SourceExternal -- explicitly pass a key using @'nodeKeyed'@ + -- @ + -- + -- Most types will use @'SourceDefault'@ or @'SourceArbitrary'@. Only + -- use @'SourceExternal'@ if the key for a value is always defined + -- externally. + -- + type KeySource a :: KeySourceType + type instance KeySource a = 'SourceDefault + + -- | Assign values from the 'Dependencies' collection to a value. + -- 'dependsOn' must be an idempotent operation. + -- + -- Law: + -- + -- prop> (\x d -> x `dependsOn` d `dependsOn` d) = dependsOn + dependsOn :: a -> Dependencies a -> a + default dependsOn + :: + ( HasEot a + , HasEot (Dependencies a) + , GHasDependencies (Proxy a) (Proxy (Dependencies a)) (Eot a) (Eot (Dependencies a)) + ) + => a -> Dependencies a -> a + dependsOn a dependencies = + fromEot $ + genericDependsOn + (Proxy :: Proxy a) + (Proxy :: Proxy (Dependencies a)) + (toEot a) + (toEot dependencies) + +-- | Abstract over how keys are generated using @'SourceDefault'@ or @'SourceArbitrary'@ +class (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a +instance (GenerateKeyInternal (KeySource a) a, KeyConstraint (KeySource a) a) => GenerateKey a + +data GenerationFailure + = GenerationFailureMaxAttemptsToConstrain TypeRep + -- ^ Could not satisfy constraints defined using @'ensure'@ + | GenerationFailureMaxAttemptsToInsert TypeRep + -- ^ Could not satisfy database constraints on insert + deriving stock (Show, Eq) + +instance Exception GenerationFailure + +type GraphulaNode m a + = ( HasDependencies a + , Logging m a + , PersistEntityBackend a ~ SqlBackend + , PersistEntity a + , Typeable a + , Arbitrary a + ) + +{-| + Generate a value with data dependencies. This leverages + 'HasDependencies' to insert the specified data in the generated value. All + dependency data is inserted after any editing operations. + + > node @Dog (ownerId, veterinarianId) mempty + > node @Dog (ownerId, veterinarianId) $ edit $ \dog -> + > dog {name = "fido"} + + A value that has an externally managed key must use @'nodeKeyed'@ instead. +-} +node + :: forall a m + . (GraphulaContext m '[a], GenerateKey a) + => Dependencies a + -> NodeOptions a + -> m (Entity a) +node = nodeImpl $ generate $ generateKey @(KeySource a) @a + +{-| + Generate a value with data dependencies given an externally managed + key. This leverages 'HasDependencies' to insert the specified data + in the generated value. All dependency data is inserted after any + editing operations. + + > someKey <- generateKey + > node @Cat someKey (ownerId, veterinarianId) mempty + > anotherKey <- generateKey + > node @Cat anotherKey (ownerId, veterinarianId) $ edit $ \cat -> + > cat {name = "milo"} + + A value that has an automatically managed key may use @'node'@ instead. +-} +nodeKeyed + :: forall a m + . GraphulaContext m '[a] + => Key a + -> Dependencies a + -> NodeOptions a + -> m (Entity a) +nodeKeyed key = nodeImpl $ pure $ Just key + +nodeImpl + :: forall a m + . GraphulaContext m '[a] + => m (Maybe (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 + let hydrated = edited `dependsOn` dependencies + logNode hydrated + mKey <- genKey + pure (mKey, hydrated) + +-- | Modify the node after it's been generated +-- +-- @ +-- a <- node @A () $ edit $ \a -> a { someField = True } +-- @ +-- +edit :: (a -> a) -> NodeOptions a +edit f = mempty { nodeOptionsEdit = Kendo $ Just . f } + +-- | Require a node to satisfy the specified predicate +-- +-- @ +-- a <- node @A () $ ensure $ (== True) . someField +-- @ +-- +ensure :: (a -> Bool) -> NodeOptions a +ensure f = mempty { nodeOptionsEdit = Kendo $ \a -> a <$ guard (f a) } + +-- | Options for generating an individual node +-- +-- @'NodeOptions'@ can be created and combined with the Monoidal +-- operations @'(<>)'@ and @'mempty'@. +-- +-- @ +-- a1 <- node @A () mempty +-- a2 <- node @A () $ edit $ \a -> a { someField = True } +-- a3 <- node @A () $ ensure $ (== True) . someField +-- @ +-- +newtype NodeOptions a = NodeOptions + { nodeOptionsEdit :: Kendo Maybe a + } + deriving stock Generic + +instance Semigroup (NodeOptions a) where + (<>) = gmappend + {-# INLINE (<>) #-} + +instance Monoid (NodeOptions a) where + mempty = gmempty + {-# INLINE mempty #-} + +-- | Like @'Endo'@ but uses Kliesli composition +newtype Kendo m a = Kendo { appKendo :: a -> m a } + deriving stock Generic + +instance Monad m => Semigroup (Kendo m a) where + Kendo f <> Kendo g = Kendo $ f <=< g + {-# INLINE (<>) #-} + +instance Monad m => Monoid (Kendo m a) where + mempty = Kendo pure + {-# INLINE mempty #-} + +attempt + :: forall a m + . (GraphulaContext m '[a]) + => Int + -> Int + -> m (Maybe (Maybe (Key a), a)) + -> m (Entity a) +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) -> insert mKey value >>= \case + Nothing -> loop (succ numEdits) (succ numInserts) + -- ^ failed to insert, but also increments this + Just a -> pure a + + die :: (TypeRep -> GenerationFailure) -> m (Entity a) + die e = throwIO $ e $ typeRep (Proxy :: Proxy a) + +-- | For entities that only have singular 'Dependencies' +newtype Only a = Only { fromOnly :: a } + deriving stock (Eq, Show, Ord, Generic, Functor, Foldable, Traversable) + +only :: a -> Only a +only = Only diff --git a/src/Graphula/Arbitrary.hs b/src/Graphula/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Graphula/Arbitrary.hs @@ -0,0 +1,34 @@ +{-| + Graphula tracks its own 'QCGen' for deterministic generation with 'Arbitrary' + and 'Gen'. 'generate' can be used to produce arbitrary values utilizing + graphula's generation. +-} +module Graphula.Arbitrary + ( generate + ) +where + +import Prelude + +import Control.Monad.IO.Unlift (MonadIO, liftIO) +import Data.IORef (readIORef, writeIORef) +import Graphula.Internal (MonadGraphulaBackend, askGen) +import System.Random (split) +import Test.QuickCheck (Gen) +import Test.QuickCheck.Gen (unGen) + +-- | Run a generator +-- +-- This is akin to 'Test.QuickCheck.generate', but utilizing graphula's +-- generation. The size passed to the generator is always 30; if you want +-- another size then you should explicitly use 'Test.QuickCheck.resize'. +-- +generate :: (MonadIO m, MonadGraphulaBackend m) => Gen a -> m a +generate gen = do + genRef <- askGen + g <- liftIO $ readIORef genRef + let + (g1, g2) = split g + x = unGen gen g1 30 + liftIO $ writeIORef genRef g2 + pure x diff --git a/src/Graphula/Internal.hs b/src/Graphula/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphula/Internal.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Graphula.Internal + ( MonadGraphulaBackend(..) + , GHasDependencies(..) + , KeySourceType(..) + , GenerateKeyInternal(..) + , NoConstraint + ) +where + +import Data.IORef (IORef) +import Data.Kind (Constraint, Type) +import Database.Persist (Key) +import Generics.Eot (Proxy(..), Void) +import GHC.TypeLits (ErrorMessage(..), TypeError) +import Test.QuickCheck (Arbitrary(..), Gen) +import Test.QuickCheck.Random (QCGen) + +class MonadGraphulaBackend m where + type Logging m :: Type -> Constraint + -- ^ A constraint provided to log details of the graph to some form of + -- persistence. This is used by 'runGraphulaLogged' to store graph nodes as + -- 'Show'n 'Text' values + askGen :: m (IORef QCGen) + logNode :: Logging m a => a -> m () + +data Match t + = NoMatch t + | Match t + +type family DependenciesTypeInstance nodeTy depsTy where + DependenciesTypeInstance nodeTy depsTy = + 'Text "‘type Dependencies " ':<>: 'ShowType nodeTy ':<>: + 'Text " = " ':<>: 'ShowType depsTy ':<>: 'Text "’" + +-- Walk through the fields of our node and match them up with fields from the dependencies. +type family FindMatches nodeTy depsTy as ds :: [Match Type] where + -- Excess dependencies + FindMatches nodeTy depsTy () (d, _ds) = + TypeError + ( 'Text "Excess dependency ‘" ':<>: 'ShowType d ':<>: + 'Text "’ in " ':$$: DependenciesTypeInstance nodeTy depsTy ':$$: + 'Text "Ordering of dependencies must match their occurrence in the target type ‘" ':<>: + 'ShowType nodeTy ':<>: 'Text "’" + ) + + -- No more fields or dependencies left + FindMatches _nodeTy _depsTy () () = '[] + + -- Fields left, but no more dependencies + FindMatches nodeTy depsTy (a, as) () = 'NoMatch a ': FindMatches nodeTy depsTy as () + + -- Field matches dependency, keep going + FindMatches nodeTy depsTy (a, as) (a, ds) = 'Match a ': FindMatches nodeTy depsTy as ds + + -- Field does not match dependency, keep going + FindMatches nodeTy depsTy (a, as) (d, ds) = 'NoMatch a ': FindMatches nodeTy depsTy as (d, ds) + +class GHasDependencies nodeTyProxy depsTyProxy node deps where + genericDependsOn :: nodeTyProxy -> depsTyProxy -> node -> deps -> node + +class GHasDependenciesRecursive fieldsProxy node deps where + genericDependsOnRecursive :: fieldsProxy -> node -> deps -> node + +-- This instance head only matches EoT representations of +-- datatypes with no constructors and no dependencies +instance {-# OVERLAPPING #-} GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either () Void) where + genericDependsOn _ _ node _ = node + +-- This instance warns the user if they give dependencies +-- to a datatype with no constructors +instance + {-# OVERLAPPABLE #-} + ( TypeError + ( 'Text "A datatype with no constructors can't use the dependencies in" ':$$: + DependenciesTypeInstance nodeTy depsTy + ) + ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) Void (Either deps rest) where + genericDependsOn _ _ _ _ = error "Impossible" + +-- This instance head only matches EoT representations of +-- datatypes with a single constructor +instance + ( FindMatches nodeTy depsTy node deps ~ fields + , GHasDependenciesRecursive (Proxy fields) node deps + ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either node Void) (Either deps Void) where + genericDependsOn _ _ (Left node) (Left deps) = + Left (genericDependsOnRecursive (Proxy :: Proxy fields) node deps) + genericDependsOn _ _ _ _ = error "Impossible" -- EoT never generates an actual `Right (x :: Void)` here + +-- This instance matches a sum type as both node and dependencies. +-- We use this to report an error to the user. +instance + ( TypeError + ( 'Text "Cannot automatically find dependencies for sum type in" ':$$: + DependenciesTypeInstance nodeTy depsTy + ) + ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either left (Either right rest)) (Either deps Void) where + genericDependsOn _ _ _ _ = error "Impossible" + +-- This instance matches a sum type as the node. +-- This is also an error. +instance + ( TypeError + ( 'Text "Cannot automatically use a sum type as dependencies in" ':$$: + DependenciesTypeInstance nodeTy depsTy + ) + ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either node Void) (Either left (Either right rest)) where + genericDependsOn _ _ _ _ = error "Impossible" + +-- This instance matches a sum type as the dependencies. +-- This is also an error. +instance + ( TypeError + ( 'Text "Cannot automatically find dependencies for sum type or use a sum type as a dependency in" ':$$: + DependenciesTypeInstance nodeTy depsTy + ) + ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) (Either left1 (Either right1 rest1)) (Either left2 (Either right2 rest2)) where + genericDependsOn _ _ _ _ = error "Impossible" + +-- Don't let the user specify `Void` as a dependency +instance + ( TypeError + ( 'Text "Use ‘()’ instead of ‘Void’ for datatypes with no dependencies in" ':$$: + DependenciesTypeInstance nodeTy depsTy + ) + ) => GHasDependencies (Proxy nodeTy) (Proxy depsTy) node Void where + genericDependsOn _ _ _ _ = error "Impossible" + +instance + ( a ~ dep + , GHasDependenciesRecursive (Proxy fields) as deps + ) => GHasDependenciesRecursive (Proxy ('Match a ': fields)) (a, as) (dep, deps) where + genericDependsOnRecursive _ (_, as) (dep, deps) = + (dep, genericDependsOnRecursive (Proxy :: Proxy fields) as deps) + +instance + ( GHasDependenciesRecursive (Proxy fields) as deps + ) => GHasDependenciesRecursive (Proxy ('NoMatch a ': fields)) (a, as) deps where + genericDependsOnRecursive _ (a, as) deps = + (a, genericDependsOnRecursive (Proxy :: Proxy fields) as deps) + +-- Without the kind-signature for '[], ghc will fail to find this +-- instance for nullary constructors +instance GHasDependenciesRecursive (Proxy ('[] :: [Match Type])) () () where + genericDependsOnRecursive _ _ _ = () + +data KeySourceType + = SourceDefault + -- ^ Generate keys using the database's @DEFAULT@ strategy + | SourceArbitrary + -- ^ Generate keys using the @'Arbitrary'@ instance for the @'Key'@ + | SourceExternal + -- ^ Always explicitly pass an external key + +-- | Handle key generation for @'SourceDefault'@ and @'SourceArbitrary'@ +-- +-- Ths could be a single-parameter class, but carrying the @a@ around +-- lets us give a better error message when @'node'@ is called instead +-- of @'nodeKeyed'@. +-- +class GenerateKeyInternal (s :: KeySourceType) a where + type KeyConstraint s a :: Constraint + generateKey :: KeyConstraint s a => Gen (Maybe (Key a)) + +instance GenerateKeyInternal 'SourceDefault a where + type KeyConstraint 'SourceDefault a = NoConstraint a + generateKey = pure Nothing + +instance GenerateKeyInternal 'SourceArbitrary a where + type KeyConstraint 'SourceArbitrary a = Arbitrary (Key a) + generateKey = Just <$> arbitrary + +-- | Explicit instance for @'SourceExternal'@ to give an actionable error message +-- +-- Rendered: +-- +-- @ +-- Cannot generate a value of type ‘X’ using ‘node’ since +-- +-- instance HasDependencies X where +-- type KeySource X = 'SourceExternal +-- +-- Possible fixes include: +-- • Use ‘nodeKeyed’ instead of ‘node’ +-- • Change ‘KeySource X’ to 'SourceDefault or 'SourceArbitrary +-- @ +-- +instance TypeError + ( 'Text "Cannot generate a value of type " + ':<>: Quote ('ShowType a) + ':<>: 'Text " using " + ':<>: Quote ('Text "node") + ':<>: 'Text " since" + ':$$: 'Text "" + ':$$: 'Text " instance HasDependencies " + ':<>: 'ShowType a + ':<>: 'Text " where" + ':$$: 'Text " " + ':<>: 'Text "type KeySource " + ':<>: 'ShowType a + ':<>: 'Text " = " + ':<>: 'ShowType 'SourceExternal + ':$$: 'Text "" + ':$$: 'Text "Possible fixes include:" + ':$$: 'Text "• Use " + ':<>: Quote ('Text "nodeKeyed") + ':<>: 'Text " instead of " + ':<>: Quote ('Text "node") + ':$$: 'Text "• Change " + ':<>: Quote ('Text "KeySource " ':<>: 'ShowType a) + ':<>: 'Text " to " + ':<>: 'Text "'SourceDefault" + ':<>: 'Text " or " + ':<>: 'Text "'SourceArbitrary" + ) => GenerateKeyInternal 'SourceExternal a where + type KeyConstraint 'SourceExternal a = NoConstraint a + generateKey = error "unreachable" + +type family Quote t where + Quote t = 'Text "‘" ':<>: t ':<>: 'Text "’" + +-- | Graphula accepts constraints for various uses. Frontends do not always +-- utilize these constraints. 'NoConstraint' is a universal class that all +-- types inhabit. It has no behavior and no additional constraints. +class NoConstraint a +instance NoConstraint a diff --git a/src/Graphula/Key.hs b/src/Graphula/Key.hs new file mode 100644 --- /dev/null +++ b/src/Graphula/Key.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Graphula.Key + ( onlyKey + , keys + , Keys + ) +where + +import Database.Persist +import GHC.TypeLits (ErrorMessage(..), TypeError) +import Graphula (Only(..), only) + +class EntityKeys a where + type Keys a + keys :: a -> Keys a + +instance + ( TypeError + ( 'Text "Cannot use naked ‘" ':<>: 'ShowType (Entity a) ':<>: + 'Text "’ as argument to ‘keys’." ':$$: + 'Text "Did you mean ‘Only (" ':<>: + 'ShowType (Entity a) ':<>: 'Text ")’?" + ) + ) => EntityKeys (Entity a) where + type Keys (Entity a) = Key a + keys = entityKey + +onlyKey :: Entity a -> Only (Key a) +onlyKey = keys . only + +instance EntityKeys (Only (Entity a)) where + type Keys (Only (Entity a)) = Only (Key a) + keys (Only a) = Only (entityKey a) + +instance EntityKeys (Entity a, Entity b) where + type Keys (Entity a, Entity b) = (Key a, Key b) + keys (a, b) = (entityKey a, entityKey b) + +instance EntityKeys (Entity a, Entity b, Entity c) where + type Keys (Entity a, Entity b, Entity c) = (Key a, Key b, Key c) + keys (a, b, c) = (entityKey a, entityKey b, entityKey c) + +-- For some reason, this definition (but no others) triggers +-- +-- ERROR: brittany pretty printer returned syntactically invalid result. +-- +-- brittany-disable-next-binding + +instance EntityKeys (Entity a, Entity b, Entity c, Entity d) where + type Keys (Entity a, Entity b, Entity c, Entity d) = (Key a, Key b, Key c, Key d) + keys (a, b, c, d) = (entityKey a, entityKey b, entityKey c, entityKey d) diff --git a/test/Graphula/UUIDKey.hs b/test/Graphula/UUIDKey.hs new file mode 100644 --- /dev/null +++ b/test/Graphula/UUIDKey.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Graphula.UUIDKey + ( UUIDKey + ) +where + +import Prelude + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Text as Text +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import Database.Persist +import Database.Persist.Sql +import Test.QuickCheck (Arbitrary(..), Gen, getLarge) +import Web.HttpApiData (FromHttpApiData, ToHttpApiData) +import Web.PathPieces (PathPiece(..)) + +-- | Example non-serial key +newtype UUIDKey = UUIDKey { unUUIDKey :: UUID } + deriving newtype (Eq, Show, Ord, Read, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData) + +instance Arbitrary UUIDKey where + arbitrary = UUIDKey <$> uuid + where uuid = UUID.fromWords <$> large <*> large <*> large <*> large + +large :: (Integral a, Bounded a) => Gen a +large = getLarge <$> arbitrary + +instance PathPiece UUIDKey where + toPathPiece = Text.pack . UUID.toString . unUUIDKey + fromPathPiece = fmap UUIDKey . UUID.fromString . Text.unpack + +instance PersistField UUIDKey where + toPersistValue = PersistText . Text.pack . UUID.toString . unUUIDKey + fromPersistValue = \case + PersistText t -> case UUID.fromString $ Text.unpack t of + Just x -> Right $ UUIDKey x + Nothing -> Left "Invalid UUID" + _ -> Left "Not PersistText" + +instance PersistFieldSql UUIDKey where + sqlType _ = SqlOther "uuid" diff --git a/test/README.lhs b/test/README.lhs new file mode 100644 --- /dev/null +++ b/test/README.lhs @@ -0,0 +1,267 @@ +# Graphula Core + +Graphula is a simple interface for generating persistent data and linking its dependencies. We use this interface to generate fixtures for automated testing. The interface is extensible and supports pluggable front-ends. + + + + +## Arbitrary Data + +Graphula utilizes `QuickCheck` to generate random data. We need to declare `Arbitrary` instances for our types. + +```haskell +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +A + a String + b Int + deriving Show Eq Generic + +B + a AId + b String + deriving Show Eq Generic + +C + a AId + b BId + c String + deriving Show Eq Generic + +D + Id UUIDKey + a Int + b String + deriving Show Eq Generic + +E + Id DId sqltype=uuid + a String + deriving Show Eq Generic + +F + a Bool + UniqueFA a + deriving Show Eq Generic +|] + +instance Arbitrary A where + arbitrary = A <$> arbitrary <*> arbitrary + +instance Arbitrary B where + arbitrary = B <$> arbitrary <*> arbitrary + +instance Arbitrary C where + arbitrary = C <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary D where + arbitrary = D <$> arbitrary <*> arbitrary + +instance Arbitrary E where + arbitrary = E <$> arbitrary + +instance Arbitrary F where + arbitrary = F <$> arbitrary +``` + +## Dependencies + +We declare dependencies via the `HasDependencies` typeclass and its associated type `Dependencies`. + +By default a type does not have any dependencies. We only need to declare an empty instance. + +```haskell +instance HasDependencies A +instance HasDependencies F +``` + +For single dependencies we use the `Only` type. + +```haskell +instance HasDependencies B where + type Dependencies B = Only AId +``` + +Groups of dependencies use tuples. Declare these dependencies in the order they appear in the type. `HasDependencies` leverages generic programming to inject dependencies for you. + +```haskell +instance HasDependencies C where + type Dependencies C = (AId, BId) +``` + +## Non Sequential Keys + +Graphula supports non-sequential keys with the `KeySource` associated type. To generate a key using +its `Arbitrary` instance, use `'SourceArbitrary`. Non-serial keys will need to also derive +an overlapping `Arbitrary` instance. + +```haskell +instance HasDependencies D where + type KeySource D = 'SourceArbitrary + +deriving newtype instance {-# OVERLAPPING #-} Arbitrary (Key D) +``` + +You can also elect to always specify an external key using `'SourceExternal`. This means that +this type cannot be constructed with `node`; use `nodeKeyed` instead. + +```haskell +instance HasDependencies E where + type KeySource E = 'SourceExternal +``` + +By default, `HasDependencies` instances use `type KeySource _ = 'SourceDefault`, which means +that graphula will expect the database to provide a key. + +## Serialization + +Graphula allows logging of graphs via `runGraphulaLogged`. Graphula dumps graphs +to a temp file on test failure. + +```haskell +loggingSpec :: IO () +loggingSpec = do + let + logFile :: FilePath + logFile = "test.graphula" + + -- We'd typically use `runGraphulaLogged` which utilizes a temp file. + failingGraph :: IO () + failingGraph = runGraphulaT Nothing runDB . runGraphulaLoggedWithFileT logFile $ do + Entity _ a <- node @A () $ edit $ \n -> + n {aA = "success"} + liftIO $ aA a `shouldBe` "failed" + + failingGraph + `shouldThrow` anyException + + n <- lines <$> readFile "test.graphula" + n `shouldSatisfy` (not . null) +``` + +## Running It + +```haskell +simpleSpec :: IO () +simpleSpec = + runGraphulaT Nothing runDB $ do + -- Type application is not necessary, but recommended for clarity. + Entity aId _ <- node @A () mempty + Entity bId b <- node @B (only aId) mempty + Entity _ c <- node @C (aId, bId) $ edit $ \n -> n { cC = "edited" } + Entity dId _ <- node @D () mempty + Entity eId _ <- nodeKeyed @E (EKey dId) () mempty + + -- Do something with your data + liftIO $ do + cC c `shouldBe` "edited" + cA c `shouldBe` bA b + unEKey eId `shouldBe` dId +``` + +`runGraphulaT` carries frontend instructions. If we'd like to override them we need to declare our own frontend. + +For example, a front-end that always fails to insert. + +```haskell +newtype GraphulaFailT m a = GraphulaFailT { runGraphulaFailT :: m a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadGraphulaBackend) + +instance MonadGraphulaFrontend (GraphulaFailT m) where + insert _ _ = pure Nothing + remove = const (pure ()) + +insertionFailureSpec :: IO () +insertionFailureSpec = do + let + failingGraph :: IO () + failingGraph = runGraphulaT Nothing runDB . runGraphulaFailT $ do + Entity _ _ <- node @A () mempty + pure () + failingGraph + `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @A))) +``` + +Note that graphula can fail naturally if we define a graph that violates unique constraints +in the database: + +```haskell +constraintFailureSpec :: IO () +constraintFailureSpec = do + let + failingGraph :: IO () + failingGraph = runGraphulaT Nothing runDB $ + replicateM_ 3 $ node @F () mempty + failingGraph + `shouldThrow` (== (GenerationFailureMaxAttemptsToInsert (typeRep $ Proxy @F))) +``` + +or if we define a graph with an unsatisfiable predicates: + +```haskell +ensureFailureSpec :: IO () +ensureFailureSpec = do + let + failingGraph :: IO () + failingGraph = runGraphulaT Nothing runDB $ do + Entity _ _ <- node @A () $ ensure $ \a -> a /= a + pure () + failingGraph + `shouldThrow` (== (GenerationFailureMaxAttemptsToConstrain (typeRep $ Proxy @A))) +``` + +