771ba49 · project-m36 · git.iko.soy

git.iko.soy/project-m36

Merge branch '102_graphlock'

commit771ba49eff30e421b65f2aa80fd047f276105ef0 authorAgentM <agentm@themactionfaction.com> dateMon 12 Jun 2017, 17:43 (9 years ago) parent41d9b1e 593df53

15 files changed+382−116

compare with master

unifiedsplit

Changelog.markdown+8 docs/acid_assessment.markdown+2−2 docs/replication.markdown+30 project-m36.cabal+26−11 src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+1 src/lib/ProjectM36/Client.hs+103−63 src/lib/ProjectM36/DataTypes/DateTime.hs−1 src/lib/ProjectM36/Error.hs+2−1 src/lib/ProjectM36/FileLock.hs+85 src/lib/ProjectM36/Persist.hs+5−4 src/lib/ProjectM36/TransactionGraph.hs+4−4 src/lib/ProjectM36/TransactionGraph/Persist.hs+60−27 test/MultiProcessDatabaseAccess.hs+53 test/TransactionGraph/Persist.hs+2−2 test/TutorialD/Interpreter.hs+1−1

Changelog.markdown+8

@@ -1,3 +1,11 @@

1+# 2017-06-12

3+## add file locking

5+This [feature](#102) allows Project:M36 database directories to be shared amongst multiple Project:M36 processes. This is similar to how SQLite operates except that the remote server mode supports the feature as well. This could allow, for example, multi-master, file-based replication across Windows shares or NFS.

7+[Documentation](/docs/replication.markdown)

19# 2016-11-30

210

311## add functional dependency macro

docs/acid_assessment.markdown+2−2

@@ -41,6 +41,6 @@ However, Project:M36 allows the user to disable fsync()'ing, for example, for th

4141

4242In addition, Project:M36 relies on the user to use Project:M36 databases on ordered, journaled metadata filesystems only. A future improvement could be to detect scenarios under which Project:M36 is not offering guaranteed durability. Write-ahead-logs do not suffer from this requirement.

4343

44−We feel that these potential pitfalls warrant removing an arbitrary 10% from the compliance scale because there is room for further improvement here. It is, however, possible to use Project:M36 with full durability guarantees.

44+Database directories can be shared across multiple Project:M36 database processes. This operates similarly to SQLite and relies on POSIX advisory locking and Windows file locking to ensure consistency.

4545

46−Compliance: 90%

46+Compliance: 100%

docs/replication.markdownnew file+30

@@ -0,0 +1,30 @@

1+# Project:M36 Multi-Node Replication

3+## Introduction

5+The stored transaction graph feature makes Project:M36 naturally more suitable for replication. Just like with git, having access to historical transactions makes merging transactional data much more logical and unambiguous.

7+## Current Multi-Master Support

9+Project:M36 plans to support logical replication in the future. In the meantime, multi-master replication is supported through shared database directories. Using NFS or SMB shares where file locking is properly supported, one can run multiple ```project-m36-server``` instances on the same database directory. This is a shared-storage form of multi-master operation.

10+

11+Multi-master replication is enabled and reasonably fast due to the intentional design decision to rewrite as few files as possible. Typical databases write and rewrite the same files which back relation variables (or tables) directly which necessitates heavy use of file locking or even locks on file content regions. Project:M36 operates on a write-once, read-many (WORM) principle whereby transaction data can be written without holding locks so only the transaction graph itself needs synchronization.

12+

13+Multi-master support can also be useful for simple databases where one wishes to avoid running and maintaining a ```project-m36-server```. Instead, one can create in-process database instances which share the same database directory. This is similar to the use-case for SQLite. However, Project:M36 seamlessly supports server and in-process modes which makes moving from a small, local database to a larger server installation trivial; the storage format is identical.

14+

15+To use the simple multi-master mode, start two instances of ```project-m36-server``` which point at the same local or remote database directory over NFS or SMB. No further configuration is required.

16+

17+## Caveats

18+

19+Project:M36 does not and cannot detect if the filesystem's implementation of file locking is actually functioning.

20+

21+On Linux and macOS, any recent on-disk filesystems and NFS should support POSIX advisory locking, as required. However, sharing the database over samba (SMB) shares or mixed operating systems may result in database transaction graph corruption. The symptom will be that arbitrary, committed transactions may be missing from the transaction graph.

22+

23+On Windows, locking is implemented using mandatory locking controls which any supported version of Windows offers. Cross-platform use of locking (such as with samba server on Linux) is probably *not* safe.

24+

25+If a commit happens behind the back of another ```project-m36-server``` and one server attempts to commit, two possibilities can occur:

26+

27+1. The commits occurred on two disparate branches, so the transaction graph can be updated without conflict.

28+1. The commits occurred on the same branch, so one transaction commit will be rejected with a ```TransactionIsNotAHead``` error. This means that the head (leaf node) of the transaction graph for that branch has moved on, so the transaction needs to be re-executed and committed.

29+

30+To avoid ```TransactionIsNotAHead``` errors, branch the transaction graph and merge it to the head when ready to commit.

project-m36.cabal+26−11

@@ -66,6 +66,8 @@ Library

6666 ,list-t

6767 ,optparse-applicative

6868 ,Glob

69+--used for hashing the transaction graph file to check for differences

70+ ,cryptohash-sha256

6971 Exposed-Modules: ProjectM36.Error,

7072 ProjectM36.Transaction,

7173 ProjectM36.TransactionGraph,

@@ -125,10 +127,11 @@ Library

125127 ProjectM36.Sessions,

126128 ProjectM36.Transaction.Persist,

127129 ProjectM36.TypeConstructor,

128− ProjectM36.TypeConstructorDef

130+ ProjectM36.TypeConstructorDef,

131+ ProjectM36.FileLock

129132 GHC-Options: -Wall

130133 if os(windows)

131− Build-Depends: Win32 >= 2.3 && < 2.4

134+ Build-Depends: Win32 >= 2.3

132135 Other-Modules: ProjectM36.Win32Handle

133136 else

134137 C-sources: cbits/DirectoryFsync.c

@@ -271,7 +274,7 @@ Test-Suite test-tutoriald

271274 Default-Extensions: OverloadedStrings

272275 type: exitcode-stdio-1.0

273276 main-is: test/TutorialD/Interpreter.hs

274− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36 == 0.1, random, MonadRandom

277+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36 == 0.1, random, MonadRandom, semigroups

275278 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator

276279 GHC-Options: -Wall

277280 Hs-Source-Dirs: ./src/bin, ., test

@@ -283,7 +286,7 @@ Test-Suite test-tutoriald-atomfunctionscript

283286 type: exitcode-stdio-1.0

284287 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator

285288 main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs

286− Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom

289+ Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups

287290 GHC-Options: -Wall

288291 Hs-Source-Dirs: ./src/bin, ./test, .

289292 CPP-Options: -DPROJECTM36_VERSION="v0.1"

@@ -294,7 +297,7 @@ Test-Suite test-tutoriald-databasecontextfunctionscript

294297 type: exitcode-stdio-1.0

295298 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator

296299 main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs

297− Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom

300+ Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups

298301 GHC-Options: -Wall

299302 Hs-Source-Dirs: ./src/bin, ./test, .

300303 CPP-Options: -DPROJECTM36_VERSION="v0.1"

@@ -321,7 +324,7 @@ Test-Suite test-transactiongraph-persist

321324 Default-Extensions: OverloadedStrings

322325 type: exitcode-stdio-1.0

323326 main-is: test/TransactionGraph/Persist.hs

324− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1, random, MonadRandom

327+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1, random, MonadRandom, semigroups

325328 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples

326329 Hs-Source-Dirs: ., ./src/bin

327330 GHC-Options: -Wall

@@ -340,7 +343,7 @@ Test-Suite test-tutoriald-import-tutoriald

340343 Default-Extensions: OverloadedStrings

341344 type: exitcode-stdio-1.0

342345 main-is: test/TutorialD/Interpreter/Import/TutorialD.hs

343− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1, random, MonadRandom

346+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1, random, MonadRandom, semigroups

344347 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples

345348 GHC-Options: -Wall

346349 Hs-Source-Dirs: ., ./src/bin

@@ -375,7 +378,7 @@ Test-Suite test-server

375378 Default-Extensions: OverloadedStrings

376379 type: exitcode-stdio-1.0

377380 main-is: test/Server/Main.hs

378− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36 == 0.1, network-transport

381+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36 == 0.1, network-transport, semigroups

379382 HS-Source-Dirs: ., ./src/bin

380383 GHC-Options: -Wall

381384

@@ -407,7 +410,7 @@ Test-Suite test-scripts

407410 Default-Extensions: OverloadedStrings

408411 type: exitcode-stdio-1.0

409412 main-is: test/scripts.hs

410− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36 == 0.1, random, MonadRandom

413+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36 == 0.1, random, MonadRandom, semigroups

411414 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples

412415 GHC-Options: -Wall

413416 Hs-Source-Dirs: ., ./src/bin

@@ -426,7 +429,7 @@ Test-Suite test-websocket-server

426429 Default-Language: Haskell2010

427430 type: exitcode-stdio-1.0

428431 main-is: test/Server/WebSocket.hs

429− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom, network-transport-tcp

432+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom, network-transport-tcp, semigroups

430433 Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator

431434 Default-Extensions: OverloadedStrings

432435 GHC-Options: -Wall

@@ -447,8 +450,20 @@ Test-Suite test-atomable

447450 Default-Language: Haskell2010

448451 type: exitcode-stdio-1.0

449452 main-is: test/Relation/Atomable.hs

453+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom, semigroups

454+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types

455+ Default-Extensions: OverloadedStrings

456+ GHC-Options: -Wall

457+ Hs-Source-Dirs: ./src/bin, ., test/

458+ CPP-Options: -DPROJECTM36_VERSION="v0.1"

459+

460+Test-Suite test-multiprocess-access

461+ Default-Language: Haskell2010

462+ type: exitcode-stdio-1.0

463+ main-is: test/MultiProcessDatabaseAccess.hs

450464 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom

451465 Default-Extensions: OverloadedStrings

452466 GHC-Options: -Wall

453467 Hs-Source-Dirs: ./src/bin, ., test/

454− CPP-Options: -DPROJECTM36_VERSION="v0.1"

468+ CPP-Options: -DPROJECTM36_VERSION="v0.1"

469+

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+1

@@ -134,6 +134,7 @@ instance ToJSON MergeStrategy

134134instance FromJSON MergeStrategy

135135

136136instance ToJSON PersistenceError

137+instance FromJSON PersistenceError

137138

138139instance ToJSON AtomFunctionError

139140instance FromJSON AtomFunctionError

src/lib/ProjectM36/Client.hs+103−63

@@ -20,7 +20,7 @@ module ProjectM36.Client

2020 typeForRelationalExpr,

2121 inclusionDependencies,

2222 planForDatabaseContextExpr,

23− processPersistence,

23+ processTransactionGraphPersistence,

2424 currentSchemaName,

2525 SchemaName,

2626 HeadName,

@@ -101,6 +101,7 @@ import ProjectM36.TransactionGraph.Persist

101101import ProjectM36.Attribute hiding (atomTypes)

102102import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)

