{-# LANGUAGE DeriveGeneric, CPP, FlexibleContexts, DerivingVia #-}
module ProjectM36.TransactionGraph where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.Transaction
import ProjectM36.TransactionInfo as TI
import ProjectM36.Relation
import ProjectM36.TupleSet
import ProjectM36.Tuple
import ProjectM36.RelationalExpression
import ProjectM36.TransactionGraph.Merge
import ProjectM36.MerkleHash
import qualified ProjectM36.DisconnectedTransaction as Discon
import qualified ProjectM36.Attribute as A
import ProjectM36.HashSecurely
import ProjectM36.ReferencedTransactionIds

import Codec.Winery
import Control.Monad.Except hiding (join)
import Control.Monad.Reader hiding (join)
import qualified Data.Vector as V
import qualified Data.UUID as U
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.List.NonEmpty as NE
import Data.Time.Clock
import qualified Data.Text as T
import GHC.Generics
import Data.Either (lefts, rights, isRight)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
import Control.Arrow
import Data.Maybe
import Data.UUID.V4

-- | Record a lookup for a specific transaction in the graph.
data TransactionIdLookup = TransactionIdLookup TransactionId |
                           TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]
                           deriving (Int -> TransactionIdLookup -> ShowS
[TransactionIdLookup] -> ShowS
TransactionIdLookup -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TransactionIdLookup] -> ShowS
$cshowList :: [TransactionIdLookup] -> ShowS
show :: TransactionIdLookup -> [Char]
$cshow :: TransactionIdLookup -> [Char]
showsPrec :: Int -> TransactionIdLookup -> ShowS
$cshowsPrec :: Int -> TransactionIdLookup -> ShowS
Show, TransactionIdLookup -> TransactionIdLookup -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransactionIdLookup -> TransactionIdLookup -> Bool
$c/= :: TransactionIdLookup -> TransactionIdLookup -> Bool
== :: TransactionIdLookup -> TransactionIdLookup -> Bool
$c== :: TransactionIdLookup -> TransactionIdLookup -> Bool
Eq, forall x. Rep TransactionIdLookup x -> TransactionIdLookup
forall x. TransactionIdLookup -> Rep TransactionIdLookup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TransactionIdLookup x -> TransactionIdLookup
$cfrom :: forall x. TransactionIdLookup -> Rep TransactionIdLookup x
Generic)
                           deriving Typeable TransactionIdLookup
BundleSerialise TransactionIdLookup
Extractor TransactionIdLookup
Decoder TransactionIdLookup
Proxy TransactionIdLookup -> SchemaGen Schema
TransactionIdLookup -> Builder
forall a.
Typeable a
-> (Proxy a -> SchemaGen Schema)
-> (a -> Builder)
-> Extractor a
-> Decoder a
-> BundleSerialise a
-> Serialise a
bundleSerialise :: BundleSerialise TransactionIdLookup
$cbundleSerialise :: BundleSerialise TransactionIdLookup
decodeCurrent :: Decoder TransactionIdLookup
$cdecodeCurrent :: Decoder TransactionIdLookup
extractor :: Extractor TransactionIdLookup
$cextractor :: Extractor TransactionIdLookup
toBuilder :: TransactionIdLookup -> Builder
$ctoBuilder :: TransactionIdLookup -> Builder
schemaGen :: Proxy TransactionIdLookup -> SchemaGen Schema
$cschemaGen :: Proxy TransactionIdLookup -> SchemaGen Schema
Serialise via WineryVariant TransactionIdLookup
                           
-- | Used for git-style head backtracking such as topic~3^2.
data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~v: walk back n parents, arbitrarily choosing a parent when a choice must be made
                                  TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent 
                                  TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp
                                  deriving (Int -> TransactionIdHeadBacktrack -> ShowS
[TransactionIdHeadBacktrack] -> ShowS
TransactionIdHeadBacktrack -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TransactionIdHeadBacktrack] -> ShowS
$cshowList :: [TransactionIdHeadBacktrack] -> ShowS
show :: TransactionIdHeadBacktrack -> [Char]
$cshow :: TransactionIdHeadBacktrack -> [Char]
showsPrec :: Int -> TransactionIdHeadBacktrack -> ShowS
$cshowsPrec :: Int -> TransactionIdHeadBacktrack -> ShowS
Show, TransactionIdHeadBacktrack -> TransactionIdHeadBacktrack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransactionIdHeadBacktrack -> TransactionIdHeadBacktrack -> Bool
$c/= :: TransactionIdHeadBacktrack -> TransactionIdHeadBacktrack -> Bool
== :: TransactionIdHeadBacktrack -> TransactionIdHeadBacktrack -> Bool
$c== :: TransactionIdHeadBacktrack -> TransactionIdHeadBacktrack -> Bool
Eq, forall x.
Rep TransactionIdHeadBacktrack x -> TransactionIdHeadBacktrack
forall x.
TransactionIdHeadBacktrack -> Rep TransactionIdHeadBacktrack x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep TransactionIdHeadBacktrack x -> TransactionIdHeadBacktrack
$cfrom :: forall x.
TransactionIdHeadBacktrack -> Rep TransactionIdHeadBacktrack x
Generic)
                                  deriving Typeable TransactionIdHeadBacktrack
BundleSerialise TransactionIdHeadBacktrack
Extractor TransactionIdHeadBacktrack
Decoder TransactionIdHeadBacktrack
Proxy TransactionIdHeadBacktrack -> SchemaGen Schema
TransactionIdHeadBacktrack -> Builder
forall a.
Typeable a
-> (Proxy a -> SchemaGen Schema)
-> (a -> Builder)
-> Extractor a
-> Decoder a
-> BundleSerialise a
-> Serialise a
bundleSerialise :: BundleSerialise TransactionIdHeadBacktrack
$cbundleSerialise :: BundleSerialise TransactionIdHeadBacktrack
decodeCurrent :: Decoder TransactionIdHeadBacktrack
$cdecodeCurrent :: Decoder TransactionIdHeadBacktrack
extractor :: Extractor TransactionIdHeadBacktrack
$cextractor :: Extractor TransactionIdHeadBacktrack
toBuilder :: TransactionIdHeadBacktrack -> Builder
$ctoBuilder :: TransactionIdHeadBacktrack -> Builder
schemaGen :: Proxy TransactionIdHeadBacktrack -> SchemaGen Schema
$cschemaGen :: Proxy TransactionIdHeadBacktrack -> SchemaGen Schema
Serialise via WineryVariant TransactionIdHeadBacktrack

  
-- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon.
data TransactionGraphOperator = JumpToHead HeadName  |
                                JumpToTransaction TransactionId |
                                WalkBackToTime UTCTime |
                                Branch HeadName |
                                DeleteBranch HeadName |
                                MergeTransactions MergeStrategy HeadName HeadName |
                                Commit |
                                Rollback
                              deriving (TransactionGraphOperator -> TransactionGraphOperator -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransactionGraphOperator -> TransactionGraphOperator -> Bool
$c/= :: TransactionGraphOperator -> TransactionGraphOperator -> Bool
== :: TransactionGraphOperator -> TransactionGraphOperator -> Bool
$c== :: TransactionGraphOperator -> TransactionGraphOperator -> Bool
Eq, Int -> TransactionGraphOperator -> ShowS
[TransactionGraphOperator] -> ShowS
TransactionGraphOperator -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TransactionGraphOperator] -> ShowS
$cshowList :: [TransactionGraphOperator] -> ShowS
show :: TransactionGraphOperator -> [Char]
$cshow :: TransactionGraphOperator -> [Char]
showsPrec :: Int -> TransactionGraphOperator -> ShowS
$cshowsPrec :: Int -> TransactionGraphOperator -> ShowS
Show, forall x.
Rep TransactionGraphOperator x -> TransactionGraphOperator
forall x.
TransactionGraphOperator -> Rep TransactionGraphOperator x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep TransactionGraphOperator x -> TransactionGraphOperator
$cfrom :: forall x.
TransactionGraphOperator -> Rep TransactionGraphOperator x
Generic)
                              deriving Typeable TransactionGraphOperator
BundleSerialise TransactionGraphOperator
Extractor TransactionGraphOperator
Decoder TransactionGraphOperator
Proxy TransactionGraphOperator -> SchemaGen Schema
TransactionGraphOperator -> Builder
forall a.
Typeable a
-> (Proxy a -> SchemaGen Schema)
-> (a -> Builder)
-> Extractor a
-> Decoder a
-> BundleSerialise a
-> Serialise a
bundleSerialise :: BundleSerialise TransactionGraphOperator
$cbundleSerialise :: BundleSerialise TransactionGraphOperator
decodeCurrent :: Decoder TransactionGraphOperator
$cdecodeCurrent :: Decoder TransactionGraphOperator
extractor :: Extractor TransactionGraphOperator
$cextractor :: Extractor TransactionGraphOperator
toBuilder :: TransactionGraphOperator -> Builder
$ctoBuilder :: TransactionGraphOperator -> Builder
schemaGen :: Proxy TransactionGraphOperator -> SchemaGen Schema
$cschemaGen :: Proxy TransactionGraphOperator -> SchemaGen Schema
Serialise via WineryVariant TransactionGraphOperator
                                       
isCommit :: TransactionGraphOperator -> Bool                                       
isCommit :: TransactionGraphOperator -> Bool
isCommit TransactionGraphOperator
Commit = Bool
True
isCommit TransactionGraphOperator
_ = Bool
False
                                       
data ROTransactionGraphOperator = ShowGraph | ValidateMerkleHashes
                                  deriving Int -> ROTransactionGraphOperator -> ShowS
