f3f99cd · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP compilation checkpoint

commitf3f99cd4947eeffef0408938b733ef22e4ec414f authorAgentM <agentm@themactionfaction.com> dateWed 12 Oct 2016, 23:36 (10 years ago) parent47bad43

10 files changed+149−81

compare with master

unifiedsplit

project-m36.cabal+1 src/lib/ProjectM36/Base.hs+28−13 src/lib/ProjectM36/Client.hs+23−18 src/lib/ProjectM36/IsomorphicSchema.hs+27−11 src/lib/ProjectM36/Session.hs+9−4 src/lib/ProjectM36/TransGraphRelationalExpression.hs+5−4 src/lib/ProjectM36/Transaction.hs+14−6 src/lib/ProjectM36/Transaction/Persist.hs+22−4 src/lib/ProjectM36/TransactionGraph.hs+20−15 test/IsomorphicSchema.hs−6

project-m36.cabal+1

@@ -85,6 +85,7 @@ Library

8585 ProjectM36.Key,

8686 ProjectM36.DatabaseContext,

8787 ProjectM36.DateExamples,

88+ ProjectM36.DisconnectedTransaction,

8889 ProjectM36.AtomFunctionBody,

8990 ProjectM36.RelationalExpression,

9091 ProjectM36.Relation.Show.HTML,

src/lib/ProjectM36/Base.hs+28−13

@@ -259,15 +259,33 @@ data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructo

259259

260260type InclusionDependencies = M.Map IncDepName InclusionDependency

261261type RelationVariables = M.Map RelVarName Relation

262−

262+

263+type SchemaName = StringType

264+

265+type Subschemas = M.Map SchemaName Schema

266+

267+-- | Every transaction has one concrete database context and any number of isomorphic subschemas.

268+data Schemas = Schemas DatabaseContext Subschemas

269+

263270-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.