103103import ProjectM36.Persist (DiskSync(..))

104+import ProjectM36.FileLock

104105import ProjectM36.Notifications

105106import ProjectM36.Server.RemoteCallTypes

106107import qualified ProjectM36.DisconnectedTransaction as Discon

@@ -108,6 +109,8 @@ import ProjectM36.Relation (typesAsRelation)

108109import ProjectM36.ScriptSession (initScriptSession, ScriptSession)

109110import qualified ProjectM36.Relation as R

110111import qualified ProjectM36.DatabaseContext as DBC

112+import Control.Exception.Base

113+import GHC.Conc.Sync

111114

112115import Network.Transport (Transport(closeTransport))

113116import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)

@@ -117,7 +120,6 @@ import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)

117120import Control.Distributed.Process (NodeId(..), reconnect)

118121

119122import Data.UUID.V4 (nextRandom)

120−import Control.Concurrent.STM

121123import Data.Word

122124import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match)

123125import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception)

@@ -134,6 +136,7 @@ import Data.Binary (Binary)

134136import GHC.Generics (Generic)

135137import Control.DeepSeq (force)

136138import System.IO

139+import qualified Crypto.Hash.SHA256 as SHA256

137140

138141type Hostname = String

139142

@@ -195,6 +198,8 @@ defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (c

195198-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

196199type ClientNodes = STMSet.Set ProcessId

197200

201+type TransactionGraphLockHandle = Handle

202+

198203-- internal structure specific to in-process connections

199204data InProcessConnectionConf = InProcessConnectionConf {

200205 ipPersistenceStrategy :: PersistenceStrategy,

@@ -203,7 +208,8 @@ data InProcessConnectionConf = InProcessConnectionConf {

203208 ipTransactionGraph :: TVar TransactionGraph,

204209 ipScriptSession :: Maybe ScriptSession,

205210 ipLocalNode :: LocalNode,

206− ipTransport :: Transport -- we hold onto this so that we can close it gracefully

211+ ipTransport :: Transport, -- we hold onto this so that we can close it gracefully

212+ ipLocks :: Maybe (TransactionGraphLockHandle, MVar LockFileHash) -- nothing when NoPersistence

207213 }

208214

209215data RemoteProcessConnectionConf = RemoteProcessConnectionConf {

@@ -275,14 +281,16 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPath

275281 (localNode, transport) <- createLocalNode

276282 notificationPid <- startNotificationListener localNode notificationCallback

277283 mScriptSession <- createScriptSession ghcPkgPaths

284+

278285 let conn = InProcessConnection (InProcessConnectionConf {

279− ipPersistenceStrategy =strat,

286+ ipPersistenceStrategy = strat,

280287 ipClientNodes = clientNodes,

281288 ipSessions = sessions,

282289 ipTransactionGraph = graphTvar,

283290 ipScriptSession = mScriptSession,

284291 ipLocalNode = localNode,

285− ipTransport = transport })

292+ ipTransport = transport,

293+ ipLocks = Nothing})

286294 addClientNode conn notificationPid

287295 pure (Right conn)

288296 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

@@ -318,8 +326,8 @@ connectPersistentProjectM36 :: PersistenceStrategy ->

318326connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghcPkgPaths = do

319327 err <- setupDatabaseDir sync dbdir freshGraph

320328 case err of

321− Just err' -> return $ Left (SetupDatabaseDirectoryError err')

