e7e0776 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP set/get current schema name

e7e0776AgentM10 years ago

src/bin/TutorialD/Interpreter.hs+18−7

compare with master

unifiedsplit

@@ -7,6 +7,7 @@ import TutorialD.Interpreter.TransactionGraphOperator

7import TutorialD.Interpreter.InformationOperator

8import TutorialD.Interpreter.DatabaseContextIOOperator

9import TutorialD.Interpreter.TransGraphRelationalOperator

10+import TutorialD.Interpreter.SchemaOperator

11import TutorialD.Interpreter.Import.CSV

12import TutorialD.Interpreter.Import.CSV

12import TutorialD.Interpreter.Import.TutorialD

13import TutorialD.Interpreter.Import.TutorialD

@@ -19,6 +20,7 @@ import TutorialD.Interpreter.Export.Base

19import ProjectM36.Base

20import ProjectM36.Base

20import ProjectM36.Relation.Show.Term

21import ProjectM36.Relation.Show.Term

21import ProjectM36.TransactionGraph

22import ProjectM36.TransactionGraph

23+import ProjectM36.IsomorphicSchema

22import qualified ProjectM36.Client as C

24import qualified ProjectM36.Client as C

23import ProjectM36.Relation (attributes)

25import ProjectM36.Relation (attributes)

@@ -30,6 +32,7 @@ import System.Directory (getHomeDirectory)

30import qualified Data.Text as T

32import qualified Data.Text as T

31import Data.Maybe (fromMaybe)

33import Data.Maybe (fromMaybe)

32import System.IO (hPutStrLn, stderr)

34import System.IO (hPutStrLn, stderr)

35+import Data.Monoid

34{-

37{-

35context ops are read-only operations which only operate on the database context (relvars and constraints)

38context ops are read-only operations which only operate on the database context (relvars and constraints)

@@ -46,7 +49,8 @@ data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

46 ImportDBContextOp DatabaseContextDataImportOperator |

49 ImportDBContextOp DatabaseContextDataImportOperator |

47 ImportBasicExampleOp ImportBasicExampleOperator |

50 ImportBasicExampleOp ImportBasicExampleOperator |

48 RelVarExportOp RelVarDataExportOperator |

51 RelVarExportOp RelVarDataExportOperator |

49− TransGraphRelationalOp TransGraphRelationalOperator

52+ TransGraphRelationalOp TransGraphRelationalOperator |

53+ SchemaOp SchemaOperator

51interpreterParserP :: Parser ParsedOperation

55interpreterParserP :: Parser ParsedOperation

52interpreterParserP = safeInterpreterParserP <|>

56interpreterParserP = safeInterpreterParserP <|>

@@ -63,13 +67,13 @@ safeInterpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <

63 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>

67 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>

64 liftM DatabaseContextExprOp (databaseExprOpP <* eof) <|>

68 liftM DatabaseContextExprOp (databaseExprOpP <* eof) <|>

65 liftM ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>

69 liftM ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>

66− liftM TransGraphRelationalOp (transGraphRelationalOpP <* eof)

70+ liftM TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|>

71+ liftM SchemaOp (schemaOperatorP <* eof)

68−

69−promptText :: Maybe HeadName -> StringType

73+promptText :: Maybe HeadName -> Maybe SchemaName -> StringType

70−promptText mHeadName = "TutorialD (" `T.append` transInfo `T.append` "): "

74+promptText mHeadName mSchemaName = "TutorialD (" <> transInfo <> "): "

71 where

75 where

72− transInfo = fromMaybe "<unknown>" mHeadName

76+ transInfo = fromMaybe "<unknown>" mHeadName <> "/" <> fromMaybe "<no schema>" mSchemaName

74parseTutorialD :: T.Text -> Either ParseError ParsedOperation

78parseTutorialD :: T.Text -> Either ParseError ParsedOperation

75parseTutorialD inputString = parse interpreterParserP "" inputString

79parseTutorialD inputString = parse interpreterParserP "" inputString

@@ -116,6 +120,12 @@ evalTutorialD sessionId conn safe expr = case expr of

116 Left err -> barf err

120 Left err -> barf err

117 Right rel -> pure (DisplayRelationResult rel)

121 Right rel -> pure (DisplayRelationResult rel)

118

122

123+ (SchemaOp execOp) -> do

124+ opResult <- evalSchemaOperator sessionId conn execOp

125+ case opResult of

126+ Just err -> barf err

127+ Nothing -> pure QuietSuccessResult

128+

119 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do

129 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do

120 if needsSafe then

130 if needsSafe then

121 unsafeError

131 unsafeError

@@ -188,7 +198,8 @@ reprLoop config sessionId conn = do

188 homeDirectory <- getHomeDirectory

198 homeDirectory <- getHomeDirectory

189 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

199 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

190 mHeadName <- C.headName sessionId conn

200 mHeadName <- C.headName sessionId conn

201+ mSchemaName <- C.currentSchemaName sessionId conn

191− maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText mHeadName))