264−data DatabaseContext = DatabaseContext {

271+-- I spent some time thinking about whether the VirtualDatabaseContext/Schema and DatabaseContext data constructors should be the same constructor, but that would allow relation variables to be created in a "virtual" context which would appear to defeat the isomorphisms of the contexts. It should be possible to switch to an alternative schema to view the same equivalent information without information loss. However, allowing all contexts to reference another context while maintaining its own relation variables, new types, etc. could be interesting from a security perspective. For example, if a user creates a new relvar in a virtual context, then does it necessarily appear in all linked contexts? After deliberation, I think the relvar should appear in *all* linked contexts to retain the isomorphic properties, even when the isomorphism is for a subset of the context. This hints that the IsoMorphs should allow for "fall-through"; that is, when a relvar is not defined in the virtual context (for morphing), then the lookup should fall through to the underlying context.

272+data Schema = Schema SchemaIsomorphs

273+ deriving (Generic, Binary)

274+

275+data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (Maybe RelVarName, Maybe RelVarName) | --maps one relvar into two relvars (true, false), if the false name is Nothing, no relvar in schemaB is created. This is useful for renaming relation variables between schemas or hiding relvars altogether.

276+ IsoUnion (RelVarName, Maybe RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar

277+ -- IsoTypeConstructor in morphAttrExpr

278+ deriving (Generic, Binary)

279+

280+type SchemaIsomorphs = [SchemaIsomorph]

281+

282+data DatabaseContext = DatabaseContext {

265283 inclusionDependencies :: InclusionDependencies,

266284 relationVariables :: RelationVariables,

267285 atomFunctions :: AtomFunctions,

268286 notifications :: Notifications,

269287 typeConstructorMapping :: TypeConstructorMapping

270− } deriving (Show, Generic)

288+ }

271289

272290type IncDepName = StringType

273291

@@ -276,6 +294,8 @@ data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr der

276294

277295instance Binary InclusionDependency

278296

297+type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr

298+

279299-- | Database context expressions modify the database context.

280300data DatabaseContextExpr =

281301 NoOperation |

@@ -284,7 +304,7 @@ data DatabaseContextExpr =

284304 Assign RelVarName RelationalExpr |

285305 Insert RelVarName RelationalExpr |

286306 Delete RelVarName RestrictionPredicateExpr |

287− Update RelVarName (M.Map AttributeName AtomExpr) RestrictionPredicateExpr |

307+ Update RelVarName AttributeNameAtomExprMap RestrictionPredicateExpr |

288308

289309 AddInclusionDependency IncDepName InclusionDependency |

290310 RemoveInclusionDependency IncDepName |

@@ -331,7 +351,6 @@ type TransactionHeads = M.Map HeadName Transaction

331351

332352-- | The transaction graph is the global database's state which references every committed transaction.

333353data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

334− deriving (Show, Eq)

335354

336355transactionsForGraph :: TransactionGraph -> S.Set Transaction

337356transactionsForGraph (TransactionGraph _ t) = t

@@ -349,23 +368,19 @@ instance Binary TransactionInfo

349368-- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.

350369type TransactionId = UUID

351370

352−data Transaction = Transaction TransactionId TransactionInfo DatabaseContext -- self uuid

353− deriving (Show, Generic)

354−

371+data Transaction = Transaction TransactionId TransactionInfo Schemas

372+

355373--instance Binary Transaction

356374

357375-- | The disconnected transaction represents an in-progress workspace used by sessions before changes are committed. This is similar to git's "index". After a transaction is committed, it is "connected" in the transaction graph and can no longer be modified.

358−data DisconnectedTransaction = DisconnectedTransaction TransactionId DatabaseContext --parentID, context

376+data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas --parentID, context- the context here represents the singular concrete context from the schema

359377

360378transactionId :: Transaction -> TransactionId

361379transactionId (Transaction tid _ _) = tid

362380

363−transactionContext :: Transaction -> DatabaseContext

364−transactionContext (Transaction _ _ context) = context

365−

366381transactionInfo :: Transaction -> TransactionInfo

367382transactionInfo (Transaction _ info _) = info

368−

383+

369384instance Eq Transaction where

370385 (Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB

371386

src/lib/ProjectM36/Client.hs+23−18

@@ -64,6 +64,8 @@ import Control.Monad.State

6464import qualified ProjectM36.RelationalExpression as RE

6565import ProjectM36.DatabaseContext (basicDatabaseContext)

6666import ProjectM36.TransactionGraph

67+import qualified ProjectM36.Transaction as Trans

68+import qualified ProjectM36.DisconnectedTransaction as DTrans

6769import ProjectM36.TransactionGraph.Persist

6870import ProjectM36.Attribute hiding (atomTypes)

6971import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)

@@ -90,6 +92,7 @@ import Control.Distributed.Process.Serializable (Serializable)

9092--import Control.Distributed.Process.Debug

9193import qualified STMContainers.Map as STMMap

9294import qualified STMContainers.Set as STMSet

95+import qualified ProjectM36.Session as Sess

9396import ProjectM36.Session

9497import ProjectM36.Sessions

9598import ListT

@@ -279,7 +282,7 @@ createSessionAtCommit_ commitId newSessionId (InProcessConnection _ _ sessions g

279282 case transactionForId commitId graph of

280283 Left err -> pure (Left err)

281284 Right transaction -> do

282− let freshDiscon = DisconnectedTransaction commitId (transactionContext transaction)

285+ let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction)

283286 keyDuplication <- STMMap.lookup newSessionId sessions

284287 case keyDuplication of

285288 Just _ -> pure $ Left (SessionIdInUseError newSessionId)

@@ -361,7 +364,7 @@ executeRelationalExpr sessionId (InProcessConnection _ _ sessions _ _) expr = ex

361364 eSession <- sessionForSessionId sessionId sessions

362365 case eSession of

363366 Left err -> pure $ Left err

364− Right (Session (DisconnectedTransaction _ context)) -> case evalState (RE.evalRelationalExpr expr) context of

367+ Right (Session discon) -> case evalState (RE.evalRelationalExpr expr) (DTrans.concreteDatabaseContext discon) of

365368 Left err -> pure (Left err)

366369 Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here

367370executeRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)

@@ -373,10 +376,11 @@ executeDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _ _) expr

373376 case eSession of

374377 Left err -> pure $ Just err

375378 Right session -> do

376− case runState (RE.evalContextExpr expr) (sessionContext session) of

379+ case runState (RE.evalContextExpr expr) (Sess.concreteDatabaseContext session) of

377380 (Just err,_) -> return $ Just err