322− Nothing -> do

329+ Left err' -> return $ Left (SetupDatabaseDirectoryError err')

330+ Right (lockFileH, digest) -> do

323331 mScriptSession <- createScriptSession ghcPkgPaths

324332 graph <- transactionGraphLoad dbdir emptyTransactionGraph mScriptSession

325333 case graph of

@@ -329,6 +337,7 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

329337 sessions <- STMMap.newIO

330338 clientNodes <- STMSet.newIO

331339 (localNode, transport) <- createLocalNode

340+ lockMVar <- newMVar digest

332341 let conn = InProcessConnection (InProcessConnectionConf {

333342 ipPersistenceStrategy = strat,

334343 ipClientNodes = clientNodes,

@@ -336,7 +345,8 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

336345 ipTransactionGraph = tvarGraph,

337346 ipScriptSession = mScriptSession,

338347 ipLocalNode = localNode,

339− ipTransport = transport

348+ ipTransport = transport,

349+ ipLocks = Just (lockFileH, lockMVar)

340350 })

341351

342352 notificationPid <- startNotificationListener localNode notificationCallback

@@ -569,19 +579,17 @@ executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excMayb

569579 pure Nothing

570580executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)

571581

572−executeGraphExprSTM_ :: TransactionId -> SessionId -> Sessions -> TransactionGraphOperator -> TVar TransactionGraph -> STM (Either RelationalError TransactionGraph)

573−executeGraphExprSTM_ freshId sessionId sessions graphExpr graphTvar = do

574− graph <- readTVar graphTvar

575− eSession <- sessionForSessionId sessionId sessions

576− case eSession of

577− Left err -> pure $ Left err

578− Right session -> case evalGraphOp freshId (Sess.disconnectedTransaction session) graph graphExpr of

579− Left err -> pure $ Left err

580− Right (discon', graph') -> do

581− writeTVar graphTvar graph'

582− let newSession = Session discon' (Sess.schemaName session)

583− STMMap.insert newSession sessionId sessions

584− pure $ Right graph'

582+executeGraphExprSTM_ :: Bool -> TransactionId -> SessionId -> Session -> Sessions -> TransactionGraphOperator -> TransactionGraph -> TVar TransactionGraph -> STM (Either RelationalError TransactionGraph)

