{-# 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 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
import qualified Data.ByteString.Lazy as BL
import ProjectM36.DatabaseContext as DBC
import Crypto.Hash.SHA256

-- | Record a lookup for a specific transaction in the graph.
data TransactionIdLookup = TransactionIdLookup TransactionId |
                           TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]
                           deriving (Int -> TransactionIdLookup -> ShowS
[TransactionIdLookup] -> ShowS
TransactionIdLookup -> String
(Int -> TransactionIdLookup -> ShowS)
-> (TransactionIdLookup -> String)
-> ([TransactionIdLookup] -> ShowS)
-> Show TransactionIdLookup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransactionIdLookup] -> ShowS
$cshowList :: [TransactionIdLookup] -> ShowS
show :: TransactionIdLookup -> String
$cshow :: TransactionIdLookup -> String
showsPrec :: Int -> TransactionIdLookup -> ShowS
$cshowsPrec :: Int -> TransactionIdLookup -> ShowS
Show, TransactionIdLookup -> TransactionIdLookup -> Bool
(TransactionIdLookup -> TransactionIdLookup -> Bool)
-> (TransactionIdLookup -> TransactionIdLookup -> Bool)
-> Eq TransactionIdLookup
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. TransactionIdLookup -> Rep TransactionIdLookup x)
-> (forall x. Rep TransactionIdLookup x -> TransactionIdLookup)
-> Generic TransactionIdLookup
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
Typeable TransactionIdLookup
-> (Proxy TransactionIdLookup -> SchemaGen Schema)
-> (TransactionIdLookup -> Builder)
-> Extractor TransactionIdLookup
-> Decoder TransactionIdLookup
-> BundleSerialise TransactionIdLookup
-> Serialise 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
$cp1Serialise :: Typeable TransactionIdLookup
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 -> String
(Int -> TransactionIdHeadBacktrack -> ShowS)
-> (TransactionIdHeadBacktrack -> String)
-> ([TransactionIdHeadBacktrack] -> ShowS)
-> Show TransactionIdHeadBacktrack
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransactionIdHeadBacktrack] -> ShowS
$cshowList :: [TransactionIdHeadBacktrack] -> ShowS
show :: TransactionIdHeadBacktrack -> String
$cshow :: TransactionIdHeadBacktrack -> String
showsPrec :: Int -> TransactionIdHeadBacktrack -> ShowS
$cshowsPrec :: Int -> TransactionIdHeadBacktrack -> ShowS
Show, TransactionIdHeadBacktrack -> TransactionIdHeadBacktrack -> Bool
(TransactionIdHeadBacktrack -> TransactionIdHeadBacktrack -> Bool)
-> (TransactionIdHeadBacktrack
    -> TransactionIdHeadBacktrack -> Bool)
-> Eq TransactionIdHeadBacktrack
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.
 TransactionIdHeadBacktrack -> Rep TransactionIdHeadBacktrack x)
-> (forall x.
    Rep TransactionIdHeadBacktrack x -> TransactionIdHeadBacktrack)
-> Generic TransactionIdHeadBacktrack
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
Typeable TransactionIdHeadBacktrack
-> (Proxy TransactionIdHeadBacktrack -> SchemaGen Schema)
-> (TransactionIdHeadBacktrack -> Builder)
-> Extractor TransactionIdHeadBacktrack
-> Decoder TransactionIdHeadBacktrack
-> BundleSerialise TransactionIdHeadBacktrack
-> Serialise 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
$cp1Serialise :: Typeable TransactionIdHeadBacktrack
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
(TransactionGraphOperator -> TransactionGraphOperator -> Bool)
-> (TransactionGraphOperator -> TransactionGraphOperator -> Bool)
-> Eq TransactionGraphOperator
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 -> String
(Int -> TransactionGraphOperator -> ShowS)
-> (TransactionGraphOperator -> String)
-> ([TransactionGraphOperator] -> ShowS)
-> Show TransactionGraphOperator
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransactionGraphOperator] -> ShowS
$cshowList :: [TransactionGraphOperator] -> ShowS
show :: TransactionGraphOperator -> String
$cshow :: TransactionGraphOperator -> String
showsPrec :: Int -> TransactionGraphOperator -> ShowS
$cshowsPrec :: Int -> TransactionGraphOperator -> ShowS
Show, (forall x.
 TransactionGraphOperator -> Rep TransactionGraphOperator x)
-> (forall x.
    Rep TransactionGraphOperator x -> TransactionGraphOperator)
-> Generic TransactionGraphOperator
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
Typeable TransactionGraphOperator
-> (Proxy TransactionGraphOperator -> SchemaGen Schema)
-> (TransactionGraphOperator -> Builder)
-> Extractor TransactionGraphOperator
-> Decoder TransactionGraphOperator
-> BundleSerialise TransactionGraphOperator
-> Serialise 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
$cp1Serialise :: Typeable TransactionGraphOperator
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 -> String
(Int -> ROTransactionGraphOperator -> ShowS)
-> (ROTransactionGraphOperator -> String)
-> ([ROTransactionGraphOperator] -> ShowS)
-> Show ROTransactionGraphOperator
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ROTransactionGraphOperator] -> ShowS
$cshowList :: [ROTransactionGraphOperator] -> ShowS
show :: ROTransactionGraphOperator -> String
$cshow :: ROTransactionGraphOperator -> String
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 = HeadName -> Transaction -> TransactionHeads
forall k a. k -> a -> Map k a
M.singleton HeadName
"master" Transaction
freshTransaction
    newSchemas :: Schemas
