e7e0776 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP set/get current schema name

commite7e0776fdd960630bd82cc349a0d70c8b9ebb94c authorAgentM <agentm@themactionfaction.com> dateFri 14 Oct 2016, 11:45 (10 years ago) parentf3f99cd

11 files changed+206−25

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter.hs+18−7 src/bin/TutorialD/Interpreter/SchemaOperator.hs+66 src/lib/ProjectM36/Base.hs+2 src/lib/ProjectM36/Client.hs+49−9 src/lib/ProjectM36/DisconnectedTransaction.hs+11 src/lib/ProjectM36/Error.hs+5 src/lib/ProjectM36/IsomorphicSchema.hs+23−1 src/lib/ProjectM36/Server/RemoteCallTypes.hs+8−1 src/lib/ProjectM36/Session.hs+23−5 src/lib/ProjectM36/Sessions.hs+1−1 src/lib/ProjectM36/Transaction.hs−1

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

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

77import TutorialD.Interpreter.InformationOperator

88import TutorialD.Interpreter.DatabaseContextIOOperator

99import TutorialD.Interpreter.TransGraphRelationalOperator

10+import TutorialD.Interpreter.SchemaOperator

1011

1112import TutorialD.Interpreter.Import.CSV

1213import TutorialD.Interpreter.Import.TutorialD

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

1920import ProjectM36.Base

2021import ProjectM36.Relation.Show.Term

2122import ProjectM36.TransactionGraph

23+import ProjectM36.IsomorphicSchema

2224import qualified ProjectM36.Client as C

2325import ProjectM36.Relation (attributes)

2426

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

3032import qualified Data.Text as T

3133import Data.Maybe (fromMaybe)

3234import System.IO (hPutStrLn, stderr)

35+import Data.Monoid

3336

3437{-

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

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

4649 ImportDBContextOp DatabaseContextDataImportOperator |

4750 ImportBasicExampleOp ImportBasicExampleOperator |

4851 RelVarExportOp RelVarDataExportOperator |

49− TransGraphRelationalOp TransGraphRelationalOperator

52+ TransGraphRelationalOp TransGraphRelationalOperator |

53+ SchemaOp SchemaOperator

5054

5155interpreterParserP :: Parser ParsedOperation

5256interpreterParserP = safeInterpreterParserP <|>

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

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

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

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

66− liftM TransGraphRelationalOp (transGraphRelationalOpP <* eof)

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

71+ liftM SchemaOp (schemaOperatorP <* eof)

6772

68−

69−promptText :: Maybe HeadName -> StringType

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

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

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

7175 where

72− transInfo = fromMaybe "<unknown>" mHeadName

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

7377

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

7579parseTutorialD inputString = parse interpreterParserP "" inputString

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

116120 Left err -> barf err

117121 Right rel -> pure (DisplayRelationResult rel)

118122

123+ (SchemaOp execOp) -> do

124+ opResult <- evalSchemaOperator sessionId conn execOp

125+ case opResult of

126+ Just err -> barf err

127+ Nothing -> pure QuietSuccessResult

128+

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

120130 if needsSafe then

121131 unsafeError

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

188198 homeDirectory <- getHomeDirectory

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

190200 mHeadName <- C.headName sessionId conn

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

201+ mSchemaName <- C.currentSchemaName sessionId conn

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

192203 case maybeLine of

193204 Nothing -> return ()

194205 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 =

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

488488 SelectedBranchMergeStrategy HeadName

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

490+

491+

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

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

1212 executeDatabaseContextExpr,

1313 executeDatabaseContextIOExpr,

1414 executeGraphExpr,

15+ executeSchemaExpr,

1516 executeTransGraphRelationalExpr,

1617 commit,

1718 rollback,

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

1920 inclusionDependencies,

2021 planForDatabaseContextExpr,

2122 processPersistence,

23+ currentSchemaName,

24+ setCurrentSchemaName,

2225 transactionGraphAsRelation,

2326 relationVariablesAsRelation,

2427 headName,

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

6063import qualified ProjectM36.Base as B

6164import ProjectM36.Error

6265import ProjectM36.StaticOptimizer

66+import qualified ProjectM36.IsomorphicSchema as Schema

6367import Control.Monad.State

6468import qualified ProjectM36.RelationalExpression as RE

6569import ProjectM36.DatabaseContext (basicDatabaseContext)

6670import ProjectM36.TransactionGraph

6771import qualified ProjectM36.Transaction as Trans

68−import qualified ProjectM36.DisconnectedTransaction as DTrans

6972import ProjectM36.TransactionGraph.Persist

7073import ProjectM36.Attribute hiding (atomTypes)

7174import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)

7275import ProjectM36.Persist (DiskSync(..))

7376import ProjectM36.Notifications

7477import ProjectM36.Server.RemoteCallTypes