378381 (Nothing, context') -> do

379− let newDiscon = DisconnectedTransaction (sessionParentId session) context'

382+ let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas

383+ newSchemas = Schemas context' (Sess.subschemas session)

380384 newSession = Session newDiscon

381385 STMMap.insert newSession sessionId sessions

382386 pure Nothing

@@ -391,11 +395,12 @@ executeDatabaseContextIOExpr sessionId (InProcessConnection _ _ sessions _ scrip

391395 case eSession of

392396 Left err -> pure $ Just err

393397 Right session -> do

394− res <- RE.evalDatabaseContextIOExpr scriptSession (sessionContext session) expr

398+ res <- RE.evalDatabaseContextIOExpr scriptSession (Sess.concreteDatabaseContext session) expr

395399 case res of

396400 Left err -> pure (Just err)

397401 Right context' -> do

398− let newDiscon = DisconnectedTransaction (sessionParentId session) context'

402+ let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas

403+ newSchemas = Schemas context' (Sess.subschemas session)

399404 newSession = Session newDiscon

400405 atomically $ STMMap.insert newSession sessionId sessions

401406 pure Nothing

@@ -434,16 +439,16 @@ executeGraphExpr sessionId (InProcessConnection strat clientNodes sessions graph

434439 oldGraph <- readTVar graphTvar

435440 case eSession of

436441 Left err -> pure (Left err)

437− Right (Session (DisconnectedTransaction parentId currentContext)) -> do

442+ Right session -> do

438443 eGraph <- executeGraphExprSTM_ freshId sessionId sessions graphExpr graphTvar

439444 case eGraph of

440445 Left err -> pure (Left err)

441446 Right newGraph -> do

442447 if graphExpr == Commit then

443− case transactionForId parentId oldGraph of

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

444449 Left err -> pure $ Left err

445− Right (Transaction _ _ previousContext) -> do

446− (evaldNots, nodes) <- executeCommitExprSTM_ previousContext currentContext clientNodes

450+ Right previousTrans -> do

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

447452 nodesToNotify <- toList (STMSet.stream nodes)

448453 pure $ Right (evaldNots, nodesToNotify, newGraph)

449454 else

@@ -512,7 +517,7 @@ typeForRelationalExprSTM sessionId (InProcessConnection _ _ sessions _ _) relExp

512517 eSession <- sessionForSessionId sessionId sessions

513518 case eSession of

514519 Left err -> pure $ Left err

515− Right session -> pure $ evalState (RE.typeForRelationalExpr relExpr) (sessionContext session)

520+ Right session -> pure $ evalState (RE.typeForRelationalExpr relExpr) (Sess.concreteDatabaseContext session)

516521

517522typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"

518523

@@ -523,7 +528,7 @@ inclusionDependencies sessionId (InProcessConnection _ _ sessions _ _) = do

523528 eSession <- sessionForSessionId sessionId sessions

524529 case eSession of

525530 Left err -> pure $ Left err

526− Right session -> pure $ Right (B.inclusionDependencies (sessionContext session))

531+ Right session -> pure $ Right (B.inclusionDependencies (Sess.concreteDatabaseContext session))

527532

528533inclusionDependencies sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveInclusionDependencies sessionId)

529534

@@ -534,7 +539,7 @@ planForDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _ _) dbEx

534539 eSession <- sessionForSessionId sessionId sessions

535540 case eSession of

536541 Left err -> pure $ Left err

537− Right session -> pure $ evalState (applyStaticDatabaseOptimization dbExpr) (sessionContext session)

542+ Right session -> pure $ evalState (applyStaticDatabaseOptimization dbExpr) (Sess.concreteDatabaseContext session)

538543planForDatabaseContextExpr sessionId conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)

539544

540545-- | Return a relation which represents the current state of the global transaction graph. The attributes are

@@ -560,7 +565,7 @@ relationVariablesAsRelation sessionId (InProcessConnection _ _ sessions _ _) = d

560565 eSession <- sessionForSessionId sessionId sessions

561566 case eSession of

562567 Left err -> pure (Left err)

563− Right (Session (DisconnectedTransaction _ context)) -> pure $ R.relationVariablesAsRelation (relationVariables context)

568+ Right session -> pure $ R.relationVariablesAsRelation (relationVariables (Sess.concreteDatabaseContext session))

564569

565570relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

566571

@@ -571,7 +576,7 @@ headTransactionId sessionId (InProcessConnection _ _ sessions _ _) = do

571576 eSession <- sessionForSessionId sessionId sessions

572577 case eSession of

573578 Left _ -> pure Nothing

574− Right session -> pure $ Just (sessionParentId session)

579+ Right session -> pure $ Just (Sess.parentId session)

575580headTransactionId sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveHeadTransactionId sessionId)

576581

577582headNameSTM_ :: SessionId -> Sessions -> TVar TransactionGraph -> STM (Maybe HeadName)

