lock

hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs

@@ -39,6 +39,7 @@ import System.Posix.Files qualified as PFS
 import System.IO.MMap as MMap
 import Control.Concurrent.STM qualified as STM
 import Control.Concurrent.STM.TSem
+import System.FileLock as FL
 
 ncqStorageOpen3 :: MonadIO m => FilePath -> (NCQStorage3 -> NCQStorage3) -> m NCQStorage3
 ncqStorageOpen3 fp upd = do
@@ -80,11 +81,16 @@ ncqStorageOpen3 fp upd = do
   ncqStateKey       <- newTVarIO (FileKey maxBound)
   ncqStateUse       <- newTVarIO mempty
   ncqServiceSem     <- atomically $ newTSem 1
+  ncqFileLock       <- newTVarIO Nothing
 
   let ncq = NCQStorage3{..} & upd
 
   mkdir (ncqGetWorkDir ncq)
 
+  liftIO (FL.tryLockFile (ncqGetFileName ncq ".lock") Exclusive)
+    >>= orThrow NCQStorageCurrentAlreadyOpen
+    >>= atomically . writeTVar ncqFileLock . Just
+
   liftIO (ncqTryLoadState ncq)
 
   pure ncq

hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Prelude.hs

@@ -34,6 +34,7 @@ module HBS2.Storage.NCQ3.Internal.Prelude
   ) where
 
 import HBS2.Prelude as Exported
+import HBS2.OrDie as Exported
 
 import HBS2.Data.Log.Structured.NCQ as Exported
 import HBS2.Data.Types.Refs as Exported

hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs

@@ -38,9 +38,11 @@ import System.Posix.Files ( getFileStatus
 import System.Posix.Files qualified as PFS
 import System.IO.MMap as MMap
 import Control.Concurrent.STM qualified as STM
+import System.FileLock as FL
 
 ncqStorageStop3 :: forall m . MonadUnliftIO m => NCQStorage3 -> m ()
-ncqStorageStop3 NCQStorage3{..} = atomically $ writeTVar ncqStopReq True
+ncqStorageStop3 NCQStorage3{..} = do
+  atomically $ writeTVar ncqStopReq True
 
 ncqStorageRun3 :: forall m . MonadUnliftIO m
                => NCQStorage3
@@ -48,6 +50,9 @@ ncqStorageRun3 :: forall m . MonadUnliftIO m
 ncqStorageRun3 ncq@NCQStorage3{..} = flip runContT pure do
   ContT $ bracket setAlive (const unsetAlive)
 
+  ContT $ bracket none $ const $ liftIO do
+    readTVarIO ncqFileLock >>= mapM_  FL.unlockFile
+
   closeQ <- liftIO newTQueueIO
 
   closer <- spawnActivity $ liftIO $ fix \loop -> do

hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs

@@ -10,7 +10,7 @@ import Data.Set qualified as Set
 import Data.HashSet qualified as HS
 import Text.Printf
 import Control.Concurrent.STM.TSem (TSem,waitTSem,signalTSem)
-
+import System.FileLock (FileLock)
 
 data CachedData =  CachedData !ByteString
 data CachedIndex = CachedIndex !ByteString !NWayHash
@@ -104,6 +104,7 @@ data NCQStorage3 =
   , ncqOnRunWriteIdle :: TVar (IO ())
   , ncqSyncNo         :: TVar Int
   , ncqServiceSem     :: TSem
+  , ncqFileLock       :: TVar (Maybe FileLock)
   }
 
 

hbs2-tests/test/NCQ3.hs

@@ -536,6 +536,37 @@ ncq3Tests = do
 
           pause @'Seconds 600
 
+  entry $ bindMatch "test:ncq3:lock" $ nil_ $ \e -> runTest $ \TestEnv{..} -> do
+
+    w <- newTVarIO 0
+
+    r <- try @_ @SomeException do
+            flip runContT pure do
+
+              notice $ "run 1st storage" <+> pretty testEnvDir
+              sto1 <- ContT $ ncqWithStorage3 testEnvDir
+
+              atomically $ writeTVar w 1
+
+              pause @'Seconds 1
+
+              notice $ "run 2nd storage" <+> pretty testEnvDir
+              sto1 <- ContT $ ncqWithStorage3 testEnvDir
+
+              pause @'Seconds 1
+
+              notice "so what?"
+
+              atomically $ writeTVar w 2
+
+              pure 42
+
+    wx <- readTVarIO w
+
+    liftIO $ assertBool "first run, second fail" (wx == 1)
+
+    notice $ "second must fail" <+> pretty wx <+> "=>" <+> viaShow r
+
 testNCQ3Concurrent1 :: MonadUnliftIO m
          => Bool
          -> Int