469c243 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP merkle-ize transaction graph

commit469c243a93bbaf6d71e1ec47c8d89b11ea5a645a authorAgentM <agentm@themactionfaction.com> dateWed 27 May 2020, 15:10 (6 years ago) parent4f76414

9 files changed+99−18

compare with master

unifiedsplit

src/lib/ProjectM36/AtomFunction.hs+12−1 src/lib/ProjectM36/Base.hs+2−1 src/lib/ProjectM36/DatabaseContext.hs+15 src/lib/ProjectM36/DatabaseContextFunction.hs+11−1 src/lib/ProjectM36/Relation/Show/Term.hs+3 src/lib/ProjectM36/RelationalExpression.hs+5−1 src/lib/ProjectM36/Transaction.hs+9−4 src/lib/ProjectM36/TransactionGraph.hs+37−7 src/lib/ProjectM36/TransactionInfo.hs+5−3

src/lib/ProjectM36/AtomFunction.hs+12−1

@@ -9,7 +9,8 @@ import ProjectM36.ScriptSession

99import qualified ProjectM36.Attribute as A

1010import qualified Data.HashSet as HS

1111import qualified Data.Text as T

12−

12+import qualified Data.ByteString.Lazy as BL

13+import Data.Binary as B

1314

1415foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

1516--the underscore in the attribute name means that any attributes are acceptable

@@ -87,3 +88,13 @@ atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

8788 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

8889 TextAtom (atomFuncTypeToText aFunc)]

8990 atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))

91+

92+--for calculating the merkle hash

93+hashBytes :: AtomFunction -> BL.ByteString

94+hashBytes func = mconcat [B.encode (atomFuncName func),

95+ B.encode (atomFuncType func),

96+ bodyBin

97+ ]

98+ where

99+ bodyBin = case atomFuncBody func of

100+ AtomFunctionBody mScript _ -> B.encode mScript

src/lib/ProjectM36/Base.hs+2−1

@@ -413,7 +413,8 @@ transactionsForGraph (TransactionGraph _ ts) = ts

413413-- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch).

414414data TransactionInfo = TransactionInfo {

415415 parents :: TransactionParents,

416− stamp :: UTCTime

416+ stamp :: UTCTime,

417+ merkleHash :: ByteString

417418 } deriving (Show, Generic)

418419

419420type TransactionParents = NE.NonEmpty TransactionId

src/lib/ProjectM36/DatabaseContext.hs+15

@@ -7,6 +7,10 @@ import ProjectM36.DataTypes.Basic

77import ProjectM36.AtomFunctions.Basic

88import ProjectM36.DatabaseContextFunction

99import ProjectM36.Relation

10+import qualified Data.ByteString.Lazy as BL

11+import Data.Binary as B

12+import ProjectM36.AtomFunction as AF

13+import ProjectM36.DatabaseContextFunction as DBCF

1014

1115empty :: DatabaseContext

1216empty = DatabaseContext { inclusionDependencies = M.empty,

@@ -38,3 +42,14 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

3842 notifications = M.empty,

3943 typeConstructorMapping = basicTypeConstructorMapping

4044 }

45+

46+--for building the Merkle hash

47+hashBytes :: DatabaseContext -> BL.ByteString

48+hashBytes ctx = mconcat [incDeps, rvs, atomFs, dbcFs, nots, tConsMap]

49+ where

50+ incDeps = B.encode (inclusionDependencies ctx)

51+ rvs = B.encode (relationVariables ctx)

52+ atomFs = HS.foldr (\f -> mappend (AF.hashBytes f)) mempty (atomFunctions ctx)

53+ dbcFs = HS.foldr (\f -> mappend (DBCF.hashBytes f)) mempty (dbcFunctions ctx)

54+ nots = B.encode (notifications ctx)

55+ tConsMap = B.encode (typeConstructorMapping ctx)

src/lib/ProjectM36/DatabaseContextFunction.hs+11−1

@@ -10,6 +10,8 @@ import qualified Data.HashSet as HS

1010import qualified Data.Map as M

1111import ProjectM36.ScriptSession

1212import qualified Data.Text as T

13+import qualified Data.ByteString.Lazy as BL

14+import Data.Binary as B

1315

1416emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