[ROTransactionGraphOperator] -> ShowS
ROTransactionGraphOperator -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ROTransactionGraphOperator] -> ShowS
$cshowList :: [ROTransactionGraphOperator] -> ShowS
show :: ROTransactionGraphOperator -> [Char]
$cshow :: ROTransactionGraphOperator -> [Char]
showsPrec :: Int -> ROTransactionGraphOperator -> ShowS
$cshowsPrec :: Int -> ROTransactionGraphOperator -> ShowS
Show

bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph
bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph
bootstrapTransactionGraph UTCTime
stamp' TransactionId
freshId DatabaseContext
context = TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
bootstrapHeads Set Transaction
bootstrapTransactions
  where
    bootstrapHeads :: TransactionHeads
bootstrapHeads = forall k a. k -> a -> Map k a
M.singleton HeadName
"master" Transaction
freshTransaction
    newSchemas :: Schemas
newSchemas = DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
context forall k a. Map k a
M.empty
    freshTransaction :: Transaction
freshTransaction = TransactionId -> UTCTime -> Schemas -> Transaction
fresh TransactionId
freshId UTCTime
stamp' Schemas
newSchemas
    hashedTransaction :: Transaction
hashedTransaction = TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
freshId ((Transaction -> TransactionInfo
transactionInfo Transaction
freshTransaction) { merkleHash :: MerkleHash
merkleHash = Transaction -> TransactionGraph -> MerkleHash
calculateMerkleHash Transaction
freshTransaction TransactionGraph
emptyTransactionGraph }) Schemas
newSchemas
    bootstrapTransactions :: Set Transaction
bootstrapTransactions = forall a. a -> Set a
S.singleton Transaction
hashedTransaction

-- | Create a transaction graph from a context.
freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)
freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)
freshTransactionGraph DatabaseContext
ctx = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  TransactionId
freshId <- IO TransactionId
nextRandom
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph
bootstrapTransactionGraph UTCTime
now TransactionId
freshId DatabaseContext
ctx, TransactionId
freshId)


emptyTransactionGraph :: TransactionGraph
emptyTransactionGraph :: TransactionGraph
emptyTransactionGraph = TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph forall k a. Map k a
M.empty forall a. Set a
S.empty

transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
headName TransactionGraph
graph = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HeadName
headName (TransactionGraph -> TransactionHeads
transactionHeadsForGraph TransactionGraph
graph)

headList :: TransactionGraph -> [(HeadName, TransactionId)]
headList :: TransactionGraph -> [(HeadName, TransactionId)]
headList TransactionGraph
graph = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Transaction -> TransactionId
transactionId) (forall k a. Map k a -> [(k, a)]
M.assocs (TransactionGraph -> TransactionHeads
transactionHeadsForGraph TransactionGraph
graph))

headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
headNameForTransaction Transaction
transaction (TransactionGraph TransactionHeads
heads Set Transaction
_) = if forall k a. Map k a -> Bool
M.null TransactionHeads
matchingTrans then
                                                                  forall a. Maybe a
Nothing
                                                                else
                                                                  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys) TransactionHeads
matchingTrans
  where
    matchingTrans :: TransactionHeads
matchingTrans = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Transaction
transaction forall a. Eq a => a -> a -> Bool
==) TransactionHeads
heads

transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)
transactionsForIds :: Set TransactionId
-> TransactionGraph -> Either RelationalError (Set Transaction)
transactionsForIds Set TransactionId
idSet TransactionGraph
graph =
  forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
S.toList Set TransactionId
idSet) (TransactionId
-> TransactionGraph -> Either RelationalError Transaction
`transactionForId` TransactionGraph
graph)

-- | A root transaction terminates a graph and has no parents.
isRootTransaction :: Transaction -> Bool
isRootTransaction :: Transaction -> Bool
isRootTransaction Transaction
trans = Transaction -> Set TransactionId
parentIds Transaction
trans forall a. Eq a => a -> a -> Bool
== forall a. a -> Set a
S.singleton TransactionId
U.nil

rootTransactions :: TransactionGraph -> S.Set Transaction
rootTransactions :: TransactionGraph -> Set Transaction
rootTransactions TransactionGraph
graph = forall a. (a -> Bool) -> Set a -> Set a
S.filter Transaction -> Bool
isRootTransaction (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph)

-- the first transaction has no parent - all other do have parents- merges have two parents
parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
parentTransactions :: Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
parentTransactions Transaction
trans = Set TransactionId
-> TransactionGraph -> Either RelationalError (Set Transaction)
transactionsForIds (Transaction -> Set TransactionId
parentIds Transaction
trans)

childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
childTransactions :: Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
childTransactions Transaction
trans TransactionGraph
graph = Set TransactionId
-> TransactionGraph -> Either RelationalError (Set Transaction)
transactionsForIds Set TransactionId
childIds TransactionGraph
graph
  where
    childIds :: Set TransactionId
childIds = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Transaction -> TransactionId
transactionId (forall a. (a -> Bool) -> Set a -> Set a
S.filter Transaction -> Bool
filt (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph))
    filt :: Transaction -> Bool
filt Transaction
trans' = forall a. Ord a => a -> Set a -> Bool
S.member (Transaction -> TransactionId
transactionId Transaction
trans) (Transaction -> Set TransactionId
parentIds Transaction
trans')

-- create a new commit and add it to the heads
-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
addBranch :: UTCTime
-> TransactionId
-> HeadName
-> TransactionId
-> TransactionGraph
-> Either RelationalError (Transaction, TransactionGraph)
addBranch UTCTime
stamp' TransactionId
newId HeadName
newBranchName TransactionId
branchPointId TransactionGraph
graph = do
  Transaction
parentTrans <- TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
branchPointId TransactionGraph
graph
  let newTrans :: Transaction
newTrans = TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
newId (TransactionId -> UTCTime -> TransactionInfo
TI.singleParent TransactionId
branchPointId UTCTime
stamp') (Transaction -> Schemas
schemas Transaction
parentTrans)
  HeadName
-> Transaction
-> TransactionGraph
-> Either RelationalError (Transaction, TransactionGraph)
addTransactionToGraph HeadName
newBranchName Transaction
newTrans TransactionGraph
graph

--adds a disconnected transaction to a transaction graph at some head
addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
addDisconnectedTransaction :: UTCTime
-> TransactionId
-> HeadName
-> DisconnectedTransaction
-> TransactionGraph
-> Either RelationalError (Transaction, TransactionGraph)
addDisconnectedTransaction UTCTime
stamp' TransactionId
newId HeadName
headName (DisconnectedTransaction TransactionId
parentId Schemas
schemas' Bool
_) = HeadName
-> Transaction
-> TransactionGraph
-> Either RelationalError (Transaction, TransactionGraph)
addTransactionToGraph HeadName
headName Transaction
newTrans
  where
    newTrans :: Transaction
newTrans = TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
newId TransactionInfo
newTInfo Schemas
schemas'
    newTInfo :: TransactionInfo
newTInfo = TransactionId -> UTCTime -> TransactionInfo
TI.singleParent TransactionId
parentId UTCTime
stamp'

addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
addTransactionToGraph :: HeadName
-> Transaction
-> TransactionGraph
-> Either RelationalError (Transaction, TransactionGraph)
addTransactionToGraph HeadName
headName Transaction
newTrans TransactionGraph
graph = do
  let parentIds' :: Set TransactionId
parentIds' = Transaction -> Set TransactionId
parentIds Transaction
newTrans
      newId :: TransactionId
newId = Transaction -> TransactionId
transactionId Transaction
newTrans
      validateIds :: Set TransactionId -> Either RelationalError [Transaction]
validateIds Set TransactionId
ids = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TransactionId
-> TransactionGraph -> Either RelationalError Transaction
`transactionForId` TransactionGraph
graph) (forall a. Set a -> [a]
S.toList Set TransactionId
ids)
  Set Transaction
childTs <- Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
childTransactions Transaction
newTrans TransactionGraph
graph
  --validate that the parent transactions are in the graph
  [Transaction]
_ <- Set TransactionId -> Either RelationalError [Transaction]
validateIds Set TransactionId
parentIds'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Set a -> Int
S.size Set TransactionId
parentIds' forall a. Ord a => a -> a -> Bool
< Int
1) (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
NewTransactionMissingParentError TransactionId
newId)
  --if the headName already exists, ensure that it refers to a parent
  case HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
headName TransactionGraph
graph of
    Maybe Transaction
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- any headName is OK 
    Just Transaction
trans -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> Set a -> Bool
S.notMember (Transaction -> TransactionId
transactionId Transaction
trans) Set TransactionId
parentIds') (forall a b. a -> Either a b
Left (HeadName -> RelationalError
HeadNameSwitchingHeadProhibitedError HeadName
headName))
  --validate that the transaction has no children
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
S.null Set Transaction
childTs) (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
NewTransactionMayNotHaveChildrenError TransactionId
newId)
  --validate that the trasaction's id is unique
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a b. Either a b -> Bool
isRight (TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
newId TransactionGraph
graph)) (forall a b. a -> Either a b
Left (TransactionId -> RelationalError
TransactionIdInUseError TransactionId
newId))
  --replace all references to UncommittedTransactionMarker to new transaction id
  let newTrans' :: Transaction
newTrans' = Transaction -> Transaction
newTransUncommittedReplace Transaction
newTrans
      --add merkle hash to all new transactions
      hashedTransactionInfo :: TransactionInfo
