@@ -3,11 +3,12 @@ import Test.HUnit
33import ProjectM36.Base
44import ProjectM36.Persist (DiskSync(NoDiskSync))
55import ProjectM36.TransactionGraph.Persist
6−import ProjectM36.TransactionGraph
6+import ProjectM36.TransactionGraph as TG
77import ProjectM36.Transaction
88import ProjectM36.DateExamples
99import System.IO.Temp
1010import System.Exit
11+import System.Directory
1112import Data.Either
1213import Data.UUID.V4 (nextRandom)
1314import System.FilePath
@@ -16,10 +17,9 @@ import qualified Data.Map as M
1617import qualified Data.Set as S
1718import Data.Time.Clock
1819import Data.Time.Calendar
19−#ifdef PM36_HASKELL_SCRIPTING
20−import ProjectM36.Client
20+import ProjectM36.Client as C
2121import ProjectM36.Relation
22−#endif
22+import ProjectM36.Transaction.Persist
2323
2424main :: IO ()
2525main = do
@@ -29,7 +29,8 @@ main = do
2929testList :: Test
3030testList = TestList [testBootstrapDB,
3131 testDBSimplePersistence,
32− testFunctionPersistence]
32+ testFunctionPersistence,
33+ testMerkleHashValidation]
3334
3435
3536stamp' :: UTCTime
@@ -74,7 +75,62 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp
7475 case graphErr of
7576 Left err -> assertFailure (show err)
7677 Right graph'' -> assertBool "graph equality" (mapEq graph'' == mapEq graph')
77−
78+
79+testMerkleHashValidation :: Test
80+testMerkleHashValidation = TestCase $
81+ -- add a commit and validate the hashes successfully
82+ withSystemTempDirectory "m36testdb" $ \tempdir -> do
83+ let dbdir = tempdir </> "dbdir"
84+ connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []
85+ conn <- assertIOEither $ connectProjectM36 connInfo
86+ sess <- assertIOEither $ createSessionAtHead conn "master"
87+ Right _ <- executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue))
88+ Right _ <- commit sess conn
89+ val <- C.validateMerkleHashes sess conn
90+ assertEqual "merkle success" (Right ()) val
91+
92+ --read graph from disk
93+ conn' <- assertIOEither $ connectProjectM36 connInfo
94+ sess' <- assertIOEither $ createSessionAtHead conn' "master"
95+
96+ val' <- C.validateMerkleHashes sess' conn'
97+ assertEqual "merkle read again success" (Right ()) val'
98+
99+ --alter the on-disk representation and check that the hash validation fails
100+ eGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing
101+ case eGraph of
102+ Left err -> assertFailure "failed to load graph"
103+ Right graph -> do
104+ let trans = transactionHeadsForGraph graph M.! "master"
105+ updatedTrans = Transaction (transactionId trans) (transactionInfo trans) updatedSchemas
106+ transactionDir = dbdir </> show (transactionId trans)
107+ updatedSchemas =
108+ case schemas trans of
109+ Schemas ctx sschemas ->
110+ let updatedContext = ctx {
111+ relationVariables = M.insert "malicious" (ExistingRelation relationFalse) (relationVariables ctx)
112+ } in
113+ Schemas updatedContext sschemas
114+ maliciousGraph = TransactionGraph malHeads malTransSet
115+ malHeads = M.insert "master" updatedTrans (transactionHeadsForGraph graph)
116+ malTransSet = S.insert updatedTrans (transactionsForGraph graph)
117+ malMerkleHash = calculateMerkleHash updatedTrans maliciousGraph
118+ regMerkleHash = merkleHash (transactionInfo trans)
119+ --validate and fail
120+ let val'' = TG.validateMerkleHashes maliciousGraph
121+ assertEqual "loaded graph merkle hashes" (Left [MerkleValidationError (transactionId trans) regMerkleHash malMerkleHash]) val''
122+ --delete existing transaction directory
123+ removeDirectoryRecursive transactionDir
124+ writeTransaction NoDiskSync dbdir updatedTrans
125+
126+ --read graph from disk
127+ eConnFail <- connectProjectM36 connInfo
128+ case eConnFail of
129+ Left err ->
130+ assertEqual "open connection merkle validation" (DatabaseValidationError [MerkleValidationError (transactionId trans) regMerkleHash malMerkleHash]) err
131+ Right _ -> assertFailure "open connection validation"
132+
133+
78134
79135--only Haskell-scripted dbc and atom functions can be serialized
80136testFunctionPersistence :: Test
@@ -103,10 +159,11 @@ testFunctionPersistence = TestCase $
103159 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]
104160 assertEqual "testdisk dbc function run" expectedRel res
105161
162+#endif
163+
106164assertIOEither :: (Show a) => IO (Either a b) -> IO b
107165assertIOEither x = do
108166 ret <- x
109167 case ret of
110168 Left err -> assertFailure (show err) >> undefined
111169 Right val -> pure val
112−#endif