wip

hbs2-tests/hbs2-tests.cabal

@@ -1191,7 +1191,7 @@ executable test-ncq
     ghc-options:
     hs-source-dirs:   test
     main-is:          TestNCQ.hs
-    other-modules:    NCQTestCommon NCQ3 NCQ3.Endurance
+    other-modules:    NCQTestCommon NCQ3 NCQ3.Endurance Tee
 
     build-depends:
           base, hbs2-core, hbs2-log-structured, hbs2-storage-ncq

hbs2-tests/test/NCQ3/Endurance.hs

@@ -9,29 +9,10 @@ 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.Peer.Proto.AnyRef
 
 import HBS2.Storage
-import HBS2.Storage.Simple
-import HBS2.Storage.Operations.ByteString
 import HBS2.Storage.NCQ3
 import HBS2.Storage.NCQ3.Internal.Prelude
-import HBS2.Storage.NCQ3.Internal.Files
-import HBS2.Storage.NCQ3.Internal.Index
-import HBS2.Storage.NCQ3.Internal.Fossil
-import HBS2.Storage.NCQ3.Internal.State
-import HBS2.Storage.NCQ3.Internal.Sweep
-import HBS2.Storage.NCQ3.Internal
-
-import HBS2.System.Logger.Simple.ANSI
-
-import HBS2.Data.Log.Structured.SD
-import HBS2.Data.Log.Structured.NCQ
-
-import HBS2.CLI.Run.Internal.Merkle
 
 import Data.Config.Suckless.Syntax
 import Data.Config.Suckless.Script as SC
@@ -39,39 +20,19 @@ import Data.Config.Suckless.System
 
 import NCQTestCommon
 
-import Data.Generics.Labels
 import Lens.Micro.Platform
-import Network.ByteOrder qualified as N
-import System.TimeIt
-import Data.Fixed
-import Data.HashSet qualified as HS
 import Data.Either
 import Data.HashPSQ qualified as HPSQ
 import Data.HashMap.Strict qualified as HM
-import Test.Tasty.HUnit
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as LBS
-import Data.Ord
-import Data.Set qualified as Set
 import System.Random.MWC as MWC
-import Control.Concurrent.STM qualified as STM
-import Data.List qualified as List
 import Control.Monad.Trans.Cont
-import Control.Monad.Except
-import System.IO.Temp qualified as Temp
 import System.Environment (getExecutablePath)
 import System.Process.Typed as PT
 import System.IO qualified as IO
-import System.IO.Error
-import System.Posix.IO qualified as Posix
-import GHC.IO.Handle qualified as GHC
-import System.Random.Stateful
 import qualified Data.Vector as V
 import qualified Data.Vector.Unboxed as U
-import UnliftIO
-import UnliftIO.IO.File
-import UnliftIO.IO as IO
-import UnliftIO.Directory
 
 import Streaming.Prelude qualified as S
 
@@ -137,6 +98,9 @@ getRandomFromPSQ g tvar = do
       pure e
 
 
+toConsole :: MonadIO m => Handle -> Doc AnsiStyle -> m ()
+toConsole ss doc = liftIO $ hPutDoc ss (doc <> line)
+
 -- | Deleted = Left (), Alive = Right size
 type BlockState = Either () Integer
 
@@ -464,74 +428,74 @@ ncq3EnduranceTest = do
 
             EndurancePutBlk -> do
               bsize <- liftIO $ uniformRM (1, wMaxBlk) g
-              liftIO $ IO.hPrint inp ("write-random-block" <+> viaShow bsize)
+              toConsole inp ("write-random-block" <+> viaShow bsize)
               atomically $ modifyTVar rest pred
               getNextState >>= loop
 
             EnduranceDelBlk -> do
               blk <- getRandomBlock
               for_ blk $ \h -> do
-                liftIO $ IO.hPrint inp ("del-block" <+> pretty h)
+                toConsole inp ("del-block" <+> pretty h)
 
               getNextState >>= loop
 
             EnduranceHasBlk -> do
               blk <- getRandomBlock
               for_ blk $ \h -> do
-                liftIO $ IO.hPrint inp ("has-block" <+> pretty h)
+                toConsole inp ("has-block" <+> pretty h)
 
               getNextState >>= loop
 
             EnduranceHasSeedBlk -> do
               blk <- getRandomSeedBlock
               for_ blk $ \h -> do
-                liftIO $ IO.hPrint inp ("has-seed-block" <+> pretty h)
+                toConsole inp ("has-seed-block" <+> pretty h)
 
               getNextState >>= loop
 
             EnduranceGetBlk -> do
               blk <- getRandomBlock
               for_ blk $ \h -> do
-                liftIO $ IO.hPrint inp ("get-block" <+> pretty h)
+                toConsole inp ("get-block" <+> pretty h)
               getNextState >>= loop
 
             EndurancePutRef -> do
               href <- liftIO (genRandomBS g 32) <&> HashRef . coerce
               blk  <- getRandomBlock
               for_ blk $ \val -> do
-                liftIO $ IO.hPrint inp ("set-ref" <+> pretty href <+> pretty val)
+                toConsole inp ("set-ref" <+> pretty href <+> pretty val)
               atomically $ modifyTVar rest pred
               getNextState >>= loop
 
             EnduranceGetRef -> do
               e <- getRandomRef
               for_ e $ \h ->
-                liftIO $ IO.hPrint inp ("get-ref" <+> pretty h)
+                toConsole inp ("get-ref" <+> pretty h)
               getNextState >>= loop
 
             EnduranceDelRef -> do
               e <- getRandomRef
               for_ e $ \h ->
-                liftIO $ IO.hPrint inp ("del-ref" <+> pretty h)
+                toConsole inp ("del-ref" <+> pretty h)
               getNextState >>= loop
 
             EnduranceMerge -> do