1517emptyDatabaseContextFunction name = DatabaseContextFunction {

@@ -77,4 +79,12 @@ databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

7779 dbcFuncToTuple func = [TextAtom (dbcFuncName func),

7880 TextAtom (dbcTextType (dbcFuncType func))]

7981 dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"])

80−

82+

83+-- for merkle hash

84+hashBytes :: DatabaseContextFunction -> BL.ByteString

85+hashBytes func = mconcat [fname, ftype, fbody]

86+ where

87+ fname = B.encode (dbcFuncName func)

88+ ftype = B.encode (dbcFuncType func)

89+ fbody = case dbcFuncBody func of

90+ DatabaseContextFunctionBody mBody _ -> B.encode mBody

src/lib/ProjectM36/Relation/Show/Term.hs+3

@@ -9,6 +9,8 @@ import ProjectM36.Attribute hiding (null)

99import qualified Data.List as L

1010import qualified Data.Text as T

1111import Control.Arrow hiding (left)

12+import Data.ByteString.Base64 as B64

13+import qualified Data.Text.Encoding as TE

1214#if __GLASGOW_HASKELL__ < 804

1315import Data.Monoid

1416#endif

@@ -97,6 +99,7 @@ showAtom :: Int -> Atom -> StringType

9799showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel

98100showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && not (null atoms)) $ T.concat (L.intersperse " " (dConsName : map (showAtom 1) atoms))

99101showAtom _ (TextAtom t) = "\"" <> t <> "\""

102+showAtom _ (ByteStringAtom bs) = TE.decodeUtf8 (B64.encode bs)

100103showAtom _ atom = atomToText atom

101104

102105renderTable :: Table -> StringType

src/lib/ProjectM36/RelationalExpression.hs+5−1

@@ -793,7 +793,11 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

793793 tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,

794794 utctDayTime = secondsToDiffTime 0 }

795795 tempSchemas = Schemas context M.empty

796− tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas

796+ tempTrans = Transaction U.nil tempTransInfo tempSchemas

797+ tempTransInfo = TransactionInfo { parents = transId NE.:| [],

798+ stamp = tempStamp,

799+ merkleHash = mempty

800+ }

797801

798802 deps = inclusionDependencies context

799803 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

src/lib/ProjectM36/Transaction.hs+9−4

@@ -17,11 +17,10 @@ singleParent tid = tid NE.:| []

1717-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

1818filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

1919filterTransactionInfoTransactions filterIds tinfo =

20− TransactionInfo { parents = case

20+ tinfo { parents = case

2121 NE.filter (`S.member` filterIds) (parents tinfo) of

2222 [] -> rootParent

23− xs -> NE.fromList xs,

24− stamp = stamp tinfo }

23+ xs -> NE.fromList xs}

2524

2625filterParent :: TransactionId -> S.Set TransactionId -> TransactionId

2726filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil

@@ -43,7 +42,13 @@ subschemas :: Transaction -> Subschemas

4342subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

4443

4544fresh :: TransactionId -> UTCTime -> Schemas -> Transaction

46−fresh freshId stamp' = Transaction freshId (TransactionInfo rootParent stamp')

45+fresh freshId stamp' = Transaction freshId tinfo

46+ where

47+ tinfo = TransactionInfo {parents = rootParent,

48+ stamp = stamp',

49+ merkleHash = mempty

50+ }

4751

4852timestamp :: Transaction -> UTCTime

4953timestamp (Transaction _ tinfo _) = stamp tinfo

54+

src/lib/ProjectM36/TransactionGraph.hs+37−7

@@ -22,7 +22,7 @@ import qualified Data.List.NonEmpty as NE

2222import Data.Time.Clock

2323import qualified Data.Text as T

2424import GHC.Generics

25−import Data.Binary

25+import Data.Binary as B

2626import Data.Either (lefts, rights, isRight)

2727#if __GLASGOW_HASKELL__ < 804

2828import Data.Monoid

@@ -30,6 +30,10 @@ import Data.Monoid

3030import Control.Arrow

3131import Data.Maybe

3232import Data.UUID.V4

33+import qualified Data.ByteString as BS

34+import qualified Data.ByteString.Lazy as BL

35+import ProjectM36.DatabaseContext as DBC

36+import Crypto.Hash.SHA256

3337

3438-- | Record a lookup for a specific transaction in the graph.

3539data TransactionIdLookup = TransactionIdLookup TransactionId |

@@ -67,7 +71,8 @@ bootstrapTransactionGraph stamp' freshId context = TransactionGraph bootstrapHea

6771 bootstrapHeads = M.singleton "master" freshTransaction

6872 newSchemas = Schemas context M.empty