hashedTransactionInfo = (Transaction -> TransactionInfo
transactionInfo Transaction
newTrans')
                              { merkleHash :: MerkleHash
merkleHash = Transaction -> TransactionGraph -> MerkleHash
calculateMerkleHash Transaction
newTrans' TransactionGraph
graph }
      hashedTrans :: Transaction
hashedTrans = TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction (Transaction -> TransactionId
transactionId Transaction
newTrans') TransactionInfo
hashedTransactionInfo (Transaction -> Schemas
schemas Transaction
newTrans')
      updatedTransSet :: Set Transaction
updatedTransSet = forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
hashedTrans (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph)
      updatedHeads :: TransactionHeads
updatedHeads = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert HeadName
headName Transaction
hashedTrans (TransactionGraph -> TransactionHeads
transactionHeadsForGraph TransactionGraph
graph)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transaction
hashedTrans, TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
updatedHeads Set Transaction
updatedTransSet)

--replace all occurrences of the uncommitted context marker
newTransUncommittedReplace :: Transaction -> Transaction
newTransUncommittedReplace :: Transaction -> Transaction
newTransUncommittedReplace trans :: Transaction
trans@(Transaction TransactionId
tid TransactionInfo
tinfo (Schemas DatabaseContext
ctx Subschemas
sschemas)) =
  TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
tid TransactionInfo
tinfo (DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
fixedContext Subschemas
sschemas)
  where
  uncommittedReplace :: GraphRefTransactionMarker -> GraphRefTransactionMarker
uncommittedReplace GraphRefTransactionMarker
UncommittedContextMarker = TransactionId -> GraphRefTransactionMarker
TransactionMarker TransactionId
tid
  uncommittedReplace GraphRefTransactionMarker
marker = GraphRefTransactionMarker
marker
  relvars :: RelationVariables
relvars = DatabaseContext -> RelationVariables
relationVariables (Transaction -> DatabaseContext
concreteDatabaseContext Transaction
trans)  
  fixedRelvars :: RelationVariables
fixedRelvars = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GraphRefTransactionMarker -> GraphRefTransactionMarker
uncommittedReplace) RelationVariables
relvars
  fixedContext :: DatabaseContext
fixedContext = DatabaseContext
ctx { relationVariables :: RelationVariables
relationVariables = RelationVariables
fixedRelvars }
  


validateGraph :: TransactionGraph -> Maybe [RelationalError]
validateGraph :: TransactionGraph -> Maybe [RelationalError]
validateGraph graph :: TransactionGraph
graph@(TransactionGraph TransactionHeads
_ Set Transaction
transSet) = do
  --check that all transaction ids are unique in the graph
  --FINISH ME!
  --uuids = map transactionId transSet
  --check that all heads appear in the transSet
  --check that all forward and backward links are in place
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Set TransactionId
-> TransactionGraph -> Transaction -> Maybe RelationalError
walkParentTransactions forall a. Set a
S.empty TransactionGraph
graph) (forall a. Set a -> [a]
S.toList Set Transaction
transSet)
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Set TransactionId
-> TransactionGraph -> Transaction -> Maybe RelationalError
walkChildTransactions forall a. Set a
S.empty TransactionGraph
graph) (forall a. Set a -> [a]
S.toList Set Transaction
transSet)

--verify that all parent links exist and that all children exist
--maybe verify that all parents end at transaction id nil and all children end at leaves
walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
walkParentTransactions :: Set TransactionId
-> TransactionGraph -> Transaction -> Maybe RelationalError
walkParentTransactions Set TransactionId
seenTransSet TransactionGraph
graph Transaction
trans =
  let transId :: TransactionId
transId = Transaction -> TransactionId
transactionId Transaction
trans in
  if TransactionId
transId forall a. Eq a => a -> a -> Bool
== TransactionId
U.nil then
    forall a. Maybe a
Nothing
  else if forall a. Ord a => a -> Set a -> Bool
S.member TransactionId
transId Set TransactionId
seenTransSet then
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
TransactionGraphCycleError TransactionId
transId
    else
      let parentTransSetOrError :: Either RelationalError (Set Transaction)
parentTransSetOrError = Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
parentTransactions Transaction
trans TransactionGraph
graph in
      case Either RelationalError (Set Transaction)
parentTransSetOrError of
        Left RelationalError
err -> forall a. a -> Maybe a
Just RelationalError
err
        Right Set Transaction
parentTransSet -> do
          [RelationalError]
walk <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Set TransactionId
-> TransactionGraph -> Transaction -> Maybe RelationalError
walkParentTransactions (forall a. Ord a => a -> Set a -> Set a
S.insert TransactionId
transId Set TransactionId
seenTransSet) TransactionGraph
graph) (forall a. Set a -> [a]
S.toList Set Transaction
parentTransSet)
          case [RelationalError]
walk of
            RelationalError
err:[RelationalError]
_ -> forall a. a -> Maybe a
Just RelationalError
err
            [RelationalError]
_ -> forall a. Maybe a
Nothing

--refactor: needless duplication in these two functions
walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
walkChildTransactions :: Set TransactionId
-> TransactionGraph -> Transaction -> Maybe RelationalError
walkChildTransactions Set TransactionId
seenTransSet TransactionGraph
graph Transaction
trans =
  let transId :: TransactionId
transId = Transaction -> TransactionId
transactionId Transaction
trans in
  if Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
childTransactions Transaction
trans TransactionGraph
graph forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right forall a. Set a
S.empty then
    forall a. Maybe a
Nothing
  else if forall a. Ord a => a -> Set a -> Bool
S.member TransactionId
transId Set TransactionId
seenTransSet then
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
TransactionGraphCycleError TransactionId
transId
    else
     let childTransSetOrError :: Either RelationalError (Set Transaction)
childTransSetOrError = Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
childTransactions Transaction
trans TransactionGraph
graph in
     case Either RelationalError (Set Transaction)
childTransSetOrError of
       Left RelationalError
err -> forall a. a -> Maybe a
Just RelationalError
err
       Right Set Transaction
childTransSet -> do
         [RelationalError]
walk <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Set TransactionId
-> TransactionGraph -> Transaction -> Maybe RelationalError
walkChildTransactions (forall a. Ord a => a -> Set a -> Set a
S.insert TransactionId
transId Set TransactionId
seenTransSet) TransactionGraph
graph) (forall a. Set a -> [a]
S.toList Set Transaction
childTransSet)
         case [RelationalError]
walk of
           RelationalError
err:[RelationalError]
_ -> forall a. a -> Maybe a
Just RelationalError
err
           [RelationalError]
_ -> forall a. Maybe a
Nothing

-- returns the new "current" transaction, updated graph, and tutorial d result
-- the current transaction is not part of the transaction graph until it is committed
evalGraphOp :: UTCTime -> TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

evalGraphOp :: UTCTime
-> TransactionId
-> DisconnectedTransaction
-> TransactionGraph
-> TransactionGraphOperator
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
evalGraphOp UTCTime
_ TransactionId
_ DisconnectedTransaction
_ TransactionGraph
graph (JumpToTransaction TransactionId
jumpId) = case TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
jumpId TransactionGraph
graph of
  Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
  Right Transaction
parentTrans -> forall a b. b -> Either a b
Right (DisconnectedTransaction
newTrans, TransactionGraph
graph)
    where
      newTrans :: DisconnectedTransaction
newTrans = TransactionId -> Schemas -> Bool -> DisconnectedTransaction
DisconnectedTransaction TransactionId
jumpId (Transaction -> Schemas
schemas Transaction
parentTrans) Bool
False

-- switch from one head to another
evalGraphOp UTCTime
_ TransactionId
_ DisconnectedTransaction
_ TransactionGraph
graph (JumpToHead HeadName
headName) =
  case HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
headName TransactionGraph
graph of
    Just Transaction
newHeadTransaction -> let disconnectedTrans :: DisconnectedTransaction
disconnectedTrans = TransactionId -> Schemas -> Bool -> DisconnectedTransaction
DisconnectedTransaction (Transaction -> TransactionId
transactionId Transaction
newHeadTransaction) (Transaction -> Schemas
schemas Transaction
newHeadTransaction) Bool
False in
      forall a b. b -> Either a b
Right (DisconnectedTransaction
disconnectedTrans, TransactionGraph
graph)
    Maybe Transaction
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HeadName -> RelationalError
NoSuchHeadNameError HeadName
headName
    
evalGraphOp UTCTime
_ TransactionId
_ DisconnectedTransaction
discon TransactionGraph
graph (WalkBackToTime UTCTime
backTime) = do
  let startTransId :: TransactionId
startTransId = DisconnectedTransaction -> TransactionId
Discon.parentId DisconnectedTransaction
discon
  TransactionId
jumpDest <- TransactionGraph
-> TransactionId
-> TransactionIdHeadBacktrack
-> Either RelationalError TransactionId
backtrackGraph TransactionGraph
graph TransactionId
startTransId (UTCTime -> TransactionIdHeadBacktrack
TransactionStampHeadBacktrack UTCTime
backTime) 
  case TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
jumpDest TransactionGraph
graph of
    Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
    Right Transaction
trans -> do
      let disconnectedTrans :: DisconnectedTransaction
disconnectedTrans = TransactionId -> Schemas -> DisconnectedTransaction
Discon.freshTransaction (Transaction -> TransactionId
transactionId Transaction
trans) (Transaction -> Schemas
schemas Transaction
trans)
      forall a b. b -> Either a b
Right (DisconnectedTransaction
disconnectedTrans, TransactionGraph
graph)
              