@@ -580,7 +585,7 @@ headNameSTM_ sessionId sessions graphTvar = do

580585 eSession <- sessionForSessionId sessionId sessions

581586 case eSession of

582587 Left _ -> pure $ Nothing

583− Right session -> pure $ case transactionForId (sessionParentId session) graph of

588+ Right session -> pure $ case transactionForId (Sess.parentId session) graph of

584589 Left _ -> Nothing

585590 Right parentTrans -> headNameForTransaction parentTrans graph

586591

@@ -596,8 +601,8 @@ atomTypesAsRelation sessionId (InProcessConnection _ _ sessions _ _) = do

596601 eSession <- sessionForSessionId sessionId sessions

597602 case eSession of

598603 Left err -> pure (Left err)

599− Right (Session (DisconnectedTransaction _ context)) -> do

600− case typesAsRelation (typeConstructorMapping context) of

604+ Right session -> do

605+ case typesAsRelation (typeConstructorMapping (Sess.concreteDatabaseContext session)) of

601606 Left err -> pure (Left err)

602607 Right rel -> pure (Right rel)

603608atomTypesAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)

src/lib/ProjectM36/IsomorphicSchema.hs+27−11

@@ -10,11 +10,6 @@ import Control.Monad

1010

1111-- the isomorphic building blocks should not be arbitrarily combined; for example, combing restrict and union on the same target relvar does not make sense as that would create effects at a distance in the secondary schema

1212--this should create a new schema

13−data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (Maybe RelVarName, Maybe RelVarName) | --maps one relvar into two relvars (true, false), if the false name is Nothing, no relvar in schemaB is created. This is useful for renaming relation variables between schemas or hiding relvars altogether.