202+ maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText mHeadName mSchemaName))

192 case maybeLine of

203 case maybeLine of

193 Nothing -> return ()

204 Nothing -> return ()

194 Just line -> do

205 Just line -> do

src/bin/TutorialD/Interpreter/SchemaOperator.hsnew file+66

@@ -0,0 +1,66 @@

1+module TutorialD.Interpreter.SchemaOperator where

2+import Text.Megaparsec

3+import Text.Megaparsec.Text

4+import qualified Data.Map as M

6+import ProjectM36.Base

7+import ProjectM36.IsomorphicSchema

8+import ProjectM36.Session

9+import ProjectM36.Client

10+import ProjectM36.Error

11+import TutorialD.Interpreter.RelationalExpr

12+import TutorialD.Interpreter.Base

13+

14+data SchemaOperator = ModifySchemaExpr SchemaExpr |

15+ SetCurrentSchema SchemaName

16+

17+schemaOperatorP :: Parser SchemaOperator

18+schemaOperatorP = (ModifySchemaExpr <$> schemaExprP) <|>

19+ setCurrentSchemaP

20+

21+setCurrentSchemaP :: Parser SchemaOperator

22+setCurrentSchemaP = do

23+ reserved ":setschema"

24+ SetCurrentSchema <$> identifier

25+

26+schemaExprP :: Parser SchemaExpr

27+schemaExprP = addSubschemaP

28+

29+addSubschemaP :: Parser SchemaExpr

30+addSubschemaP = do

31+ reserved ":addsubschema"

32+ AddSubschema <$> identifier

33+

34+addSubschemaIsoMorphP :: Parser SchemaExpr

35+addSubschemaIsoMorphP = do

36+ reserved ":addsubschemaisomorph"

37+ AddSubschemaIsomorph <$> identifier <*> schemaIsomorphP

38+

39+schemaIsomorphP :: Parser SchemaIsomorph

40+schemaIsomorphP = isoRestrictP <|> isoUnionP

41+

42+isoRestrictP :: Parser SchemaIsomorph

43+isoRestrictP = do

44+ reserved "isorestrict"

45+ IsoRestrict <$> quotedString <*> restrictionPredicateP <*> isoRestrictOutRelVarsP

46+

47+isoRestrictOutRelVarsP :: Parser (Maybe RelVarName, Maybe RelVarName)

48+isoRestrictOutRelVarsP = (,) <$> maybeRelVarP <*> maybeRelVarP

49+

50+maybeRelVarP :: Parser (Maybe RelVarName)

51+maybeRelVarP = (Just <$> quotedString) <|> (reserved "Nothing" >> pure Nothing)

52+

53+isoUnionP :: Parser SchemaIsomorph

54+isoUnionP = do

55+ reserved "isounion"

56+ IsoUnion <$> isoUnionInRelVarsP <*> restrictionPredicateP <*> quotedString

57+

58+isoUnionInRelVarsP :: Parser (RelVarName, Maybe RelVarName)

59+isoUnionInRelVarsP = (,) <$> quotedString <*> maybeRelVarP

60+

61+evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> Either RelationalError Session

