hbs2/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs

{-# Language AllowAmbiguousTypes #-}
{-# Language UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures #-}
module HBS2.Git.Oracle.State where

import HBS2.Git.Oracle.Prelude
import HBS2.Hash

import HBS2.Git.Oracle.Facts

import DBPipe.SQLite hiding (insert,columnName)
import DBPipe.SQLite qualified as SQL
import DBPipe.SQLite.Generic

import Data.HashSet qualified as HS
import Data.Aeson
import Text.InterpolatedString.Perl6 (qc)
import Data.Coerce
import Data.Text qualified as Text

data GitRepoPage =
  GitRepoPage
  { repoPageRef      :: GitLwwRef
  , repoPageHead     :: GitRepoHeadRef
  , repoPageName     :: GitName
  , repoPageBrief    :: GitBrief
  , repoPageManifest :: GitManifest
  , repoPageGK0      :: GitEncrypted
  }
  deriving stock (Generic,Data)

instance FromRow GitRepoPage


data GitRepoListEntry =
  GitRepoListEntry
  { listEntryRef   :: GitLwwRef
  , listEntrySeq   :: GitLwwSeq
  , listEntryHead  :: GitRepoHeadRef
  , listEntryName  :: GitName
  , listEntryBrief :: GitBrief
  , listEntryGK0   :: GitEncrypted
  }
  deriving stock (Generic,Data)

instance ToJSON GitRepoListEntry

instance FromRow GitRepoListEntry

processedRepoTx :: (LWWRefKey HBS2Basic, HashRef) -> HashVal
processedRepoTx w = HashVal $ HashRef $ hashObject @HbSync (serialise w)

evolveDB :: MonadUnliftIO m => DBPipeM m ()
evolveDB = do
  debug $ yellow "evolveDB"
  gitRepoFactTable
  gitRepoRelatedFactTable
  gitRepoManifestTable
  gitRepoBundleTable
  gitRepoFactView
  txProcessedTable

txProcessedTable :: MonadUnliftIO m => DBPipeM m ()
txProcessedTable = do
  ddl [qc|
    create table if not exists txprocessed
    ( hash text not null primary key
    )
  |]


gitRepoFactTable :: MonadUnliftIO m => DBPipeM m ()
gitRepoFactTable = do
  ddl [qc|
    create table if not exists gitrepofact
    ( lwwref        text not null
    , lwwseq        integer not null
    , reflog        text not null
    , tx            text not null
    , repohead      text not null
    , repoheadseq   integer not null
    , name          text null
    , brief         text null
    , gk            text null
    , primary key (lwwref,lwwseq,reflog,tx,repohead)
    )
  |]


gitRepoRelatedFactTable :: MonadUnliftIO m => DBPipeM m ()
gitRepoRelatedFactTable = do
  ddl [qc|
    create table if not exists gitreporelatedfact
    ( lwwref        text not null
    , lwwrefrel     text not null
    , primary key (lwwref,lwwrefrel)
    )
  |]

gitRepoManifestTable :: MonadUnliftIO m => DBPipeM m ()
gitRepoManifestTable = do
  ddl [qc|
    create table if not exists gitrepomanifest
    ( repohead      text not null
    , manifest      text
    , primary key (repohead)
    )
  |]


gitRepoBundleTable :: MonadUnliftIO m => DBPipeM m ()
gitRepoBundleTable = do
  ddl [qc|
    create table if not exists gitrepobundle
    ( lwwref     text not null
    , bundle     text not null
    , primary key (lwwref,bundle)
    )
  |]

gitRepoFactView :: MonadUnliftIO m => DBPipeM m ()
gitRepoFactView = do
  ddl [qc|DROP VIEW IF EXISTS vrepofact|]
  ddl [qc|
    CREATE VIEW IF NOT EXISTS vrepofact AS
    SELECT
      lwwref,
      repoheadseq as lwwseq,
      repohead,
      name,
      brief,
      gk
    FROM (
      SELECT
        lwwref,
        repohead,
        name,
        brief,
        repoheadseq,
        gk,
        ROW_NUMBER() OVER (PARTITION BY lwwref ORDER BY lwwseq DESC, repoheadseq DESC) as rn
      FROM gitrepofact
    ) as s0
    WHERE rn = 1;
  |]

newtype GitRepoKey = GitRepoKey (LWWRefKey HBS2Basic)
                     deriving stock Generic

newtype HashVal    = HashVal HashRef
                     deriving stock Generic
                     deriving newtype (Pretty,Show)

instance ToJSON HashVal where
  toJSON (HashVal x) = toJSON (show $ pretty x)

instance ToField GitRepoKey where
  toField (GitRepoKey r) = toField $ show $ pretty $ AsBase58 r

instance ToField HashVal where
  toField (HashVal r) = toField $ show $ pretty $ AsBase58 r

instance FromField HashVal where
  fromField = fmap (HashVal . fromString @HashRef) . fromField @String


insertTxProcessed :: MonadUnliftIO m => HashVal -> DBPipeM m ()
insertTxProcessed hash = do
  SQL.insert [qc|
    insert into txprocessed (hash) values (?)
    on conflict do nothing
  |] (Only hash)


isTxProcessed :: MonadUnliftIO m => HashVal -> DBPipeM m Bool
isTxProcessed hash = do
  results <- select [qc|
    select 1 from txprocessed where hash = ? limit 1
  |] (Only hash)
  pure $ not $ null (results :: [Only Int])


gitRepoBundleProcessedKey :: HashRef -> HashVal
gitRepoBundleProcessedKey mhead =
  hashObject @HbSync (serialise ("GitRepoBundle", mhead)) & HashRef & HashVal

isGitRepoBundleProcessed :: MonadUnliftIO m => HashRef -> DBPipeM m Bool
isGitRepoBundleProcessed mhead = do
  isTxProcessed (gitRepoBundleProcessedKey mhead)

insertGitRepoBundleProcessed :: MonadUnliftIO m => HashRef -> DBPipeM m ()
insertGitRepoBundleProcessed mhead = do
  insertTxProcessed (gitRepoBundleProcessedKey mhead)

insertRepoBundleFact :: MonadUnliftIO m => GitRepoBundle -> DBPipeM m ()
insertRepoBundleFact rb = do
 insert @GitRepoBundle $
   onConflictIgnore @GitRepoBundle rb

insertRepoFacts :: (MonadUnliftIO m) => GitRepoFacts -> DBPipeM m ()

insertRepoFacts GitRepoRelatedFact{..} = do
  for_ (HS.toList gitRelated) $ \rel -> do
   insert @GitRepoRelatedFactTable $
     onConflictIgnore @GitRepoRelatedFactTable
     ( gitLwwRef
     , GitLwwRefRel (coerce rel)
     )

insertRepoFacts facts@GitRepoFacts{..} = do
 insert @GitRepoFacts $
   onConflictIgnore @GitRepoFacts
    ( gitLwwRef
    , gitLwwSeq
    , gitRefLog
    , gitTx
    , gitRepoHead
    , gitRepoHeadSeq
    , gitName
    , gitBrief
    , gitEncrypted
    )
 let mf = [ m | m :: GitManifest <- universeBi facts ]
 for_ mf $ \m@GitManifest{} -> do
  insert @GitManifest $ onConflictIgnore @GitManifest (gitRepoHead, m)
  pure ()

  -- insert @GitManifest ( gitRepoHead,