6973 freshTransaction = fresh freshId stamp' newSchemas

70− bootstrapTransactions = S.singleton freshTransaction

74+ hashedTransaction = Transaction freshId ((transactionInfo freshTransaction) { merkleHash = calculateMerkleHash freshTransaction emptyTransactionGraph }) newSchemas

75+ bootstrapTransactions = S.singleton hashedTransaction

7176

7277-- | Create a transaction graph from a context.

7378freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)

@@ -125,10 +130,13 @@ addBranch stamp' newId newBranchName branchPointId graph = do

125130

126131--adds a disconnected transaction to a transaction graph at some head

127132addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

128−addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans

133+addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) graph = addTransactionToGraph headName newTrans' graph

129134 where

130− newTrans = Transaction newId (TI.singleParent parentId stamp') schemas'

131−

135+ newTrans = Transaction newId newTInfo schemas'

136+ newTInfo = TI.singleParent parentId stamp'

137+ newTrans' = Transaction newId (newTInfo { merkleHash = newHash }) schemas'

138+ newHash = calculateMerkleHash newTrans graph--lookup parents in graph to calculate

139+--LOOP

132140addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

133141addTransactionToGraph headName newTrans graph = do

134142 let parentIds' = parentIds newTrans

@@ -295,6 +303,7 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

295303 mkRelationFromList attrs tupleMatrix

296304 where

297305 attrs = A.attributesFromList [Attribute "id" TextAtomType,

306+ Attribute "hash" ByteStringAtomType,

298307 Attribute "stamp" DateTimeAtomType,

299308 Attribute "parents" (RelationAtomType parentAttributes),

300309 Attribute "current" BoolAtomType,

@@ -304,6 +313,7 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

304313 tupleGenerator transaction = case transactionParentsRelation transaction graph of

305314 Left err -> Left err

306315 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),

316+ ByteStringAtom $ merkleHash (transactionInfo transaction),

307317 DateTimeAtom (timestamp transaction),

308318 RelationAtom parentTransRel,

309319 BoolAtom $ parentId == transactionId transaction,

@@ -338,7 +348,8 @@ createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch)

338348 pure $ Transaction newId (TransactionInfo {

339349 parents = NE.fromList [transactionId trans1,

340350 transactionId trans2],

341− stamp = stamp' }) (schemas selectedTrans)

351+ stamp = stamp',

352+ merkleHash = unimplemented }) (schemas selectedTrans)

342353

343354-- merge functions, relvars, individually

344355createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =

@@ -496,7 +507,8 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do

496507 pure (Transaction newId (TransactionInfo {

497508 parents = NE.fromList [transactionId t1,

498509 transactionId t2],

499− stamp = stamp'}) newSchemas)

510+ stamp = stamp',

511+ merkleHash = unimplemented }) newSchemas)

500512

501513lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

502514lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

@@ -572,3 +584,21 @@ autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) disc

572584 pure (discon''''', graph''''')

573585

574586

587+-- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions

588+calculateMerkleHash :: Transaction -> TransactionGraph -> BS.ByteString

589+calculateMerkleHash trans graph = hashlazy (mconcat ([transIds,

590+ dbcBytes,

591+ schemasBytes,

592+ parentMerkleHashes]))

593+ where

594+ parentMerkleHashes = BL.fromChunks $ map getMerkleHash parentTranses

595+ parentTranses =

596+ case transactionsForIds (parentIds trans) graph of

597+ Left RootTransactionTraversalError -> []

598+ Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e)

599+ Right t -> S.toList t

600+ getMerkleHash t = merkleHash (transactionInfo t)

601+ transIds = B.encode (transactionId trans : S.toList (parentIds trans))

602+ dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)

603+ schemasBytes = B.encode (subschemas trans)

604+

src/lib/ProjectM36/TransactionInfo.hs+5−3

@@ -1,10 +1,12 @@

11module ProjectM36.TransactionInfo where

22import ProjectM36.Base

33import Data.Time.Clock

4−import Data.List.NonEmpty

4+import qualified Data.List.NonEmpty as NE

66-- | Create a TransactionInfo with just one parent transaction ID.

77singleParent :: TransactionId -> UTCTime -> TransactionInfo

88singleParent tid stamp' = TransactionInfo {

9− parents = tid :| [],

10− stamp = stamp' }

9+ parents = tid NE.:| [],

10+ stamp = stamp',

11+ merkleHash = mempty }

12+