-- add new head pointing to branchPoint
-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
    {-
evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case transactionForId parentId graph of
  Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
  Just parentTrans -> case addBranch newBranchName parentTrans graph of
    Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
    Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
     where
       newDiscon = DisconnectedTransaction (transactionId parentTrans) disconContext
-}

-- create a new commit and add it to the heads
-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
evalGraphOp UTCTime
stamp' TransactionId
newId (DisconnectedTransaction TransactionId
parentId Schemas
schemas' Bool
_) TransactionGraph
graph (Branch HeadName
newBranchName) = do
  let newDiscon :: DisconnectedTransaction
newDiscon = TransactionId -> Schemas -> DisconnectedTransaction
Discon.freshTransaction TransactionId
newId Schemas
schemas'
  case UTCTime
-> TransactionId
-> HeadName
-> TransactionId
-> TransactionGraph
-> Either RelationalError (Transaction, TransactionGraph)
addBranch UTCTime
stamp' TransactionId
newId HeadName
newBranchName TransactionId
parentId TransactionGraph
graph of
    Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
    Right (Transaction
_, TransactionGraph
newGraph) -> forall a b. b -> Either a b
Right (DisconnectedTransaction
newDiscon, TransactionGraph
newGraph)
  
-- add the disconnected transaction to the graph
-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
evalGraphOp UTCTime
stamp' TransactionId
newTransId discon :: DisconnectedTransaction
discon@(DisconnectedTransaction TransactionId
parentId Schemas
schemas' Bool
_) TransactionGraph
graph TransactionGraphOperator
Commit = case TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
parentId TransactionGraph
graph of
  Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
  Right Transaction
parentTransaction -> case Transaction -> TransactionGraph -> Maybe HeadName
headNameForTransaction Transaction
parentTransaction TransactionGraph
graph of
    Maybe HeadName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
TransactionIsNotAHeadError TransactionId
parentId
    Just HeadName
headName -> case Either RelationalError (Transaction, TransactionGraph)
maybeUpdatedGraph of
      Left RelationalError
err-> forall a b. a -> Either a b
Left RelationalError
err
      Right (Transaction
_, TransactionGraph
updatedGraph) -> forall a b. b -> Either a b
Right (DisconnectedTransaction
newDisconnectedTrans, TransactionGraph
updatedGraph)
      where
        newDisconnectedTrans :: DisconnectedTransaction
newDisconnectedTrans = TransactionId -> Schemas -> DisconnectedTransaction
Discon.freshTransaction TransactionId
newTransId Schemas
schemas'
        maybeUpdatedGraph :: Either RelationalError (Transaction, TransactionGraph)
maybeUpdatedGraph = UTCTime
-> TransactionId
-> HeadName
-> DisconnectedTransaction
-> TransactionGraph
-> Either RelationalError (Transaction, TransactionGraph)
addDisconnectedTransaction UTCTime
stamp' TransactionId
newTransId HeadName
headName DisconnectedTransaction
discon TransactionGraph
graph

-- refresh the disconnected transaction, return the same graph
evalGraphOp UTCTime
_ TransactionId
_ (DisconnectedTransaction TransactionId
parentId Schemas
_ Bool
_) TransactionGraph
graph TransactionGraphOperator
Rollback = case TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
parentId TransactionGraph
graph of
  Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
  Right Transaction
parentTransaction -> forall a b. b -> Either a b
Right (DisconnectedTransaction
newDiscon, TransactionGraph
graph)
    where
      newDiscon :: DisconnectedTransaction
newDiscon = TransactionId -> Schemas -> DisconnectedTransaction
Discon.freshTransaction TransactionId
parentId (Transaction -> Schemas
schemas Transaction
parentTransaction)
      
evalGraphOp UTCTime
stamp' TransactionId
newId (DisconnectedTransaction TransactionId
parentId Schemas
_ Bool
_) TransactionGraph
graph (MergeTransactions MergeStrategy
mergeStrategy HeadName
headNameA HeadName
headNameB) = 
  forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
env forall a b. (a -> b) -> a -> b
$ UTCTime
-> TransactionId
-> TransactionId
-> MergeStrategy
-> (HeadName, HeadName)
-> GraphRefRelationalExprM
     (DisconnectedTransaction, TransactionGraph)
mergeTransactions UTCTime
stamp' TransactionId
newId TransactionId
parentId MergeStrategy
mergeStrategy (HeadName
headNameA, HeadName
headNameB)
  where
    env :: GraphRefRelationalExprEnv
env = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv forall a. Maybe a
Nothing TransactionGraph
graph

evalGraphOp UTCTime
_ TransactionId
_ DisconnectedTransaction
discon graph :: TransactionGraph
graph@(TransactionGraph TransactionHeads
graphHeads Set Transaction
transSet) (DeleteBranch HeadName
branchName) = case HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
branchName TransactionGraph
graph of
  Maybe Transaction
Nothing -> forall a b. a -> Either a b
Left (HeadName -> RelationalError
NoSuchHeadNameError HeadName
branchName)
  Just Transaction
_ -> forall a b. b -> Either a b
Right (DisconnectedTransaction
discon, TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph (forall k a. Ord k => k -> Map k a -> Map k a
M.delete HeadName
branchName TransactionHeads
graphHeads) Set Transaction
transSet)

--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
graphAsRelation :: DisconnectedTransaction
-> TransactionGraph -> Either RelationalError Relation
graphAsRelation (DisconnectedTransaction TransactionId
parentId Schemas
_ Bool
_) graph :: TransactionGraph
graph@(TransactionGraph TransactionHeads
_ Set Transaction
transSet) = do
  [[Atom]]
tupleMatrix <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Transaction -> Either RelationalError [Atom]
tupleGenerator (forall a. Set a -> [a]
S.toList Set Transaction
transSet)
  Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
attrs [[Atom]]
tupleMatrix
  where
    attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [HeadName -> AtomType -> Attribute
Attribute HeadName
"id" AtomType
TextAtomType,
                                  HeadName -> AtomType -> Attribute
Attribute HeadName
"hash" AtomType
ByteStringAtomType,
                                  HeadName -> AtomType -> Attribute
Attribute HeadName
"stamp" AtomType
DateTimeAtomType,
                                  HeadName -> AtomType -> Attribute
Attribute HeadName
"parents" (Attributes -> AtomType
RelationAtomType Attributes
parentAttributes),
                                  HeadName -> AtomType -> Attribute
Attribute HeadName
"current" AtomType
BoolAtomType,
                                  HeadName -> AtomType -> Attribute
Attribute HeadName
"head" AtomType
TextAtomType
                                 ]
    parentAttributes :: Attributes
parentAttributes = [Attribute] -> Attributes
A.attributesFromList [HeadName -> AtomType -> Attribute
Attribute HeadName
"id" AtomType
TextAtomType]
    tupleGenerator :: Transaction -> Either RelationalError [Atom]
tupleGenerator Transaction
transaction = case Transaction -> TransactionGraph -> Either RelationalError Relation
transactionParentsRelation Transaction
transaction TransactionGraph
graph of
      Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
      Right Relation
parentTransRel -> forall a b. b -> Either a b
Right [HeadName -> Atom
TextAtom forall a b. (a -> b) -> a -> b
$ [Char] -> HeadName
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (Transaction -> TransactionId
transactionId Transaction
transaction),
                                     ByteString -> Atom
ByteStringAtom forall a b. (a -> b) -> a -> b
$ MerkleHash -> ByteString
_unMerkleHash (TransactionInfo -> MerkleHash
merkleHash (Transaction -> TransactionInfo
transactionInfo Transaction
transaction)),
                                     UTCTime -> Atom
DateTimeAtom (Transaction -> UTCTime
timestamp Transaction
transaction),
                                     Relation -> Atom
RelationAtom Relation
parentTransRel,
                                     Bool -> Atom
BoolAtom forall a b. (a -> b) -> a -> b
$ TransactionId
parentId forall a. Eq a => a -> a -> Bool
== Transaction -> TransactionId
transactionId Transaction
transaction,
                                     HeadName -> Atom
TextAtom forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe HeadName
"" (Transaction -> TransactionGraph -> Maybe HeadName
headNameForTransaction Transaction
transaction TransactionGraph
graph)
                                      ]

transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
transactionParentsRelation Transaction
trans TransactionGraph
graph = 
  if Transaction -> Bool
isRootTransaction Transaction
trans then    
    Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attrs RelationTupleSet
emptyTupleSet
    else do
      Set Transaction
parentTransSet <- Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
parentTransactions Transaction
trans TransactionGraph
graph
      let tuples :: [RelationTuple]
tuples = forall a b. (a -> b) -> [a] -> [b]
map Transaction -> RelationTuple
trans2tuple (forall a. Set a -> [a]
S.toList Set Transaction
parentTransSet)
      Attributes -> [RelationTuple] -> Either RelationalError Relation
mkRelationFromTuples Attributes
attrs [RelationTuple]
tuples
  where
    attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [HeadName -> AtomType -> Attribute
Attribute HeadName
"id" AtomType
TextAtomType]
    trans2tuple :: Transaction -> RelationTuple
trans2tuple Transaction
trans2 = Attributes -> Vector Atom -> RelationTuple
mkRelationTuple Attributes
attrs forall a b. (a -> b) -> a -> b
$ forall a. a -> Vector a
V.singleton (HeadName -> Atom
TextAtom ([Char] -> HeadName
T.pack (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Transaction -> TransactionId
transactionId Transaction
trans2)))

{-
--display transaction graph as relation
evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
evalROGraphOp discon graph ShowGraph = do
  graphRel <- graphAsRelation discon graph
  return graphRel
-}

