From 71ab399cd403340dd660691013e69e55eb70ad9e Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 28 Jul 2025 11:07:10 +0300 Subject: [PATCH] wip --- hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs | 12 +++- .../lib/HBS2/Storage/NCQ3/Internal/Run.hs | 2 +- hbs2-tests/hbs2-tests.cabal | 1 + hbs2-tests/test/NCQ3.hs | 42 +++++++++++++ hbs2-tests/test/NCQTestCommon.hs | 60 +++++++++++++++++++ hbs2-tests/test/TestNCQ.hs | 52 ++-------------- 6 files changed, 120 insertions(+), 49 deletions(-) create mode 100644 hbs2-tests/test/NCQ3.hs create mode 100644 hbs2-tests/test/NCQTestCommon.hs diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs index 0228d427..428b409c 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3.hs @@ -1,8 +1,16 @@ module HBS2.Storage.NCQ3 - ( module Exported ) + ( module Exported + , ncqWithStorage3 + , ncqStorageSync3 + , ncqStorageStop3 + , ncqStorageOpen3 + , ncqStorageRun3 + ) where import HBS2.Storage.NCQ3.Internal.Types as Exported - +import HBS2.Storage.NCQ3.Internal +import HBS2.Storage.NCQ3.Internal.Run +import HBS2.Storage.NCQ3.Internal.State diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs index e1e542e9..84086ce3 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs +++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs @@ -150,7 +150,7 @@ ncqStorageRun3 ncq@NCQStorage3{..} = flip runContT pure do openNewDataFile :: forall mx . MonadIO mx => mx (FileKey, Fd) openNewDataFile = do - fname <- toFileName . DataFile <$> ncqGetNewFileKey ncq + fname <- ncqGetFileName ncq . toFileName . DataFile <$> ncqGetNewFileKey ncq touch fname let flags = defaultFileFlags { exclusive = False, creat = Just 0o666 } (fromString fname,) <$> liftIO (PosixBase.openFd fname Posix.ReadWrite flags) diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 6faa6860..aa6b6d88 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -1208,6 +1208,7 @@ executable test-ncq ghc-options: hs-source-dirs: test main-is: TestNCQ.hs + other-modules: NCQTestCommon NCQ3 build-depends: base, hbs2-core, hbs2-log-structured, hbs2-storage-ncq , network diff --git a/hbs2-tests/test/NCQ3.hs b/hbs2-tests/test/NCQ3.hs new file mode 100644 index 00000000..9916a060 --- /dev/null +++ b/hbs2-tests/test/NCQ3.hs @@ -0,0 +1,42 @@ +{-# Language RecordWildCards #-} +module NCQ3 where + +import HBS2.Prelude.Plated +import HBS2.OrDie +import HBS2.Hash +import HBS2.Data.Types.Refs +import HBS2.Misc.PrettyStuff +import HBS2.Clock +import HBS2.Merkle +import HBS2.Polling + +import HBS2.Storage +import HBS2.Storage.Simple +import HBS2.Storage.Operations.ByteString +import HBS2.Storage.NCQ3 + +import HBS2.System.Logger.Simple.ANSI + +import HBS2.Data.Log.Structured.SD +import HBS2.Storage.NCQ +import HBS2.Storage.NCQ2 as N2 +import HBS2.Data.Log.Structured.NCQ + +import HBS2.CLI.Run.Internal.Merkle + +import Data.Config.Suckless.Syntax +import Data.Config.Suckless.Script as SC +import Data.Config.Suckless.System + +import NCQTestCommon + +import UnliftIO + + +ncq3Tests :: forall m . MonadUnliftIO m => MakeDictM C m () +ncq3Tests = do + entry $ bindMatch "test:ncq3:start-stop" $ nil_ $ \e ->do + runTest $ \TestEnv{..} -> do + ncqWithStorage3 testEnvDir $ \sto -> do + notice "start/stop ncq3 storage" + diff --git a/hbs2-tests/test/NCQTestCommon.hs b/hbs2-tests/test/NCQTestCommon.hs new file mode 100644 index 00000000..732f33c6 --- /dev/null +++ b/hbs2-tests/test/NCQTestCommon.hs @@ -0,0 +1,60 @@ +module NCQTestCommon where + +import HBS2.Prelude +import HBS2.System.Logger.Simple.ANSI + +import Data.Config.Suckless.Syntax +import Data.Config.Suckless.Script as SC +import Data.Config.Suckless.System + +import System.IO.Temp as Temp +import Control.Monad.Trans.Cont +import UnliftIO + +data TestEnv = + TestEnv + { testEnvDir :: FilePath + } + +runTest :: forall m a . MonadUnliftIO m => (TestEnv -> m a) -> RunM C m a +runTest action = do + pref <- lookupValueDef nil "test:root" >>= \case + StringLike dir -> pure dir + _ -> pure "/tmp/ncq-tests" + + keep <- lookupValueDef nil "test:dir:keep" >>= \case + LitBoolVal True -> pure True + _ -> pure False + + mkdir pref + + tmp <- liftIO (Temp.createTempDirectory pref "ncq-test") + SC.bind "test:dir" (mkStr tmp) + + flip runContT pure do + ContT $ bracket none $ const do + unless keep (rm tmp) + flushLoggers + + lift $ lift $ action (TestEnv tmp) + + +setupLogger :: MonadIO m => m () +setupLogger = do + setLogging @DEBUG $ toStderr . logPrefix "[debug] " + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" + +flushLoggers :: MonadIO m => m () +flushLoggers = do + silence + +silence :: MonadIO m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE + setLoggingOff @TRACE + diff --git a/hbs2-tests/test/TestNCQ.hs b/hbs2-tests/test/TestNCQ.hs index 735539dc..d0a8f266 100644 --- a/hbs2-tests/test/TestNCQ.hs +++ b/hbs2-tests/test/TestNCQ.hs @@ -32,6 +32,9 @@ import Data.Config.Suckless.Syntax import Data.Config.Suckless.Script as SC import Data.Config.Suckless.System +import NCQTestCommon +import NCQ3 + import DBPipe.SQLite hiding (field) import Codec.Compression.Zstd qualified as Zstd @@ -102,52 +105,7 @@ import Data.BloomFilter.Easy as Bloom {- HLINT ignore "Functor law" -} -setupLogger :: MonadIO m => m () -setupLogger = do - setLogging @DEBUG $ toStderr . logPrefix "[debug] " - setLogging @ERROR $ toStderr . logPrefix "[error] " - setLogging @WARN $ toStderr . logPrefix "[warn] " - setLogging @NOTICE $ toStdout . logPrefix "" -flushLoggers :: MonadIO m => m () -flushLoggers = do - silence - -silence :: MonadIO m => m () -silence = do - setLoggingOff @DEBUG - setLoggingOff @ERROR - setLoggingOff @WARN - setLoggingOff @NOTICE - setLoggingOff @TRACE - - -data TestEnv = - TestEnv - { testEnvDir :: FilePath - } - -runTest :: forall m a . MonadUnliftIO m => (TestEnv -> m a) -> RunM C m a -runTest action = do - pref <- lookupValueDef nil "test:root" >>= \case - StringLike dir -> pure dir - _ -> pure "/tmp/ncq-tests" - - keep <- lookupValueDef nil "test:dir:keep" >>= \case - LitBoolVal True -> pure True - _ -> pure False - - mkdir pref - - tmp <- liftIO (Temp.createTempDirectory pref "ncq-test") - SC.bind "test:dir" (mkStr tmp) - - flip runContT pure do - ContT $ bracket none $ const do - unless keep (rm tmp) - flushLoggers - - lift $ lift $ action (TestEnv tmp) testNCQFuckupRecovery1 :: MonadUnliftIO m @@ -1782,7 +1740,6 @@ main = do entry $ bindMatch "test:ncq2:facts-db1" $ nil_ $ \e -> do - notice "test:ncq2:probes-db1" runTest $ \TestEnv{..} -> do g <- liftIO MWC.createSystemRandom @@ -1819,6 +1776,9 @@ main = do pause @'Seconds 300 +-- NCQ3 tests + + ncq3Tests hidden do internalEntries