62+evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = do

63+ newSubschemas <- evalSchemaExpr sessionId conn expr (subschemas session)

64+ pure (Session (DisconnectedTransaction (parentId session) (Schemas (concreteDatabaseContext session) newSubschemas)) (schemaName session))

65+evalSchemaOperator sessionId conn (SetCurrentSchema sname) = setCurrentSchemaName sessionId conn sname

66+

src/lib/ProjectM36/Base.hs+2

@@ -487,3 +487,5 @@ data MergeStrategy =

487 -- | Similar to the our/theirs merge strategy in git, the merge transaction's context is identical to that of the last transaction in the selected branch.

488 SelectedBranchMergeStrategy HeadName

489 deriving (Eq, Show, Binary, Generic, NFData)

490+

491+

src/lib/ProjectM36/Client.hs+49−9

@@ -12,6 +12,7 @@ module ProjectM36.Client

12 executeDatabaseContextExpr,

13 executeDatabaseContextIOExpr,

14 executeGraphExpr,

15+ executeSchemaExpr,

15 executeTransGraphRelationalExpr,

16 executeTransGraphRelationalExpr,

16 commit,

17 commit,

17 rollback,

18 rollback,

@@ -19,6 +20,8 @@ module ProjectM36.Client

19 inclusionDependencies,

20 inclusionDependencies,

20 planForDatabaseContextExpr,

21 planForDatabaseContextExpr,

21 processPersistence,

22 processPersistence,

23+ currentSchemaName,

24+ setCurrentSchemaName,

22 transactionGraphAsRelation,

25 transactionGraphAsRelation,

23 relationVariablesAsRelation,

26 relationVariablesAsRelation,

24 headName,

27 headName,

@@ -60,18 +63,19 @@ import ProjectM36.Base hiding (inclusionDependencies) --defined in this module a

60import qualified ProjectM36.Base as B

63import qualified ProjectM36.Base as B

61import ProjectM36.Error

64import ProjectM36.Error

62import ProjectM36.StaticOptimizer

65import ProjectM36.StaticOptimizer

66+import qualified ProjectM36.IsomorphicSchema as Schema

63import Control.Monad.State

67import Control.Monad.State

64import qualified ProjectM36.RelationalExpression as RE

68import qualified ProjectM36.RelationalExpression as RE

65import ProjectM36.DatabaseContext (basicDatabaseContext)

69import ProjectM36.DatabaseContext (basicDatabaseContext)

66import ProjectM36.TransactionGraph

70import ProjectM36.TransactionGraph

67import qualified ProjectM36.Transaction as Trans

71import qualified ProjectM36.Transaction as Trans

68−import qualified ProjectM36.DisconnectedTransaction as DTrans

69import ProjectM36.TransactionGraph.Persist

72import ProjectM36.TransactionGraph.Persist

70import ProjectM36.Attribute hiding (atomTypes)

73import ProjectM36.Attribute hiding (atomTypes)

71import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)

74import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)

72import ProjectM36.Persist (DiskSync(..))

75import ProjectM36.Persist (DiskSync(..))

73import ProjectM36.Notifications

76import ProjectM36.Notifications

74import ProjectM36.Server.RemoteCallTypes

77import ProjectM36.Server.RemoteCallTypes

78+import qualified ProjectM36.DisconnectedTransaction as Discon

75import ProjectM36.Relation (typesAsRelation)

79import ProjectM36.Relation (typesAsRelation)

76import ProjectM36.AtomFunctionBody (initScriptSession, ScriptSession)

80import ProjectM36.AtomFunctionBody (initScriptSession, ScriptSession)

77import qualified ProjectM36.Relation as R

81import qualified ProjectM36.Relation as R

