{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.Node.DbLock (
    DbLocked (..)
  , withLockDB
    -- * Defaults
  , dbLockFsPath
  , dbLockTimeout
    -- * For testing purposes
  , withLockDB_
  ) where

import           Control.Monad.Class.MonadTimer
import qualified Data.Time.Clock as Time

import           Ouroboros.Consensus.Storage.FS.API.Types
import           Ouroboros.Consensus.Util.FileLock
import           Ouroboros.Consensus.Util.IOLike

-- | 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 :: 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_ :: 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 (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 (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 (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
lockTimeout (Async m (m ()) -> m (m ())
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 (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 (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 (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
/= :: DbLocked -> DbLocked -> Bool
$c/= :: DbLocked -> DbLocked -> Bool
== :: DbLocked -> DbLocked -> Bool
$c== :: 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
showList :: [DbLocked] -> ShowS
$cshowList :: [DbLocked] -> ShowS
show :: DbLocked -> FilePath
$cshow :: DbLocked -> FilePath
showsPrec :: Int -> DbLocked -> ShowS
$cshowsPrec :: Int -> 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"