-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
createMergeTransaction :: UTCTime
-> TransactionId
-> MergeStrategy
-> (Transaction, Transaction)
-> GraphRefRelationalExprM Transaction
createMergeTransaction UTCTime
stamp' TransactionId
newId (SelectedBranchMergeStrategy HeadName
selectedBranch) t2 :: (Transaction, Transaction)
t2@(Transaction
trans1, Transaction
trans2) = do
  TransactionGraph
graph <- GraphRefRelationalExprM TransactionGraph
gfGraph
  Transaction
selectedTrans <- HeadName
-> TransactionGraph
-> (Transaction, Transaction)
-> GraphRefRelationalExprM Transaction
validateHeadName HeadName
selectedBranch TransactionGraph
graph (Transaction, Transaction)
t2
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Transaction -> Transaction
addMerkleHash TransactionGraph
graph forall a b. (a -> b) -> a -> b
$
    TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
newId (TransactionInfo {
                          parents :: TransactionParents
parents = forall a. [a] -> NonEmpty a
NE.fromList [Transaction -> TransactionId
transactionId Transaction
trans1,
                                                 Transaction -> TransactionId
transactionId Transaction
trans2],
                          stamp :: UTCTime
stamp = UTCTime
stamp',
                          merkleHash :: MerkleHash
merkleHash = forall a. Monoid a => a
mempty }) (Transaction -> Schemas
schemas Transaction
selectedTrans)
                       
-- merge functions, relvars, individually
createMergeTransaction UTCTime
stamp' TransactionId
newId strat :: MergeStrategy
strat@MergeStrategy
UnionMergeStrategy (Transaction, Transaction)
t2 =
  UTCTime
-> TransactionId
-> MergeStrategy
-> (Transaction, Transaction)
-> GraphRefRelationalExprM Transaction
createUnionMergeTransaction UTCTime
stamp' TransactionId
newId MergeStrategy
strat (Transaction, Transaction)
t2

-- merge function, relvars, but, on error, just take the component from the preferred branch
createMergeTransaction UTCTime
stamp' TransactionId
newId strat :: MergeStrategy
strat@(UnionPreferMergeStrategy HeadName
_) (Transaction, Transaction)
t2 =
  UTCTime
-> TransactionId
-> MergeStrategy
-> (Transaction, Transaction)
-> GraphRefRelationalExprM Transaction
createUnionMergeTransaction UTCTime
stamp' TransactionId
newId MergeStrategy
strat (Transaction, Transaction)
t2

-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.
validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
validateHeadName :: HeadName
-> TransactionGraph
-> (Transaction, Transaction)
-> GraphRefRelationalExprM Transaction
validateHeadName HeadName
headName TransactionGraph
graph (Transaction
t1, Transaction
t2) =
  case HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
headName TransactionGraph
graph of
    Maybe Transaction
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError MergeError
SelectedHeadMismatchMergeError)
    Just Transaction
trans -> if Transaction
trans forall a. Eq a => a -> a -> Bool
/= Transaction
t1 Bool -> Bool -> Bool
&& Transaction
trans forall a. Eq a => a -> a -> Bool
/= Transaction
t2 then 
                    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError MergeError
SelectedHeadMismatchMergeError)
                  else
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure Transaction
trans
  
-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal. The subgraph must also include any transactions which are referenced by other transactions.
subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
subGraphOfFirstCommonAncestor :: TransactionGraph
-> TransactionHeads
-> Transaction
-> Transaction
-> Set Transaction
-> Either RelationalError TransactionGraph
subGraphOfFirstCommonAncestor TransactionGraph
origGraph TransactionHeads
resultHeads Transaction
currentTrans' Transaction
goalTrans Set Transaction
traverseSet = do
  let currentid :: TransactionId
currentid = Transaction -> TransactionId
transactionId Transaction
currentTrans'
      goalid :: TransactionId
goalid = Transaction -> TransactionId
transactionId Transaction
goalTrans
  if Transaction
currentTrans' forall a. Eq a => a -> a -> Bool
== Transaction
goalTrans then
    forall a b. b -> Either a b
Right (TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
resultHeads Set Transaction
traverseSet) -- add filter
    --catch root transaction to improve error?
    else do
    Set Transaction
currentTransChildren <- Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
childTransactions Transaction
currentTrans' TransactionGraph
origGraph
    let searchChildren :: Set Transaction
searchChildren = forall a. Ord a => Set a -> Set a -> Set a
S.difference (forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
currentTrans' Set Transaction
traverseSet) Set Transaction
currentTransChildren
        searchChild :: Transaction -> Either RelationalError (Set Transaction)
searchChild Transaction
start' = TransactionGraph
-> Transaction
-> Transaction
-> Set Transaction
-> Either RelationalError (Set Transaction)
pathToTransaction TransactionGraph
origGraph Transaction
start' Transaction
goalTrans (forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
currentTrans' Set Transaction
traverseSet)
        childSearches :: [Either RelationalError (Set Transaction)]
childSearches = forall a b. (a -> b) -> [a] -> [b]
map Transaction -> Either RelationalError (Set Transaction)
searchChild (forall a. Set a -> [a]
S.toList Set Transaction
searchChildren)
        errors :: [RelationalError]
errors = forall a b. [Either a b] -> [a]
lefts [Either RelationalError (Set Transaction)]
childSearches
        pathsFound :: [Set Transaction]
pathsFound = forall a b. [Either a b] -> [b]
rights [Either RelationalError (Set Transaction)]
childSearches
        realErrors :: [RelationalError]
realErrors = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= TransactionId -> RelationalError
FailedToFindTransactionError TransactionId
goalid) [RelationalError]
errors
    -- report any non-search-related errors        
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RelationalError]
realErrors) (forall a b. a -> Either a b
Left (forall a. [a] -> a
head [RelationalError]
realErrors))
    -- if no paths found, search the parent
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Transaction]
pathsFound then
      case Transaction -> Either RelationalError Transaction
oneParent Transaction
currentTrans' of
        Left RelationalError
RootTransactionTraversalError -> forall a b. a -> Either a b
Left (TransactionId -> TransactionId -> RelationalError
NoCommonTransactionAncestorError TransactionId
currentid TransactionId
goalid)
        Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
        Right Transaction
currentTransParent ->
          TransactionGraph
-> TransactionHeads
-> Transaction
-> Transaction
-> Set Transaction
-> Either RelationalError TransactionGraph
subGraphOfFirstCommonAncestor TransactionGraph
origGraph TransactionHeads
resultHeads Transaction
currentTransParent Transaction
goalTrans (forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
currentTrans' Set Transaction
traverseSet)
      else do -- we found a path
        -- we union all the relevant path transactions together, but we are missing any transactions which these transaction may reference. To make a valid transaction graph, we must include these referenced transactions.
        let openSet :: Set Transaction
openSet = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (Set Transaction
traverseSet forall a. a -> [a] -> [a]
: [Set Transaction]
pathsFound)
            transactionIncluder :: Set Transaction
-> Transaction -> Either RelationalError (Set Transaction)
transactionIncluder Set Transaction
acc Transaction
trans = do
              Set Transaction
allTrans <- Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
referencedTransactionIdsForTransaction Transaction
trans TransactionGraph
origGraph
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
S.union Set Transaction
allTrans Set Transaction
acc
        Set Transaction
closedTransactionSet <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Set Transaction
-> Transaction -> Either RelationalError (Set Transaction)
transactionIncluder forall a. Monoid a => a
mempty (forall a. Set a -> [a]
S.toList Set Transaction
openSet)
        forall a b. b -> Either a b
Right (TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
resultHeads Set Transaction
closedTransactionSet)
  where
    oneParent :: Transaction -> Either RelationalError Transaction
oneParent (Transaction TransactionId
_ TransactionInfo
tinfo Schemas
_) = TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId (forall a. NonEmpty a -> a
NE.head (TransactionInfo -> TransactionParents
parents TransactionInfo
tinfo)) TransactionGraph
origGraph
    
-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
pathToTransaction :: TransactionGraph
-> Transaction
-> Transaction
-> Set Transaction
-> Either RelationalError (Set Transaction)
pathToTransaction TransactionGraph
graph Transaction
currentTransaction Transaction
targetTransaction Set Transaction
accumTransSet = do
  let targetId :: TransactionId
targetId = Transaction -> TransactionId
transactionId Transaction
targetTransaction
  if Transaction -> TransactionId
transactionId Transaction
targetTransaction forall a. Eq a => a -> a -> Bool
== Transaction -> TransactionId
transactionId Transaction
currentTransaction then
    forall a b. b -> Either a b
Right Set Transaction
accumTransSet
    else do
    Set Transaction
currentTransChildren <- Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
childTransactions Transaction
currentTransaction TransactionGraph
graph
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Transaction
currentTransChildren then
      forall a b. a -> Either a b
Left (TransactionId -> RelationalError
FailedToFindTransactionError TransactionId
targetId)
      else do
      let searches :: [Either RelationalError (Set Transaction)]
searches = forall a b. (a -> b) -> [a] -> [b]
map (\Transaction
t -> TransactionGraph
-> Transaction
-> Transaction
-> Set Transaction
-> Either RelationalError (Set Transaction)
pathToTransaction TransactionGraph
graph Transaction
t Transaction
targetTransaction (forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
t Set Transaction
accumTransSet)) (forall a. Set a -> [a]
S.toList Set Transaction
currentTransChildren)
      let realErrors :: [RelationalError]