@@ -287,7 +291,7 @@ createSessionAtCommit_ commitId newSessionId (InProcessConnection _ _ sessions g

287 case keyDuplication of

291 case keyDuplication of

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

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

289 Nothing -> do

293 Nothing -> do

290− STMMap.insert (Session freshDiscon) newSessionId sessions

294+ STMMap.insert (Session freshDiscon defaultSchemaName) newSessionId sessions

291 pure $ Right newSessionId

295 pure $ Right newSessionId

292createSessionAtCommit_ _ _ (RemoteProcessConnection _ _) = error "createSessionAtCommit_ called on remote connection"

296createSessionAtCommit_ _ _ (RemoteProcessConnection _ _) = error "createSessionAtCommit_ called on remote connection"

293

297

@@ -357,6 +361,24 @@ sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Sess

357sessionForSessionId sessionId sessions = do

361sessionForSessionId sessionId sessions = do

358 maybeSession <- STMMap.lookup sessionId sessions

362 maybeSession <- STMMap.lookup sessionId sessions

359 pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession

363 pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession

364+

365+currentSchemaName :: SessionId -> Connection -> IO (Maybe SchemaName)

366+currentSchemaName sessionId (InProcessConnection _ _ sessions _ _) = atomically $ do

367+ eSession <- sessionForSessionId sessionId sessions

368+ case eSession of

369+ Left _ -> pure Nothing

370+ Right session -> pure (Just (Sess.schemaName session))

371+currentSchemaName sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveCurrentSchemaName sessionId)

372+

373+setCurrentSchemaName :: SessionId -> Connection -> SchemaName -> IO (Maybe RelationalError)

374+setCurrentSchemaName sessionId (InProcessConnection _ _ sessions _ _) sname = atomically $ do

375+ eSession <- sessionForSessionId sessionId sessions

376+ case eSession of

377+ Left _ -> pure Nothing

378+ Right session -> case Sess.setSchemaName sname session of

379+ Left err -> pure (Just err)

380+ Right newSession -> STMMap.insert newSession sessionId sessions >> pure Nothing

381+setCurrentSchemaName sessionId conn@(RemoteProcessConnection _ _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname)

360

382

361-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.

383-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.

362executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

384executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

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

364 eSession <- sessionForSessionId sessionId sessions

386 eSession <- sessionForSessionId sessionId sessions

365 case eSession of

387 case eSession of

366 Left err -> pure $ Left err

388 Left err -> pure $ Left err

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

389+ Right session -> case evalState (RE.evalRelationalExpr expr) (Sess.concreteDatabaseContext session) of

368 Left err -> pure (Left err)

390 Left err -> pure (Left err)

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

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

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

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

@@ -381,7 +403,7 @@ executeDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _ _) expr

381 (Nothing, context') -> do

403 (Nothing, context') -> do

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

404 let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas

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

405 newSchemas = Schemas context' (Sess.subschemas session)

384− newSession = Session newDiscon

406+ newSession = Session newDiscon (Sess.schemaName session)

385 STMMap.insert newSession sessionId sessions

407 STMMap.insert newSession sessionId sessions

386 pure Nothing

408 pure Nothing

387

409

@@ -401,7 +423,7 @@ executeDatabaseContextIOExpr sessionId (InProcessConnection _ _ sessions _ scrip

401 Right context' -> do

423 Right context' -> do

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

424 let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas

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

425 newSchemas = Schemas context' (Sess.subschemas session)

404− newSession = Session newDiscon

426+ newSession = Session newDiscon (Sess.schemaName session)

405 atomically $ STMMap.insert newSession sessionId sessions

427 atomically $ STMMap.insert newSession sessionId sessions

406 pure Nothing

428 pure Nothing

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

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

@@ -412,11 +434,11 @@ executeGraphExprSTM_ freshId sessionId sessions graphExpr graphTvar = do

412 eSession <- sessionForSessionId sessionId sessions

434 eSession <- sessionForSessionId sessionId sessions

413 case eSession of

435 case eSession of

414 Left err -> pure $ Left err

436 Left err -> pure $ Left err

415− Right (Session discon) -> case evalGraphOp freshId discon graph graphExpr of

437+ Right session -> case evalGraphOp freshId (Sess.disconnectedTransaction session) graph graphExpr of

416 Left err -> pure $ Left err

438 Left err -> pure $ Left err

417 Right (discon', graph') -> do

439 Right (discon', graph') -> do

418 writeTVar graphTvar graph'

440 writeTVar graphTvar graph'

419− let newSession = Session discon'

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

420 STMMap.insert newSession sessionId sessions

442 STMMap.insert newSession sessionId sessions

421 pure $ Right graph'

443 pure $ Right graph'

422

444

@@ -483,6 +505,24 @@ executeTransGraphRelationalExpr _ (InProcessConnection _ _ _ graphTvar _) tgraph

483 Right rel -> pure (force (Right rel))

505 Right rel -> pure (force (Right rel))

484executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _ _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)

506executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _ _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)

485

507

508+executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Maybe RelationalError)

