db-pipe (empty) → 0.1.0.1
raw patch · 7 files changed
+544/−0 lines, 7 filesdep +basedep +clockdep +interpolatedstring-perl6
Dependencies added: base, clock, interpolatedstring-perl6, mtl, sqlite-simple, stm, text, unliftio
Files
- CHANGELOG.md +14/−0
- LICENSE +30/−0
- README.md +24/−0
- db-pipe.cabal +85/−0
- lib/DBPipe/SQLite.hs +189/−0
- lib/DBPipe/SQLite/Generic.hs +195/−0
- lib/DBPipe/SQLite/Types.hs +7/−0
+ CHANGELOG.md view
@@ -0,0 +1,14 @@+# Revision history for db-pipe++## 0.1.0.1 2026-06-08++First Hackage release. Previously this package only lived as a+vendored subtree inside the `hbs2` repository; the source moves to+`github.com/NCrashed/db-pipe` for independent maintenance.++ - No source changes from the vendored 0.1.0.1.+ - Cabal metadata filled in: synopsis, description, homepage,+ bug-reports, source-repository, `tested-with`, explicit version+ bounds on every dependency.+ - Maintainer is now `Anton Gushcha <ncrashed@gmail.com>`;+ original authorship by Dmitry Zuykov is preserved.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,24 @@+# db-pipe++A pipe-like wrapper around [`sqlite-simple`](https://hackage.haskell.org/package/sqlite-simple).++## What it does++`db-pipe` wraps `sqlite-simple` in a small monadic pipe abstraction.+A long-lived `DBPipeEnv` owns a connection, a transaction handle,+and a couple of STM channels; individual queries run inside a+`DBPipeM` monad that batches `select`, `update`, `insert`, and+`ddl` statements into explicit transactional blocks+(`transactional`, `transactional_`, `commitAll`).++## Where it came from++Originally written by Dmitry Zuykov (voidlizard) inside the+[`hbs2`](https://github.com/NCrashed/hbs2) project. This Hackage+release is published from `github.com/NCrashed/db-pipe` so+downstream projects can depend on it without vendoring.++## License++BSD-3-Clause; see `LICENSE`. Copyright holders are listed in the+cabal file.
+ db-pipe.cabal view
@@ -0,0 +1,85 @@+cabal-version: 3.0+name: db-pipe+version: 0.1.0.1+synopsis: A pipe-like wrapper around sqlite-simple+description:+ @db-pipe@ wraps @sqlite-simple@ in a small monadic pipe+ abstraction: a long-lived environment (@DBPipeEnv@) owns a+ connection, a transaction handle, and a couple of STM channels,+ and individual queries run inside a @DBPipeM@ monad that batches+ @select@, @update@, @insert@, and @ddl@ statements into explicit+ transactional blocks (@transactional@, @transactional_@,+ @commitAll@). Originally written by Dmitry Zuykov ("voidlizard")+ for the @hbs2@ project; this Hackage release is published from+ <https://github.com/NCrashed/db-pipe> so downstream projects can+ depend on it without vendoring.+license: BSD-3-Clause+license-file: LICENSE+author: Dmitry Zuykov+maintainer: Anton Gushcha <ncrashed@gmail.com>+copyright: (c) Dmitry Zuykov 2023, (c) Anton Gushcha 2026+category: Database+build-type: Simple+tested-with: GHC == 9.6.6+extra-doc-files: CHANGELOG.md+ README.md+homepage: https://github.com/NCrashed/db-pipe+bug-reports: https://github.com/NCrashed/db-pipe/issues++source-repository head+ type: git+ location: https://github.com/NCrashed/db-pipe.git++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++ build-depends: base >= 4.17 && < 5+ , clock >= 0.8 && < 0.9+ , interpolatedstring-perl6 >= 1.0 && < 1.1+ , mtl >= 2.3 && < 2.4+ , stm >= 2.5 && < 2.6+ , sqlite-simple >= 0.4.18 && < 0.5+ , text >= 2.0 && < 2.2+ , unliftio >= 0.2.24 && < 0.3++ hs-source-dirs: lib
+ lib/DBPipe/SQLite.hs view
@@ -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++
+ lib/DBPipe/SQLite/Generic.hs view
@@ -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+
+ lib/DBPipe/SQLite/Types.hs view
@@ -0,0 +1,7 @@+module DBPipe.SQLite.Types+ ( ToField(..)+ )where++import Database.SQLite.Simple.ToField++