realErrors = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= TransactionId -> RelationalError
FailedToFindTransactionError TransactionId
targetId) (forall a b. [Either a b] -> [a]
lefts [Either RelationalError (Set Transaction)]
searches)
          paths :: [Set Transaction]
paths = forall a b. [Either a b] -> [b]
rights [Either RelationalError (Set Transaction)]
searches
      if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RelationalError]
realErrors) then -- found some real errors
        forall a b. a -> Either a b
Left (forall a. [a] -> a
head [RelationalError]
realErrors)
      else if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Transaction]
paths then -- failed to find transaction in all children
             forall a b. a -> Either a b
Left (TransactionId -> RelationalError
FailedToFindTransactionError TransactionId
targetId)
           else --we have some paths!
             forall a b. b -> Either a b
Right (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Transaction]
paths)

mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> GraphRefRelationalExprM (DisconnectedTransaction, TransactionGraph)
mergeTransactions :: UTCTime
-> TransactionId
-> TransactionId
-> MergeStrategy
-> (HeadName, HeadName)
-> GraphRefRelationalExprM
     (DisconnectedTransaction, TransactionGraph)
mergeTransactions UTCTime
stamp' TransactionId
newId TransactionId
parentId MergeStrategy
mergeStrategy (HeadName
headNameA, HeadName
headNameB) = do
  TransactionGraph
graph <- GraphRefRelationalExprM TransactionGraph
gfGraph
  let transactionForHeadErr :: HeadName -> m Transaction
transactionForHeadErr HeadName
name = case HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
name TransactionGraph
graph of
        Maybe Transaction
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HeadName -> RelationalError
NoSuchHeadNameError HeadName
name)
        Just Transaction
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Transaction
t
      runE :: Either e a -> m a
runE Either e a
e = case Either e a
e of
        Left e
e' -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e'
        Right a
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
  Transaction
transA <- forall {m :: * -> *}.
MonadError RelationalError m =>
HeadName -> m Transaction
transactionForHeadErr HeadName
headNameA
  Transaction
transB <- forall {m :: * -> *}.
MonadError RelationalError m =>
HeadName -> m Transaction
transactionForHeadErr HeadName
headNameB
  Transaction
disconParent <- TransactionId -> GraphRefRelationalExprM Transaction
gfTransForId TransactionId
parentId
  let subHeads :: TransactionHeads
subHeads = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\HeadName
k Transaction
_ -> HeadName
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HeadName
headNameA, HeadName
headNameB]) (TransactionGraph -> TransactionHeads
transactionHeadsForGraph TransactionGraph
graph)
  -- is this an optimization???
  TransactionGraph
subGraph <- forall {e} {m :: * -> *} {a}. MonadError e m => Either e a -> m a
runE forall a b. (a -> b) -> a -> b
$ TransactionGraph
-> TransactionHeads
-> Transaction
-> Transaction
-> Set Transaction
-> Either RelationalError TransactionGraph
subGraphOfFirstCommonAncestor TransactionGraph
graph TransactionHeads
subHeads Transaction
transA Transaction
transB forall a. Set a
S.empty
  TransactionGraph
_ <- forall {e} {m :: * -> *} {a}. MonadError e m => Either e a -> m a
runE forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Either RelationalError TransactionGraph
validateConnectivity TransactionGraph
subGraph

  TransactionGraph
subGraph' <- forall {e} {m :: * -> *} {a}. MonadError e m => Either e a -> m a
runE forall a b. (a -> b) -> a -> b
$ TransactionGraph
-> TransactionHeads -> Either RelationalError TransactionGraph
filterSubGraph TransactionGraph
subGraph TransactionHeads
subHeads
  -- we cannot cut the transaction graph away only to "relevant" transactions because transactions can reference other transactions via relvar expressions
  Transaction
mergedTrans <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a b. a -> b -> a
const (Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv forall a. Maybe a
Nothing TransactionGraph
subGraph')) forall a b. (a -> b) -> a -> b
$
                 UTCTime
-> TransactionId
-> MergeStrategy
-> (Transaction, Transaction)
-> GraphRefRelationalExprM Transaction
createMergeTransaction UTCTime
stamp' TransactionId
newId MergeStrategy
mergeStrategy (Transaction
transA, Transaction
transB)
  case Transaction -> TransactionGraph -> Maybe HeadName
headNameForTransaction Transaction
disconParent TransactionGraph
graph of
        Maybe HeadName
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TransactionId -> RelationalError
TransactionIsNotAHeadError TransactionId
parentId)
        Just HeadName
headName -> do
          (Transaction
newTrans, TransactionGraph
newGraph) <- forall {e} {m :: * -> *} {a}. MonadError e m => Either e a -> m a
runE forall a b. (a -> b) -> a -> b
$ HeadName
-> Transaction
-> TransactionGraph
-> Either RelationalError (Transaction, TransactionGraph)
addTransactionToGraph HeadName
headName Transaction
mergedTrans TransactionGraph
graph
          case DatabaseContext
-> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints (Transaction -> DatabaseContext
concreteDatabaseContext Transaction
mergedTrans) TransactionId
newId TransactionGraph
graph of
            Left RelationalError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
            Right ()
_ -> do
              let newGraph' :: TransactionGraph
newGraph' = TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph (TransactionGraph -> TransactionHeads
transactionHeadsForGraph TransactionGraph
newGraph) (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
newGraph)
                  newDiscon :: DisconnectedTransaction
newDiscon = TransactionId -> Schemas -> DisconnectedTransaction
Discon.freshTransaction TransactionId
newId (Transaction -> Schemas
schemas Transaction
newTrans)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (DisconnectedTransaction
newDiscon, TransactionGraph
newGraph')
  
--TEMPORARY COPY/PASTE  
showTransactionStructureX :: Bool -> Transaction -> TransactionGraph -> String
showTransactionStructureX :: Bool -> Transaction -> TransactionGraph -> [Char]
showTransactionStructureX Bool
showRelVars Transaction
trans TransactionGraph
graph = [Char]
headInfo forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Transaction -> TransactionId
transactionId Transaction
trans) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
parentTransactionsInfo forall a. [a] -> [a] -> [a]
++ [Char]
relVarsInfo
  where
    relVarsInfo :: [Char]
relVarsInfo | Bool -> Bool
not Bool
showRelVars = [Char]
""
                | Bool
otherwise = [Char]
"\n" forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Show a => a -> [Char]
show (forall k a. Map k a -> [(k, a)]
M.toList (DatabaseContext -> RelationVariables
relationVariables (Transaction -> DatabaseContext
concreteDatabaseContext Transaction
trans)))
    headInfo :: [Char]
headInfo = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" forall a. Show a => a -> [Char]
show (Transaction -> TransactionGraph -> Maybe HeadName
headNameForTransaction Transaction
trans TransactionGraph
graph)
    parentTransactionsInfo :: [Char]
parentTransactionsInfo = if Transaction -> Bool
isRootTransaction Transaction
trans then [Char]
"root" else case Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
parentTransactions Transaction
trans TransactionGraph
graph of
      Left RelationalError
err -> forall a. Show a => a -> [Char]
show RelationalError
err
      Right Set Transaction
parentTransSet -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction -> TransactionId
transactionId) Set Transaction
parentTransSet
  
showGraphStructureX :: Bool -> TransactionGraph -> String
showGraphStructureX :: Bool -> TransactionGraph -> [Char]
showGraphStructureX Bool
showRelVars graph :: TransactionGraph
graph@(TransactionGraph TransactionHeads
heads Set Transaction
transSet) = [Char]
headsInfo forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr Transaction -> ShowS
folder [Char]
"" Set Transaction
transSet
  where
    folder :: Transaction -> ShowS
folder Transaction
trans [Char]
acc = [Char]
acc forall a. [a] -> [a] -> [a]
++ Bool -> Transaction -> TransactionGraph -> [Char]
showTransactionStructureX Bool
showRelVars Transaction
trans TransactionGraph
graph forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    headsInfo :: [Char]
headsInfo = forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
M.map Transaction -> TransactionId
transactionId TransactionHeads
heads
    
-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
filterSubGraph :: TransactionGraph
-> TransactionHeads -> Either RelationalError TransactionGraph
filterSubGraph TransactionGraph
graph TransactionHeads
heads = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
newHeads Set Transaction
newTransSet
  where
    validIds :: Set TransactionId
validIds = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Transaction -> TransactionId
transactionId (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph)
    newTransSet :: Set Transaction
newTransSet = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (Set TransactionId -> Transaction -> Transaction
filterTransaction Set TransactionId
validIds) (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph)
    newHeads :: TransactionHeads
newHeads = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Set TransactionId -> Transaction -> Transaction
filterTransaction Set TransactionId
validIds) TransactionHeads
heads
    
--helper function for commonalities in union merge
createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
createUnionMergeTransaction :: UTCTime
-> TransactionId
-> MergeStrategy
-> (Transaction, Transaction)
-> GraphRefRelationalExprM Transaction
createUnionMergeTransaction UTCTime
stamp' TransactionId
newId MergeStrategy
strategy (Transaction
t1,Transaction
t2) = do
  let contextA :: DatabaseContext
contextA = Transaction -> DatabaseContext
concreteDatabaseContext Transaction
t1
      contextB :: DatabaseContext
contextB = Transaction -> DatabaseContext
concreteDatabaseContext Transaction
t2
      liftMergeE :: Either MergeError a -> m a
liftMergeE Either MergeError a
x = case Either MergeError a
x of
        Left MergeError
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError MergeError
e)
        Right a
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
t
        
  TransactionGraph
graph <- GraphRefRelationalExprM TransactionGraph
gfGraph
  MergePreference