583+executeGraphExprSTM_ updateGraphOnError freshId sessionId session sessions graphExpr graph graphTVar= do

584+ case evalGraphOp freshId (Sess.disconnectedTransaction session) graph graphExpr of

585+ Left err -> do

586+ when updateGraphOnError (writeTVar graphTVar graph)

587+ pure $ Left err

588+ Right (discon', graph') -> do

589+ writeTVar graphTVar graph'

590+ let newSession = Session discon' (Sess.schemaName session)

591+ STMMap.insert newSession sessionId sessions

592+ pure $ Right graph'

585593

586594-- process notifications for commits

587595executeCommitExprSTM_ :: DatabaseContext -> DatabaseContext -> ClientNodes -> STM (EvaluatedNotifications, ClientNodes)

@@ -591,54 +599,81 @@ executeCommitExprSTM_ oldContext newContext nodes = do

591599 evaldNots = M.map mkEvaldNot fireNots

592600 mkEvaldNot notif = EvaluatedNotification { notification = notif, reportRelation = evalState (RE.evalRelationalExpr (reportExpr notif)) (RE.mkRelationalExprState oldContext) }

593601 pure (evaldNots, nodes)

594−

595−

602+

596603-- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators modify the transaction graph state.

604+-- OPTIMIZATION OPPORTUNITY: no locks are required to write new transaction data, only to update the transaction graph id file

605+-- if writing data is re-entrant, we may be able to use unsafeIOtoSTM

606+-- perhaps keep hash of data file instead of checking if our head was updated on every write

597607executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)

598608executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excMaybe $ do

599609 let strat = ipPersistenceStrategy conf

600610 clientNodes = ipClientNodes conf

601611 sessions = ipSessions conf

602612 graphTvar = ipTransactionGraph conf

613+ mLockFileH = ipLocks conf

614+ lockHandler body = case graphExpr of

615+ Commit -> case mLockFileH of

616+ Nothing -> body False

617+ Just (lockFileH, lockMVar) -> let acquireLocks = do

618+ lastWrittenDigest <- takeMVar lockMVar

619+ lockFile lockFileH WriteLock

620+ latestDigest <- readGraphTransactionIdDigest strat

621+ pure (latestDigest /= lastWrittenDigest)

622+

623+ releaseLocks _ = do

624+ --still holding the lock- get the latest digest

625+ gDigest <- readGraphTransactionIdDigest strat

626+ unlockFile lockFileH

627+ putMVar lockMVar gDigest

628+ in bracket acquireLocks releaseLocks body

629+ _ -> body False

603630 freshId <- nextRandom

604− manip <- atomically $ do

605− eSession <- sessionForSessionId sessionId sessions

606− oldGraph <- readTVar graphTvar

607− case eSession of

608− Left err -> pure (Left err)

609− Right session -> do

610− eGraph <- executeGraphExprSTM_ freshId sessionId sessions graphExpr graphTvar

611− case eGraph of

612− Left err -> pure (Left err)

613− Right newGraph -> do

614− if graphExpr == Commit then

615− case transactionForId (Sess.parentId session) oldGraph of

616− Left err -> pure $ Left err

617− Right previousTrans -> do

618− (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

619− nodesToNotify <- toList (STMSet.stream nodes)

620− pure $ Right (evaldNots, nodesToNotify, newGraph)

621− else

622− pure $ Right (M.empty, [], newGraph)

623− case manip of

624− Left err -> return $ Just err

625− Right (notsToFire, nodesToNotify, newGraph) -> do

626− --update filesystem database, if necessary

627− --this should really grab a lock at the beginning of the method to be threadsafe

628− processPersistence strat newGraph

629− sendNotifications nodesToNotify (ipLocalNode conf) notsToFire

630− return Nothing

631+ lockHandler $ \dbWrittenByOtherProcess -> do

632+ --if the database file has been updated since we wrote it last, load it before trying to sync our version done- this can result in TransactionNotAHeadErrors

633+ --read transaction data and compare to existing graph

634+ --in the future, we can detect if updated transaction graph can be safely merged (such as with a transaction on a separate head) (rebase-able commits should force the user to rebase from the client to confirm that the action makes sense)

635+ manip <- atomically $ do

636+ eSession <- sessionForSessionId sessionId sessions

637+ --handle graph update by other process

638+ oldGraph <- readTVar graphTvar

639+ case eSession of

640+ Left err -> pure (Left err)

641+ Right session -> do

642+ let mScriptSession = ipScriptSession conf

643+ dbdir = case strat of

644+ MinimalPersistence x -> x

645+ CrashSafePersistence x -> x

646+ _ -> error "accessing dbdir on non-persisted connection"

647+ eRefreshedGraph <- if dbWrittenByOtherProcess then

648+ unsafeIOToSTM (transactionGraphLoad dbdir oldGraph mScriptSession)

649+ else

650+ pure (Right oldGraph)

651+ case eRefreshedGraph of

652+ Left err -> pure (Left (DatabaseLoadError err))

653+ Right refreshedGraph -> do

654+ eGraph <- executeGraphExprSTM_ dbWrittenByOtherProcess freshId sessionId session sessions graphExpr refreshedGraph graphTvar

655+ case eGraph of

656+ Left err -> pure (Left err)

657+ Right newGraph -> do

658+ --handle commit

659+ if graphExpr == Commit then

660+ case transactionForId (Sess.parentId session) oldGraph of

661+ Left err -> pure $ Left err

662+ Right previousTrans -> do

663+ (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

664+ nodesToNotify <- toList (STMSet.stream nodes)

665+ pure $ Right (evaldNots, nodesToNotify, newGraph)

666+ else

667+ pure $ Right (M.empty, [], newGraph)

668+ case manip of

669+ Left err -> return $ Just err

670+ Right (notsToFire, nodesToNotify, newGraph) -> do

671+ --update filesystem database, if necessary

672+ processTransactionGraphPersistence strat newGraph

673+ sendNotifications nodesToNotify (ipLocalNode conf) notsToFire

674+ pure Nothing

631675executeGraphExpr sessionId conn@(RemoteProcessConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr)

632676

633−{-

634−commitSTM_ :: UUID -> SessionId -> Sessions -> TVar TransactionGraph -> STM (Maybe RelationalError)

635−commitSTM_ freshUUID sessionId sessions graph = do

636− mErr <- executeGraphExprSTM_ freshUUID sessionId sessions Commit graph

637− pure $ case mErr of

638− Left err -> Just err

639− Right _ -> Nothing

640−-}

641−

642677-- | A trans-graph expression is a relational query executed against the entirety of a transaction graph.

643678executeTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation)

644679executeTransGraphRelationalExpr _ (InProcessConnection conf) tgraphExpr = excEither . atomically $ do

@@ -686,10 +721,15 @@ rollback :: SessionId -> Connection -> IO (Maybe RelationalError)

686721rollback sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Rollback

687722rollback sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback)

