diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs index 21903573..b0be40c1 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal.hs +++ b/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 diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Prelude.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Prelude.hs index bee17352..4c7187db 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Prelude.hs +++ b/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 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 f26126bb..4c4d4b45 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Run.hs +++ b/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 diff --git a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs b/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs index 7c9b62c4..055ef782 100644 --- a/hbs2-storage-ncq/lib/HBS2/Storage/NCQ3/Internal/Types.hs +++ b/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) } diff --git a/hbs2-tests/test/NCQ3.hs b/hbs2-tests/test/NCQ3.hs index 23578122..34740bec 100644 --- a/hbs2-tests/test/NCQ3.hs +++ b/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