14− IsoUnion (RelVarName, Maybe RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar

15− -- IsoTypeConstructor in morphAttrExpr

16−

17−type SchemaIsomorphs = [SchemaIsomorph]

1813

1914-- | Return True iff the SchemaIsomorph is fully isomorphic in the sense that it does not represent an isomorphic sub-schema.

2015isFullyIsomorphic :: SchemaIsomorph -> Bool

@@ -108,11 +103,9 @@ databaseContextExprMorph iso@(IsoRestrict rvIn filt split) = \expr -> case expr

108103 (Nothing, Just rvFalse) -> pure (falseExpr rvFalse)

109104 (Nothing, Nothing) -> Left (RelVarNotDefinedError rvIn)

110105 Update rv attrMap predi | rv == rvIn -> do

111−--something missing here, create a function to conver the attr->atom map to a relexpr to insert based on what matches in the existing relation variable

112− let trueExpr n = MultipleExpr [Update n attrMap (AndPredicate predi filt)]

113− --Insert rvTrue ...

114− falseExpr n = MultipleExpr [Update n attrMap (AndPredicate predi (NotPredicate filt))]

115− --Insert rvFalse, retrieve matching tuples based on attrMap

106+ -- if the update would "shift" a tuple from the true->false relvar or vice versa, that would be a constraint violation in the virtual schema

107+ let trueExpr n = Update n attrMap (AndPredicate predi filt)

108+ falseExpr n = Update n attrMap (AndPredicate predi (NotPredicate filt))

116109 case split of

117110 (Just rvTrue, Just rvFalse) -> pure (MultipleExpr [trueExpr rvTrue, falseExpr rvFalse])

118111 (Just rvTrue, Nothing) -> pure (trueExpr rvTrue)

@@ -150,4 +143,27 @@ applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprM

150143

151144-- | Apply the isomorphism transformations to the database context expression to convert the expression from operating on one schema to a disparate, isomorphic schema.

152145applyDatabaseCotextExprSchemaIsomorphs :: SchemaIsomorphs -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr

153−applyDatabaseCotextExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> databaseContextExprMogrify (databaseContextExprMorph morph) expr') expr morphs

146+applyDatabaseCotextExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> databaseContextExprMogrify (databaseContextExprMorph morph) expr') expr morphs

147+

148+inclusionDependenciesMorph :: SchemaIsomorph -> (InclusionDependency -> Either RelationalError InclusionDependency)

149+inclusionDependenciesMorph iso = \(InclusionDependency subExpr expr) -> InclusionDependency <$> relExprMorph iso subExpr <*> relExprMorph iso expr

150+

151+applyInclusionDependenciesSchemaIsoMorphs :: SchemaIsomorphs -> InclusionDependencies -> Either RelationalError InclusionDependencies

152+--add inc deps for restriction with some automatic name

153+applyInclusionDependenciesSchemaIsoMorphs morphs incDeps = undefined

154+

155+applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables

156+applyRelationVariablesSchemaIsomorphs = undefined

157+

158+applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext

159+applySchemaIsomorphsToDatabaseContext morphs context = do

160+ incdeps <- applyInclusionDependenciesSchemaIsoMorphs morphs (inclusionDependencies context)

161+ relvars <- applyRelationVariablesSchemaIsomorphs morphs (relationVariables context)

162+ pure (context { inclusionDependencies = incdeps,

163+ relationVariables = relvars

164+ --atomFunctions = atomfuncs,

165+ --notifications = notifs,

166+ --typeConstructorMapping = tconsmapping

167+ })

168+

169+

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

@@ -8,9 +8,14 @@ type SessionId = UUID

88-- sessions are not associated with connections and have separate lifetimes

99data Session = Session DisconnectedTransaction

1010

11−sessionContext :: Session -> DatabaseContext

12−sessionContext (Session (DisconnectedTransaction _ context)) = context

11+concreteDatabaseContext :: Session -> DatabaseContext

12+concreteDatabaseContext (Session (DisconnectedTransaction _ (Schemas context _))) = context

1313

14−sessionParentId :: Session -> TransactionId

15−sessionParentId (Session (DisconnectedTransaction parentUUID _)) = parentUUID

14+parentId :: Session -> TransactionId

15+parentId (Session (DisconnectedTransaction parentUUID _)) = parentUUID

1616

17+subschemas :: Session -> Subschemas

18+subschemas (Session (DisconnectedTransaction _ (Schemas _ s))) = s

19+

20+schemas :: Session -> Schemas

21+schemas (Session (DisconnectedTransaction _ s)) = s

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

@@ -4,6 +4,7 @@

44module ProjectM36.TransGraphRelationalExpression where

55import ProjectM36.Base

66import ProjectM36.TransactionGraph

7+import ProjectM36.Transaction

78import ProjectM36.RelationalExpression

89import ProjectM36.Error

910import Control.Monad.State

@@ -48,7 +49,7 @@ evalTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) _ = pure (MakeSta

4849evalTransGraphRelationalExpr (ExistingRelation rel) _ = pure (ExistingRelation rel)

4950evalTransGraphRelationalExpr (RelationVariable rvname transLookup) graph = do

5051 trans <- lookupTransaction graph transLookup

51− rel <- evalState (evalRelationalExpr (RelationVariable rvname ())) (transactionContext trans)

52+ rel <- evalState (evalRelationalExpr (RelationVariable rvname ())) (concreteDatabaseContext trans)

5253 pure (ExistingRelation rel)

5354evalTransGraphRelationalExpr (Project attrNames expr) graph = do

5455 expr' <- evalTransGraphRelationalExpr expr graph

@@ -106,7 +107,7 @@ evalTransGraphAtomExpr graph (FunctionAtomExpr funcName args tLookup) = do

106107 trans <- lookupTransaction graph tLookup

107108 --I can't return a FunctionAtomExpr because the function needs to be resolved at a specific context

108109 args' <- mapM (evalTransGraphAtomExpr graph) args

109− atom <- evalAtomExpr emptyTuple (transactionContext trans) (FunctionAtomExpr funcName args' ())

110+ atom <- evalAtomExpr emptyTuple (concreteDatabaseContext trans) (FunctionAtomExpr funcName args' ())

110111 pure (NakedAtomExpr atom)

111112evalTransGraphAtomExpr graph (RelationAtomExpr expr) = do

112113 expr' <- evalTransGraphRelationalExpr expr graph

@@ -114,7 +115,7 @@ evalTransGraphAtomExpr graph (RelationAtomExpr expr) = do

114115evalTransGraphAtomExpr graph (ConstructedAtomExpr dConsName args tLookup) = do

115116 trans <- lookupTransaction graph tLookup

116117 args' <- mapM (evalTransGraphAtomExpr graph) args

117− atom <- evalAtomExpr emptyTuple (transactionContext trans) (ConstructedAtomExpr dConsName args' ())

118+ atom <- evalAtomExpr emptyTuple (concreteDatabaseContext trans) (ConstructedAtomExpr dConsName args' ())

118119 pure (NakedAtomExpr atom)

119120

120121evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransactionGraph -> Either RelationalError RestrictionPredicateExpr

@@ -148,6 +149,6 @@ evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) graph = d

148149evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr

149150evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do

150151 trans <- lookupTransaction graph tLookup

151− aType <- atomTypeForTypeConstructor tCons (typeConstructorMapping (transactionContext trans))

152+ aType <- atomTypeForTypeConstructor tCons (typeConstructorMapping (concreteDatabaseContext trans))

152153 pure (NakedAttributeExpr (Attribute attrName aType))

153154evalTransGraphAttributeExpr _ (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)

src/lib/ProjectM36/Transaction.hs+14−6

@@ -2,10 +2,7 @@ module ProjectM36.Transaction where

22import ProjectM36.Base

33import qualified Data.Set as S

44import qualified Data.UUID as U

5−

6−--create a disconnected transaction with a parent

7−newDisconnectedTransaction :: TransactionId -> DatabaseContext -> DisconnectedTransaction

8−newDisconnectedTransaction parentId context = DisconnectedTransaction parentId context

5+import qualified Data.Map as M

107transactionParentIds :: Transaction -> S.Set TransactionId

118transactionParentIds (Transaction _ (TransactionInfo pId _) _) = S.singleton pId

@@ -17,8 +14,8 @@ transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children) _) = chil

1714

1815-- | Create a new transaction which is identical to the original except that a new set of child transaction ids is added.

1916transactionSetChildren :: Transaction -> S.Set TransactionId -> Transaction

20−transactionSetChildren t@(Transaction _ (TransactionInfo pId _) _) childIds = Transaction (transactionId t) (TransactionInfo pId childIds) (transactionContext t)

21−transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _) _) childIds = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds) (transactionContext t)

