mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
4aed4d839b
commit
9dd3dc2a11
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue