{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Consensus.Node.DbLock ( DbLocked (..) , withLockDB -- * Defaults , dbLockFsPath , dbLockTimeout -- * For testing purposes , withLockDB_ ) where import Control.Monad.Class.MonadTimer.SI import qualified Data.Time.Clock as Time import Ouroboros.Consensus.Util.FileLock import Ouroboros.Consensus.Util.IOLike import System.FS.API.Types -- | We use an empty file ('dbLockFsPath') as a lock of the database so that -- the database cannot be opened by more than one process. We wait up to -- 'dbLockTimeout' to take the lock, before timing out and throwing a -- 'DbLocked' exception. withLockDB :: MountPoint -> IO a -> IO a withLockDB :: forall a. MountPoint -> IO a -> IO a withLockDB MountPoint mountPoint = FileLock IO -> MountPoint -> FsPath -> DiffTime -> IO a -> IO a forall (m :: * -> *) a. (IOLike m, MonadTimer m) => FileLock m -> MountPoint -> FsPath -> DiffTime -> m a -> m a withLockDB_ FileLock IO ioFileLock MountPoint mountPoint FsPath dbLockFsPath DiffTime dbLockTimeout -- | The default lock file dbLockFsPath :: FsPath dbLockFsPath :: FsPath dbLockFsPath = [Text] -> FsPath fsPathFromList [Text "lock"] -- | Default time to wait on the lock dbLockTimeout :: DiffTime dbLockTimeout :: DiffTime dbLockTimeout = Integer -> DiffTime Time.secondsToDiffTime Integer 2 -- | We use the given 'FsPath' in the 'MountPoint' as a lock of the database -- so that the database cannot be opened by more than one process. We wait the -- given 'DiffTime' on the thread taking the lock. In case of a timeout, we -- throw a 'DbLocked' exception. -- -- Some systems may delete the empty file when all its handles are closed. -- This is not an issue, since the file is created if it doesn't exist. withLockDB_ :: forall m a. (IOLike m, MonadTimer m) => FileLock m -> MountPoint -- ^ Root of the path -> FsPath -- ^ File to lock -> DiffTime -- ^ Timeout -> m a -> m a withLockDB_ :: forall (m :: * -> *) a. (IOLike m, MonadTimer m) => FileLock m -> MountPoint -> FsPath -> DiffTime -> m a -> m a withLockDB_ FileLock m fileLock MountPoint mountPoint FsPath lockFsPath DiffTime lockTimeout m a action = m (m ()) -> (m () -> m ()) -> (m () -> m a) -> m a forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c forall (m :: * -> *) a b c. MonadThrow m => m a -> (a -> m b) -> (a -> m c) -> m c bracket m (m ()) acquireLock m () -> m () forall a. a -> a id (m a -> m () -> m a forall a b. a -> b -> a const m a action) where -- We want to avoid blocking the main thread at an uninterruptible ffi, to -- avoid unresponsiveness to timeouts and ^C. So we use 'async' and let a -- new thread do the actual ffi call. -- -- We shouldn't be tempted to use 'withAsync', which is usually mentioned -- as a better alternative, or try to synchronously cancel the forked -- thread during cleanup, since this would block the main thread and negate -- the whole point of using 'async'. -- -- This means that we leave the thread taking the lock running in case of -- a timeout. This is not a problem, though, since if we fail to take the -- lock, the whole process will soon die. acquireLock :: m (m ()) acquireLock :: m (m ()) acquireLock = do Async m (m ()) lockFileAsync <- m (m ()) -> m (Async m (m ())) forall a. m a -> m (Async m a) forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a) async (FileLock m -> FilePath -> m (m ()) forall (m :: * -> *). FileLock m -> FilePath -> m (m ()) lockFile FileLock m fileLock FilePath lockFilePath) DiffTime -> m (m ()) -> m (Maybe (m ())) forall a. DiffTime -> m a -> m (Maybe a) forall (m :: * -> *) a. MonadTimer m => DiffTime -> m a -> m (Maybe a) timeout DiffTime lockTimeout (Async m (m ()) -> m (m ()) forall a. Async m a -> m a forall (m :: * -> *) a. MonadAsync m => Async m a -> m a wait Async m (m ()) lockFileAsync) m (Maybe (m ())) -> (Maybe (m ()) -> m (m ())) -> m (m ()) forall a b. m a -> (a -> m b) -> m b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case -- We timed out while waiting on the lock. The db is still locked. Maybe (m ()) Nothing -> DbLocked -> m (m ()) forall e a. Exception e => e -> m a forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO (DbLocked -> m (m ())) -> DbLocked -> m (m ()) forall a b. (a -> b) -> a -> b $ FilePath -> DbLocked DbLocked FilePath lockFilePath Just m () unlock -> m () -> m (m ()) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return m () unlock lockFilePath :: FilePath lockFilePath = MountPoint -> FsPath -> FilePath fsToFilePath MountPoint mountPoint FsPath lockFsPath newtype DbLocked = DbLocked FilePath deriving (DbLocked -> DbLocked -> Bool (DbLocked -> DbLocked -> Bool) -> (DbLocked -> DbLocked -> Bool) -> Eq DbLocked forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: DbLocked -> DbLocked -> Bool == :: DbLocked -> DbLocked -> Bool $c/= :: DbLocked -> DbLocked -> Bool /= :: DbLocked -> DbLocked -> Bool Eq, Int -> DbLocked -> ShowS [DbLocked] -> ShowS DbLocked -> FilePath (Int -> DbLocked -> ShowS) -> (DbLocked -> FilePath) -> ([DbLocked] -> ShowS) -> Show DbLocked forall a. (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> DbLocked -> ShowS showsPrec :: Int -> DbLocked -> ShowS $cshow :: DbLocked -> FilePath show :: DbLocked -> FilePath $cshowList :: [DbLocked] -> ShowS showList :: [DbLocked] -> ShowS Show) instance Exception DbLocked where displayException :: DbLocked -> FilePath displayException (DbLocked FilePath f) = FilePath "The db is used by another process. File \"" FilePath -> ShowS forall a. Semigroup a => a -> a -> a <> FilePath f FilePath -> ShowS forall a. Semigroup a => a -> a -> a <> FilePath "\" is locked"