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

git.iko.soy/project-m36

on master help sign in

WIP merkle-ize transaction graph

469c243AgentM6 years ago

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

compare with master

unifiedsplit

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

9import qualified ProjectM36.Attribute as A

10import qualified Data.HashSet as HS

11import qualified Data.Text as T

12−

12+import qualified Data.ByteString.Lazy as BL

13+import Data.Binary as B

14foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

15foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

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

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

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

87 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

88 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

88 TextAtom (atomFuncTypeToText aFunc)]

89 TextAtom (atomFuncTypeToText aFunc)]

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

90 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

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

414data TransactionInfo = TransactionInfo {

415 parents :: TransactionParents,

416− stamp :: UTCTime

416+ stamp :: UTCTime,

417+ merkleHash :: ByteString

417 } deriving (Show, Generic)

418 } deriving (Show, Generic)

418

419

419type TransactionParents = NE.NonEmpty TransactionId

420type TransactionParents = NE.NonEmpty TransactionId

src/lib/ProjectM36/DatabaseContext.hs+15

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

7import ProjectM36.AtomFunctions.Basic

8import ProjectM36.DatabaseContextFunction

9import 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

11empty :: DatabaseContext

15empty :: DatabaseContext

12empty = DatabaseContext { inclusionDependencies = M.empty,

16empty = DatabaseContext { inclusionDependencies = M.empty,

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

38 notifications = M.empty,

42 notifications = M.empty,

39 typeConstructorMapping = basicTypeConstructorMapping

43 typeConstructorMapping = basicTypeConstructorMapping

40 }

44 }

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

10import qualified Data.Map as M

11import ProjectM36.ScriptSession

12import qualified Data.Text as T

13+import qualified Data.ByteString.Lazy as BL

14+import Data.Binary as B

14emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

16emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

15emptyDatabaseContextFunction name = DatabaseContextFunction {

17emptyDatabaseContextFunction name = DatabaseContextFunction {

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

77 dbcFuncToTuple func = [TextAtom (dbcFuncName func),

79 dbcFuncToTuple func = [TextAtom (dbcFuncName func),

78 TextAtom (dbcTextType (dbcFuncType func))]

80 TextAtom (dbcTextType (dbcFuncType func))]

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

81 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)

9import qualified Data.List as L

10import qualified Data.Text as T

11import Control.Arrow hiding (left)

12+import Data.ByteString.Base64 as B64

13+import qualified Data.Text.Encoding as TE

12#if __GLASGOW_HASKELL__ < 804

14#if __GLASGOW_HASKELL__ < 804

13import Data.Monoid

15import Data.Monoid

14#endif

16#endif

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

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

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

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

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

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

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

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

100showAtom _ atom = atomToText atom

103showAtom _ atom = atomToText atom

101

104

102renderTable :: Table -> StringType

105renderTable :: Table -> StringType

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

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

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

794 utctDayTime = secondsToDiffTime 0 }

795 tempSchemas = Schemas context M.empty

796+ tempTrans = Transaction U.nil tempTransInfo tempSchemas

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

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

798+ stamp = tempStamp,

799+ merkleHash = mempty

800+ }

797

801

798 deps = inclusionDependencies context

802 deps = inclusionDependencies context

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

803 -- 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.:| []

17-- | 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.

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

19filterTransactionInfoTransactions filterIds tinfo =

20− TransactionInfo { parents = case

20+ tinfo { parents = case

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

22 [] -> rootParent

23− xs -> NE.fromList xs,

23+ xs -> NE.fromList xs}

24− stamp = stamp tinfo }

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

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

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

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

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

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

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

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

44fresh :: 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+ }

48timestamp :: Transaction -> UTCTime

52timestamp :: Transaction -> UTCTime

49timestamp (Transaction _ tinfo _) = stamp tinfo

53timestamp (Transaction _ tinfo _) = stamp tinfo

54+

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

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

22import Data.Time.Clock

23import qualified Data.Text as T

24import GHC.Generics