preference <- case MergeStrategy
strategy of 
    MergeStrategy
UnionMergeStrategy -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MergePreference
PreferNeither
    UnionPreferMergeStrategy HeadName
preferBranch ->
      case HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
preferBranch TransactionGraph
graph of
        Maybe Transaction
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError (HeadName -> MergeError
PreferredHeadMissingMergeError HeadName
preferBranch))
        Just Transaction
preferredTrans -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Transaction
t1 forall a. Eq a => a -> a -> Bool
== Transaction
preferredTrans then MergePreference
PreferFirst else MergePreference
PreferSecond
    MergeStrategy
badStrat -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError (MergeStrategy -> MergeError
InvalidMergeStrategyError MergeStrategy
badStrat))
          
  Map HeadName InclusionDependency
incDeps <- forall {m :: * -> *} {a}.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE forall a b. (a -> b) -> a -> b
$ forall k a.
(Ord k, Eq a) =>
MergePreference
-> Map k a -> Map k a -> Either MergeError (Map k a)
unionMergeMaps MergePreference
preference (DatabaseContext -> Map HeadName InclusionDependency
inclusionDependencies DatabaseContext
contextA) (DatabaseContext -> Map HeadName InclusionDependency
inclusionDependencies DatabaseContext
contextB)
  RelationVariables
relVars <- MergePreference
-> RelationVariables
-> RelationVariables
-> GraphRefRelationalExprM RelationVariables
unionMergeRelVars MergePreference
preference (DatabaseContext -> RelationVariables
relationVariables DatabaseContext
contextA) (DatabaseContext -> RelationVariables
relationVariables DatabaseContext
contextB)
  AtomFunctions
atomFuncs <- forall {m :: * -> *} {a}.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE forall a b. (a -> b) -> a -> b
$ MergePreference
-> AtomFunctions
-> AtomFunctions
-> Either MergeError AtomFunctions
unionMergeAtomFunctions MergePreference
preference (DatabaseContext -> AtomFunctions
atomFunctions DatabaseContext
contextA) (DatabaseContext -> AtomFunctions
atomFunctions DatabaseContext
contextB)
  Map HeadName Notification
notifs <- forall {m :: * -> *} {a}.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE forall a b. (a -> b) -> a -> b
$ forall k a.
(Ord k, Eq a) =>
MergePreference
-> Map k a -> Map k a -> Either MergeError (Map k a)
unionMergeMaps MergePreference
preference (DatabaseContext -> Map HeadName Notification
notifications DatabaseContext
contextA) (DatabaseContext -> Map HeadName Notification
notifications DatabaseContext
contextB)
  TypeConstructorMapping
types <- forall {m :: * -> *} {a}.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE forall a b. (a -> b) -> a -> b
$ MergePreference
-> TypeConstructorMapping
-> TypeConstructorMapping
-> Either MergeError TypeConstructorMapping
unionMergeTypeConstructorMapping MergePreference
preference (DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
contextA) (DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
contextB)
  DatabaseContextFunctions
dbcFuncs <- forall {m :: * -> *} {a}.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE forall a b. (a -> b) -> a -> b
$ MergePreference
-> DatabaseContextFunctions
-> DatabaseContextFunctions
-> Either MergeError DatabaseContextFunctions
unionMergeDatabaseContextFunctions MergePreference
preference (DatabaseContext -> DatabaseContextFunctions
dbcFunctions DatabaseContext
contextA) (DatabaseContext -> DatabaseContextFunctions
dbcFunctions DatabaseContext
contextB)
  RegisteredQueries
registeredQs <- forall {m :: * -> *} {a}.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE forall a b. (a -> b) -> a -> b
$ MergePreference
-> RegisteredQueries
-> RegisteredQueries
-> Either MergeError RegisteredQueries
unionMergeRegisteredQueries MergePreference
preference (DatabaseContext -> RegisteredQueries
registeredQueries DatabaseContext
contextA) (DatabaseContext -> RegisteredQueries
registeredQueries DatabaseContext
contextB)
  -- TODO: add merge of subschemas
  let newContext :: DatabaseContext
newContext = DatabaseContext {
        inclusionDependencies :: Map HeadName InclusionDependency
inclusionDependencies = Map HeadName InclusionDependency
incDeps, 
        relationVariables :: RelationVariables
relationVariables = RelationVariables
relVars, 
        atomFunctions :: AtomFunctions
atomFunctions = AtomFunctions
atomFuncs,
        dbcFunctions :: DatabaseContextFunctions
dbcFunctions = DatabaseContextFunctions
dbcFuncs,
        notifications :: Map HeadName Notification
notifications = Map HeadName Notification
notifs,
        typeConstructorMapping :: TypeConstructorMapping
typeConstructorMapping = TypeConstructorMapping
types,
        registeredQueries :: RegisteredQueries
registeredQueries = RegisteredQueries
registeredQs
        }
      newSchemas :: Schemas
newSchemas = DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
newContext (Transaction -> Subschemas
subschemas Transaction
t1)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Transaction -> Transaction
addMerkleHash TransactionGraph
graph forall a b. (a -> b) -> a -> b
$
    TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
newId (TransactionInfo {
                          parents :: TransactionParents
parents = forall a. [a] -> NonEmpty a
NE.fromList [Transaction -> TransactionId
transactionId Transaction
t1,
                                                  Transaction -> TransactionId
transactionId Transaction
t2],
                            stamp :: UTCTime
stamp = UTCTime
stamp',
                            merkleHash :: MerkleHash
merkleHash = forall a. Monoid a => a
mempty }) Schemas
newSchemas

lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
lookupTransaction :: TransactionGraph
-> TransactionIdLookup -> Either RelationalError Transaction
lookupTransaction TransactionGraph
graph (TransactionIdLookup TransactionId
tid) = TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
tid TransactionGraph
graph
lookupTransaction TransactionGraph
graph (TransactionIdHeadNameLookup HeadName
headName [TransactionIdHeadBacktrack]
backtracks) = case HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
headName TransactionGraph
graph of 
  Maybe Transaction
Nothing -> forall a b. a -> Either a b
Left (HeadName -> RelationalError
NoSuchHeadNameError HeadName
headName)
  Just Transaction
headTrans -> do
    TransactionId
traversedId <- TransactionGraph
-> TransactionId
-> [TransactionIdHeadBacktrack]
-> Either RelationalError TransactionId
traverseGraph TransactionGraph
graph (Transaction -> TransactionId
transactionId Transaction
headTrans) [TransactionIdHeadBacktrack]
backtracks
    TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
traversedId TransactionGraph
graph
    
traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId
traverseGraph :: TransactionGraph
-> TransactionId
-> [TransactionIdHeadBacktrack]
-> Either RelationalError TransactionId
traverseGraph TransactionGraph
graph = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (TransactionGraph
-> TransactionId
-> TransactionIdHeadBacktrack
-> Either RelationalError TransactionId
backtrackGraph TransactionGraph
graph)
             
backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId
-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily
backtrackGraph :: TransactionGraph
-> TransactionId
-> TransactionIdHeadBacktrack
-> Either RelationalError TransactionId
backtrackGraph TransactionGraph
graph TransactionId
currentTid (TransactionIdHeadParentBacktrack Int
steps) = do
  Transaction
trans <- TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
currentTid TransactionGraph
graph

  let parentIds' :: [TransactionId]
parentIds' = forall a. Set a -> [a]
S.toAscList (Transaction -> Set TransactionId
parentIds Transaction
trans)
  case [TransactionId]
parentIds' of
    [] -> forall a b. a -> Either a b
Left RelationalError
RootTransactionTraversalError
    TransactionId
firstParentId:[TransactionId]
_ -> do
      Transaction
parentTrans <- TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
firstParentId TransactionGraph
graph
      if Int
steps forall a. Eq a => a -> a -> Bool
== Int
1 then
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transaction -> TransactionId
transactionId Transaction
parentTrans)
        else
        TransactionGraph
-> TransactionId
-> TransactionIdHeadBacktrack
-> Either RelationalError TransactionId
backtrackGraph TransactionGraph
graph (Transaction -> TransactionId
transactionId Transaction
parentTrans) (Int -> TransactionIdHeadBacktrack
TransactionIdHeadParentBacktrack (Int
steps forall a. Num a => a -> a -> a
- Int
1))
  
backtrackGraph TransactionGraph
graph TransactionId
currentTid (TransactionIdHeadBranchBacktrack Int
steps) = do
  Transaction
trans <- TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
currentTid TransactionGraph
graph
  let parentIds' :: Set TransactionId
parentIds' = Transaction -> Set TransactionId
parentIds Transaction
trans
  if forall a. Set a -> Int
S.size Set TransactionId
parentIds' forall a. Ord a => a -> a -> Bool
< Int
1 then
    forall a b. a -> Either a b
Left RelationalError
RootTransactionTraversalError    
    else if forall a. Set a -> Int
S.size Set TransactionId
parentIds' forall a. Ord a => a -> a -> Bool
< Int
steps then
           forall a b. a -> Either a b
