dbpipe-generic: the beginning

.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
 

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
 

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
+
+

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 (FromField, ToField)
+                     deriving newtype (ToField)
 
 newtype GitLwwSeq  = GitLwwSeq Word64
                      deriving stock (Generic,Data)
-                    deriving newtype (FromField, ToField)
-
+                     deriving newtype (ToField)
 
 newtype GitRefLog  = GitRefLog (RefLogKey HBS2Basic)
                      deriving stock (Generic,Data)
-                    deriving newtype (FromField, ToField)
+                     deriving newtype (ToField)
 
 newtype GitTx  = GitTx HashRef
                  deriving stock (Generic,Data)
-                deriving newtype (FromField, ToField)
+                 deriving newtype (ToField)
 
 newtype GitRepoHeadRef  = GitRepoHeadRef HashRef
                           deriving stock (Generic,Data)
-                         deriving newtype (FromField, ToField)
+                          deriving newtype (ToField)
 
 newtype GitName  = GitName  (Maybe Text)
                    deriving stock (Generic,Data)
-                  deriving newtype (FromField, ToField)
+                   deriving newtype (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"
+
 
 

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"

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
+ insert @GitRepoFacts $
+   onConflictIgnore @GitRepoFacts
     ( gitLwwRef
     , gitLwwSeq
     , gitRefLog
+    , gitTx
+    , gitRepoHead
+    , gitName
+    , gitBrief
+    , gitEncrypted
     )
-                   -- ( gitLwwRef
-                   -- , gitLwwSeq
-                   -- , gitTx
-                   -- , gitRepoHead
-                   -- , gitName
-                   -- , gitBrief
-                   -- , gitEncrypted )
-  pure ()
 
 

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