509+executeSchemaExpr sessionId (InProcessConnection _ _ sessions _ _) schemaExpr = atomically $ do

510+ eSession <- sessionForSessionId sessionId sessions

511+ case eSession of

512+ Left err -> pure (Just err)

513+ Right session -> do

514+ let subschemas' = subschemas session

515+ case Schema.evalSchemaExpr schemaExpr subschemas' of

516+ Left err -> pure (Just err)

517+ Right newSubschemas -> do

518+ --hm- maybe we should start using lenses

519+ let discon = Sess.disconnectedTransaction session

520+ newSchemas = Schemas (Sess.concreteDatabaseContext session) newSubschemas

521+ newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas) (Sess.schemaName session)

522+ STMMap.insert newSession sessionId sessions

523+ pure Nothing

524+executeSchemaExpr sessionId conn@(RemoteProcessConnection _ _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)

525+

486-- | After modifying a session, 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated.

526-- | After modifying a session, 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated.

487commit :: SessionId -> Connection -> IO (Maybe RelationalError)

527commit :: SessionId -> Connection -> IO (Maybe RelationalError)

488commit sessionId conn@(InProcessConnection _ _ _ _ _) = executeGraphExpr sessionId conn Commit

528commit sessionId conn@(InProcessConnection _ _ _ _ _) = executeGraphExpr sessionId conn Commit

@@ -553,9 +593,9 @@ transactionGraphAsRelation sessionId (InProcessConnection _ _ sessions tvar _) =

553 eSession <- sessionForSessionId sessionId sessions

593 eSession <- sessionForSessionId sessionId sessions

554 case eSession of

594 case eSession of

555 Left err -> pure $ Left err

595 Left err -> pure $ Left err

556− Right (Session discon) -> do

596+ Right session -> do

557 graph <- readTVar tvar

597 graph <- readTVar tvar

558− pure $ graphAsRelation discon graph

598+ pure $ graphAsRelation (Sess.disconnectedTransaction session) graph

559

599

560transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveTransactionGraph sessionId)

600transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveTransactionGraph sessionId)

561

601

src/lib/ProjectM36/DisconnectedTransaction.hsnew file+11

@@ -0,0 +1,11 @@

1+module ProjectM36.DisconnectedTransaction where

2+import ProjectM36.Base

4+concreteDatabaseContext :: DisconnectedTransaction -> DatabaseContext

5+concreteDatabaseContext (DisconnectedTransaction _ (Schemas context _)) = context

7+schemas :: DisconnectedTransaction -> Schemas

8+schemas (DisconnectedTransaction _ s) = s

10+parentId :: DisconnectedTransaction -> TransactionId

11+parentId (DisconnectedTransaction pid _) = pid

src/lib/ProjectM36/Error.hs+5

@@ -73,6 +73,11 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

73 | UnhandledExceptionError String

74 | MergeTransactionError MergeError

75 | AtomFunctionBodyScriptError AtomFunctionBodyCompilationError

76+

77+ | SubschemaNameInUseError SchemaName

78+ | SubschemaNameNotInUseError SchemaName

79+

80+

76 | MultipleErrors [RelationalError]

81 | MultipleErrors [RelationalError]

77 deriving (Show,Eq,Generic,Binary,Typeable)

82 deriving (Show,Eq,Generic,Binary,Typeable)

src/lib/ProjectM36/IsomorphicSchema.hs+23−1

