From 371cf53e3ad667c9ede4b56d55a511fd9583b2e6 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 7 Oct 2024 05:06:33 +0300 Subject: [PATCH] Squashed 'miscellaneous/db-pipe/' content from commit 7f28fdcb2 git-subtree-dir: miscellaneous/db-pipe git-subtree-split: 7f28fdcb2ba9ccd426facffebf100e98522d7eac --- .envrc | 1 + .gitignore | 7 ++ CHANGELOG.md | 5 + LICENSE | 30 ++++++ db-pipe.cabal | 71 +++++++++++++ flake.lock | 61 +++++++++++ flake.nix | 48 +++++++++ lib/DBPipe/SQLite.hs | 189 +++++++++++++++++++++++++++++++++ lib/DBPipe/SQLite/Generic.hs | 195 +++++++++++++++++++++++++++++++++++ lib/DBPipe/SQLite/Types.hs | 7 ++ 10 files changed, 614 insertions(+) create mode 100644 .envrc create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 db-pipe.cabal create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 lib/DBPipe/SQLite.hs create mode 100644 lib/DBPipe/SQLite/Generic.hs create mode 100644 lib/DBPipe/SQLite/Types.hs diff --git a/.envrc b/.envrc new file mode 100644 index 00000000..3550a30f --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..b86c58ac --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +.hbs2/ +.direnv/ +dist-newstyle/ +.hbs2-git/ +result/ +result + diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 00000000..9d5a95fa --- /dev/null +++ b/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. diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..b9a60f0e --- /dev/null +++ b/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. diff --git a/db-pipe.cabal b/db-pipe.cabal new file mode 100644 index 00000000..a3a8755e --- /dev/null +++ b/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 diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..50805b9c --- /dev/null +++ b/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 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..2167fba3 --- /dev/null +++ b/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 + ]; + + }; +} diff --git a/lib/DBPipe/SQLite.hs b/lib/DBPipe/SQLite.hs new file mode 100644 index 00000000..391b4018 --- /dev/null +++ b/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 + + diff --git a/lib/DBPipe/SQLite/Generic.hs b/lib/DBPipe/SQLite/Generic.hs new file mode 100644 index 00000000..174ac347 --- /dev/null +++ b/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 + diff --git a/lib/DBPipe/SQLite/Types.hs b/lib/DBPipe/SQLite/Types.hs new file mode 100644 index 00000000..757d5c89 --- /dev/null +++ b/lib/DBPipe/SQLite/Types.hs @@ -0,0 +1,7 @@ +module DBPipe.SQLite.Types + ( ToField(..) + )where + +import Database.SQLite.Simple.ToField + +