688723

689−processPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()

690−processPersistence NoPersistence _ = return ()

691−processPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist NoDiskSync dbdir graph

692−processPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist FsyncDiskSync dbdir graph

724+processTransactionGraphPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()

725+processTransactionGraphPersistence NoPersistence _ = pure ()

726+processTransactionGraphPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist NoDiskSync dbdir graph >> pure ()

727+processTransactionGraphPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist FsyncDiskSync dbdir graph >> pure ()

728+

729+readGraphTransactionIdDigest :: PersistenceStrategy -> IO (LockFileHash)

730+readGraphTransactionIdDigest NoPersistence = error "attempt to read digest from transaction log without persistence enabled"

731+readGraphTransactionIdDigest (MinimalPersistence dbdir) = readGraphTransactionIdFileDigest dbdir

732+readGraphTransactionIdDigest (CrashSafePersistence dbdir) = readGraphTransactionIdFileDigest dbdir

693733

694734-- | Return a relation whose type would match that of the relational expression if it were executed. This is useful for checking types and validating a relational expression's types.

695735typeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

src/lib/ProjectM36/DataTypes/DateTime.hs−1

@@ -3,7 +3,6 @@ import ProjectM36.Base

33import ProjectM36.AtomFunctionBody

44import qualified Data.HashSet as HS

55import Data.Time.Clock.POSIX

6−import Data.Time.Clock

87dateTimeAtomFunctions :: AtomFunctions

