voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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

This commit is contained in:
voidlizard 2024-10-07 05:06:33 +03:00
parent 7c515bb267 371cf53e3a
commit eb38601339
10 changed files with 614 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
miscellaneous/db-pipe/.envrc Normal file
View File

@ -0,0 +1 @@
use flake

7
miscellaneous/db-pipe/.gitignore vendored Normal file
View File

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

5
miscellaneous/db-pipe/CHANGELOG.md Normal file
View File

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

30
miscellaneous/db-pipe/LICENSE Normal file
View File

@ -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.

71
miscellaneous/db-pipe/db-pipe.cabal Normal file
View File

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

61
miscellaneous/db-pipe/flake.lock Normal file
View File

@ -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
}

48
miscellaneous/db-pipe/flake.nix Normal file
View File

@ -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
];
};
}

189
miscellaneous/db-pipe/lib/DBPipe/SQLite.hs Normal file
View File

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

195
miscellaneous/db-pipe/lib/DBPipe/SQLite/Generic.hs Normal file
View File

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

7
miscellaneous/db-pipe/lib/DBPipe/SQLite/Types.hs Normal file
View File

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