diff --git a/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs b/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs new file mode 100644 index 00000000..d6ab9287 --- /dev/null +++ b/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs @@ -0,0 +1,80 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +{-# LANGUAGE DefaultSignatures #-} +module DBPipe.SQLite.Generic where + +import GHC.Generics +import Data.Text qualified as Text +import Data.Text (Text) +import Data.String (IsString(..)) +import Text.InterpolatedString.Perl6 (qc) +import Data.Coerce + +-- FIXME: move-to-DBPipe +newtype SQLName = SQLName Text + deriving stock (Eq,Ord,Show) + deriving newtype (IsString,Monoid,Semigroup) + +newtype SQLPart = SQLPart Text + deriving stock (Eq,Ord,Show) + deriving newtype (IsString,Monoid,Semigroup) + +class ToSQL a where + toSQL :: a -> SQLPart + +instance ToSQL SQLName where + toSQL (SQLName a) = SQLPart a + + +class HasTableName a where + tableName :: SQLName + +class HasTableName t => GHasColumnNames t f where + gColumnNames :: f p -> [SQLName] + +class HasTableName t => HasColumnNames t a where + columnNames :: a -> [SQLName] + default columnNames :: (Generic a, HasTableName t, GHasColumnNames t (Rep a)) => a -> [SQLName] + columnNames = gColumnNames @t . from + +class HasTableName t => HasColumnName t a where + columnName :: SQLName + +instance HasTableName t => HasColumnNames t [SQLName] where + columnNames = id + +instance HasTableName t => HasColumnNames t SQLName where + columnNames n = [n] + +instance (HasTableName t, Generic a, GHasColumnNames t (Rep a)) => HasColumnNames t a + +instance HasTableName t => GHasColumnNames t U1 where + gColumnNames U1 = [] + +instance (GHasColumnNames t a, GHasColumnNames t b) => GHasColumnNames t (a :*: b) where + gColumnNames (a :*: b) = gColumnNames @t a <> gColumnNames @t b + +instance (GHasColumnNames t a, GHasColumnNames t b) => GHasColumnNames t (a :+: b) where + gColumnNames _ = [] -- Не применяется для нашего случая, так как у нас нет вариантов. + +instance (HasTableName t, HasColumnName t c) => GHasColumnNames t (K1 i c) where + gColumnNames (K1 c) = [columnName @t @c] + +instance GHasColumnNames t a => GHasColumnNames t (M1 i t a) where + gColumnNames (M1 a) = gColumnNames @t a + +columnListPart :: forall t a . (HasTableName t, HasColumnNames t a) => a -> SQLPart +columnListPart w = SQLPart $ Text.intercalate "," [ coerce @_ @Text x | x <- columnNames @t w ] + +bindListPart :: forall t a . (HasTableName t, HasColumnNames t a) => a -> SQLPart +bindListPart w = SQLPart $ Text.intercalate "," [ "?" | _ <- columnNames @t w ] + +class (HasTableName t, HasColumnNames t b) => Insert t b where + insert :: b -> SQLPart + +instance (HasTableName t, HasColumnNames t b) => Insert t b where + insert values = [qc|insert into {tableName @t} values({n}) ({v})|] + where + n = bindListPart @t values + v = columnListPart @t values + diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs index dc57f992..6ca0cc05 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs @@ -1,67 +1,100 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} module HBS2.Git.Oracle.Facts where import HBS2.Git.Oracle.Prelude + import HBS2.Hash + +import DBPipe.SQLite +import DBPipe.SQLite.Generic + import Data.Word -import Codec.Serialise type PKS = PubKey 'Sign HBS2Basic deriving instance Data (RefLogKey HBS2Basic) deriving instance Data (LWWRefKey HBS2Basic) -data GitRepoRefFact = - GitRepoFact1 - { gitLwwRef :: LWWRefKey HBS2Basic - , gitLwwSeq :: Word64 - , gitRefLog :: RefLogKey HBS2Basic - } - deriving stock (Generic,Data) - -data GitRepoHeadFact = - GitRepoHeadFact1 - { gitRepoHeadRef :: HashRef - , gitRepoName :: Text - , gitRepoBrief :: Text - , gitRepoEncrypted :: Bool - } +data GitRepoExtended = + GitRepoExtended deriving stock (Generic,Data) -data GitRepoHeadVersionFact = - GitRepoHeadVersionFact1 - { gitRepoHeadVersion :: Word64 - } - deriving stock (Generic,Data) +newtype GitLwwRef = GitLwwRef (LWWRefKey HBS2Basic) + deriving stock (Generic,Data) + deriving newtype (FromField, ToField) + +newtype GitLwwSeq = GitLwwSeq Word64 + deriving stock (Generic,Data) + deriving newtype (FromField, ToField) + + +newtype GitRefLog = GitRefLog (RefLogKey HBS2Basic) + deriving stock (Generic,Data) + deriving newtype (FromField, ToField) + +newtype GitTx = GitTx HashRef + deriving stock (Generic,Data) + deriving newtype (FromField, ToField) + +newtype GitRepoHeadRef = GitRepoHeadRef HashRef + deriving stock (Generic,Data) + deriving newtype (FromField, ToField) + +newtype GitName = GitName (Maybe Text) + deriving stock (Generic,Data) + deriving newtype (FromField, ToField) + +newtype GitBrief = GitBrief (Maybe Text) + deriving stock (Generic,Data) + deriving newtype (FromField, ToField) + +newtype GitEncrypted = GitEncrypted (Maybe HashRef) + deriving stock (Generic,Data) data GitRepoFacts = - GitRepoRefFact GitRepoRefFact - | GitRepoHeadFact HashRef GitRepoHeadFact - | GitRepoHeadVersionFact HashRef GitRepoHeadVersionFact - | GitRepoTxFact (LWWRefKey HBS2Basic) HashRef - deriving stock (Generic,Data) + GitRepoFacts + { gitLwwRef :: GitLwwRef + , gitLwwSeq :: GitLwwSeq + , gitRefLog :: GitRefLog + , gitTx :: GitTx + , gitRepoHead :: GitRepoHeadRef + , gitName :: GitName + , gitBrief :: GitBrief + , gitEncrypted :: GitEncrypted + , gitExtended :: [GitRepoExtended] + } + deriving stock (Generic,Data) - -instance Serialise GitRepoRefFact -instance Serialise GitRepoHeadFact instance Serialise GitRepoFacts -instance Serialise GitRepoHeadVersionFact +instance Serialise GitLwwRef +instance Serialise GitLwwSeq +instance Serialise GitRefLog +instance Serialise GitTx +instance Serialise GitRepoHeadRef +instance Serialise GitName +instance Serialise GitBrief +instance Serialise GitRepoExtended +instance Serialise GitEncrypted -instance Pretty GitRepoFacts where - pretty (GitRepoRefFact x) = pretty x - pretty (GitRepoHeadFact ha x) = pretty ("gitrpoheadfact",ha,x) - pretty (GitRepoHeadVersionFact ha x) = pretty ("gitrpoheadversionfact",ha,x) - pretty (GitRepoTxFact r tx) = pretty ("gitrepotxfact", r, tx) +instance ToField HashRef where + toField = toField @String . show . pretty -instance Pretty GitRepoRefFact where - pretty (GitRepoFact1{..}) = - parens ( "gitrepofact1" <+> hsep [pretty gitLwwRef, pretty gitLwwSeq, pretty gitRefLog]) +instance FromField HashRef where + fromField x = fromField @String x <&> fromString -instance Pretty GitRepoHeadFact where - pretty (GitRepoHeadFact1{..}) = - parens ( "gitrepoheadfact1" <+> hsep [pretty gitRepoHeadRef]) +instance (ToField (LWWRefKey HBS2Basic)) where + toField = toField @String . show . pretty -instance Pretty GitRepoHeadVersionFact where - pretty (GitRepoHeadVersionFact1 v) = pretty v +instance (FromField (LWWRefKey HBS2Basic)) where + fromField x = fromField @String x <&> fromString + +instance ToField (RefLogKey HBS2Basic) where + toField = toField @String . show . pretty + +instance (FromField (RefLogKey HBS2Basic)) where + fromField x = fromField @String x <&> fromString diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs index c74d88df..cbfcec61 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs @@ -25,7 +25,7 @@ module HBS2.Git.Oracle.Prelude , module HBS2.Peer.RPC.Client.StorageClient , module HBS2.Peer.RPC.Client.Unix - , module DBPipe.SQLite + -- , module DBPipe.SQLite , module Data.Kind , module Control.Monad.Reader @@ -59,7 +59,7 @@ import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient import HBS2.Peer.RPC.Client.Unix -import DBPipe.SQLite hiding (runPipe) +-- import DBPipe.SQLite hiding (runPipe) import Data.Kind import Control.Monad.Reader 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 a24da3a2..eef9a823 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 @@ -19,6 +19,8 @@ import HBS2.KeyMan.Keys.Direct import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.Tx +import DBPipe.SQLite + import Data.ByteString.Lazy (ByteString) @@ -61,18 +63,15 @@ runOracleIndex auPk = do (lw,blk) <- readLWWBlock sto r >>= toMPlus let rk = lwwRefLogPubKey blk - lift $ S.yield $ - GitRepoFact1 r - (lwwSeq lw) - (RefLogKey rk) + lift $ S.yield (r,RefLogKey rk,blk) db <- asks _db facts <- S.toList_ do - for_ repos $ \what@GitRepoFact1{..} -> do + for_ repos $ \(lw,rk,LWWBlockData{..}) -> do - mhead <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce gitRefLog) + mhead <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk) <&> join for_ mhead $ \mh -> do @@ -104,26 +103,22 @@ runOracleIndex auPk = do (rhh,RepoHeadSimple{..}) <- readRepoHeadFromTx sto tx >>= toMPlus - let enc = isJust _repoHeadGK0 let name = Text.take 256 $ _repoHeadName let brief = Text.take 1024 $ _repoHeadBrief let manifest = _repoManifest - let repoFactHash = hashObject @HbSync (serialise what) & HashRef + lift $ S.yield $ GitRepoFacts + (GitLwwRef lw) + (GitLwwSeq lwwRefSeed) + (GitRefLog rk) + (GitTx tx) + (GitRepoHeadRef rhh) + (GitName (Just name)) + (GitBrief (Just brief)) + (GitEncrypted _repoHeadGK0) + mempty - let f1 = GitRepoRefFact what - let f2 = GitRepoHeadFact - repoFactHash - (GitRepoHeadFact1 rhh name brief enc) - let f3 = GitRepoHeadVersionFact rhh (GitRepoHeadVersionFact1 _repoHeadTime) - let f4 = GitRepoTxFact gitLwwRef tx - - lift $ S.yield f1 - lift $ S.yield f2 - lift $ S.yield f3 - lift $ S.yield f4 - - liftIO $ withDB db (insertTxProcessed (HashVal tx)) + -- liftIO $ withDB db (insertTxProcessed (HashVal tx)) rchanAPI <- asks _refchanAPI chan <- asks _refchanId @@ -157,8 +152,7 @@ runDump pks = do flip runContT pure do - -- p <- ContT $ withProcessWait cmd - p <- lift $ startProcess cmd -- ContT $ withProcessWait cmd + p <- ContT $ withProcessWait cmd let ssin = getStdin p let sout = getStdout p @@ -287,8 +281,8 @@ updateState = do Right txs -> do -- FIXME: skip-already-processed-blocks for_ txs $ \htx -> void $ runMaybeT do - -- done <- liftIO $ withDB db (isTxProcessed (HashVal htx)) - -- guard (not done) + done <- liftIO $ withDB db (isTxProcessed (HashVal htx)) + guard (not done) getBlock sto (fromHashRef htx) >>= toMPlus <&> deserialiseOrFail @(RefChanUpdate L4Proto) @@ -302,32 +296,15 @@ updateState = do >>= \(ProposeTran _ box) -> toMPlus (unboxSignedBox0 box) <&> snd <&> deserialiseOrFail @GitRepoFacts . LBS.fromStrict - >>= toMPlus >>= lift . S.yield . (htx,) - let rf = [ (HashRef (hashObject $ serialise f), f) - | f@GitRepoFact1{} <- universeBi facts - ] - 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 - ] - - let rhtf = [ (h,f) | (GitRepoHeadVersionFact h f) <- universeBi facts ] - lift $ withState $ transactional do - for_ rf $ \(h, GitRepoFact1{..}) -> do - insertGitRepo (GitRepoKey gitLwwRef) - insertGitRepoFact (GitRepoKey gitLwwRef) (HashVal h) - 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) + for_ facts $ \case + (tx, Right f) -> do + debug $ "GOOD FACT" <+> pretty tx - for_ rhtf $ \(h, GitRepoHeadVersionFact1{..}) -> do - insertGitRepoHeadVersion (HashVal h) gitRepoHeadVersion + (tx, _) -> do + debug "BAD FACT" + insertTxProcessed (HashVal tx) 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 005a3205..5e847ece 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 @@ -1,11 +1,23 @@ +{-# 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 GHC.Generics import Data.Aeson import Text.InterpolatedString.Perl6 (qc) +import Data.Coerce import Data.Word +import Data.Text qualified as Text processedRepoTx :: (LWWRefKey HBS2Basic, HashRef) -> HashVal processedRepoTx w = HashVal $ HashRef $ hashObject @HbSync (serialise w) @@ -13,12 +25,7 @@ processedRepoTx w = HashVal $ HashRef $ hashObject @HbSync (serialise w) evolveDB :: MonadUnliftIO m => DBPipeM m () evolveDB = do debug $ yellow "evolveDB" - gitRepoTable gitRepoFactTable - gitRepoNameTable - gitRepoBriefTable - gitRepoHeadTable - gitRepoHeadVersionTable txProcessedTable txProcessedTable :: MonadUnliftIO m => DBPipeM m () @@ -29,63 +36,20 @@ txProcessedTable = do ) |] -gitRepoTable :: MonadUnliftIO m => DBPipeM m () -gitRepoTable = do - ddl [qc| - create table if not exists gitrepo - ( ref text not null primary key - ) - |] 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 - ddl [qc| - create table if not exists gitreponame - ( ref text not null - , hash text not null - , name text not null - , primary key (ref, hash) - ) - |] - -gitRepoBriefTable :: MonadUnliftIO m => DBPipeM m () -gitRepoBriefTable = do - ddl [qc| - create table if not exists gitrepobrief - ( ref text not null - , hash text not null - , brief text not null - , primary key (ref, hash) - ) - |] - -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| - create table if not exists gitrepoheadversion - ( hash text not null - , version integer not null - , primary key (hash) + ( lwwref text not null + , lwwseq integer not null + , reflog text not null + , tx text not null + , repohead text not null + , name text null + , brief text null + , encrypted text null + , primary key (lwwref,seq,reflog,tx,repohead) ) |] @@ -107,53 +71,17 @@ instance ToField HashVal where instance FromField HashVal where fromField = fmap (HashVal . fromString @HashRef) . fromField @String -insertGitRepo :: MonadUnliftIO m => GitRepoKey -> DBPipeM m () -insertGitRepo repo = do - insert [qc| - insert into gitrepo(ref) values(?) - on conflict (ref) do nothing - |] (Only repo) - - insertGitRepoFact :: MonadUnliftIO m => GitRepoKey -> HashVal -> DBPipeM m () insertGitRepoFact repo h = do - insert [qc| + SQL.insert [qc| insert into gitrepofact(ref,hash) values(?,?) on conflict (ref,hash) do nothing |] (repo,h) -insertGitRepoName :: MonadUnliftIO m - => (GitRepoKey, HashVal) - -> Text - -> DBPipeM m () -insertGitRepoName (r,h) name = do - insert [qc| - insert into gitreponame (ref,hash,name) values(?,?,?) - on conflict (ref,hash) do update set name = excluded.name - |] (r,h,name) - -insertGitRepoBrief :: MonadUnliftIO m - => (GitRepoKey, HashVal) - -> Text - -> DBPipeM m () -insertGitRepoBrief (r,h) b = do - insert [qc| - insert into gitrepobrief (ref,hash,brief) values(?,?,?) - on conflict (ref,hash) do update set brief = excluded.brief - |] (r,h,b) - - -insertGitRepoHeadVersion :: MonadUnliftIO m => HashVal -> Word64 -> DBPipeM m () -insertGitRepoHeadVersion hashVal version = do - insert [qc| - insert into gitrepoheadversion (hash, version) values(?,?) - on conflict (hash) do update set version = excluded.version - |] (hashVal, version) - insertTxProcessed :: MonadUnliftIO m => HashVal -> DBPipeM m () insertTxProcessed hash = do - insert [qc| + SQL.insert [qc| insert into txprocessed (hash) values (?) on conflict do nothing |] (Only hash) @@ -166,10 +94,36 @@ 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) + + +instance HasTableName t => HasColumnName t GitLwwRef where + columnName = "lwwref" + +instance HasTableName t => HasColumnName t GitLwwSeq where + columnName = "lwwseq" + +instance HasTableName t => HasColumnName t GitRefLog where + columnName = "reflog" + + +instance HasTableName GitRepoFacts where + tableName = "gitrepofact" + + +insertRepoFacts :: (MonadUnliftIO m) => GitRepoFacts -> DBPipeM m () +insertRepoFacts GitRepoFacts{..} = do + let sql = insert @GitRepoFacts + ( gitLwwRef + , gitLwwSeq + , gitRefLog + ) + -- ( gitLwwRef + -- , gitLwwSeq + -- , gitTx + -- , gitRepoHead + -- , gitName + -- , gitBrief + -- , gitEncrypted ) + pure () + diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index a8aa0a58..6f7cf5da 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -178,6 +178,7 @@ library hbs2-git-oracle-oracle-lib HBS2.Git.Oracle.Run HBS2.Git.Oracle.State HBS2.Git.Oracle.Facts + DBPipe.SQLite.Generic build-depends: base, hbs2-git , base16-bytestring