98dateTimeAtomFunctions = HS.fromList [ AtomFunction {

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

@@ -81,6 +81,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

8181 | MergeTransactionError MergeError

8282 | ScriptError ScriptCompilationError

8383 | DatabaseContextFunctionUserError DatabaseContextFunctionError

84+ | DatabaseLoadError PersistenceError

8485

8586 | SubschemaNameInUseError SchemaName

8687 | SubschemaNameNotInUseError SchemaName

@@ -94,7 +95,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

9495

9596data PersistenceError = InvalidDirectoryError FilePath |

9697 MissingTransactionError TransactionId

97− deriving (Show, Eq, Generic)

98+ deriving (Show, Eq, Generic, Binary, NFData)

9899

99100--collapse list of errors into normal error- if there is just one, just return one

100101someErrors :: [RelationalError] -> RelationalError

src/lib/ProjectM36/FileLock.hsnew file+85

@@ -0,0 +1,85 @@

1+{-# LANGUAGE CPP #-}

2+--cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking

3+--hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite

4+module ProjectM36.FileLock where

5+import System.IO

8+#if defined(mingw32_HOST_OS)

9+import ProjectM36.Win32Handle

10+import System.Win32.Types

11+import Foreign.Marshal.Alloc

12+import System.Win32.File

13+import System.Win32.Mem

14+import Data.Bits

15+

16+#if defined(i386_HOST_ARCH)

17+# define WINDOWS_CCONV stdcall

18+#elif defined(x86_64_HOST_ARCH)

19+# define WINDOWS_CCONV ccall

20+#else

21+# error Unknown mingw32 arch

22+#endif

23+foreign import WINDOWS_CCONV "LockFileEx" c_lockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL

24+

25+foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL

26+

27+--swiped from System.FileLock package

28+lockFile :: Handle -> LockType -> IO ()

29+lockFile handle lock = withHandleToHANDLE handle $ \winHandle -> do

30+ let exFlag = case lock of

31+ WriteLock -> 2

32+ ReadLock -> 0

33+ blockFlag = 0 --always block

34+ sizeof_OVERLAPPED = 32

35+

36+ allocaBytes sizeof_OVERLAPPED $ \op -> do

37+ zeroMemory op $ fromIntegral sizeof_OVERLAPPED

38+ res <- c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op

39+ if res then

40+ pure ()

41+ else

42+ error "failed to wait for database lock"

43+

44+unlockFile :: Handle -> IO ()

45+unlockFile handle = withHandleToHANDLE handle $ \winHandle -> do

46+ let sizeof_OVERLAPPED = 32

47+ allocaBytes sizeof_OVERLAPPED $ \op -> do

48+ zeroMemory op $ fromIntegral sizeof_OVERLAPPED

49+ res <- c_unlockFileEx winHandle 0 1 0 op

50+ if res then

51+ pure ()

52+ else

53+ error ("failed to unlock database lock: " ++ show res)

54+

55+#else

56+import qualified System.Posix.IO as P

57+

58+lockStruct :: P.LockRequest -> P.FileLock

59+lockStruct req = (req, AbsoluteSeek, 0, 0)

60+

61+--blocks on lock, if necessary

62+lockFile :: Handle -> LockType -> IO ()

63+lockFile file lock = do

64+ fd <- P.handleToFd file

65+ let lockt = case lock of

66+ WriteLock -> P.WriteLock

67+ ReadLock -> P.ReadLock

68+ P.waitToSetLock fd (lockStruct lockt)

69+

70+unlockFile :: Handle -> IO ()

71+unlockFile file = do

72+ fd <- P.handleToFd file

73+ P.waitToSetLock fd (lockStruct P.Unlock)

74+#endif

75+

76+data LockType = ReadLock | WriteLock

77+

78+{-

79+lockFileSTM :: Handle -> LockType -> STM ()

80+lockFileSTM file lock = unsafeIOToSTM $ onException (lockFile file lock) (unlockFile file)

81+

82+unlockFileSTM :: Handle -> STM ()

83+unlockFileSTM file = unsafeIOToSTM $ unlockFile file

84+-}

85+

src/lib/ProjectM36/Persist.hs+5−4

@@ -5,7 +5,8 @@ module ProjectM36.Persist (writeFileSync,

55 renameSync,

66 DiskSync(..)) where

77-- on Windows, use FlushFileBuffers and MoveFileEx

8−

8+import qualified Data.Text.IO as TIO

9+import Data.Text

910#if defined(mingw32_HOST_OS)

1011import qualified System.Win32 as Win32

1112#else

@@ -19,7 +20,7 @@ import System.Posix.IO (handleToFd)

1920import Foreign.C

2021#endif

2122

22−import System.IO (withFile, IOMode(WriteMode), hPutStr, Handle)

23+import System.IO (withFile, IOMode(WriteMode), Handle)

2324import qualified Data.ByteString.Lazy as BS

2425

2526#if defined(mingw32_HOST_OS)

@@ -30,11 +31,11 @@ foreign import ccall unsafe "cDirectoryFsync" cHSDirectoryFsync :: CString -> IO

3031

3132data DiskSync = NoDiskSync | FsyncDiskSync

3233

33−writeFileSync :: DiskSync -> FilePath -> String -> IO()

34+writeFileSync :: DiskSync -> FilePath -> Text -> IO()

3435writeFileSync sync path strOut = withFile path WriteMode handler

3536 where

3637 handler handle = do

37− hPutStr handle strOut

38+ TIO.hPutStr handle strOut

3839 syncHandle sync handle

3940

4041renameSync :: DiskSync -> FilePath -> FilePath -> IO ()

src/lib/ProjectM36/TransactionGraph.hs+4−4

@@ -17,7 +17,6 @@ import GHC.Generics

1717import Data.Binary

1818import ProjectM36.TransactionGraph.Merge

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

20−--import Debug.Trace

2120

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

2322data TransactionIdLookup = TransactionIdLookup TransactionId |

@@ -55,7 +54,10 @@ emptyTransactionGraph :: TransactionGraph

5554emptyTransactionGraph = TransactionGraph M.empty S.empty

5655

5756transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction

58−transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads

57+transactionForHead headName graph = M.lookup headName (transactionHeadsForGraph graph)

58+

59+headList :: TransactionGraph -> [(HeadName, TransactionId)]

60+headList graph = map (\(k,v) -> (k, transactionId v)) (M.assocs (transactionHeadsForGraph graph))

5961

6062headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName

6163headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then

@@ -186,7 +188,6 @@ walkChildTransactions seenTransSet graph trans =

186188-- the current transaction is not part of the transaction graph until it is committed

187189evalGraphOp :: TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

188190

189−--affects only disconncted transaction

190191evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of

191192 Left err -> Left err

192193 Right parentTrans -> Right (newTrans, graph)

@@ -194,7 +195,6 @@ evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId

194195 newTrans = DisconnectedTransaction jumpId (schemas parentTrans)

195196

196197-- switch from one head to another

197−-- affects only disconnectedtransaction

198198evalGraphOp _ _ graph (JumpToHead headName) =

199199 case transactionForHead headName graph of

200200 Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) in

src/lib/ProjectM36/TransactionGraph/Persist.hs+60−27

@@ -6,17 +6,26 @@ import ProjectM36.Transaction.Persist

66import ProjectM36.Base

77import ProjectM36.ScriptSession

88import ProjectM36.Persist (writeFileSync, renameSync, DiskSync)

9+import ProjectM36.FileLock

910import System.Directory

1011import System.FilePath

1112import System.IO.Temp

12−import Data.List

13+import System.IO

1314import qualified Data.UUID as U

1415import qualified Data.Set as S

1516import qualified Data.Map as M

1617import qualified Data.Text as T

18+import Data.Text.Encoding

1719import Control.Monad (foldM)

1820import Data.Either (isRight)

1921import Data.Maybe (catMaybes)

22+import Control.Exception.Base

23+import qualified Data.Text.IO as TIO

24+import Data.ByteString (ByteString)

25+import Data.Monoid

26+import qualified Crypto.Hash.SHA256 as SHA256

27+

28+type LockFileHash = ByteString

2029

2130{-

2231The "m36v1" file at the top-level of the destination directory contains the the transaction graph as a set of transaction ids referencing their parents (1 or more)

@@ -31,44 +40,63 @@ transactionLogPath dbdir = dbdir </> "m36v1"

3140headsPath :: FilePath -> FilePath

3241headsPath dbdir = dbdir </> "heads"

3342

43+lockFilePath :: FilePath -> FilePath

44+lockFilePath dbdir = dbdir </> "lockFile"

45+

3446{-

3547verify that the database directory is valid or bootstrap it

3648-note: checking for the existence of every transaction may be prohibitively expensive

49+- return error or lock file handle which is already locked with a read lock

3750-}

3851

39−setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Maybe PersistenceError)

52+setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (Handle, LockFileHash))

4053setupDatabaseDir sync dbdir bootstrapGraph = do

4154 dbdirExists <- doesDirectoryExist dbdir

4255 m36exists <- doesFileExist (transactionLogPath dbdir)

43− if dbdirExists && m36exists then

44− return Nothing

56+ if dbdirExists && m36exists then do

57+ --no directories to write, just

58+ lockFileH <- openLockFile dbdir

59+ gDigest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (readGraphTransactionIdFileDigest dbdir)

60+ pure (Right (lockFileH, gDigest))

4561 else if not m36exists then do

46− bootstrapDatabaseDir sync dbdir bootstrapGraph

47− return Nothing

62+ locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph

63+ pure (Right locks)

4864 else

49− return $ Just (InvalidDirectoryError dbdir)

50−

65+ pure (Left (InvalidDirectoryError dbdir))

5166{-

52−initialize a database directory with the graph from which to bootstrap

67+initialize a database directory with the graph from which to bootstrap- return lock file handle

5368-}

54−bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO ()

69+bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Handle, LockFileHash)

