From 4aed4d839b17f61e17408811bb4ee1ddd42277a8 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 28 Mar 2024 09:05:41 +0300 Subject: [PATCH] wip, before reworking fact types --- hbs2-git/hbs2-git-oracle/app/Main.hs | 9 +++- .../lib/HBS2/Git/Oracle/Run.hs | 47 +++++++------------ .../lib/HBS2/Git/Oracle/State.hs | 37 ++++++++++++++- 3 files changed, 61 insertions(+), 32 deletions(-) diff --git a/hbs2-git/hbs2-git-oracle/app/Main.hs b/hbs2-git/hbs2-git-oracle/app/Main.hs index 50dd2cd2..611237c3 100644 --- a/hbs2-git/hbs2-git-oracle/app/Main.hs +++ b/hbs2-git/hbs2-git-oracle/app/Main.hs @@ -11,6 +11,7 @@ import Options.Applicative as O data RunMode = RunIndex PKS + | RunUpdate | RunDump PKS | RunPipe @@ -18,7 +19,8 @@ main :: IO () main = do let parser = hsubparser $ pRunIndexCmd <> pRunDumpCmd <> - pRunPipeCmd + pRunPipeCmd <> + pRunUpdateCmd join $ execParser (O.info (parser <**> helper) ( fullDesc @@ -45,6 +47,10 @@ main = do chan <- option pkey ( long "refchan" <> short 'r' <> help "refchan for queries" ) pure $ runApp chan RunPipe + pRunUpdateCmd = command "update" ( O.info pRunUpdate (progDesc "update state") ) + pRunUpdate = do + chan <- option pkey ( long "refchan" <> short 'r' <> help "refchan" ) + pure $ runApp chan RunUpdate runApp :: MonadUnliftIO m => RefChanId L4Proto @@ -62,6 +68,7 @@ runApp chan mode = do RunIndex a -> runWithOracleEnv chan $ runOracleIndex a RunPipe{} -> runWithOracleEnv chan $ runPipe RunDump pks -> runDump pks + RunUpdate -> runWithOracleEnv chan $ updateState `finally` do setLoggingOff @DEBUG diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs index a2460dc6..a24da3a2 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs @@ -115,7 +115,7 @@ runOracleIndex auPk = do let f2 = GitRepoHeadFact repoFactHash (GitRepoHeadFact1 rhh name brief enc) - let f3 = GitRepoHeadVersionFact repoFactHash (GitRepoHeadVersionFact1 _repoHeadTime) + let f3 = GitRepoHeadVersionFact rhh (GitRepoHeadVersionFact1 _repoHeadTime) let f4 = GitRepoTxFact gitLwwRef tx lift $ S.yield f1 @@ -307,38 +307,27 @@ updateState = do let rf = [ (HashRef (hashObject $ serialise f), f) | f@GitRepoFact1{} <- universeBi facts - ] & HM.fromListWith (\v1 v2 -> if gitLwwSeq v1 > gitLwwSeq v2 then v1 else v2) + ] + let rfm = HM.fromListWith (\v1 v2 -> if gitLwwSeq v1 > gitLwwSeq v2 then v1 else v2) rf - - let rhf = [ (h,f) | (GitRepoHeadFact h f) <- universeBi facts ] - & HM.fromList + let rhf = [ (h, f) + | (GitRepoHeadFact h f) <- universeBi facts + ] let rhtf = [ (h,f) | (GitRepoHeadVersionFact h f) <- universeBi facts ] - let done = [ (r,t) | GitRepoTxFact r t <- universeBi facts ] + lift $ withState $ transactional do + for_ rf $ \(h, GitRepoFact1{..}) -> do + insertGitRepo (GitRepoKey gitLwwRef) + insertGitRepoFact (GitRepoKey gitLwwRef) (HashVal h) - lift $ withState do + for_ rhf $ \(h, GitRepoHeadFact1{..}) -> void $ runMaybeT do + GitRepoFact1{..} <- HM.lookup h rfm & toMPlus + lift do + insertGitRepoName (GitRepoKey gitLwwRef , HashVal gitRepoHeadRef) gitRepoName + insertGitRepoBrief (GitRepoKey gitLwwRef , HashVal gitRepoHeadRef) gitRepoBrief + insertGitRepoHead (GitRepoKey gitLwwRef) (HashVal gitRepoHeadRef) - transactional do - - for_ done $ \w -> do - insertTxProcessed (processedRepoTx w) - - for_ facts $ \(t,_) -> do - insertTxProcessed (HashVal t) - - for_ (HM.toList rf) $ \(k, GitRepoFact1{..}) -> do - - insertGitRepo (GitRepoKey gitLwwRef) - - void $ runMaybeT do - d <- HM.lookup k rhf & toMPlus - lift do - insertGitRepoName (GitRepoKey gitLwwRef, HashVal k) (gitRepoName d) - insertGitRepoBrief(GitRepoKey gitLwwRef, HashVal k) (gitRepoBrief d) - - pure () - - for_ rhtf $ \(k, GitRepoHeadVersionFact1 v) -> do - insertGitRepoHeadVersion (HashVal k) v + for_ rhtf $ \(h, GitRepoHeadVersionFact1{..}) -> do + insertGitRepoHeadVersion (HashVal h) gitRepoHeadVersion diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs index 6a352793..005a3205 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs @@ -14,8 +14,10 @@ evolveDB :: MonadUnliftIO m => DBPipeM m () evolveDB = do debug $ yellow "evolveDB" gitRepoTable + gitRepoFactTable gitRepoNameTable gitRepoBriefTable + gitRepoHeadTable gitRepoHeadVersionTable txProcessedTable @@ -35,6 +37,15 @@ gitRepoTable = do ) |] +gitRepoFactTable :: MonadUnliftIO m => DBPipeM m () +gitRepoFactTable = do + ddl [qc| + create table if not exists gitrepofact + ( ref text not null + , hash text not null + , primary key (ref,hash) + ) + |] gitRepoNameTable :: MonadUnliftIO m => DBPipeM m () gitRepoNameTable = do @@ -58,6 +69,16 @@ gitRepoBriefTable = do ) |] +gitRepoHeadTable :: MonadUnliftIO m => DBPipeM m () +gitRepoHeadTable = do + ddl [qc| + create table if not exists gitrepohead + ( ref text not null + , head text not null + , primary key (ref) + ) + |] + gitRepoHeadVersionTable :: MonadUnliftIO m => DBPipeM m () gitRepoHeadVersionTable = do ddl [qc| @@ -93,6 +114,14 @@ insertGitRepo repo = do on conflict (ref) do nothing |] (Only repo) + +insertGitRepoFact :: MonadUnliftIO m => GitRepoKey -> HashVal -> DBPipeM m () +insertGitRepoFact repo h = do + insert [qc| + insert into gitrepofact(ref,hash) values(?,?) + on conflict (ref,hash) do nothing + |] (repo,h) + insertGitRepoName :: MonadUnliftIO m => (GitRepoKey, HashVal) -> Text @@ -137,6 +166,10 @@ isTxProcessed hash = do |] (Only hash) pure $ not $ null (results :: [Only Int]) - - +insertGitRepoHead :: MonadUnliftIO m => GitRepoKey -> HashVal -> DBPipeM m () +insertGitRepoHead repo headRef = do + insert [qc| + insert into gitrepohead (ref, head) values (?, ?) + on conflict (ref) do nothing + |] (repo, headRef)