benchmark + storage optimization

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)
+

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
 
 
 

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