17+transactionSetChildren t@(Transaction _ (TransactionInfo pId _) schemas') childIds = Transaction (transactionId t) (TransactionInfo pId childIds) schemas'

18+transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _) schemas') childIds = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds) schemas'

2219

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

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

@@ -32,3 +29,14 @@ filterParent parentId validIds = if S.member parentId validIds then parentId els

3229filterTransaction :: S.Set TransactionId -> Transaction -> Transaction

3330filterTransaction filterIds (Transaction selfId tInfo context) = Transaction selfId (filterTransactionInfoTransactions filterIds tInfo) context

3431

32+-- | Return the singular context which is not virtual.

33+concreteDatabaseContext :: Transaction -> DatabaseContext

34+concreteDatabaseContext (Transaction _ _ (Schemas context _)) = context

35+

36+-- | Returns all schemas including the concrete schema.

37+schemas :: Transaction -> Schemas

38+schemas (Transaction _ _ schemas') = schemas'

39+

40+-- | Returns all subschemas which are isomorphic or sub-isomorphic to the concrete schema.

41+subschemas :: Transaction -> Subschemas

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

src/lib/ProjectM36/Transaction/Persist.hs+22−4

@@ -1,6 +1,7 @@

11module ProjectM36.Transaction.Persist where

22import ProjectM36.Base

33import ProjectM36.Error

4+import ProjectM36.Transaction

45import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)

56import qualified Data.Map as M

67import qualified Data.HashSet as HS

@@ -38,6 +39,9 @@ atomFuncsDir transdir = transdir </> "atomfuncs"

3839typeConsPath :: FilePath -> FilePath

3940typeConsPath transdir = transdir </> "typecons"

4041

42+subschemasPath :: FilePath -> FilePath

43+subschemasPath transdir = transdir </> "subschemas"

44+

4145readTransaction :: FilePath -> TransactionId -> IO (Either PersistenceError Transaction)

4246readTransaction dbdir transId = do

4347 let transDir = transactionDir dbdir transId

@@ -49,6 +53,7 @@ readTransaction dbdir transId = do

4953 transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)

5054 incDeps <- readIncDeps transDir

5155 typeCons <- readTypeConstructorMapping transDir

56+ sschemas <- readSubschemas transDir

5257 --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet

5358 let atomFuncs = basicAtomFunctions

5459 let newContext = DatabaseContext { inclusionDependencies = incDeps,

@@ -56,14 +61,14 @@ readTransaction dbdir transId = do

5661 typeConstructorMapping = typeCons,

5762 notifications = M.empty,

5863 atomFunctions = atomFuncs }

59−

60− return $ Right $ Transaction transId transInfo newContext

64+ newSchemas = Schemas newContext sschemas