25−import Data.Binary

25+import Data.Binary as B

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

27#if __GLASGOW_HASKELL__ < 804

28import Data.Monoid

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

30import Control.Arrow

31import Data.Maybe

32import 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

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

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

35data TransactionIdLookup = TransactionIdLookup TransactionId |

39data TransactionIdLookup = TransactionIdLookup TransactionId |

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

67 bootstrapHeads = M.singleton "master" freshTransaction

71 bootstrapHeads = M.singleton "master" freshTransaction

68 newSchemas = Schemas context M.empty

72 newSchemas = Schemas context M.empty

69 freshTransaction = fresh freshId stamp' newSchemas

73 freshTransaction = fresh freshId stamp' newSchemas

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

70− bootstrapTransactions = S.singleton freshTransaction

75+ bootstrapTransactions = S.singleton hashedTransaction

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

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

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

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

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

125

130

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

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

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

132addDisconnectedTransaction :: 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

129 where

134 where

135+ newTrans = Transaction newId newTInfo schemas'

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

136+ newTInfo = TI.singleParent parentId stamp'

131−

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

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

139+--LOOP

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

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

133addTransactionToGraph headName newTrans graph = do

141addTransactionToGraph headName newTrans graph = do

134 let parentIds' = parentIds newTrans

142 let parentIds' = parentIds newTrans

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

295 mkRelationFromList attrs tupleMatrix

303 mkRelationFromList attrs tupleMatrix

296 where

304 where

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

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

306+ Attribute "hash" ByteStringAtomType,

298 Attribute "stamp" DateTimeAtomType,

307 Attribute "stamp" DateTimeAtomType,

299 Attribute "parents" (RelationAtomType parentAttributes),

308 Attribute "parents" (RelationAtomType parentAttributes),

300 Attribute "current" BoolAtomType,

309 Attribute "current" BoolAtomType,

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

304 tupleGenerator transaction = case transactionParentsRelation transaction graph of

313 tupleGenerator transaction = case transactionParentsRelation transaction graph of

305 Left err -> Left err

314 Left err -> Left err

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

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

316+ ByteStringAtom $ merkleHash (transactionInfo transaction),

307 DateTimeAtom (timestamp transaction),

317 DateTimeAtom (timestamp transaction),

308 RelationAtom parentTransRel,

318 RelationAtom parentTransRel,

309 BoolAtom $ parentId == transactionId transaction,

319 BoolAtom $ parentId == transactionId transaction,

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

338 pure $ Transaction newId (TransactionInfo {

348 pure $ Transaction newId (TransactionInfo {

339 parents = NE.fromList [transactionId trans1,

349 parents = NE.fromList [transactionId trans1,

340 transactionId trans2],

350 transactionId trans2],

351+ stamp = stamp',

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

352+ merkleHash = unimplemented }) (schemas selectedTrans)

342

353

343-- merge functions, relvars, individually

354-- merge functions, relvars, individually

344createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =

355createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =

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

496 pure (Transaction newId (TransactionInfo {

507 pure (Transaction newId (TransactionInfo {

497 parents = NE.fromList [transactionId t1,

508 parents = NE.fromList [transactionId t1,

498 transactionId t2],

509 transactionId t2],

499− stamp = stamp'}) newSchemas)

510+ stamp = stamp',

511+ merkleHash = unimplemented }) newSchemas)

500

512

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

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

502lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

514lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

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

572 pure (discon''''', graph''''')

584 pure (discon''''', graph''''')

573

585

574

586

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 @@

1module ProjectM36.TransactionInfo where

2import ProjectM36.Base

3import Data.Time.Clock

4−import Data.List.NonEmpty

4+import qualified Data.List.NonEmpty as NE

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

7singleParent :: TransactionId -> UTCTime -> TransactionInfo

8singleParent tid stamp' = TransactionInfo {

9− parents = tid :| [],

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

10− stamp = stamp' }

10+ stamp = stamp',

11+ merkleHash = mempty }

12+