@@ -1,8 +1,12 @@

1+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

1module ProjectM36.IsomorphicSchema where

2module ProjectM36.IsomorphicSchema where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.Error

4import Data.Maybe

5import Data.Maybe

5import Control.Monad

6import Control.Monad

7+import GHC.Generics

8+import Data.Binary

9+import qualified Data.Map as M

6-- isomorphic schemas offer bi-directional functors between two schemas

10-- isomorphic schemas offer bi-directional functors between two schemas

8--TODO: note that renaming a relvar should alter any stored isomorphisms as well

12--TODO: note that renaming a relvar should alter any stored isomorphisms as well

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

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

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

12--this should create a new schema

16--this should create a new schema

18+data SchemaExpr = AddSubschema SchemaName |

19+ AddSubschemaIsomorph SchemaName SchemaIsomorph |

20+ RemoveSubschema SchemaName

21+ deriving (Generic, Binary)

22+

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

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

15isFullyIsomorphic :: SchemaIsomorph -> Bool

24isFullyIsomorphic :: SchemaIsomorph -> Bool

16isFullyIsomorphic (IsoRestrict _ _ (a, b)) = isJust a && isJust b

25isFullyIsomorphic (IsoRestrict _ _ (a, b)) = isJust a && isJust b

@@ -76,11 +85,13 @@ relExprMogrify func (NotEquals exprA exprB) = do

76relExprMogrify func (Extend ext expr) = func expr >>= \ex -> func (Extend ext ex)

85relExprMogrify func (Extend ext expr) = func expr >>= \ex -> func (Extend ext ex)

77relExprMogrify func other = func other

86relExprMogrify func other = func other

88+{-

79spam :: Either RelationalError RelationalExpr

89spam :: Either RelationalError RelationalExpr

80spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate (Just "nonboss", Just "boss"))) (RelationVariable "emp" ())

90spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate (Just "nonboss", Just "boss"))) (RelationVariable "emp" ())

82spam2 :: Either RelationalError RelationalExpr

92spam2 :: Either RelationalError RelationalExpr

83spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ())

93spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ())

94+-}

85databaseContextExprMorph :: SchemaIsomorph -> (DatabaseContextExpr -> Either RelationalError DatabaseContextExpr)

96databaseContextExprMorph :: SchemaIsomorph -> (DatabaseContextExpr -> Either RelationalError DatabaseContextExpr)

86databaseContextExprMorph iso@(IsoRestrict rvIn filt split) = \expr -> case expr of

97databaseContextExprMorph iso@(IsoRestrict rvIn filt split) = \expr -> case expr of

@@ -166,4 +177,15 @@ applySchemaIsomorphsToDatabaseContext morphs context = do

166 --typeConstructorMapping = tconsmapping

177 --typeConstructorMapping = tconsmapping

167 })

178 })

168

179

169−

180+evalSchemaExpr :: SchemaExpr -> Subschemas -> Either RelationalError Subschemas

181+evalSchemaExpr (AddSubschema sname) sschemas = if M.member sname sschemas then

182+ Left (SubschemaNameInUseError sname)

183+ else

184+ pure (M.insert sname (Schema []) sschemas)

185+evalSchemaExpr (AddSubschemaIsomorph sname morph) sschemas = case M.lookup sname sschemas of

186+ Nothing -> Left (SubschemaNameNotInUseError sname)

187+ Just (Schema oldMorphs) -> pure (M.insert sname (Schema (oldMorphs ++ [morph])) sschemas)

188+evalSchemaExpr (RemoveSubschema sname) sschemas = if M.member sname sschemas then

189+ pure (M.delete sname sschemas)

190+ else

191+ Left (SubschemaNameNotInUseError sname)

src/lib/ProjectM36/Server/RemoteCallTypes.hs+8−1

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

1{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}

2module ProjectM36.Server.RemoteCallTypes where

3import ProjectM36.Base

4+import ProjectM36.IsomorphicSchema

4import ProjectM36.TransactionGraph

5import ProjectM36.TransactionGraph