5570bootstrapDatabaseDir sync dbdir bootstrapGraph = do

5671 createDirectory dbdir

57− transactionGraphPersist sync dbdir bootstrapGraph

72+ lockFileH <- openLockFile dbdir

73+ digest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (transactionGraphPersist sync dbdir bootstrapGraph)

74+ pure (lockFileH, digest)

75+

76+openLockFile :: FilePath -> IO (Handle)

77+openLockFile dbdir = do

78+ lockFileH <- openFile (lockFilePath dbdir) WriteMode

79+ pure lockFileH

5880

5981{-

6082incrementally updates an existing database directory

6183--algorithm:

62−-check that all heads have been written

84+--assume that all transaction data has already been written

6385-assume that all non-head transactions have already been written because this is an incremental (and concurrent!) write method

6486--store the head names with a symlink to the transaction under "heads"

6587-}

66−transactionGraphPersist :: DiskSync -> FilePath -> TransactionGraph -> IO ()

88+transactionGraphPersist :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash

6789transactionGraphPersist sync destDirectory graph = do

68− mapM_ (writeTransaction sync destDirectory) $ M.elems (transactionHeadsForGraph graph)

69− writeGraphTransactionIdFile sync destDirectory graph

90+ transactionHeadTransactionsPersist sync destDirectory graph

91+ --write graph file

92+ newDigest <- writeGraphTransactionIdFile sync destDirectory graph

93+ --write heads file

7094 transactionGraphHeadsPersist sync destDirectory graph

71− return ()

95+ pure newDigest

96+

97+-- | The incremental writer which only writes from the set of heads. New heads must be written on every commit. Most heads will already be written on every commit.

98+transactionHeadTransactionsPersist :: DiskSync -> FilePath -> TransactionGraph -> IO ()

99+transactionHeadTransactionsPersist sync destDirectory graphIn = mapM_ (writeTransaction sync destDirectory) $ M.elems (transactionHeadsForGraph graphIn)

72100

73101{-

74102write graph heads to a file which can be atomically swapped

@@ -76,12 +104,12 @@ write graph heads to a file which can be atomically swapped

76104--writing the heads in a directory is a synchronization nightmare, so just write the binary to a file and swap atomically

77105transactionGraphHeadsPersist :: DiskSync -> FilePath -> TransactionGraph -> IO ()

78106transactionGraphHeadsPersist sync dbdir graph = do

79− let headFileStr :: (HeadName, Transaction) -> String

80− headFileStr (headName, trans) = T.unpack headName ++ " " ++ U.toString (transactionId trans)

107+ let headFileStr :: (HeadName, Transaction) -> T.Text

108+ headFileStr (headName, trans) = headName <> " " <> U.toText (transactionId trans)

81109 withTempDirectory dbdir ".heads.tmp" $ \tempHeadsDir -> do

82110 let tempHeadsPath = tempHeadsDir </> "heads"

83111 headsStrLines = map headFileStr $ M.toList (transactionHeadsForGraph graph)

84− writeFileSync sync tempHeadsPath $ intercalate "\n" headsStrLines

112+ writeFileSync sync tempHeadsPath $ T.intercalate "\n" headsStrLines

85113 renameSync sync tempHeadsPath (headsPath dbdir)

86114

87115transactionGraphHeadsLoad :: FilePath -> IO [(HeadName,TransactionId)]

@@ -96,7 +124,6 @@ transactionGraphHeadsLoad dbdir = do

96124load any transactions which are not already part of the incoming transaction graph

97125-}

98126

99−--ALERT I need to figure out how to manage the transaction heads (branch names)

100127transactionGraphLoad :: FilePath -> TransactionGraph -> Maybe ScriptSession -> IO (Either PersistenceError TransactionGraph)

101128transactionGraphLoad dbdir graphIn mScriptSession = do

102129 --optimization: perform tail-bisection search to find last-recorded transaction in the existing stream- replay the rest

@@ -131,20 +158,26 @@ readTransactionIfNecessary dbdir transId mScriptSession graphIn = do

131158 Left err -> return $ Left err

132159 Right trans' -> return $ Right $ TransactionGraph (transactionHeadsForGraph graphIn) (S.insert trans' (transactionsForGraph graphIn))

