Merge commit '371cf53e3ad667c9ede4b56d55a511fd9583b2e6' as 'miscellaneous/db-pipe'

miscellaneous/db-pipe/.envrc

@@ -0,0 +1 @@
+use flake

miscellaneous/db-pipe/.gitignore

@@ -0,0 +1,7 @@
+.hbs2/
+.direnv/
+dist-newstyle/
+.hbs2-git/
+result/
+result
+

miscellaneous/db-pipe/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for db-pipe
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

miscellaneous/db-pipe/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2023, Dmitry Zuykov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Dmitry Zuykov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

miscellaneous/db-pipe/db-pipe.cabal

@@ -0,0 +1,71 @@
+cabal-version:      3.0
+name:               db-pipe
+version:            0.1.0.1
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuykov
+maintainer:         dzuikov@gmail.com
+-- copyright:
+category:           Database
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common common-properties
+    ghc-options: -Wall
+
+  default-language:   GHC2021
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , OverloadedLabels
+                     , QuasiQuotes
+                     , RankNTypes
+                     , RecordWildCards
+                     , RecursiveDo
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+                     , TypeOperators
+
+library
+    import:           common-properties
+    exposed-modules:
+      DBPipe.SQLite
+      DBPipe.SQLite.Types
+      DBPipe.SQLite.Generic
+
+    -- other-modules:
+    -- other-extensions:
+    build-depends:    base >=4.17.2.0
+                    , clock
+                    , interpolatedstring-perl6
+                    , mtl
+                    , stm
+                    , sqlite-simple
+                    , text
+                    , unliftio
+
+    hs-source-dirs:   lib
+    default-language: GHC2021

miscellaneous/db-pipe/flake.lock