-              liftIO $ IO.hPrint inp "merge"
+              toConsole inp "merge"
               atomically $ modifyTVar merged succ
               getNextState >>= loop
 
             EnduranceCompact -> do
-              liftIO $ IO.hPrint inp "compact"
+              toConsole inp "compact"
               atomically $ modifyTVar compacted succ
               getNextState >>= loop
 
             EnduranceSweep -> do
-              liftIO $ IO.hPrint inp "sweep"
+              toConsole inp "sweep"
               atomically $ modifyTVar sweeped succ
               getNextState >>= loop
 
             EnduranceExit -> do
-              liftIO $ IO.hPrint inp "exit"
+              toConsole inp "exit"
               debug $ yellow "inner process stopped?"
               liftIO $ race (pause @'Seconds 1) (waitExitCode p) >>= \case
                 Right{} -> none
@@ -619,7 +583,7 @@ testEnduranceInner path = flip runContT pure $ callCC \exit -> do
      lift (try @_ @SomeException (run @c (dict g sto) s')) >>= \case
         Left e -> err (viaShow e)
         Right (StringLike "done") -> do
-          liftIO $ IO.hPutStrLn stderr $ "INNER PROCESS TO EXIT"
+          toConsole stderr $ "INNER PROCESS TO EXIT"
           exit ()
 
         Right _ -> none

hbs2-tests/test/Tee.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Tee (withTeeLogging) where
+
+import Control.Concurrent (forkFinally)
+import Control.Monad (void, when)
+import qualified Data.ByteString as BS
+import Data.Word (Word8)
+-- import System.IO
+import GHC.IO.Handle (hDuplicateTo,hDuplicate)
+import System.Posix.IO
+import System.Posix.Types (Fd)
+import UnliftIO
+import UnliftIO.IO.File
+
+withTeeLogging :: forall a m . MonadUnliftIO m => FilePath -> m a -> m a
+withTeeLogging logPath action = withBinaryFile logPath AppendMode \hLog -> do
+    hSetBuffering hLog NoBuffering
+    -- Сохраняем реальные stdout/stderr
+    hOut <- liftIO $ hDuplicate stdout
+    hErr <- liftIO $ hDuplicate stderr
+    liftIO do
+      hSetBuffering hOut NoBuffering
+      hSetBuffering hErr NoBuffering
+
+    bracket makePipe (\(r,w) -> mapM_ hClose [r,w]) $ \(hR, hW) -> do
+      bracket_
+        (liftIO ( do hDuplicateTo hW stdout
+                     hDuplicateTo hW stderr
+                     hClose hW ))
+        (liftIO ( do
+            hDuplicateTo hOut stdout
+            hDuplicateTo hErr stderr
+            hFlush hOut
+            hFlush hErr))
+        $ do
+          -- Поток-перехватчик
+          _ <- liftIO $ forkFinally (pump hR hOut hErr hLog) (\_ -> hClose hR)
+          action
+  where
+    makePipe = liftIO do
+      (rfd :: Fd, wfd :: Fd) <- createPipe
+      hR <- fdToHandle rfd
+      hW <- fdToHandle wfd
+      hSetBuffering hR NoBuffering
+      hSetBuffering hW NoBuffering
+      pure (hR, hW)
+
+    pump hR hOut hErr hLog = loop
+      where
+        loop = do
+          bs <- BS.hGetLine hR
+          if BS.null bs
+            then pure ()
+            else do
+              BS.hPut hOut bs >> hFlush hOut
+              BS.hPut hLog (stripANSI bs) >> hFlush hLog
+              loop
+
+-- ---- ANSI stripper ----
+-- Удаляем распространённые последовательности:
+--   CSI:  ESC '[' ... <final @..~>
+--   OSC:  ESC ']' ... BEL (0x07) или ESC '\'
+--   Single ESC: ESC <printable>
+stripANSI :: BS.ByteString -> BS.ByteString
+stripANSI = go
+  where
+    esc  = 0x1b :: Word8
+    bel  = 0x07 :: Word8
+    bksl = fromIntegral (fromEnum '\\') :: Word8
+    lbr  = fromIntegral (fromEnum '[') :: Word8
+    rbr  = fromIntegral (fromEnum ']') :: Word8
+
+    go bs =
+      case BS.uncons bs of
+        Nothing -> BS.empty
+        Just (c, rest)
+          | c /= esc  -> BS.cons c (go rest)
+          | otherwise -> dropEsc rest
+
+    -- после ESC
+    dropEsc s =
+      case BS.uncons s of
+        Nothing       -> BS.empty
+        Just (c1, r1)
+          | c1 == lbr -> go (BS.drop1 $ dropCSI r1)    -- ESC [
+          | c1 == rbr -> go (dropOSC r1)    -- ESC ]
+          | otherwise -> go r1              -- Прочие короткие ESC-послед.
+
+    -- CSI: ESC '[' ... <final in 0x40..0x7E>
+    dropCSI = BS.dropWhile (not . isFinal)
+      where
+        isFinal w = w >= 0x40 && w <= 0x7e
+        -- также съедаем финальный байт, если он есть
+        -- делаем это в вызывающем месте: go (dropCSI r1)
+
+    -- OSC: ESC ']' ... (BEL | ESC '\')
+    dropOSC = goOSC
+      where
+        goOSC s =
+          case BS.uncons s of
+            Nothing -> BS.empty
+            Just (w, r)
+              | w == bel                 -> r
+              | w == esc, startsWithBS bksl r -> BS.drop 1 r  -- пропустить '\'
+              | otherwise                -> goOSC r
+
+        startsWithBS x s = case BS.uncons s of
+                             Just (y, _) -> y == x
+                             _           -> False