mirror of https://github.com/voidlizard/hbs2
160 lines
4.2 KiB
Haskell
160 lines
4.2 KiB
Haskell
module Main where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Defaults
|
|
import HBS2.Hash
|
|
import HBS2.Clock
|
|
import HBS2.Storage.Simple
|
|
|
|
import HBS2.System.Logger.Simple
|
|
|
|
import Test.QuickCheck
|
|
import Test.Tasty.HUnit
|
|
|
|
import Control.Concurrent.Async
|
|
import Control.Monad
|
|
import Data.ByteString.Lazy.Char8 (ByteString)
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS
|
|
import Lens.Micro.Platform
|
|
import System.Directory
|
|
import System.FilePath.Posix
|
|
import System.IO.Temp
|
|
import Control.Concurrent.STM
|
|
import System.ProgressBar
|
|
import Control.Concurrent
|
|
import System.IO
|
|
|
|
randomByteString :: Int -> Gen ByteString
|
|
randomByteString n = vectorOf n arbitrary <&> LBS.pack
|
|
{-# NOINLINE randomByteString #-}
|
|
|
|
{-# NOINLINE randomSizedByteString #-}
|
|
randomSizedByteString :: Gen ByteString
|
|
randomSizedByteString = do
|
|
let low = 0
|
|
let high = 256 -- ceiling $ realToFrac defBlockSize * 1.5
|
|
size <- choose (low, high)
|
|
randomByteString size
|
|
|
|
waitTime :: Timeout 'Seconds
|
|
waitTime = 30
|
|
|
|
testSimpleStorageRandomReadWrite :: IO ()
|
|
testSimpleStorageRandomReadWrite = do
|
|
|
|
withTempDirectory "." "simpleStorageTest" $ \dir -> do
|
|
|
|
let opts = [ StoragePrefix (dir </> ".storage")
|
|
]
|
|
|
|
storage <- simpleStorageInit [StoragePrefix (dir </> ".storage")] :: IO (SimpleStorage HbSync)
|
|
|
|
exists <- doesDirectoryExist ( storage ^. storageBlocks )
|
|
|
|
assertBool "blocks directory exists" exists
|
|
|
|
workers <- replicateM 8 $ async (simpleStorageWorker storage)
|
|
|
|
blkQ <- newTQueueIO
|
|
err <- newTVarIO 0
|
|
errHash <- newTVarIO 0
|
|
done <- newTVarIO 0
|
|
|
|
let succErrIO v = atomically $ modifyTVar v succ
|
|
|
|
let tot = toMicroSeconds waitTime
|
|
let st = defStyle { styleWidth = ConstantWidth 50 }
|
|
mon1 <- newProgressBar st 10 (Progress 0 tot ())
|
|
|
|
prog <- async $ forever do
|
|
let w = 1
|
|
pause @'Seconds w
|
|
incProgress mon1 (toMicroSeconds w)
|
|
|
|
producer <- async $ void $ race ( pause @'Seconds (waitTime + 0.25) ) $ do
|
|
replicateConcurrently 6 do
|
|
forever do
|
|
bs <- generate randomSizedByteString
|
|
times <- generate (elements [1,1,1,1,2])
|
|
replicateConcurrently times $ do
|
|
ha <- putBlock storage bs
|
|
atomically $ writeTQueue blkQ ha
|
|
|
|
checker <- async $ forever do
|
|
bh <- atomically $ readTQueue blkQ
|
|
|
|
case bh of
|
|
Nothing -> do
|
|
succErrIO err
|
|
-- hPrint stderr "error 1"
|
|
|
|
Just h -> do
|
|
blk <- getBlock storage h
|
|
case blk of
|
|
Nothing -> do
|
|
succErrIO err
|
|
-- hPrint stderr "error 2"
|
|
|
|
Just s -> do
|
|
let hash = hashObject s
|
|
if hash /= h then do
|
|
succErrIO errHash
|
|
else do
|
|
succErrIO done
|
|
-- hPrint stderr "error 3"
|
|
|
|
wait producer
|
|
|
|
void $ waitAnyCatchCancel $ producer : prog : checker : workers
|
|
|
|
e1 <- readTVarIO err
|
|
e2 <- readTVarIO errHash
|
|
ok <- readTVarIO done
|
|
|
|
notice $ "errors:" <+> pretty e1 <+> pretty e2
|
|
notice $ "blocks done:" <+> pretty ok
|
|
|
|
assertEqual "errors1" e1 0
|
|
assertEqual "errors2" e2 0
|
|
|
|
logPrefix s = set loggerTr (s <>)
|
|
|
|
tracePrefix :: SetLoggerEntry
|
|
tracePrefix = logPrefix "[trace] "
|
|
|
|
debugPrefix :: SetLoggerEntry
|
|
debugPrefix = logPrefix "[debug] "
|
|
|
|
errorPrefix :: SetLoggerEntry
|
|
errorPrefix = logPrefix "[error] "
|
|
|
|
warnPrefix :: SetLoggerEntry
|
|
warnPrefix = logPrefix "[warn] "
|
|
|
|
noticePrefix :: SetLoggerEntry
|
|
noticePrefix = logPrefix "[notice] "
|
|
|
|
|
|
main :: IO ()
|
|
main = do
|
|
-- hSetBuffering stdout LineBuffering
|
|
-- hSetBuffering stderr LineBuffering
|
|
|
|
setLogging @DEBUG debugPrefix
|
|
setLogging @INFO defLog
|
|
setLogging @ERROR errorPrefix
|
|
setLogging @WARN warnPrefix
|
|
setLogging @NOTICE noticePrefix
|
|
setLoggingOff @TRACE
|
|
|
|
testSimpleStorageRandomReadWrite
|
|
|
|
|
|
setLoggingOff @DEBUG
|
|
setLoggingOff @INFO
|
|
setLoggingOff @ERROR
|
|
setLoggingOff @WARN
|
|
setLoggingOff @NOTICE
|
|
setLoggingOff @TRACE
|
|
|