65+ return $ Right $ Transaction transId transInfo newSchemas

6166

6267writeTransaction :: DiskSync -> FilePath -> Transaction -> IO ()

6368writeTransaction sync dbdir trans = do

6469 let tempTransDir = tempTransactionDir dbdir (transactionId trans)

6570 finalTransDir = transactionDir dbdir (transactionId trans)

66− context = transactionContext trans

71+ context = concreteDatabaseContext trans

6772 transDirExists <- doesDirectoryExist finalTransDir

6873 if not transDirExists then do

6974 --create sub directories

@@ -137,6 +142,17 @@ readIncDeps transDir = do

137142 incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)

138143 return $ M.fromList incDeps

139144

145+readSubschemas :: FilePath -> IO Subschemas

146+readSubschemas transDir = do

147+ let sschemasPath = subschemasPath transDir

148+ bytes <- BS.readFile sschemasPath

149+ pure (B.decode bytes)

150+

151+writeSubschemas :: FilePath -> Subschemas -> IO ()

152+writeSubschemas transDir sschemas = do

153+ let sschemasPath = subschemasPath transDir

154+ BS.writeFile sschemasPath (B.encode sschemas)

155+

140156writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()

141157writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in

142158 writeBSFileSync sync atPath $ B.encode types

@@ -144,4 +160,6 @@ writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in

144160readTypeConstructorMapping :: FilePath -> IO (TypeConstructorMapping)

145161readTypeConstructorMapping path = do

146162 let atPath = typeConsPath path

147− liftM B.decode (BS.readFile atPath)

163+ liftM B.decode (BS.readFile atPath)

164+

165+

src/lib/ProjectM36/TransactionGraph.hs+20−15

@@ -45,7 +45,8 @@ bootstrapTransactionGraph :: TransactionId -> DatabaseContext -> TransactionGrap

4545bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions

4646 where

4747 bootstrapHeads = M.singleton "master" freshTransaction

48− freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty) context

48+ newSchemas = Schemas context M.empty

49+ freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty) newSchemas

4950 bootstrapTransactions = S.singleton freshTransaction

5051

5152emptyTransactionGraph :: TransactionGraph

@@ -99,12 +100,13 @@ childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transa

99100addBranch :: TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

100101addBranch newId newBranchName branchPointId graph = do

101102 parentTrans <- transactionForId branchPointId graph

102− let newTrans = Transaction newId (TransactionInfo branchPointId S.empty) (transactionContext parentTrans)

103+ let newTrans = Transaction newId (TransactionInfo branchPointId S.empty) (schemas parentTrans)

103104 addTransactionToGraph newBranchName newTrans graph

104105

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

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

107−addDisconnectedTransaction newId headName (DisconnectedTransaction parentId context) graph = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) context) graph

108+addDisconnectedTransaction newId headName (DisconnectedTransaction parentId schemas') graph = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) schemas') graph

109+

108110

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

110112addTransactionToGraph headName newTrans graph = do

@@ -187,13 +189,13 @@ evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId

187189 Left err -> Left err

188190 Right parentTrans -> Right (newTrans, graph)

189191 where

190− newTrans = DisconnectedTransaction jumpId (transactionContext parentTrans)

192+ newTrans = DisconnectedTransaction jumpId (schemas parentTrans)

191193

192194-- switch from one head to another

193195-- affects only disconnectedtransaction

194196evalGraphOp _ _ graph (JumpToHead headName) =

195197 case transactionForHead headName graph of

196− Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionId newHeadTransaction) (transactionContext newHeadTransaction) in

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

197199 Right (disconnectedTrans, graph)

198200 Nothing -> Left $ NoSuchHeadNameError headName

199201-- add new head pointing to branchPoint

@@ -211,15 +213,15 @@ evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph

211213

212214-- create a new commit and add it to the heads

213215-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)

