wip

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
+

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 =
+data GitRepoExtended =
-  GitRepoFact1
+  GitRepoExtended
-  { gitLwwRef :: LWWRefKey HBS2Basic
-  , gitLwwSeq :: Word64
-  , gitRefLog :: RefLogKey HBS2Basic
-  }
-  deriving stock (Generic,Data)
-
-data GitRepoHeadFact =
-  GitRepoHeadFact1
-  { gitRepoHeadRef   :: HashRef
-  , gitRepoName      :: Text
-  , gitRepoBrief     :: Text
-  , gitRepoEncrypted :: Bool
-  }
   deriving stock (Generic,Data)
 
 
-data GitRepoHeadVersionFact =
+newtype GitLwwRef = GitLwwRef (LWWRefKey HBS2Basic)
-  GitRepoHeadVersionFact1
+                    deriving stock (Generic,Data)
-  { gitRepoHeadVersion  :: Word64
+                    deriving newtype (FromField, ToField)
-  }
+
-  deriving stock (Generic,Data)
+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
+  GitRepoFacts
-    | GitRepoHeadFact HashRef GitRepoHeadFact
+  { gitLwwRef    :: GitLwwRef
-    | GitRepoHeadVersionFact HashRef GitRepoHeadVersionFact
+  , gitLwwSeq    :: GitLwwSeq
-    | GitRepoTxFact (LWWRefKey HBS2Basic) HashRef
+  , gitRefLog    :: GitRefLog
-    deriving stock (Generic,Data)
+  , 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
+instance ToField HashRef where
-  pretty (GitRepoRefFact x)    = pretty x
+  toField = toField @String . show . pretty
-  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 Pretty GitRepoRefFact where
+instance FromField HashRef where
-  pretty (GitRepoFact1{..}) =
+  fromField x = fromField @String x <&> fromString
-    parens ( "gitrepofact1" <+>  hsep [pretty gitLwwRef, pretty gitLwwSeq, pretty gitRefLog])
 
-instance Pretty GitRepoHeadFact where
+instance (ToField (LWWRefKey HBS2Basic))  where
-  pretty (GitRepoHeadFact1{..}) =
+  toField = toField @String . show . pretty
-    parens ( "gitrepoheadfact1" <+>  hsep [pretty gitRepoHeadRef])
 
-instance Pretty GitRepoHeadVersionFact where
+instance (FromField (LWWRefKey HBS2Basic))  where
-  pretty (GitRepoHeadVersionFact1 v) = pretty v
+  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
 
 

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

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 $
+            lift $ S.yield (r,RefLogKey rk,blk)
-              GitRepoFact1 r
-                           (lwwSeq lw)
-                           (RefLogKey rk)
 
   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
+          -- liftIO $ withDB db (insertTxProcessed (HashVal tx))
-          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))
 
   rchanAPI <- asks _refchanAPI
   chan  <- asks _refchanId
@@ -157,8 +152,7 @@ runDump pks = do
 
   flip runContT pure do
 
-    -- p <- ContT $ withProcessWait cmd
+    p <- ContT $ withProcessWait cmd
-    p <- lift $ startProcess cmd -- 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))
+            done <- liftIO $ withDB db (isTxProcessed (HashVal htx))
-            -- guard (not done)
+            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
+      for_ facts $ \case
-        GitRepoFact1{..} <- HM.lookup h rfm & toMPlus
+        (tx, Right f) -> do
-        lift do
+          debug $ "GOOD FACT" <+> pretty tx
-          insertGitRepoName (GitRepoKey gitLwwRef , HashVal gitRepoHeadRef) gitRepoName
-          insertGitRepoBrief (GitRepoKey gitLwwRef , HashVal gitRepoHeadRef) gitRepoBrief
-          insertGitRepoHead  (GitRepoKey gitLwwRef) (HashVal gitRepoHeadRef)
 
-      for_ rhtf $ \(h, GitRepoHeadVersionFact1{..}) -> do
+        (tx, _) -> do
-        insertGitRepoHeadVersion (HashVal h) gitRepoHeadVersion
+          debug "BAD FACT"
+          insertTxProcessed (HashVal tx)
 

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
+    ( lwwref        text not null
-    , hash text not null
+    , lwwseq        integer not null
-    , primary key (ref,hash)
+    , reflog        text not null
-    )
+    , tx            text not null
-  |]
+    , repohead      text not null
-
+    , name          text null
-gitRepoNameTable :: MonadUnliftIO m => DBPipeM m ()
+    , brief         text null
-gitRepoNameTable = do
+    , encrypted     text null
-  ddl [qc|
+    , primary key (lwwref,seq,reflog,tx,repohead)
-    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)
     )
   |]
 
@@ -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|
+instance HasTableName t => HasColumnName t GitLwwRef where
-    insert into gitrepohead (ref, head) values (?, ?)
+  columnName = "lwwref"
-    on conflict (ref) do nothing
+
-  |] (repo, headRef)
+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 ()
+
 

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