133160

134−writeGraphTransactionIdFile :: DiskSync -> FilePath -> TransactionGraph -> IO ()

135−writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = writeFileSync sync graphFile uuidInfo

161+writeGraphTransactionIdFile :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash

162+writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = writeFileSync sync graphFile uuidInfo >> pure digest

136163 where

137164 graphFile = destDirectory </> "m36v1"

138− uuidInfo = intercalate "\n" graphLines

165+ uuidInfo = T.intercalate "\n" graphLines

166+ digest = SHA256.hash (encodeUtf8 uuidInfo)

139167 graphLines = S.toList $ S.map graphLine transSet

140− graphLine trans = U.toString (transactionId trans) ++ " " ++ intercalate " " (S.toList (S.map U.toString $ transactionParentIds trans))

168+ graphLine trans = U.toText (transactionId trans) <> " " <> T.intercalate " " (S.toList (S.map U.toText $ transactionParentIds trans))

169+

170+readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

171+readGraphTransactionIdFileDigest dbdir = do

172+ graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

173+ pure (SHA256.hash (encodeUtf8 graphTransactionIdData))

141174

142175readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, [TransactionId])])

143176readGraphTransactionIdFile dbdir = do

144177 --read in all transactions' uuids

145− let grapher line = let tids = catMaybes (map U.fromString (words line)) in

178+ let grapher line = let tids = catMaybes (map U.fromText (T.words line)) in

146179 (head tids, tail tids)

147180 --warning: uses lazy IO

148− graphTransactionIdData <- readFile (transactionLogPath dbdir)

149− return $ Right (map grapher $ lines graphTransactionIdData)

181+ graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

182+ return $ Right (map grapher $ T.lines graphTransactionIdData)

150183

test/MultiProcessDatabaseAccess.hsnew file+53

@@ -0,0 +1,53 @@

1+--tests which cover multi-process access to the same database directory

2+import Test.HUnit

3+import ProjectM36.Client

4+import ProjectM36.Error

6+import System.IO.Temp

7+import System.Exit

8+import System.FilePath

10+main :: IO ()

11+main = do

12+ tcounts <- runTestTT testList

13+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

14+

15+assertIOEither :: (Show a) => IO (Either a b) -> IO b

16+assertIOEither x = do

17+ ret <- x

18+ case ret of

19+ Left err -> assertFailure (show err) >> undefined

20+ Right val -> pure val

21+

22+assertIONothing :: (Show a) => IO (Maybe a) -> IO ()

23+assertIONothing x = do

24+ ret <- x

25+ case ret of

26+ Nothing -> pure ()

27+ Just err -> assertFailure (show err)

28+

29+testList :: Test

30+testList = TestList [testMultipleProcessAccess]

31+

32+testMultipleProcessAccess :: Test

33+testMultipleProcessAccess = TestCase $ do

34+ withSystemTempDirectory "pm36" $ \tmpdir -> do

35+ let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []

36+ master = "master"

37+ dudExpr = Assign "x" (RelationVariable "true" ())

38+ dbdir = tmpdir </> "db"

39+ conn1 <- assertIOEither $ connectProjectM36 connInfo

40+ conn2 <- assertIOEither $ connectProjectM36 connInfo

41+ session1 <- assertIOEither (createSessionAtHead master conn1)

42+ session2 <- assertIOEither (createSessionAtHead master conn2)

43+ --add a commit on conn1 which conn2 doesn't know about

44+ assertIONothing $ executeDatabaseContextExpr session1 conn1 dudExpr

45+ assertIONothing $ commit session1 conn1

46+

47+ assertIONothing $ executeDatabaseContextExpr session2 conn2 dudExpr

48+ mHeadId <- headTransactionId session2 conn2

49+ headId <- case mHeadId of

50+ Nothing -> assertFailure "headTransactionId failed" >> undefined

51+ Just x -> pure x

52+ res <- commit session2 conn2

53+ assertEqual "commit should fail" (Just (TransactionIsNotAHeadError headId)) res

test/TransactionGraph/Persist.hs+2−2

@@ -42,7 +42,7 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

4242 let dbdir = tempdir </> "dbdir"

4343 freshId <- nextRandom

4444 let graph = bootstrapTransactionGraph freshId dateExamples

45− bootstrapDatabaseDir NoDiskSync dbdir graph

45+ _ <- bootstrapDatabaseDir NoDiskSync dbdir graph

4646 case transactionForHead "master" graph of

4747 Nothing -> assertFailure "Failed to retrieve head transaction for master branch."

4848 Just headTrans -> do

@@ -57,7 +57,7 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

5757 Left err -> assertFailure (show err)

5858 Right (_, graph') -> do

5959 --persist the new graph

60− transactionGraphPersist NoDiskSync dbdir graph'

60+ _ <- transactionGraphPersist NoDiskSync dbdir graph'

6161 --reload the graph from the filesystem and confirm that the transaction is present

6262 graphErr <- transactionGraphLoad dbdir emptyTransactionGraph Nothing

6363 let mapEq graphArg = S.map transactionId (transactionsForGraph graphArg)

test/TutorialD/Interpreter.hs+1−1

@@ -126,7 +126,7 @@ main = do

126126 ("x:=relation{tuple{a Left 3}}", Left (TypeConstructorTypeVarsMismatch (S.fromList ["a","b"]) (S.fromList ["a"]))), -- Left 3, alone is not enough information to imply the type

127127 ("x:=relation{a Either Int Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntAtomType TextAtomType) [IntAtom 3]]]),

128128 --test datetime constructor

129− ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac 1495199790))]])

129+ ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]])

130130 ]

131131

132132assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion