From 8bc92062bd47fe27a7102e19cf67634764f2347f Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 23 Dec 2023 15:11:48 +0300 Subject: [PATCH] benchmark + storage optimization --- hbs2-storage-simple/benchmarks/Main.hs | 83 +++++++++++++++++++ hbs2-storage-simple/hbs2-storage-simple.cabal | 52 +++++++++++- .../lib/HBS2/Storage/Simple.hs | 19 ++--- 3 files changed, 140 insertions(+), 14 deletions(-) create mode 100644 hbs2-storage-simple/benchmarks/Main.hs diff --git a/hbs2-storage-simple/benchmarks/Main.hs b/hbs2-storage-simple/benchmarks/Main.hs new file mode 100644 index 00000000..f04913fb --- /dev/null +++ b/hbs2-storage-simple/benchmarks/Main.hs @@ -0,0 +1,83 @@ +module Main where + +import HBS2.Prelude +import HBS2.Hash +import HBS2.Storage +import HBS2.Storage.Simple + +import System.TimeIt + +import DBPipe.SQLite + +import System.Environment +import System.FilePath + +import System.Random (randomRIO) +import Control.Monad (replicateM) +import Data.ByteString.Lazy qualified as LBS +import Data.Word (Word8) + +import Text.InterpolatedString.Perl6 (qc) +import Control.Monad +import UnliftIO + +import Streaming.Prelude (Of,Stream) +import Streaming.Prelude qualified as S + +-- Генерация одного случайного байта +randomByte :: IO Word8 +randomByte = randomRIO (0, 255) + +-- Генерация одной случайной байтовой строки заданной длины +randomByteString :: Int -> IO LBS.ByteString +randomByteString len = LBS.pack <$> replicateM len randomByte + +-- Генерация списка из n случайных байтовых строк заданной длины +-- randomByteStrings :: Int -> Int -> IO (S.Stream (S.Of LBS.ByteString )) +-- randomByteStrings n len = replicateM n (randomByteString len) + +randomByteStrings :: MonadIO m => Int -> Int -> Stream (Of LBS.ByteString) m () +randomByteStrings n len = replicateM_ n $ do + bs <- liftIO $ randomByteString len + S.yield bs + +main :: IO () +main = do + (ns:ss:pref:_) <- getArgs + + let n = readDef @Int 100 ns + let s = readDef @Int 256 ss + let p = pref + + let bss = randomByteStrings n s + let bss2 = randomByteStrings n s + + let path = pref ".test-storage" + + storage <- simpleStorageInit [StoragePrefix path] :: IO (SimpleStorage HbSync) + + workers <- replicateM 4 $ async (simpleStorageWorker storage) + + env <- newDBPipeEnv dbPipeOptsDef (path "bench.db") + + withDB env do + ddl [qc| + create table if not exists + wtf ( hash text not null + , val text not null + , primary key (hash) + ) + |] + commitAll + + print $ "preparing to write" <+> pretty n <+> "chunks" + + timeItNamed "write chunks test" do + S.mapM_ (enqueueBlock storage) bss + + timeItNamed "write chunks to sqlite test" do + withDB env $ transactional do + flip S.mapM_ bss2 $ \bs -> do + let h = hashObject @HbSync bs & pretty & show + insert [qc|insert into wtf (hash,val) values(?,?)|] (h,bs) + diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 7f3b19ab..b98ea506 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -124,7 +124,57 @@ test-suite test , vector - +executable hbs2-storage-simple-benchmarks + import: shared-properties + + ghc-options: + -Wall + -- -fno-warn-unused-matches + -- -fno-warn-unused-do-bind + -- -Werror=missing-methods + -- -Werror=incomplete-patterns + -- -fno-warn-unused-binds + -threaded + -rtsopts + "-with-rtsopts=-N4 -A64m -AL256m -I0" + + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base, hbs2-core, hbs2-storage-simple + , db-pipe + , aeson + , async + , base58-bytestring + , binary + , bytestring + , cborg + , clock + , containers + , directory + , filepath + , hashable + , interpolatedstring-perl6 + , memory + , microlens-platform + , mtl + , optparse-applicative + , prettyprinter + , random + , safe + , serialise + , streaming + , text + , temporary + , transformers + , uniplate + , timeit + , stm + , unliftio + , network-byte-order + + hs-source-dirs: benchmarks + default-language: Haskell2010 diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 1a6fd75c..1df09672 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -197,6 +197,7 @@ simpleBlockFileName ss h = path where (pref,suf) = splitAt 1 (show (pretty h)) path = view storageBlocks ss pref suf +{-# INLINE simpleBlockFileName #-} simpleRefFileName :: Pretty (Hash h) => SimpleStorage h -> Hash h -> FilePath simpleRefFileName ss h = path @@ -275,14 +276,9 @@ simplePutBlockLazy :: (IsKey h, Hashed h LBS.ByteString) simplePutBlockLazy doWait s lbs = do let hash = hashObject lbs - let fn = simpleBlockFileName s hash - let fntmp = takeFileName fn - let tmp = view storageTemp s stop <- atomically $ TV.readTVar ( s ^. storageStopWriting ) - size <- simpleBlockExists s hash <&> fromMaybe 0 - if stop then do pure Nothing @@ -290,15 +286,12 @@ simplePutBlockLazy doWait s lbs = do waits <- TBQ.newTBQueueIO 1 :: IO (TBQueue Bool) - let action | size > 0 = atomically $ TBQ.writeTBQueue waits True - | otherwise = do + let action = do handle (\(_ :: IOError) -> atomically $ TBQ.writeTBQueue waits False) do - withTempFile tmp fntmp $ \tname h -> do - BS.hPut h (LBS.toStrict lbs) - hClose h - renameFile tname fn - atomically $ TBQ.writeTBQueue waits True + let fn = simpleBlockFileName s hash + AwBS.atomicWriteFile fn (LBS.toStrict lbs) + atomically $ TBQ.writeTBQueue waits True simpleAddTask s action @@ -306,7 +299,7 @@ simplePutBlockLazy doWait s lbs = do ok <- atomically $ TBQ.readTBQueue waits unless ok do - err $ "simplePutBlockLazy" <+> pretty hash <+> pretty fn + err $ "simplePutBlockLazy" <+> pretty hash pure $! if ok then Just hash else Nothing else