newSchemas = DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
context Subschemas
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 = Transaction -> Set Transaction
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
  (TransactionGraph, TransactionId)
-> IO (TransactionGraph, TransactionId)
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 TransactionHeads
forall k a. Map k a
M.empty Set Transaction
forall a. Set a
S.empty

transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead HeadName
headName TransactionGraph
graph = HeadName -> TransactionHeads -> Maybe Transaction
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 = ((HeadName, Transaction) -> (HeadName, TransactionId))
-> [(HeadName, Transaction)] -> [(HeadName, TransactionId)]
forall a b. (a -> b) -> [a] -> [b]
map ((Transaction -> TransactionId)
-> (HeadName, Transaction) -> (HeadName, TransactionId)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Transaction -> TransactionId
transactionId) (TransactionHeads -> [(HeadName, Transaction)]
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 TransactionHeads -> Bool
forall k a. Map k a -> Bool
M.null TransactionHeads
matchingTrans then
                                                                  Maybe HeadName
forall a. Maybe a
Nothing
                                                                else
                                                                  HeadName -> Maybe HeadName
forall a. a -> Maybe a
Just (HeadName -> Maybe HeadName) -> HeadName -> Maybe HeadName
forall a b. (a -> b) -> a -> b
$ ([HeadName] -> HeadName
forall a. [a] -> a
head ([HeadName] -> HeadName)
-> (TransactionHeads -> [HeadName]) -> TransactionHeads -> HeadName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionHeads -> [HeadName]
forall k a. Map k a -> [k]
M.keys) TransactionHeads
matchingTrans
  where
    matchingTrans :: TransactionHeads
matchingTrans = (Transaction -> Bool) -> TransactionHeads -> TransactionHeads
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Transaction
transaction Transaction -> Transaction -> Bool
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 =
  [Transaction] -> Set Transaction
forall a. Ord a => [a] -> Set a
S.fromList ([Transaction] -> Set Transaction)
-> Either RelationalError [Transaction]
-> Either RelationalError (Set Transaction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TransactionId]
-> (TransactionId -> Either RelationalError Transaction)
-> Either RelationalError [Transaction]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set TransactionId -> [TransactionId]
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 Set TransactionId -> Set TransactionId -> Bool
forall a. Eq a => a -> a -> Bool
== TransactionId -> Set TransactionId
forall a. a -> Set a
S.singleton TransactionId
U.nil

rootTransactions :: TransactionGraph -> S.Set Transaction
rootTransactions :: TransactionGraph -> Set Transaction
rootTransactions TransactionGraph
graph = (Transaction -> Bool) -> Set Transaction -> Set Transaction
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 = (Transaction -> TransactionId)
-> Set Transaction -> Set TransactionId
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Transaction -> TransactionId
transactionId ((Transaction -> Bool) -> Set Transaction -> Set Transaction
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' = TransactionId -> Set TransactionId -> Bool
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 = (TransactionId -> Either RelationalError Transaction)
-> [TransactionId] -> Either RelationalError [Transaction]
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) (Set TransactionId -> [TransactionId]
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'
  Bool -> Either RelationalError () -> Either RelationalError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set TransactionId -> Int
forall a. Set a -> Int
S.size Set TransactionId
parentIds' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (RelationalError -> Either RelationalError ())
-> RelationalError -> Either RelationalError ()
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 -> () -> Either RelationalError ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- any headName is OK 
    Just Transaction
trans -> Bool -> Either RelationalError () -> Either RelationalError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TransactionId -> Set TransactionId -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember (Transaction -> TransactionId
transactionId Transaction
trans) Set TransactionId
parentIds') (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (HeadName -> RelationalError
HeadNameSwitchingHeadProhibitedError HeadName
headName))
  --validate that the transaction has no children
  Bool -> Either RelationalError () -> Either RelationalError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set Transaction -> Bool
forall a. Set a -> Bool
S.null Set Transaction
childTs) (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (RelationalError -> Either RelationalError ())
-> RelationalError -> Either RelationalError ()
forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
NewTransactionMayNotHaveChildrenError TransactionId
newId)
  --validate that the trasaction's id is unique
  Bool -> Either RelationalError () -> Either RelationalError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either RelationalError Transaction -> Bool
