From 5f0875313224a6a1f65106243dddea2f695938dd Mon Sep 17 00:00:00 2001
From: voidlizard <dzuikov@gmail.com>
Date: Mon, 19 May 2025 07:10:08 +0300
Subject: [PATCH] wip, file lock introduced

---
 hbs2-storage-ncq/hbs2-storage-ncq.cabal  |  1 +
 hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs | 18 ++++++++++++++
 hbs2-tests/test/TestNCQ.hs               | 30 ++++++++++++++++++++++++
 3 files changed, 49 insertions(+)

diff --git a/hbs2-storage-ncq/hbs2-storage-ncq.cabal b/hbs2-storage-ncq/hbs2-storage-ncq.cabal
index 32e5da94..0dcfce1c 100644
--- a/hbs2-storage-ncq/hbs2-storage-ncq.cabal
+++ b/hbs2-storage-ncq/hbs2-storage-ncq.cabal
@@ -92,6 +92,7 @@ library
                     , unordered-containers
                     , vector
                     , zstd
+                    , filelock
 
 
     hs-source-dirs:   lib
diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs
index 6465e97f..bf7d4075 100644
--- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs
+++ b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ.hs
@@ -86,6 +86,8 @@ import UnliftIO
 import UnliftIO.Concurrent(getNumCapabilities)
 import UnliftIO.IO.File
 
+import System.FileLock as FL
+
 {- HLINT ignore "Functor law" -}
 
 type NCQPerks m = MonadIO m
@@ -98,6 +100,7 @@ data NCQStorageException =
   | NCQStorageCantOpenCurrent
   | NCQStorageBrokenCurrent
   | NCQMergeInvariantFailed String
+  | NCQStorageCantLock FilePath
   deriving stock (Show,Typeable)
 
 instance Exception NCQStorageException
@@ -158,6 +161,7 @@ data NCQStorage =
   , ncqCurrentFd      :: TVar (Maybe (RFd,WFd))
   , ncqCurrentUsage   :: TVar (IntMap Int)
   , ncqCurrentReadReq :: TVar (Seq (Fd, Word64, Word64, TMVar ByteString))
+  , ncqLock           :: TVar FL.FileLock
   , ncqFsyncNum       :: TVar Int
   , ncqFlushNow       :: TVar [TQueue ()]
   , ncqMergeReq       :: TVar Int
@@ -978,7 +982,9 @@ ncqStorageOpen :: MonadUnliftIO m => FilePath -> m NCQStorage
 ncqStorageOpen fp' = do
     flip fix 0 $ \next i -> do
       fp <- liftIO $ makeAbsolute fp'
+
       ncq@NCQStorage{..} <- ncqStorageInit_ False fp
+
       ncqReadTrackedFiles ncq
       ncqFixIndexes ncq
       ncqLoadIndexes ncq
@@ -1058,6 +1064,8 @@ ncqStorageInit_ check path = do
 
   let ncqGen = 0
 
+  let lockName = dropFileName (ncqGetCurrentName_ path ncqGen) </>  ".lock"
+
   here <- doesPathExist path
 
   when (here && check) $ throwIO (NCQStorageAlreadyExist path)
@@ -1066,6 +1074,12 @@ ncqStorageInit_ check path = do
 
   let seedPath = path </> ".seed"
 
+  ncqLock_ <- liftIO do
+    mkdir (takeDirectory lockName)
+    l <- tryLockFile lockName Exclusive >>= orThrow (NCQStorageCantLock lockName)
+    touch lockName
+    pure l
+
   unless here do
     now <- liftIO $ getPOSIXTime <&> round @_ @Int
 
@@ -1115,6 +1129,7 @@ ncqStorageInit_ check path = do
   ncqIndexed        <- newTVarIO mempty
   ncqMergeReq       <- newTVarIO 0
   ncqFsyncNum       <- newTVarIO 0
+  ncqLock           <- newTVarIO ncqLock_
 
   let currentName = ncqGetCurrentName_ path ncqGen
 
@@ -1152,6 +1167,7 @@ ncqStorageInit_ check path = do
   debug $ "currentFileName" <+> pretty (ncqGetCurrentName_ path ncqGen)
 
   let ncq = NCQStorage{..}
+
   ncqOpenCurrent ncq
 
   pure ncq
@@ -1175,6 +1191,8 @@ ncqFinalize NCQStorage{..} = do
 
     _ -> none
 
+  liftIO $ unlockFile =<< readTVarIO ncqLock
+
 withNCQ :: forall m a . MonadUnliftIO  m
         => (NCQStorage -> NCQStorage)
         -> FilePath
diff --git a/hbs2-tests/test/TestNCQ.hs b/hbs2-tests/test/TestNCQ.hs
index 10e10aad..35a5e942 100644
--- a/hbs2-tests/test/TestNCQ.hs
+++ b/hbs2-tests/test/TestNCQ.hs
@@ -38,6 +38,7 @@ import Data.Text.Encoding qualified as TE
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Builder
 import Data.Maybe
+import Data.Either
 import Data.Word
 import Data.List qualified as List
 import Data.Vector qualified as V
@@ -417,6 +418,35 @@ main = do
 
           e -> throwIO $ BadFormException @C (mkList e)
 
+
+        entry $ bindMatch "test:ncq:test-lock" $ nil_ $ \case
+          [ ] -> do
+            runTest $ \TestEnv{..} -> do
+              debug $ "test:ncq:test-lock" <+> pretty testEnvDir
+
+              let ncq1 = testEnvDir </> "ncq1"
+
+              flip runContT pure do
+
+                pause @'Seconds 2
+                r1 <- ContT $ withAsync do
+                        withNCQ id ncq1 $ \_ -> do
+                          forever $ pause @'Seconds 1
+
+                -- link r1
+
+                sto2 <- ContT $ withNCQ id ncq1
+
+                result <- poll r1
+
+                notice $ viaShow result
+
+                case result of
+                  Just Left{} -> none
+                  _ ->  liftIO $ assertBool "must be (Left _)" False
+
+          e -> throwIO $ BadFormException @C (mkList e)
+
         hidden do
           internalEntries
           entry $ bindMatch "#!" $ nil_ $ const none