diff --git a/.hbs2-git/manifest b/.hbs2-git/manifest index 58287d6d..b7b963ca 100644 --- a/.hbs2-git/manifest +++ b/.hbs2-git/manifest @@ -1,7 +1,7 @@ name: "hbs2" author: "Dmitry Zuikov" public: yes -brief: "HBS2: P2P CAS and protocol framework #haskell #p2p #distributed 11" +brief: "HBS2: P2P CAS and protocol framework #haskell #p2p #distributed" # Project description diff --git a/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs b/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs index 62631cac..36d7e171 100644 --- a/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs +++ b/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs @@ -3,20 +3,25 @@ {-# LANGUAGE DefaultSignatures #-} module DBPipe.SQLite.Generic where +import DBPipe.SQLite.Types +import DBPipe.SQLite qualified as SQL +import DBPipe.SQLite hiding (insert,columnName) + 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 +import UnliftIO newtype SQLName = SQLName Text - deriving stock (Eq,Ord,Show) - deriving newtype (IsString,Monoid,Semigroup) + deriving stock (Eq,Ord) + deriving newtype (IsString,Monoid,Semigroup,Show) newtype SQLPart = SQLPart Text - deriving stock (Eq,Ord,Show) - deriving newtype (IsString,Monoid,Semigroup) + deriving stock (Eq,Ord) + deriving newtype (IsString,Monoid,Semigroup,Show) class ToSQL a where toSQL :: a -> SQLPart @@ -24,17 +29,18 @@ class ToSQL a where instance ToSQL SQLName where toSQL (SQLName a) = SQLPart a + class GHasColumnNames f where gColumnNames :: f p -> [SQLName] +class HasTableName a where + tableName :: SQLName + class HasColumnNames a where columnNames :: a -> [SQLName] default columnNames :: (Generic a, GHasColumnNames (Rep a)) => a -> [SQLName] columnNames = gColumnNames . from -class HasTableName t where - tableName :: SQLName - class HasColumnName a where columnName :: SQLName @@ -44,7 +50,7 @@ instance HasColumnNames [SQLName] where instance HasColumnNames SQLName where columnNames n = [n] -instance (Generic a, GHasColumnNames (Rep a)) => HasColumnNames a +instance {-# OVERLAPPABLE #-} (Generic a, GHasColumnNames (Rep a)) => HasColumnNames a instance GHasColumnNames U1 where gColumnNames U1 = [] @@ -61,18 +67,85 @@ instance HasColumnName c => GHasColumnNames (K1 i c) where instance GHasColumnNames a => GHasColumnNames (M1 i t a) where gColumnNames (M1 a) = gColumnNames a +data Bound = forall a . ToField a => Bound a + +class GToBoundList f where + gToBoundList :: f p -> [Bound] + +instance GToBoundList U1 where + gToBoundList U1 = [] + +instance (GToBoundList a, GToBoundList b) => GToBoundList (a :*: b) where + gToBoundList (a :*: b) = gToBoundList a <> gToBoundList b + +instance (ToField c) => GToBoundList (K1 i c) where + gToBoundList (K1 c) = [Bound c] + +instance GToBoundList a => GToBoundList (M1 i t a) where + gToBoundList (M1 a) = gToBoundList a + +class ToBoundList a where + toBoundList :: a -> [Bound] + default toBoundList :: (Generic a, GToBoundList (Rep a)) => a -> [Bound] + toBoundList = gToBoundList . from + +instance (Generic a, GToBoundList (Rep a)) => ToBoundList a where + toBoundList = gToBoundList . from + columnListPart :: forall a . HasColumnNames a => a -> SQLPart columnListPart w = SQLPart $ Text.intercalate "," [ coerce @_ @Text x | x <- columnNames w ] bindListPart :: forall a . HasColumnNames a => a -> SQLPart bindListPart w = SQLPart $ Text.intercalate "," [ "?" | _ <- columnNames w ] -class (HasTableName t, HasColumnNames b) => Insert t b where - insert :: b -> SQLPart +class HasPrimaryKey t where + primaryKey :: [SQLName] -instance (HasTableName t, HasColumnNames b) => Insert t b where - insert values = [qc|insert into {tableName @t} values({v}) ({n})|] +newtype OnCoflictIgnore t r = OnCoflictIgnore r + deriving stock (Generic) + +instance (HasPrimaryKey t, HasColumnNames r) => HasColumnNames (OnCoflictIgnore t r) where + columnNames (OnCoflictIgnore r) = columnNames r + +onConflictIgnore :: forall t r . (HasTableName t, HasColumnNames r) => r -> OnCoflictIgnore t r +onConflictIgnore = OnCoflictIgnore + +instance ToField Bound where + toField (Bound x) = toField x + +data BoundQuery = + BoundQuery SQLPart [Bound] + +class (MonadIO m, HasTableName t, HasColumnNames b) => Insert t b m where + insert :: b -> DBPipeM m () + +instance {-# OVERLAPPABLE #-} + ( MonadIO m + , HasTableName t + , HasColumnNames b + , ToBoundList b + ) => Insert t b m where + insert values = do + SQL.insert [qc|insert into {tn} values({v}) ({n})|] bound where - n = bindListPart values - v = columnListPart values + v = coerce @_ @Text $ bindListPart values + n = coerce @_ @Text $ columnListPart values + bound = toBoundList values + tn = coerce @_ @Text (tableName @t) + +instance {-# OVERLAPPABLE #-} + ( MonadIO m + , HasTableName t + , HasPrimaryKey t + , HasColumnNames b + , ToBoundList b + ) => Insert t (OnCoflictIgnore t b) m where + insert (OnCoflictIgnore values) = do + SQL.insert [qc|insert into {tn} ({n}) values({v}) on conflict ({pk}) do nothing|] bound + where + v = coerce @_ @Text $ bindListPart values + n = coerce @_ @Text $ columnListPart values + bound = toBoundList values + tn = coerce @_ @Text (tableName @t) + pk = coerce @_ @Text $ columnListPart $ primaryKey @t diff --git a/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Types.hs b/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Types.hs new file mode 100644 index 00000000..757d5c89 --- /dev/null +++ b/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Types.hs @@ -0,0 +1,7 @@ +module DBPipe.SQLite.Types + ( ToField(..) + )where + +import Database.SQLite.Simple.ToField + + 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 9c70ed50..2df02ae4 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 @@ -10,6 +10,7 @@ import HBS2.Hash import DBPipe.SQLite import DBPipe.SQLite.Generic +import GHC.Generics import Data.Word type PKS = PubKey 'Sign HBS2Basic @@ -21,38 +22,39 @@ data GitRepoExtended = GitRepoExtended deriving stock (Generic,Data) +newtype GitLwwRef = GitLwwRef (LWWRefKey HBS2Basic) + deriving stock (Generic,Data) + deriving newtype (ToField) -newtype GitLwwRef = GitLwwRef (LWWRefKey HBS2Basic) +newtype GitLwwSeq = GitLwwSeq Word64 + deriving stock (Generic,Data) + deriving newtype (ToField) + +newtype GitRefLog = GitRefLog (RefLogKey HBS2Basic) + deriving stock (Generic,Data) + deriving newtype (ToField) + +newtype GitTx = GitTx HashRef + deriving stock (Generic,Data) + deriving newtype (ToField) + +newtype GitRepoHeadRef = GitRepoHeadRef HashRef + deriving stock (Generic,Data) + deriving newtype (ToField) + +newtype GitName = GitName (Maybe Text) + deriving stock (Generic,Data) + deriving newtype (ToField) + +newtype GitBrief = GitBrief (Maybe Text) 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) + deriving newtype (ToField) newtype GitEncrypted = GitEncrypted (Maybe HashRef) deriving stock (Generic,Data) + deriving newtype (ToField) + +data Facts data GitRepoFacts = GitRepoFacts @@ -97,6 +99,12 @@ instance ToField (RefLogKey HBS2Basic) where instance (FromField (RefLogKey HBS2Basic)) where fromField x = fromField @String x <&> fromString +instance HasTableName GitRepoFacts where + tableName = "gitrepofact" + +instance HasPrimaryKey GitRepoFacts where + primaryKey = ["lwwref","lwwseq","reflog","tx","repohead"] + instance HasColumnName GitLwwRef where columnName = "lwwref" @@ -106,7 +114,20 @@ instance HasColumnName GitLwwSeq where instance HasColumnName GitRefLog where columnName = "reflog" -instance HasTableName GitRepoFacts where - tableName = "gitrepofact" +instance HasColumnName GitTx where + columnName = "tx" + +instance HasColumnName GitRepoHeadRef where + columnName = "repohead" + +instance HasColumnName GitName where + columnName = "name" + +instance HasColumnName GitBrief where + columnName = "brief" + +instance HasColumnName GitEncrypted where + columnName = "gk" + 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 eef9a823..cd6cf996 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 @@ -303,6 +303,8 @@ updateState = do for_ facts $ \case (tx, Right f) -> do debug $ "GOOD FACT" <+> pretty tx + insertRepoFacts f + insertTxProcessed (HashVal tx) (tx, _) -> do debug "BAD FACT" 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 dd0c055a..de19043a 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 @@ -48,8 +48,8 @@ gitRepoFactTable = do , repohead text not null , name text null , brief text null - , encrypted text null - , primary key (lwwref,seq,reflog,tx,repohead) + , gk text null + , primary key (lwwref,lwwseq,reflog,tx,repohead) ) |] @@ -71,13 +71,6 @@ instance ToField HashVal where instance FromField HashVal where fromField = fmap (HashVal . fromString @HashRef) . fromField @String -insertGitRepoFact :: MonadUnliftIO m => GitRepoKey -> HashVal -> DBPipeM m () -insertGitRepoFact repo h = do - SQL.insert [qc| - insert into gitrepofact(ref,hash) values(?,?) - on conflict (ref,hash) do nothing - |] (repo,h) - insertTxProcessed :: MonadUnliftIO m => HashVal -> DBPipeM m () insertTxProcessed hash = do @@ -95,21 +88,18 @@ isTxProcessed hash = do pure $ not $ null (results :: [Only Int]) - insertRepoFacts :: (MonadUnliftIO m) => GitRepoFacts -> DBPipeM m () insertRepoFacts GitRepoFacts{..} = do - let sql = insert @GitRepoFacts - ( gitLwwRef - , gitLwwSeq - , gitRefLog - ) - -- ( gitLwwRef - -- , gitLwwSeq - -- , gitTx - -- , gitRepoHead - -- , gitName - -- , gitBrief - -- , gitEncrypted ) - pure () + insert @GitRepoFacts $ + onConflictIgnore @GitRepoFacts + ( gitLwwRef + , gitLwwSeq + , gitRefLog + , gitTx + , gitRepoHead + , gitName + , gitBrief + , gitEncrypted + ) diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 6f7cf5da..b5209011 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -178,12 +178,15 @@ library hbs2-git-oracle-oracle-lib HBS2.Git.Oracle.Run HBS2.Git.Oracle.State HBS2.Git.Oracle.Facts + DBPipe.SQLite.Types DBPipe.SQLite.Generic build-depends: base, hbs2-git , base16-bytestring , binary , unix + -- FIXME: ASAP-remove + , sqlite-simple hs-source-dirs: hbs2-git-oracle/lib