5import ProjectM36.TransGraphRelationalExpression

6import ProjectM36.TransGraphRelationalExpression

6import ProjectM36.Session

7import ProjectM36.Session

@@ -28,6 +29,10 @@ data ExecuteHeadName = ExecuteHeadName SessionId

28 deriving (Binary, Generic)

29 deriving (Binary, Generic)

29data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr

30data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr

30 deriving (Binary, Generic)

31 deriving (Binary, Generic)

32+data ExecuteSchemaExpr = ExecuteSchemaExpr SessionId SchemaExpr

33+ deriving (Binary, Generic)

34+data ExecuteSetCurrentSchema = ExecuteSetCurrentSchema SessionId SchemaName

35+ deriving (Binary, Generic)

31data RetrieveInclusionDependencies = RetrieveInclusionDependencies SessionId

36data RetrieveInclusionDependencies = RetrieveInclusionDependencies SessionId

32 deriving (Binary, Generic)

37 deriving (Binary, Generic)

33data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr

38data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr

@@ -45,4 +50,6 @@ data CloseSession = CloseSession SessionId

45data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

50data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

46 deriving (Binary, Generic)

51 deriving (Binary, Generic)

47data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

52data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

48− deriving (Binary, Generic)

53+ deriving (Binary, Generic)

54+data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

55+ deriving (Binary, Generic)

src/lib/ProjectM36/Session.hs+23−5

@@ -1,21 +1,39 @@

1module ProjectM36.Session where

2import ProjectM36.Base

3import Data.UUID

4+import qualified Data.Map as M

5+import ProjectM36.Error

5type SessionId = UUID

7type SessionId = UUID

7--the persistence of a session is as long as the life of the database (not serialized to disk)

9--the persistence of a session is as long as the life of the database (not serialized to disk)

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

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

9−data Session = Session DisconnectedTransaction

11+data Session = Session DisconnectedTransaction SchemaName

12+

13+defaultSchemaName :: SchemaName

14+defaultSchemaName = "main"

15+

16+disconnectedTransaction :: Session -> DisconnectedTransaction

17+disconnectedTransaction (Session discon _) = discon

11concreteDatabaseContext :: Session -> DatabaseContext

19concreteDatabaseContext :: Session -> DatabaseContext

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

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

14parentId :: Session -> TransactionId

22parentId :: Session -> TransactionId

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

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

17subschemas :: Session -> Subschemas

25subschemas :: Session -> Subschemas

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

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

20schemas :: Session -> Schemas

28schemas :: Session -> Schemas

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

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

30+

31+schemaName :: Session -> SchemaName

32+schemaName (Session _ s) = s

33+

34+setSchemaName :: SchemaName -> Session -> Either RelationalError Session

35+setSchemaName sname session = if sname == defaultSchemaName || M.member sname (subschemas session) then

36+ pure (Session (disconnectedTransaction session) sname)

37+ else

38+ Left (SubschemaNameNotInUseError sname)

39+

src/lib/ProjectM36/Sessions.hs+1−1

@@ -20,7 +20,7 @@ uuidAtom = TextAtom . U.toText

20sessionsAsRelation :: Sessions -> STM (Either RelationalError Relation)

21sessionsAsRelation sessions = do

22 sessionAssocs <- stmMapToList sessions

23− let atomMatrix = map (\(sessionId, (Session (DisconnectedTransaction parentUUID _))) -> [uuidAtom sessionId, uuidAtom parentUUID]) sessionAssocs

23+ let atomMatrix = map (\(sessionId, session) -> [uuidAtom sessionId, uuidAtom (parentId session)]) sessionAssocs

24 pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" TextAtomType,

25 Attribute "parentCommit" TextAtomType]) atomMatrix

src/lib/ProjectM36/Transaction.hs−1

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

2import ProjectM36.Base

3import qualified Data.Set as S

4import qualified Data.UUID as U

5−import qualified Data.Map as M

7transactionParentIds :: Transaction -> S.Set TransactionId

6transactionParentIds :: Transaction -> S.Set TransactionId

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

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