forall a b. Either a b -> Bool
isRight (TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
newId TransactionGraph
graph)) (RelationalError -> Either RelationalError ()
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 = Transaction -> Set Transaction -> Set Transaction
forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
hashedTrans (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph)
      updatedHeads :: TransactionHeads
updatedHeads = HeadName -> Transaction -> TransactionHeads -> TransactionHeads
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert HeadName
headName Transaction
hashedTrans (TransactionGraph -> TransactionHeads
transactionHeadsForGraph TransactionGraph
graph)
  (Transaction, TransactionGraph)
-> Either RelationalError (Transaction, TransactionGraph)
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 = (RelationalExprBase GraphRefTransactionMarker
 -> RelationalExprBase GraphRefTransactionMarker)
-> RelationVariables -> RelationVariables
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((GraphRefTransactionMarker -> GraphRefTransactionMarker)
-> RelationalExprBase GraphRefTransactionMarker
-> RelationalExprBase GraphRefTransactionMarker
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
  (Transaction -> Maybe RelationalError) -> [Transaction] -> Maybe ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Set TransactionId
-> TransactionGraph -> Transaction -> Maybe RelationalError
walkParentTransactions Set TransactionId
forall a. Set a
S.empty TransactionGraph
graph) (Set Transaction -> [Transaction]
forall a. Set a -> [a]
S.toList Set Transaction
transSet)
  (Transaction -> Maybe RelationalError)
-> [Transaction] -> Maybe [RelationalError]
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 Set TransactionId
forall a. Set a
S.empty TransactionGraph
graph) (Set Transaction -> [Transaction]
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 TransactionId -> TransactionId -> Bool
forall a. Eq a => a -> a -> Bool
== TransactionId
U.nil then
    Maybe RelationalError
forall a. Maybe a
Nothing
  else if TransactionId -> Set TransactionId -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member TransactionId
transId Set TransactionId
seenTransSet then
    RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just (RelationalError -> Maybe RelationalError)
-> RelationalError -> Maybe RelationalError
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 -> RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just RelationalError
err
        Right Set Transaction
parentTransSet -> do
          [RelationalError]
walk <- (Transaction -> Maybe RelationalError)
-> [Transaction] -> Maybe [RelationalError]
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 (TransactionId -> Set TransactionId -> Set TransactionId
forall a. Ord a => a -> Set a -> Set a
S.insert TransactionId
transId Set TransactionId
seenTransSet) TransactionGraph
graph) (Set Transaction -> [Transaction]
forall a. Set a -> [a]
S.toList Set Transaction
parentTransSet)
          case [RelationalError]
walk of
            RelationalError
err:[RelationalError]
_ -> RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just RelationalError
err
            [RelationalError]
_ -> Maybe 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 Either RelationalError (Set Transaction)
-> Either RelationalError (Set Transaction) -> Bool
forall a. Eq a => a -> a -> Bool
== Set Transaction -> Either RelationalError (Set Transaction)
forall a b. b -> Either a b
Right Set Transaction
forall a. Set a
S.empty then
    Maybe RelationalError
forall a. Maybe a
Nothing
  else if TransactionId -> Set TransactionId -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member TransactionId
transId Set TransactionId
seenTransSet then
    RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just (RelationalError -> Maybe RelationalError)
-> RelationalError -> Maybe RelationalError
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 -> RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just RelationalError
err
       Right Set Transaction
childTransSet -> do
         [RelationalError]
walk <- (Transaction -> Maybe RelationalError)
-> [Transaction] -> Maybe [RelationalError]
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 (TransactionId -> Set TransactionId -> Set TransactionId
forall a. Ord a => a -> Set a -> Set a
S.insert TransactionId
transId Set TransactionId
seenTransSet) TransactionGraph
graph) (Set Transaction -> [Transaction]
forall a. Set a -> [a]
S.toList Set Transaction
childTransSet)
         case [RelationalError]
walk of
           RelationalError
err:[RelationalError]
_ -> RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just RelationalError
err
           [RelationalError]
_ -> Maybe 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 -> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. a -> Either a b
Left RelationalError
err
  Right Transaction
