wip, before reworking fact types

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

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
 

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)