@@ -0,0 +1,61 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "locked": {
+        "lastModified": 1644229661,
+        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "haskell-flake-utils": {
+      "inputs": {
+        "flake-utils": "flake-utils"
+      },
+      "locked": {
+        "lastModified": 1707809372,
+        "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1727335715,
+        "narHash": "sha256-1uw3y94dA4l22LkqHRIsb7qr3rV5XdxQFqctINfx8Cc=",
+        "owner": "nixos",
+        "repo": "nixpkgs",
+        "rev": "28b5b8af91ffd2623e995e20aee56510db49001a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nixos",
+        "ref": "nixpkgs-unstable",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "haskell-flake-utils": "haskell-flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

miscellaneous/db-pipe/flake.nix

@@ -0,0 +1,48 @@
+{
+description = "db-pipe";
+
+inputs = {
+  nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
+  haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils";
+};
+
+outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
+  haskell-flake-utils.lib.simpleCabal2flake {
+    inherit self nixpkgs;
+    systems = [ "x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin" ];
+
+    name = "db-pipe";
+
+      # shellWithHoogle = true;
+
+      # haskellFlakes = with inputs; [
+      # ];
+
+      # hpPreOverrides = { pkgs }: new: old:
+      #   with pkgs.haskell.lib;
+      #   with haskell-flake-utils.lib;
+      #   tunePackages pkgs old {
+      #     somepkg          = [ (jailbreakUnbreak pkgs) dontCheck ];
+      #   };
+
+      packagePostOverrides = { pkgs }: with pkgs; with haskell.lib; [
+        disableExecutableProfiling
+        disableLibraryProfiling
+        dontBenchmark
+        dontCoverage
+        dontDistribute
+        dontHaddock
+        dontHyperlinkSource
+        doStrip
+        enableDeadCodeElimination
+        justStaticExecutables
+
+        dontCheck
+      ];
+
+      shellExtBuildInputs = {pkgs}: with pkgs; [
+        haskellPackages.haskell-language-server
+      ];
+
+    };
+}

miscellaneous/db-pipe/lib/DBPipe/SQLite.hs

@@ -0,0 +1,189 @@
+{-# Language AllowAmbiguousTypes #-}
+module DBPipe.SQLite
+  ( module Database.SQLite.Simple
+  , ToField(..)
+  , FromField(..)
+  , ToRow(..)
+  , FromRow(..)
+  , DBPipeEnv
+  , DBPipeOpts(..)
+  , dbPipeOptsDef
+  , runPipe
+  , newDBPipeEnv
+  , DBPipeM
+  , select, select_
+  , update, update_
+  , insert, insert_
+  , ddl
+  , transactional
+  , transactional_
+  , commitAll
+  , withDB
+  , shutdown
+  ) where
+
+import Control.Concurrent
+import Control.Concurrent.STM (flushTQueue)
+import Control.Monad
+import Control.Monad.Reader
+import Database.SQLite.Simple
+import Database.SQLite.Simple.ToField
+import Database.SQLite.Simple.FromField
+import Data.Fixed
+import System.Clock
+import Text.InterpolatedString.Perl6 (qc)
+import System.IO (hPrint)
+import Data.Kind()
+import Data.String
+import UnliftIO
+
+data DBPipeOpts =
+  DBPipeOpts
+  { dbPipeBatchTime :: Fixed E2
+  , dbLogger        :: String -> IO ()
+  }
+
+data DBPipeEnv =
+  DBPipeEnv
+  { opts         :: DBPipeOpts
+  , connPath     :: FilePath
+  , connection   :: TVar (Maybe Connection)
+  , transNum     :: TVar Int
+  , updates      :: TQueue (IO ())
+  , updatesCount :: TVar Int
+  , updatedLast  :: TVar (Maybe TimeSpec)
+  }
+
+newtype DBPipeM m a = DBPipeM { fromDBPipeM :: ReaderT DBPipeEnv m a }
+                      deriving newtype ( Applicative
+                                       , Functor
+                                       , Monad
+                                       , MonadReader DBPipeEnv
+                                       , MonadIO
+                                       , MonadUnliftIO
+                                       , MonadTrans
+                                       )
+
+dbPipeOptsDef :: DBPipeOpts
+dbPipeOptsDef = DBPipeOpts 1 (liftIO . hPrint stderr)
+
+newDBPipeEnv :: MonadIO m => DBPipeOpts -> FilePath -> m DBPipeEnv
+newDBPipeEnv opts fp = liftIO $ do
+  DBPipeEnv opts fp <$> newTVarIO Nothing
+                    <*> newTVarIO 0
+                    <*> newTQueueIO
+                    <*> newTVarIO 0
+                    <*> newTVarIO Nothing
+
+withDB :: forall a m . MonadIO m => DBPipeEnv -> DBPipeM m a -> m a
+withDB env action = runReaderT (fromDBPipeM action) env
+
+runPipe :: forall m . MonadIO m => DBPipeEnv -> m ()
+runPipe env@(DBPipeEnv{..}) = do
+  forever $ do
+    liftIO $ threadDelay (round (dbPipeBatchTime opts * 1_000_000))
+    _ <- atomically $ peekTQueue updates
+    withDB env commitAll
+
+
+shutdown :: forall m . MonadIO m => Bool -> DBPipeEnv -> m ()
+shutdown doCommit env = do
+  when doCommit $ withDB env commitAll
+  mco <- readTVarIO (connection env)
+  atomically $ writeTVar (connection env) Nothing
+  maybe (pure ()) (liftIO . close) mco
+
+transactional :: forall a m . (MonadUnliftIO m) => DBPipeM m a -> DBPipeM m ()
+transactional what = do
+  conn <- withConn pure
+  env <- ask
+  transactional_ env conn what
+
+transactional_ :: forall a m . MonadUnliftIO m => DBPipeEnv -> Connection -> m a -> m ()
+transactional_ DBPipeEnv{..} conn action = do
+  tnum <- liftIO $ atomically $ stateTVar transNum $ \s -> (s, succ s)
+  let sp = [qc|sp{tnum}|] :: String
+
+  liftIO $ execute_ conn [qc|SAVEPOINT {sp}|]
+
+  try action >>= \case
+
+    Right{} -> do
+      liftIO $ execute_ conn [qc|RELEASE SAVEPOINT {sp}|]
+
+    Left ( e :: SomeException ) -> liftIO do
+      dbLogger opts (show e)
+      execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|]
+      throwIO e
+
+class ToQuery a b where
+  toSQL :: a -> String
+
+withConn :: forall a m . MonadIO m => (Connection -> IO a) -> DBPipeM m a
+withConn action = do
+  DBPipeEnv{..} <- ask
+  conn <- readTVarIO connection >>= \case
+      Just conn -> pure conn
+      Nothing -> do
+        conn <- liftIO $ open connPath
+        atomically (writeTVar connection (Just conn))
+        pure conn
+  liftIO $ action conn
+
+
+commitAll :: MonadIO m => DBPipeM m ()
+commitAll = do
+  env@(DBPipeEnv{..}) <- ask
+  ops <- atomically $ flushTQueue updates
+  withDB env $ withConn $ \conn -> do
+    transactional_ env conn $ sequence_ ops
+
+select :: forall b args a m . (ToQuery a b, FromRow b, ToRow args, MonadIO m) => a -> args -> DBPipeM m [b]
+select q wtf = withConn $ \conn -> do
+  liftIO $ query conn (fromString (toSQL @a @b q)) wtf
+
+select_ :: (ToQuery a b, FromRow b, MonadIO m) => a -> DBPipeM m [b]
+select_ a = select a ()
+
+update_ :: forall a m . (ToQuery a (), MonadIO m) => a -> DBPipeM m ()
+update_ a = update @a @() @() a ()
+
+insert_ :: forall a m . (ToQuery a (), MonadIO m) => a -> DBPipeM m ()
+insert_ a = insert @a @() @() a ()
+
+update :: forall a args b m . (ToQuery a b, ToRow args, MonadIO m) => a -> args -> DBPipeM m ()
+update q args = withConn $ \conn -> do
+  execute conn  (fromString (toSQL @a @b q)) args
+
+insert :: forall a args b m . (ToQuery a b, ToRow args, MonadIO m) => a -> args -> DBPipeM m ()
+insert = update @a @_ @b
+
+ddl :: forall a m . (ToQuery a (), MonadIO m) => a -> DBPipeM m ()
+ddl a = update @a @() @() a ()
+
+instance ToQuery String r where
+  toSQL a = a
+
+test1 :: IO ()
+test1 = do
+  env <- newDBPipeEnv dbPipeOptsDef ":memory:"
+
+  a <- async $ runPipe env
+
+  withDB env do
+    ddl "create table wtf (k int primary key, v int)"
+    commitAll
+
+  withDB env $ do
+
+    transactional do
+      update "insert into wtf (k,v) values(1,1)" ()
+
+    commitAll
+
+    wtf <- select @(Int,Int) "select k,v from wtf" ()
+    liftIO $ print wtf
+
+  cancel a
+
+

miscellaneous/db-pipe/lib/DBPipe/SQLite/Generic.hs

@@ -0,0 +1,195 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# 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.Proxy
+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)
+                  deriving newtype (IsString,Monoid,Semigroup,Show)
+
+newtype SQLPart = SQLPart { fromSQL :: Text }
+                  deriving stock (Eq,Ord)
+                  deriving newtype (IsString,Monoid,Semigroup,Show)
+
+data AllColumns a = AllColumns
+                    deriving stock (Generic)
+
+class ToSQL a where
+  toSQL :: a -> SQLPart
+
+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 HasColumnName a where
+  columnName :: SQLName
+
+instance HasColumnNames [SQLName] where
+  columnNames = id
+
+instance HasColumnNames SQLName where
+  columnNames n = [n]
+
+instance {-# OVERLAPPABLE #-} (Generic a, GHasColumnNames (Rep a)) => HasColumnNames a
+
+instance GHasColumnNames U1 where
+  gColumnNames U1 = []
+
+instance (GHasColumnNames a, GHasColumnNames b) => GHasColumnNames (a :*: b) where
+  gColumnNames (a :*: b) = gColumnNames a <> gColumnNames b
+
+instance (GHasColumnNames a, GHasColumnNames b) => GHasColumnNames (a :+: b) where
+  gColumnNames _ = []  -- Не используется для нашего случая.
+
+instance HasColumnName c => GHasColumnNames (K1 i c) where
+  gColumnNames (K1 c) = [columnName @c]
+
+instance GHasColumnNames a => GHasColumnNames (M1 i t a) where
+  gColumnNames (M1 a) = gColumnNames a
+
+
+class GColumnNames f where
+  gColumnNames1 :: [SQLName]
+
+instance GColumnNames U1 where
+  gColumnNames1 = []
+
+instance (GColumnNames a, GColumnNames b) => GColumnNames (a :+: b) where
+  gColumnNames1 = gColumnNames1 @a ++ gColumnNames1 @b
+
+instance (GColumnNames a, GColumnNames b) => GColumnNames (a :*: b) where
+  gColumnNames1 = gColumnNames1 @a ++ gColumnNames1 @b
+
+instance (Selector s, HasColumnName c) => GColumnNames (M1 S s (K1 i c)) where
+  gColumnNames1 = [columnName @c]
+
+instance GColumnNames a => GColumnNames (M1 D d a) where
+  gColumnNames1 = gColumnNames1 @a
+
+instance GColumnNames a => GColumnNames (M1 C c a) where
+  gColumnNames1 = gColumnNames1 @a
+
+instance (Generic a, GColumnNames (Rep a)) => HasColumnNames (AllColumns a) where
+  columnNames _ = gColumnNames1 @(Rep a)
+
+-- -- Реализация GHasColumnNames для AllColumns a
+-- instance (Generic a, GHasColumnNames (Rep a)) => GHasColumnNames AllColumns where
+--   gColumnNames _ = gColumnNames (from (undefined :: a))
+
+-- -- Функция для получения списка имен колонок через AllColumns
+-- columnNamesForAll :: forall a. (Generic a, GHasColumnNames AllColumns) => [SQLName]
+-- columnNamesForAll = gColumnNames (AllColumns @a)
+
+-- Пример использования этой функции:
+-- myList = columnNamesFor (Proxy :: Proxy GitRepoListEntry)
+
+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 HasPrimaryKey t where
+  primaryKey :: [SQLName]
+
+newtype OnCoflictIgnore t r = OnCoflictIgnore r
+                              deriving stock (Generic)
+
+instance (HasPrimaryKey t, HasColumnNames r) => HasColumnNames (OnCoflictIgnore t r) where
+  columnNames (OnCoflictIgnore r) = columnNames r
+
+-- instance (HasColumnNames r) => HasColumnNames (AllColumns r) where
+  -- columnNames _ = gColumnNames @r
+  -- columnNames AllColumns = columnNames r
+
+onConflictIgnore :: (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
+      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
+

miscellaneous/db-pipe/lib/DBPipe/SQLite/Types.hs

@@ -0,0 +1,7 @@
+module DBPipe.SQLite.Types
+  ( ToField(..)
+  )where
+
+import Database.SQLite.Simple.ToField
+
+