parentTrans -> (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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
      (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. b -> Either a b
Right (DisconnectedTransaction
disconnectedTrans, TransactionGraph
graph)
    Maybe Transaction
Nothing -> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. a -> Either a b
Left (RelationalError
 -> Either
      RelationalError (DisconnectedTransaction, TransactionGraph))
-> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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 -> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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)
      (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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 -> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. a -> Either a b
Left RelationalError
err
    Right (Transaction
_, TransactionGraph
newGraph) -> (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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 -> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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 -> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. a -> Either a b
Left (RelationalError
 -> Either
      RelationalError (DisconnectedTransaction, TransactionGraph))
-> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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-> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. a -> Either a b
Left RelationalError
err
      Right (Transaction
_, TransactionGraph
updatedGraph) -> (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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 -> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. a -> Either a b
Left RelationalError
err
  Right Transaction
parentTransaction -> (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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) = 
  GraphRefRelationalExprEnv
-> GraphRefRelationalExprM
     (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
env (GraphRefRelationalExprM
   (DisconnectedTransaction, TransactionGraph)
 -> Either
      RelationalError (DisconnectedTransaction, TransactionGraph))
-> GraphRefRelationalExprM
     (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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 Maybe DatabaseContext
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 -> RelationalError
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. a -> Either a b
Left (HeadName -> RelationalError
NoSuchHeadNameError HeadName
branchName)
  Just Transaction
_ -> (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
forall a b. b -> Either a b
Right (DisconnectedTransaction
discon, TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph (HeadName -> TransactionHeads -> TransactionHeads
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 <- (Transaction -> Either RelationalError [Atom])
-> [Transaction] -> Either RelationalError [[Atom]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Transaction -> Either RelationalError [Atom]
tupleGenerator (Set Transaction -> [Transaction]
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 -> RelationalError -> Either RelationalError [Atom]
forall a b. a -> Either a b
Left RelationalError
err
      Right Relation
parentTransRel -> [Atom] -> Either RelationalError [Atom]
forall a b. b -> Either a b
Right [HeadName -> Atom
TextAtom (HeadName -> Atom) -> HeadName -> Atom
forall a b. (a -> b) -> a -> b
$ String -> HeadName
T.pack (String -> HeadName) -> String -> HeadName
forall a b. (a -> b) -> a -> b
$ TransactionId -> String
forall a. Show a => a -> String
show (Transaction -> TransactionId
transactionId Transaction
transaction),
                                     ByteString -> Atom
ByteStringAtom (ByteString -> Atom) -> ByteString -> Atom
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 (Bool -> Atom) -> Bool -> Atom
forall a b. (a -> b) -> a -> b
$ TransactionId
parentId TransactionId -> TransactionId -> Bool
forall a. Eq a => a -> a -> Bool
== Transaction -> TransactionId
transactionId Transaction
transaction,
                                     HeadName -> Atom
TextAtom (HeadName -> Atom) -> HeadName -> Atom
forall a b. (a -> b) -> a -> b
$ HeadName -> Maybe HeadName -> HeadName
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 = (Transaction -> RelationTuple) -> [Transaction] -> [RelationTuple]
forall a b. (a -> b) -> [a] -> [b]
map Transaction -> RelationTuple
trans2tuple (Set Transaction -> [Transaction]
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 (Vector Atom -> RelationTuple) -> Vector Atom -> RelationTuple
forall a b. (a -> b) -> a -> b
$ Atom -> Vector Atom
forall a. a -> Vector a
V.singleton (HeadName -> Atom
TextAtom (String -> HeadName
T.pack (TransactionId -> String
forall a. Show a => a -> String
show (TransactionId -> String) -> TransactionId -> String
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
  Transaction -> GraphRefRelationalExprM Transaction
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transaction -> GraphRefRelationalExprM Transaction)
-> Transaction -> GraphRefRelationalExprM Transaction
forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Transaction -> Transaction
addMerkleHash TransactionGraph
graph (Transaction -> Transaction) -> Transaction -> Transaction
forall a b. (a -> b) -> a -> b
$
    TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
newId (TransactionInfo :: TransactionParents -> UTCTime -> MerkleHash -> TransactionInfo
TransactionInfo {
                          parents :: TransactionParents
parents = [TransactionId] -> TransactionParents
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 = 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 -> RelationalError -> GraphRefRelationalExprM Transaction
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError MergeError
SelectedHeadMismatchMergeError)
    Just Transaction
trans -> if Transaction
trans Transaction -> Transaction -> Bool
forall a. Eq a => a -> a -> Bool
/= Transaction
t1 Bool -> Bool -> Bool
&& Transaction
trans Transaction -> Transaction -> Bool
forall a. Eq a => a -> a -> Bool
/= Transaction
t2 then 
                    RelationalError -> GraphRefRelationalExprM Transaction
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError MergeError
SelectedHeadMismatchMergeError)
                  else
                    Transaction -> GraphRefRelationalExprM Transaction
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.
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' Transaction -> Transaction -> Bool
forall a. Eq a => a -> a -> Bool
== Transaction
goalTrans then
    TransactionGraph -> Either RelationalError TransactionGraph
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 = Set Transaction -> Set Transaction -> Set Transaction
forall a. Ord a => Set a -> Set a -> Set a
S.difference (Transaction -> Set Transaction -> Set Transaction
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 (Transaction -> Set Transaction -> Set Transaction
forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
currentTrans' Set Transaction
traverseSet)
        childSearches :: [Either RelationalError (Set Transaction)]
childSearches = (Transaction -> Either RelationalError (Set Transaction))
-> [Transaction] -> [Either RelationalError (Set Transaction)]
forall a b. (a -> b) -> [a] -> [b]
map Transaction -> Either RelationalError (Set Transaction)
searchChild (Set Transaction -> [Transaction]
forall a. Set a -> [a]
S.toList Set Transaction
searchChildren)
        errors :: [RelationalError]
errors = [Either RelationalError (Set Transaction)] -> [RelationalError]
forall a b. [Either a b] -> [a]
lefts [Either RelationalError (Set Transaction)]
childSearches
        pathsFound :: [Set Transaction]
pathsFound = [Either RelationalError (Set Transaction)] -> [Set Transaction]
forall a b. [Either a b] -> [b]
rights [Either RelationalError (Set Transaction)]
childSearches
        realErrors :: [RelationalError]
realErrors = (RelationalError -> Bool) -> [RelationalError] -> [RelationalError]
forall a. (a -> Bool) -> [a] -> [a]
filter (RelationalError -> RelationalError -> Bool
forall a. Eq a => a -> a -> Bool
/= TransactionId -> RelationalError
FailedToFindTransactionError TransactionId
goalid) [RelationalError]
errors
    -- report any non-search-related errors        
    Bool -> Either RelationalError () -> Either RelationalError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RelationalError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RelationalError]
realErrors) (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left ([RelationalError] -> RelationalError
forall a. [a] -> a
head [RelationalError]
realErrors))
    -- if no paths found, search the parent
    if [Set Transaction] -> Bool
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 -> RelationalError -> Either RelationalError TransactionGraph
forall a b. a -> Either a b
Left (TransactionId -> TransactionId -> RelationalError
NoCommonTransactionAncestorError TransactionId
currentid TransactionId
goalid)
        Left RelationalError
err -> RelationalError -> Either RelationalError TransactionGraph
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 (Transaction -> Set Transaction -> Set Transaction
forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
currentTrans' Set Transaction
traverseSet)
      else -- we found a path
      TransactionGraph -> Either RelationalError TransactionGraph
forall a b. b -> Either a b
Right (TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
resultHeads ([Set Transaction] -> Set Transaction
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (Set Transaction
traverseSet Set Transaction -> [Set Transaction] -> [Set Transaction]
forall a. a -> [a] -> [a]
: [Set Transaction]
pathsFound)))
  where
    oneParent :: Transaction -> Either RelationalError Transaction
oneParent (Transaction TransactionId
_ TransactionInfo
tinfo Schemas
_) = TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId (TransactionParents -> TransactionId
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 TransactionId -> TransactionId -> Bool
forall a. Eq a => a -> a -> Bool
== Transaction -> TransactionId
transactionId Transaction
currentTransaction then
    Set Transaction -> Either RelationalError (Set Transaction)
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 Set Transaction -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Transaction
currentTransChildren then
      RelationalError -> Either RelationalError (Set Transaction)
forall a b. a -> Either a b
Left (TransactionId -> RelationalError
FailedToFindTransactionError TransactionId
targetId)
      else do
      let searches :: [Either RelationalError (Set Transaction)]
searches = (Transaction -> Either RelationalError (Set Transaction))
-> [Transaction] -> [Either RelationalError (Set Transaction)]
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 (Transaction -> Set Transaction -> Set Transaction
forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
t Set Transaction
accumTransSet)) (Set Transaction -> [Transaction]
forall a. Set a -> [a]
S.toList Set Transaction
currentTransChildren)
      let realErrors :: [RelationalError]
realErrors = (RelationalError -> Bool) -> [RelationalError] -> [RelationalError]
forall a. (a -> Bool) -> [a] -> [a]
filter (RelationalError -> RelationalError -> Bool
forall a. Eq a => a -> a -> Bool
/= TransactionId -> RelationalError
FailedToFindTransactionError TransactionId
targetId) ([Either RelationalError (Set Transaction)] -> [RelationalError]
forall a b. [Either a b] -> [a]
lefts [Either RelationalError (Set Transaction)]
searches)
          paths :: [Set Transaction]
paths = [Either RelationalError (Set Transaction)] -> [Set Transaction]
forall a b. [Either a b] -> [b]
rights [Either RelationalError (Set Transaction)]
searches
      if Bool -> Bool
not ([RelationalError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RelationalError]
realErrors) then -- found some real errors
        RelationalError -> Either RelationalError (Set Transaction)
forall a b. a -> Either a b
Left ([RelationalError] -> RelationalError
forall a. [a] -> a
head [RelationalError]
realErrors)
      else if [Set Transaction] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Transaction]
paths then -- failed to find transaction in all children
             RelationalError -> Either RelationalError (Set Transaction)
forall a b. a -> Either a b
Left (TransactionId -> RelationalError
FailedToFindTransactionError TransactionId
targetId)
           else --we have some paths!
             Set Transaction -> Either RelationalError (Set Transaction)
forall a b. b -> Either a b
Right ([Set Transaction] -> Set Transaction
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 -> RelationalError -> m Transaction
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HeadName -> RelationalError
NoSuchHeadNameError HeadName
name)
        Just Transaction
t -> Transaction -> m Transaction
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' -> e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e'
        Right a
v -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
  Transaction
transA <- HeadName -> GraphRefRelationalExprM Transaction
forall (m :: * -> *).
MonadError RelationalError m =>
HeadName -> m Transaction
transactionForHeadErr HeadName
headNameA
  Transaction
transB <- HeadName -> GraphRefRelationalExprM Transaction
forall (m :: * -> *).
MonadError RelationalError m =>
HeadName -> m Transaction
transactionForHeadErr HeadName
headNameB
  Transaction
disconParent <- TransactionId -> GraphRefRelationalExprM Transaction
gfTransForId TransactionId
parentId
  let subHeads :: TransactionHeads
subHeads = (HeadName -> Transaction -> Bool)
-> TransactionHeads -> TransactionHeads
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\HeadName
k Transaction
_ -> HeadName
k HeadName -> [HeadName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HeadName
headNameA, HeadName
headNameB]) (TransactionGraph -> TransactionHeads
transactionHeadsForGraph TransactionGraph
graph)
  TransactionGraph
subGraph <- Either RelationalError TransactionGraph
-> GraphRefRelationalExprM TransactionGraph
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
runE (Either RelationalError TransactionGraph
 -> GraphRefRelationalExprM TransactionGraph)
-> Either RelationalError TransactionGraph
-> GraphRefRelationalExprM TransactionGraph
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 Set Transaction
forall a. Set a
S.empty
  TransactionGraph
subGraph' <- Either RelationalError TransactionGraph
-> GraphRefRelationalExprM TransactionGraph
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
runE (Either RelationalError TransactionGraph
 -> GraphRefRelationalExprM TransactionGraph)
-> Either RelationalError TransactionGraph
-> GraphRefRelationalExprM TransactionGraph
forall a b. (a -> b) -> a -> b
$ TransactionGraph
-> TransactionHeads -> Either RelationalError TransactionGraph
filterSubGraph TransactionGraph
subGraph TransactionHeads
subHeads
  Transaction
mergedTrans <- (GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv)
-> GraphRefRelationalExprM Transaction
-> GraphRefRelationalExprM Transaction
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (GraphRefRelationalExprEnv
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
forall a b. a -> b -> a
const (Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv Maybe DatabaseContext
forall a. Maybe a
Nothing TransactionGraph
subGraph')) (GraphRefRelationalExprM Transaction
 -> GraphRefRelationalExprM Transaction)
-> GraphRefRelationalExprM Transaction
-> GraphRefRelationalExprM Transaction
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 -> RelationalError
-> GraphRefRelationalExprM
     (DisconnectedTransaction, TransactionGraph)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TransactionId -> RelationalError
TransactionIsNotAHeadError TransactionId
parentId)
        Just HeadName
headName -> do
          (Transaction
newTrans, TransactionGraph
newGraph) <- Either RelationalError (Transaction, TransactionGraph)
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     (Transaction, TransactionGraph)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
runE (Either RelationalError (Transaction, TransactionGraph)
 -> ReaderT
      GraphRefRelationalExprEnv
      (ExceptT RelationalError Identity)
      (Transaction, TransactionGraph))
-> Either RelationalError (Transaction, TransactionGraph)
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     (Transaction, TransactionGraph)
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 -> RelationalError
-> GraphRefRelationalExprM
     (DisconnectedTransaction, TransactionGraph)
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)
              (DisconnectedTransaction, TransactionGraph)
-> GraphRefRelationalExprM
     (DisconnectedTransaction, TransactionGraph)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DisconnectedTransaction
newDiscon, TransactionGraph
newGraph')
  
--TEMPORARY COPY/PASTE  
showTransactionStructureX :: Transaction -> TransactionGraph -> String
showTransactionStructureX :: Transaction -> TransactionGraph -> String
showTransactionStructureX Transaction
trans TransactionGraph
graph = String
headInfo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TransactionId -> String
forall a. Show a => a -> String
show (Transaction -> TransactionId
transactionId Transaction
trans) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
parentTransactionsInfo
  where
    headInfo :: String
headInfo = String -> (HeadName -> String) -> Maybe HeadName -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" HeadName -> String
forall a. Show a => a -> String
show (Transaction -> TransactionGraph -> Maybe HeadName
headNameForTransaction Transaction
trans TransactionGraph
graph)
    parentTransactionsInfo :: String
parentTransactionsInfo = if Transaction -> Bool
isRootTransaction Transaction
trans then String
"root" else case Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
parentTransactions Transaction
trans TransactionGraph
graph of
      Left RelationalError
err -> RelationalError -> String
forall a. Show a => a -> String
show RelationalError
err
      Right Set Transaction
parentTransSet -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
S.toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ (Transaction -> String) -> Set Transaction -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (TransactionId -> String
forall a. Show a => a -> String
show (TransactionId -> String)
-> (Transaction -> TransactionId) -> Transaction -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction -> TransactionId
transactionId) Set Transaction
parentTransSet
  
showGraphStructureX :: TransactionGraph -> String
showGraphStructureX :: TransactionGraph -> String
showGraphStructureX graph :: TransactionGraph
graph@(TransactionGraph TransactionHeads
heads Set Transaction
transSet) = String
headsInfo String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Transaction -> ShowS) -> String -> Set Transaction -> String
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr Transaction -> ShowS
folder String
"" Set Transaction
transSet
  where
    folder :: Transaction -> ShowS
folder Transaction
trans String
acc = String
acc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Transaction -> TransactionGraph -> String
showTransactionStructureX Transaction
trans TransactionGraph
graph String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
    headsInfo :: String
headsInfo = Map HeadName TransactionId -> String
forall a. Show a => a -> String
show (Map HeadName TransactionId -> String)
-> Map HeadName TransactionId -> String
forall a b. (a -> b) -> a -> b
$ (Transaction -> TransactionId)
-> TransactionHeads -> Map HeadName TransactionId
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 = TransactionGraph -> Either RelationalError TransactionGraph
forall a b. b -> Either a b
Right (TransactionGraph -> Either RelationalError TransactionGraph)
-> TransactionGraph -> Either RelationalError TransactionGraph
forall a b. (a -> b) -> a -> b
$ TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
newHeads Set Transaction
newTransSet
  where
    validIds :: Set TransactionId
validIds = (Transaction -> TransactionId)
-> Set Transaction -> Set TransactionId
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 = (Transaction -> Transaction) -> Set Transaction -> Set Transaction
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 = (Transaction -> Transaction)
-> TransactionHeads -> TransactionHeads
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 -> RelationalError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError MergeError
e)
        Right a
t -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
t
        
  TransactionGraph
graph <- GraphRefRelationalExprM TransactionGraph
gfGraph
  MergePreference
preference <- case MergeStrategy
strategy of 
    MergeStrategy
UnionMergeStrategy -> MergePreference
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     MergePreference
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 -> RelationalError
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     MergePreference
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError (HeadName -> MergeError
PreferredHeadMissingMergeError HeadName
preferBranch))
        Just Transaction
preferredTrans -> MergePreference
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     MergePreference
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MergePreference
 -> ReaderT
      GraphRefRelationalExprEnv
      (ExceptT RelationalError Identity)
      MergePreference)
-> MergePreference
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     MergePreference
forall a b. (a -> b) -> a -> b
$ if Transaction
t1 Transaction -> Transaction -> Bool
forall a. Eq a => a -> a -> Bool
== Transaction
preferredTrans then MergePreference
PreferFirst else MergePreference
PreferSecond
    MergeStrategy
badStrat -> RelationalError
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     MergePreference
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MergeError -> RelationalError
MergeTransactionError (MergeStrategy -> MergeError
InvalidMergeStrategyError MergeStrategy
badStrat))
          
  Map HeadName InclusionDependency
incDeps <- Either MergeError (Map HeadName InclusionDependency)
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     (Map HeadName InclusionDependency)
forall (m :: * -> *) a.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE (Either MergeError (Map HeadName InclusionDependency)
 -> ReaderT
      GraphRefRelationalExprEnv
      (ExceptT RelationalError Identity)
      (Map HeadName InclusionDependency))
-> Either MergeError (Map HeadName InclusionDependency)
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     (Map HeadName InclusionDependency)
forall a b. (a -> b) -> a -> b
$ MergePreference
-> Map HeadName InclusionDependency
-> Map HeadName InclusionDependency
-> Either MergeError (Map HeadName InclusionDependency)
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 <- Either MergeError AtomFunctions
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     AtomFunctions
forall (m :: * -> *) a.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE (Either MergeError AtomFunctions
 -> ReaderT
      GraphRefRelationalExprEnv
      (ExceptT RelationalError Identity)
      AtomFunctions)
-> Either MergeError AtomFunctions
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     AtomFunctions
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 <- Either MergeError (Map HeadName Notification)
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     (Map HeadName Notification)
forall (m :: * -> *) a.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE (Either MergeError (Map HeadName Notification)
 -> ReaderT
      GraphRefRelationalExprEnv
      (ExceptT RelationalError Identity)
      (Map HeadName Notification))
-> Either MergeError (Map HeadName Notification)
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     (Map HeadName Notification)
forall a b. (a -> b) -> a -> b
$ MergePreference
-> Map HeadName Notification
-> Map HeadName Notification
-> Either MergeError (Map HeadName Notification)
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 <- Either MergeError TypeConstructorMapping
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     TypeConstructorMapping
forall (m :: * -> *) a.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE (Either MergeError TypeConstructorMapping
 -> ReaderT
      GraphRefRelationalExprEnv
      (ExceptT RelationalError Identity)
      TypeConstructorMapping)
-> Either MergeError TypeConstructorMapping
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     TypeConstructorMapping
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 <- Either MergeError DatabaseContextFunctions
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     DatabaseContextFunctions
forall (m :: * -> *) a.
MonadError RelationalError m =>
Either MergeError a -> m a
liftMergeE (Either MergeError DatabaseContextFunctions
 -> ReaderT
      GraphRefRelationalExprEnv
      (ExceptT RelationalError Identity)
      DatabaseContextFunctions)
-> Either MergeError DatabaseContextFunctions
-> ReaderT
     GraphRefRelationalExprEnv
     (ExceptT RelationalError Identity)
     DatabaseContextFunctions
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)
  -- TODO: add merge of subschemas
  let newContext :: DatabaseContext
newContext = DatabaseContext :: Map HeadName InclusionDependency
-> RelationVariables
-> AtomFunctions
-> DatabaseContextFunctions
-> Map HeadName Notification
-> TypeConstructorMapping
-> DatabaseContext
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
        }
      newSchemas :: Schemas
newSchemas = DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
newContext (Transaction -> Subschemas
subschemas Transaction
t1)
  Transaction -> GraphRefRelationalExprM Transaction
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transaction -> GraphRefRelationalExprM Transaction)
-> Transaction -> GraphRefRelationalExprM Transaction
forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Transaction -> Transaction
addMerkleHash TransactionGraph
graph (Transaction -> Transaction) -> Transaction -> Transaction
forall a b. (a -> b) -> a -> b
$
    TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
newId (TransactionInfo :: TransactionParents -> UTCTime -> MerkleHash -> TransactionInfo
TransactionInfo {
                          parents :: TransactionParents
parents = [TransactionId] -> TransactionParents
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 = 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 -> RelationalError -> Either RelationalError Transaction
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 = (TransactionId
 -> TransactionIdHeadBacktrack
 -> Either RelationalError TransactionId)
-> TransactionId
-> [TransactionIdHeadBacktrack]
-> Either RelationalError TransactionId
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' = Set TransactionId -> [TransactionId]
forall a. Set a -> [a]
S.toAscList (Transaction -> Set TransactionId
parentIds Transaction
trans)
  case [TransactionId]
parentIds' of
    [] -> RelationalError -> Either RelationalError TransactionId
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then
        TransactionId -> Either RelationalError TransactionId
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 Int -> Int -> Int
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 Set TransactionId -> Int
forall a. Set a -> Int
S.size Set TransactionId
parentIds' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 then
    RelationalError -> Either RelationalError TransactionId
forall a b. a -> Either a b
Left RelationalError
RootTransactionTraversalError    
    else if Set TransactionId -> Int
forall a. Set a -> Int
S.size Set TransactionId
parentIds' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
steps then
           RelationalError -> Either RelationalError TransactionId
forall a b. a -> Either a b
Left (Int -> Int -> RelationalError
ParentCountTraversalError (Set TransactionId -> Int
forall a. Set a -> Int
S.size Set TransactionId
parentIds') Int
steps)
         else
           TransactionId -> Either RelationalError TransactionId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Set TransactionId -> TransactionId
forall a. Int -> Set a -> a
S.elemAt (Int
steps Int -> Int -> Int
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 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
stamp' then
    TransactionId -> Either RelationalError TransactionId
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransactionId
currentTid
    else if Set TransactionId -> Bool
forall a. Set a -> Bool
S.null Set TransactionId
parentIds' then
           RelationalError -> Either RelationalError TransactionId
forall a b. a -> Either a b
Left RelationalError
RootTransactionTraversalError
         else
           let arbitraryParent :: TransactionId
arbitraryParent = [TransactionId] -> TransactionId
forall a. [a] -> a
head (Set TransactionId -> [TransactionId]
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_" HeadName -> HeadName -> HeadName
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
-}
  
  (DisconnectedTransaction, TransactionGraph)
-> Either
     RelationalError (DisconnectedTransaction, TransactionGraph)
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 = 
  ByteString -> MerkleHash
MerkleHash ByteString
newHash
  where
    newHash :: ByteString
newHash = ByteString -> ByteString
hashlazy ([ByteString] -> ByteString
BL.fromChunks [ByteString
transIdsBytes,
                                         ByteString
schemasBytes,
                                         ByteString
tstampBytes
                                       ] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
dbcBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
parentMerkleHashes)
    tstamp :: UTCTime
tstamp = TransactionInfo -> UTCTime
stamp (Transaction -> TransactionInfo
transactionInfo Transaction
trans)
    tstampBytes :: ByteString
tstampBytes = UTCTime -> ByteString
forall a. Serialise a => a -> ByteString
serialise UTCTime
tstamp
    parentMerkleHashes :: ByteString
parentMerkleHashes = [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Transaction -> ByteString) -> [Transaction] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (MerkleHash -> ByteString
_unMerkleHash (MerkleHash -> ByteString)
-> (Transaction -> MerkleHash) -> Transaction -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction -> MerkleHash
getMerkleHash) [Transaction]
parentTranses
    parentTranses :: [Transaction]
parentTranses =
      case Set TransactionId
-> TransactionGraph -> Either RelationalError (Set Transaction)
transactionsForIds (Transaction -> Set TransactionId
parentIds Transaction
trans) TransactionGraph
graph of
        Left RelationalError
RootTransactionTraversalError -> []
        Left RelationalError
e -> String -> [Transaction]
forall a. HasCallStack => String -> a
error (String
"failed to find transaction in Merkle hash construction: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RelationalError -> String
forall a. Show a => a -> String
show RelationalError
e)
        Right Set Transaction
t -> Set Transaction -> [Transaction]
forall a. Set a -> [a]
S.toList Set Transaction
t
    getMerkleHash :: Transaction -> MerkleHash
getMerkleHash Transaction
t = TransactionInfo -> MerkleHash
merkleHash (Transaction -> TransactionInfo
transactionInfo Transaction
t)
    transIds :: [TransactionId]
transIds = Transaction -> TransactionId
transactionId Transaction
trans TransactionId -> [TransactionId] -> [TransactionId]
forall a. a -> [a] -> [a]
: Set TransactionId -> [TransactionId]
forall a. Set a -> [a]
S.toAscList (Transaction -> Set TransactionId
parentIds Transaction
trans)
    transIdsBytes :: ByteString
transIdsBytes = [TransactionId] -> ByteString
forall a. Serialise a => a -> ByteString
serialise [TransactionId]
transIds
    dbcBytes :: ByteString
dbcBytes = DatabaseContext -> ByteString
DBC.hashBytes (Transaction -> DatabaseContext
concreteDatabaseContext Transaction
trans)
    schemasBytes :: ByteString
schemasBytes = Subschemas -> ByteString
forall a. Serialise a => a -> ByteString
serialise (Transaction -> Subschemas
subschemas Transaction
trans)

validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()
validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()
validateMerkleHash Transaction
trans TransactionGraph
graph = 
  if MerkleHash
expectedHash MerkleHash -> MerkleHash -> Bool
forall a. Eq a => a -> a -> Bool
/= MerkleHash
actualHash  then
    MerkleValidationError -> Either MerkleValidationError ()
forall a b. a -> Either a b
Left (TransactionId -> MerkleHash -> MerkleHash -> MerkleValidationError
MerkleValidationError (Transaction -> TransactionId
transactionId Transaction
trans) MerkleHash
expectedHash MerkleHash
actualHash)
  else
    () -> Either MerkleValidationError ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  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 -> String
(Int -> MerkleValidationError -> ShowS)
-> (MerkleValidationError -> String)
-> ([MerkleValidationError] -> ShowS)
-> Show MerkleValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MerkleValidationError] -> ShowS
$cshowList :: [MerkleValidationError] -> ShowS
show :: MerkleValidationError -> String
$cshow :: MerkleValidationError -> String
showsPrec :: Int -> MerkleValidationError -> ShowS
$cshowsPrec :: Int -> MerkleValidationError -> ShowS
Show,MerkleValidationError -> MerkleValidationError -> Bool
(MerkleValidationError -> MerkleValidationError -> Bool)
-> (MerkleValidationError -> MerkleValidationError -> Bool)
-> Eq MerkleValidationError
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. MerkleValidationError -> Rep MerkleValidationError x)
-> (forall x. Rep MerkleValidationError x -> MerkleValidationError)
-> Generic MerkleValidationError
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 [MerkleValidationError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MerkleValidationError]
errs then () -> Either [MerkleValidationError] ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else [MerkleValidationError] -> Either [MerkleValidationError] ()
forall a b. a -> Either a b
Left [MerkleValidationError]
errs
  where
    errs :: [MerkleValidationError]
errs = (Transaction -> [MerkleValidationError] -> [MerkleValidationError])
-> [MerkleValidationError]
-> Set Transaction
-> [MerkleValidationError]
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 MerkleValidationError
-> [MerkleValidationError] -> [MerkleValidationError]
forall a. a -> [a] -> [a]
: [MerkleValidationError]
acc
        Either MerkleValidationError ()
_ -> [MerkleValidationError]
acc