Left (Int -> Int -> RelationalError
ParentCountTraversalError (forall a. Set a -> Int
S.size Set TransactionId
parentIds') Int
steps)
         else
           forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Int -> Set a -> a
S.elemAt (Int
steps forall a. Num a => a -> a -> a
- Int
1) Set TransactionId
parentIds')
           
backtrackGraph TransactionGraph
graph TransactionId
currentTid btrack :: TransactionIdHeadBacktrack
btrack@(TransactionStampHeadBacktrack UTCTime
stamp') = do           
  Transaction
trans <- TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
currentTid TransactionGraph
graph
  let parentIds' :: Set TransactionId
parentIds' = Transaction -> Set TransactionId
parentIds Transaction
trans  
  if Transaction -> UTCTime
timestamp Transaction
trans forall a. Ord a => a -> a -> Bool
<= UTCTime
stamp' then
    forall (f :: * -> *) a. Applicative f => a -> f a
pure TransactionId
currentTid
    else if forall a. Set a -> Bool
S.null Set TransactionId
parentIds' then
           forall a b. a -> Either a b
Left RelationalError
RootTransactionTraversalError
         else
           let arbitraryParent :: TransactionId
arbitraryParent = forall a. [a] -> a
head (forall a. Set a -> [a]
S.toList Set TransactionId
parentIds') in
           TransactionGraph
-> TransactionId
-> TransactionIdHeadBacktrack
-> Either RelationalError TransactionId
backtrackGraph TransactionGraph
graph TransactionId
arbitraryParent TransactionIdHeadBacktrack
btrack
    
-- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError.
--this is not a GraphOp because it combines multiple graph operations
autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
autoMergeToHead :: UTCTime
-> (TransactionId, TransactionId, TransactionId)
-> DisconnectedTransaction
-> HeadName
-> MergeStrategy
-> TransactionGraph
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
autoMergeToHead UTCTime
stamp' (TransactionId
tempBranchTransId, TransactionId
tempCommitTransId, TransactionId
mergeTransId) DisconnectedTransaction
discon HeadName
mergeToHeadName MergeStrategy
strat TransactionGraph
graph = do
  let tempBranchName :: HeadName
tempBranchName = HeadName
"mergebranch_" forall a. Semigroup a => a -> a -> a
<> TransactionId -> HeadName
U.toText TransactionId
tempBranchTransId
  --create the temp branch
  (DisconnectedTransaction
discon', TransactionGraph
graph') <- UTCTime
-> TransactionId
-> DisconnectedTransaction
-> TransactionGraph
-> TransactionGraphOperator
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
evalGraphOp UTCTime
stamp' TransactionId
tempBranchTransId DisconnectedTransaction
discon TransactionGraph
graph (HeadName -> TransactionGraphOperator
Branch HeadName
tempBranchName)
  
  --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type
  (DisconnectedTransaction
discon'', TransactionGraph
graph'') <- UTCTime
-> TransactionId
-> DisconnectedTransaction
-> TransactionGraph
-> TransactionGraphOperator
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
evalGraphOp UTCTime
stamp' TransactionId
tempCommitTransId DisconnectedTransaction
discon' TransactionGraph
graph' TransactionGraphOperator
Commit
 
  --jump to merge head
  (DisconnectedTransaction
discon''', TransactionGraph
graph''') <- UTCTime
-> TransactionId
-> DisconnectedTransaction
-> TransactionGraph
-> TransactionGraphOperator
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
evalGraphOp UTCTime
stamp' TransactionId
tempBranchTransId DisconnectedTransaction
discon'' TransactionGraph
graph'' (HeadName -> TransactionGraphOperator
JumpToHead HeadName
mergeToHeadName)
  
  --create the merge
  (DisconnectedTransaction
discon'''', TransactionGraph
graph'''') <- UTCTime
-> TransactionId
-> DisconnectedTransaction
-> TransactionGraph
-> TransactionGraphOperator
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
evalGraphOp UTCTime
stamp' TransactionId
mergeTransId DisconnectedTransaction
discon''' TransactionGraph
graph''' (MergeStrategy -> HeadName -> HeadName -> TransactionGraphOperator
MergeTransactions MergeStrategy
strat HeadName
tempBranchName HeadName
mergeToHeadName)
  
  --delete the temp branch
  (DisconnectedTransaction
discon''''', TransactionGraph
graph''''') <- UTCTime
-> TransactionId
-> DisconnectedTransaction
-> TransactionGraph
-> TransactionGraphOperator
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
evalGraphOp UTCTime
stamp' TransactionId
tempBranchTransId DisconnectedTransaction
discon'''' TransactionGraph
graph'''' (HeadName -> TransactionGraphOperator
DeleteBranch HeadName
tempBranchName)
  {-
  let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')
  traceShowM rel
-}
  
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (DisconnectedTransaction
discon''''', TransactionGraph
graph''''')


addMerkleHash :: TransactionGraph -> Transaction -> Transaction
addMerkleHash :: TransactionGraph -> Transaction -> Transaction
addMerkleHash TransactionGraph
graph Transaction
trans = TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction (Transaction -> TransactionId
transactionId Transaction
trans) TransactionInfo
newInfo (Transaction -> Schemas
schemas Transaction
trans)
  where
    newInfo :: TransactionInfo
newInfo = (Transaction -> TransactionInfo
transactionInfo Transaction
trans) { merkleHash :: MerkleHash
merkleHash = Transaction -> TransactionGraph -> MerkleHash
calculateMerkleHash Transaction
trans TransactionGraph
graph }
  -- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions
calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash
calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash
calculateMerkleHash Transaction
trans TransactionGraph
graph = Transaction -> Set Transaction -> MerkleHash
hashTransaction Transaction
trans Set Transaction
parentTranses
  where
    parentTranses :: Set Transaction
parentTranses =
      case Set TransactionId
-> TransactionGraph -> Either RelationalError (Set Transaction)
transactionsForIds (Transaction -> Set TransactionId
parentIds Transaction
trans) TransactionGraph
graph of
        Left RelationalError
RootTransactionTraversalError -> forall a. Monoid a => a
mempty
        Left RelationalError
e -> forall a. HasCallStack => [Char] -> a
error ([Char]
"failed to find transaction in Merkle hash construction: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RelationalError
e)
        Right Set Transaction
t -> Set Transaction
t

validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()
validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()
validateMerkleHash Transaction
trans TransactionGraph
graph = 
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MerkleHash
expectedHash forall a. Eq a => a -> a -> Bool
/= MerkleHash
actualHash) forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left (TransactionId -> MerkleHash -> MerkleHash -> MerkleValidationError
MerkleValidationError (Transaction -> TransactionId
transactionId Transaction
trans) MerkleHash
expectedHash MerkleHash
actualHash)
  where
    expectedHash :: MerkleHash
expectedHash = TransactionInfo -> MerkleHash
merkleHash (Transaction -> TransactionInfo
transactionInfo Transaction
trans)
    actualHash :: MerkleHash
actualHash = Transaction -> TransactionGraph -> MerkleHash
calculateMerkleHash Transaction
trans TransactionGraph
graph

data MerkleValidationError = MerkleValidationError TransactionId MerkleHash MerkleHash
  deriving (Int -> MerkleValidationError -> ShowS
[MerkleValidationError] -> ShowS
MerkleValidationError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MerkleValidationError] -> ShowS
$cshowList :: [MerkleValidationError] -> ShowS
show :: MerkleValidationError -> [Char]
$cshow :: MerkleValidationError -> [Char]
showsPrec :: Int -> MerkleValidationError -> ShowS
$cshowsPrec :: Int -> MerkleValidationError -> ShowS
Show,MerkleValidationError -> MerkleValidationError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleValidationError -> MerkleValidationError -> Bool
$c/= :: MerkleValidationError -> MerkleValidationError -> Bool
== :: MerkleValidationError -> MerkleValidationError -> Bool
$c== :: MerkleValidationError -> MerkleValidationError -> Bool
Eq, forall x. Rep MerkleValidationError x -> MerkleValidationError
forall x. MerkleValidationError -> Rep MerkleValidationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MerkleValidationError x -> MerkleValidationError
$cfrom :: forall x. MerkleValidationError -> Rep MerkleValidationError x
Generic)

validateMerkleHashes :: TransactionGraph -> Either [MerkleValidationError] ()
validateMerkleHashes :: TransactionGraph -> Either [MerkleValidationError] ()
validateMerkleHashes TransactionGraph
graph =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MerkleValidationError]
errs then forall (f :: * -> *) a. Applicative f => a -> f a
pure () else forall a b. a -> Either a b
Left [MerkleValidationError]
errs
  where
    errs :: [MerkleValidationError]
errs = forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr Transaction -> [MerkleValidationError] -> [MerkleValidationError]
validateTrans [] (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph)    
    validateTrans :: Transaction -> [MerkleValidationError] -> [MerkleValidationError]
validateTrans Transaction
trans [MerkleValidationError]
acc =
      case Transaction -> TransactionGraph -> Either MerkleValidationError ()
validateMerkleHash Transaction
trans TransactionGraph
graph of
        Left MerkleValidationError
err -> MerkleValidationError
err forall a. a -> [a] -> [a]
: [MerkleValidationError]
acc
        Either MerkleValidationError ()
_ -> [MerkleValidationError]
acc

-- | Ensure that referenced transactions remain in the graph.
validateConnectivity :: TransactionGraph -> Either RelationalError TransactionGraph
validateConnectivity :: TransactionGraph -> Either RelationalError TransactionGraph
validateConnectivity TransactionGraph
graph = do
  let validateTrans :: Transaction -> Either RelationalError ()
validateTrans Transaction
trans =
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TransactionId
-> TransactionGraph -> Either RelationalError Transaction
`transactionForId` TransactionGraph
graph) (forall a. ReferencedTransactionIds a => a -> Set TransactionId
referencedTransactionIds (Transaction -> DatabaseContext
concreteDatabaseContext Transaction
trans))
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Transaction -> Either RelationalError ()
validateTrans (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TransactionGraph
graph