214−evalGraphOp newId (DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case addBranch newId newBranchName parentId graph of

216+evalGraphOp newId (DisconnectedTransaction parentId schemas') graph (Branch newBranchName) = case addBranch newId newBranchName parentId graph of

215217 Left err -> Left err

216218 Right (_, newGraph) -> Right (newDiscon, newGraph)

217219 where

218− newDiscon = DisconnectedTransaction newId disconContext

220+ newDiscon = DisconnectedTransaction newId schemas'

219221

220222-- add the disconnected transaction to the graph

221223-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction

222−evalGraphOp newTransId discon@(DisconnectedTransaction parentId context) graph Commit = case transactionForId parentId graph of

224+evalGraphOp newTransId discon@(DisconnectedTransaction parentId schemas') graph Commit = case transactionForId parentId graph of

223225 Left err -> Left err

224226 Right parentTransaction -> case headNameForTransaction parentTransaction graph of

225227 Nothing -> Left $ TransactionIsNotAHeadError parentId

@@ -227,7 +229,7 @@ evalGraphOp newTransId discon@(DisconnectedTransaction parentId context) graph C

227229 Left err-> Left err

228230 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

229231 where

230− newDisconnectedTrans = newDisconnectedTransaction newTransId context

232+ newDisconnectedTrans = DisconnectedTransaction newTransId schemas'

231233 maybeUpdatedGraph = addDisconnectedTransaction newTransId headName discon graph

232234

233235-- refresh the disconnected transaction, return the same graph

@@ -235,7 +237,7 @@ evalGraphOp _ (DisconnectedTransaction parentId _) graph Rollback = case transac

235237 Left err -> Left err

236238 Right parentTransaction -> Right (newDiscon, graph)

237239 where

238− newDiscon = newDisconnectedTransaction parentId (transactionContext parentTransaction)

240+ newDiscon = DisconnectedTransaction parentId (schemas parentTransaction)

239241

240242-- a successful merge should remove a head

241243evalGraphOp newId (DisconnectedTransaction parentId _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph

@@ -286,7 +288,7 @@ evalROGraphOp discon graph ShowGraph = do

286288createMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

287289createMergeTransaction newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

288290 selectedTrans <- validateHeadName selectedBranch graph t2

289− pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty) (transactionContext selectedTrans)

291+ pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty) (schemas selectedTrans)

290292

291293-- merge functions, relvars, individually

292294createMergeTransaction newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction newId strat graph t2

@@ -374,7 +376,7 @@ mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do

374376 Just headName -> do

375377 (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph

376378 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)

377− newDiscon = newDisconnectedTransaction newId (transactionContext newTrans)

379+ newDiscon = DisconnectedTransaction newId (schemas newTrans)

378380 pure (newDiscon, newGraph')

379381

380382--TEMPORARY COPY/PASTE

@@ -403,8 +405,8 @@ filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet

403405--helper function for commonalities in union merge

404406createUnionMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

405407createUnionMergeTransaction newId strategy graph (t1,t2) = do

406− let contextA = transactionContext t1

407− contextB = transactionContext t2

408+ let contextA = concreteDatabaseContext t1

409+ contextB = concreteDatabaseContext t2

408410

409411 preference <- case strategy of

410412 UnionMergeStrategy -> pure PreferNeither

@@ -419,7 +421,10 @@ createUnionMergeTransaction newId strategy graph (t1,t2) = do

419421 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)

420422 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)

421423 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)

422− pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) (DatabaseContext incDeps relVars atomFuncs notifs types))

424+ -- TODO: add merge of subschemas

425+ let newContext = DatabaseContext incDeps relVars atomFuncs notifs types

426+ newSchemas = Schemas newContext (subschemas t1)

427+ pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) newSchemas)

423428

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

425430lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

test/IsomorphicSchema.hs−6

@@ -2,7 +2,6 @@ import Test.HUnit

22import ProjectM36.Base

33import ProjectM36.IsomorphicSchema

44import ProjectM36.Relation

5−import ProjectM36.Relation.Show.Term

65import ProjectM36.RelationalExpression

76import qualified ProjectM36.DatabaseContext as DBC

87import qualified ProjectM36.Attribute as A

@@ -10,8 +9,6 @@ import System.Exit

109import qualified Data.Map as M

1110import Control.Monad.State

1211

13−import qualified Data.Text as T

14−

1512testList :: Test

1613testList = TestList [testIsoRelVarName, testIsoRestrict]

1714

@@ -65,7 +62,4 @@ testIsoRestrict = TestCase $ do

6562 empExpr <- assertEither (applyRelationalExprSchemaIsomorphs isomorphsAtoB employeeq)

6663 let empResult = evalState (evalRelationalExpr empExpr) schemaA

6764 unionResult = evalState (evalRelationalExpr unionq) schemaA

68− case empResult of

69− Right rel -> putStrLn $ T.unpack (showRelation rel)

70− putStrLn $ T.unpack (showRelation nonBossRel)

7165 assertEqual "boss/nonboss isorestrict" unionResult empResult