78+import qualified ProjectM36.DisconnectedTransaction as Discon

7579import ProjectM36.Relation (typesAsRelation)

7680import ProjectM36.AtomFunctionBody (initScriptSession, ScriptSession)

7781import qualified ProjectM36.Relation as R

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

287291 case keyDuplication of

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

289293 Nothing -> do

290− STMMap.insert (Session freshDiscon) newSessionId sessions

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

291295 pure $ Right newSessionId

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

293297

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

357361sessionForSessionId sessionId sessions = do

358362 maybeSession <- STMMap.lookup sessionId sessions

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

360382

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

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

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

364386 eSession <- sessionForSessionId sessionId sessions

365387 case eSession of

366388 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

368390 Left err -> pure (Left err)

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

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

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

381403 (Nothing, context') -> do

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

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

384− newSession = Session newDiscon

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

385407 STMMap.insert newSession sessionId sessions

386408 pure Nothing

387409

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

401423 Right context' -> do

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

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

404− newSession = Session newDiscon

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

405427 atomically $ STMMap.insert newSession sessionId sessions

406428 pure Nothing

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

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

412434 eSession <- sessionForSessionId sessionId sessions

413435 case eSession of

414436 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

416438 Left err -> pure $ Left err

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

418440 writeTVar graphTvar graph'

419− let newSession = Session discon'

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

420442 STMMap.insert newSession sessionId sessions

421443 pure $ Right graph'

422444

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

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

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

485507

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+

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

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

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

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

553593 eSession <- sessionForSessionId sessionId sessions

554594 case eSession of

555595 Left err -> pure $ Left err

556− Right (Session discon) -> do

596+ Right session -> do

557597 graph <- readTVar tvar

558− pure $ graphAsRelation discon graph

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

559599

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

561601

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)

7373 | UnhandledExceptionError String

7474 | MergeTransactionError MergeError

7575 | AtomFunctionBodyScriptError AtomFunctionBodyCompilationError

76+

77+ | SubschemaNameInUseError SchemaName

78+ | SubschemaNameNotInUseError SchemaName

79+

80+

7681 | MultipleErrors [RelationalError]

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

7883

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

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

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

12module ProjectM36.IsomorphicSchema where

23import ProjectM36.Base

34import ProjectM36.Error

45import Data.Maybe

56import Control.Monad

7+import GHC.Generics

8+import Data.Binary

9+import qualified Data.Map as M

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

711

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

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

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

1216--this should create a new schema

1317

18+data SchemaExpr = AddSubschema SchemaName |

19+ AddSubschemaIsomorph SchemaName SchemaIsomorph |

20+ RemoveSubschema SchemaName

21+ deriving (Generic, Binary)

22+

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

1524isFullyIsomorphic :: SchemaIsomorph -> Bool

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

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

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

7786relExprMogrify func other = func other

7887

88+{-

7989spam :: Either RelationalError RelationalExpr

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

8191

8292spam2 :: Either RelationalError RelationalExpr

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

94+-}

8495

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

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

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

166177 --typeConstructorMapping = tconsmapping

167178 })

168179

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

11{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}

22module ProjectM36.Server.RemoteCallTypes where

33import ProjectM36.Base

4+import ProjectM36.IsomorphicSchema

45import ProjectM36.TransactionGraph

56import ProjectM36.TransGraphRelationalExpression

67import ProjectM36.Session

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

2829 deriving (Binary, Generic)

2930data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr

3031 deriving (Binary, Generic)

32+data ExecuteSchemaExpr = ExecuteSchemaExpr SessionId SchemaExpr

33+ deriving (Binary, Generic)

34+data ExecuteSetCurrentSchema = ExecuteSetCurrentSchema SessionId SchemaName

35+ deriving (Binary, Generic)

3136data RetrieveInclusionDependencies = RetrieveInclusionDependencies SessionId

3237 deriving (Binary, Generic)

3338data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr

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

4550data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

4651 deriving (Binary, Generic)

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

11module ProjectM36.Session where

22import ProjectM36.Base

33import Data.UUID

4+import qualified Data.Map as M

5+import ProjectM36.Error

57type SessionId = UUID

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

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

1018

1119concreteDatabaseContext :: Session -> DatabaseContext

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

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

1321

1422parentId :: Session -> TransactionId

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

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

1624

1725subschemas :: Session -> Subschemas

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

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

1927

2028schemas :: 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

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

2121sessionsAsRelation sessions = do

2222 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

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

2525 Attribute "parentCommit" TextAtomType]) atomMatrix

2626

src/lib/ProjectM36/Transaction.hs−1

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

22import ProjectM36.Base

33import qualified Data.Set as S

44import qualified Data.UUID as U

5−import qualified Data.Map as M

76transactionParentIds :: Transaction -> S.Set TransactionId

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