diff --git a/hbs2-tests/test/TestNCQ.hs b/hbs2-tests/test/TestNCQ.hs index 76c3c089..b3249942 100644 --- a/hbs2-tests/test/TestNCQ.hs +++ b/hbs2-tests/test/TestNCQ.hs @@ -71,6 +71,7 @@ import System.IO.Temp qualified as Temp import UnliftIO +import Test.Tasty.HUnit import Text.InterpolatedString.Perl6 (qc) import Streaming.Prelude qualified as S @@ -100,19 +101,39 @@ silence = do 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) + + lift $ lift $ action (TestEnv tmp) + testNCQFuckupRecovery1 :: MonadUnliftIO m - => FilePath + => TestEnv -> m () -testNCQFuckupRecovery1 prefix = flip runContT pure do +testNCQFuckupRecovery1 TestEnv{..} = flip runContT pure do - mkdir prefix - - tmp <- liftIO (Temp.createTempDirectory prefix "ncq-test") - let ncqDir = tmp "ncq-test-data" - - ContT $ bracket none $ const do - rm tmp + let ncqDir = testEnvDir "ncq" (cur,ha,h0) <- lift $ withNCQ id ncqDir $ \ncq -> do let sto = AnyStorage ncq @@ -153,25 +174,19 @@ testNCQFuckupRecovery1 prefix = flip runContT pure do testNCQ1 :: MonadUnliftIO m - => Bool - -> FilePath - -> Int + => Int + -> TestEnv -> m () -testNCQ1 keep prefix n = flip runContT pure do +testNCQ1 n TestEnv{..} = flip runContT pure do - mkdir prefix - - tmp <- liftIO (Temp.createTempDirectory prefix "ncq-test") + let tmp = testEnvDir let inputDir = tmp "input" let ncqDir = tmp "ncq-test-data" for_ [inputDir] mkdir - ContT $ bracket none $ const do - unless keep $ rm tmp - twritten <- newTVarIO (mempty :: HashSet HashRef) nSize <- newTVarIO 0 @@ -284,6 +299,52 @@ testNCQ1 keep prefix n = flip runContT pure do +testNCQRefs1 :: MonadUnliftIO m + => Int + -> TestEnv + -> m () + +testNCQRefs1 n TestEnv{..} = flip runContT pure do + + let tmp = testEnvDir + + let ncqDir = tmp "ncq-test-data" + + refs <- liftIO $ replicateM n $ do + ref <- SomeRefKey <$> randomIO @Word64 + val <- randomIO @Word64 <&> hashObject . serialise + pure (ref, val) + + lift $ withNCQ id ncqDir $ \ncq -> do + let sto = AnyStorage ncq + + for_ refs $ \(k,v) -> do + updateRef sto k v + + for_ refs $ \(k,v0) -> liftIO do + v1 <- getRef sto k + assertBool "refs equal 1" (Just v0 == v1) + + notice $ "all" <+> pretty n <+> "refs found" + + debug "restart storage" + + lift $ withNCQ id ncqDir $ \ncq -> do + let sto = AnyStorage ncq + + for_ refs $ \(k,v0) -> liftIO do + v1 <- getRef sto k + assertBool "refs equal 2" (Just v0 == v1) + delRef sto k + + notice $ "all" <+> pretty n <+> "refs found after restart" + + for_ refs $ \(k,_) -> liftIO do + v1 <- getRef sto k + assertBool "ref deleted" (isNothing v1) + + notice $ "all" <+> pretty n <+> "refs deleted" + main :: IO () main = do @@ -330,15 +391,34 @@ main = do _ -> setLogging @DEBUG $ toStderr . logPrefix "[debug] " - entry $ bindMatch "test:ncq:fuckup-recovery1" $ nil_ $ \_ -> lift do - debug $ "test:ncq:fuckup-recovery1" - testNCQFuckupRecovery1 "./tmp-ncq" + entry $ bindMatch "test:root" $ nil_ $ \case + [ s@(StringLike _) ] -> do + SC.bind "test:root" s + + e -> throwIO $ BadFormException @C (mkList e) + + entry $ bindMatch "test:dir:keep" $ nil_ $ \case + [] -> SC.bind "test:dir:keep" (mkBool True) + e -> throwIO $ BadFormException @C (mkList e) + + entry $ bindMatch "test:ncq:fuckup-recovery1" $ nil_ $ \_ -> do + debug $ "test:ncq:fuckup-recovery1" + runTest testNCQFuckupRecovery1 + + entry $ bindMatch "test:ncq:test1" $ nil_ $ \case + [ LitIntVal n ] -> do + debug $ "ncq:test1" <+> pretty n + runTest $ testNCQ1 (fromIntegral n) + + e -> throwIO $ BadFormException @C (mkList e) + + entry $ bindMatch "test:ncq:refs1" $ nil_ $ \case + [ LitIntVal n ] -> do + debug $ "ncq:refs1" <+> pretty n + runTest $ testNCQRefs1 (fromIntegral n) + + e -> throwIO $ BadFormException @C (mkList e) - entry $ bindMatch "test:ncq:test1" $ nil_ $ \syn -> lift do - let (opts, argz) = splitOpts [("-n",1)] syn - let n = headDef 100 [ x | ListVal [ StringLike "-n", LitIntVal x ] <- opts ] - debug $ "ncq:test1" <+> pretty n - testNCQ1 False "./tmp-ncq" (fromIntegral n) setupLogger