{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Tests for the DB marker and DB lock.
--
-- When the consensus layer is integrated into the main node, it provides two
-- safe guards to avoid data loss and/or corruption:
--
-- * When the database is opened, it locks the database so that there can be no
--   other processes trying to access it at the same time.
-- * When we create a database directory, we place a "magic marker" in that
--   directory. This allows us to distinguish the database directory from other
--   directories, and avoids that we would try to "truncate" a "chain" in a
--   directory which doesn't contain a DB at all (due to a misconfiguration),
--   thereby potentially deleting a user's files.
--
-- This module contains a bunch of unit tests to make sure that these locks and
-- markers are created correctly and behave as expected.
--
module Test.Consensus.Node (tests) where

import           Control.Monad.Class.MonadTimer.SI (MonadTimer)
import           Control.Monad.IOSim (runSimOrThrow)
import           Data.Bifunctor (second)
import           Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import           Data.Time.Clock (secondsToDiffTime)
import           Ouroboros.Consensus.Node.DbLock
import           Ouroboros.Consensus.Node.DbMarker
import           Ouroboros.Consensus.Util.FileLock (FileLock, ioFileLock)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Network.Magic (NetworkMagic (..))
import           System.Directory (getTemporaryDirectory)
import           System.FS.API.Types
import           System.FS.Sim.FsTree (FsTree (..))
import qualified System.FS.Sim.MockFS as Mock
import           System.FS.Sim.MockFS (Files)
import           System.FS.Sim.STM (runSimFS)
import           System.IO.Temp (withTempDirectory)
import           Test.Tasty
import           Test.Tasty.HUnit
import           Test.Tasty.QuickCheck
import           Test.Util.FileLock
import           Test.Util.QuickCheck (ge)

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Node"
    [ TestName -> [TestTree] -> TestTree
testGroup TestName
"checkDbMarker"
      [ TestName -> Assertion -> TestTree
testCase TestName
"match"        Assertion
test_checkNetworkMagic_match
      , TestName -> Assertion -> TestTree
testCase TestName
"mismatch"     Assertion
test_checkNetworkMagic_mismatch
      , TestName -> Assertion -> TestTree
testCase TestName
"empty folder" Assertion
test_checkNetworkMagic_empty_folder
      , TestName -> Assertion -> TestTree
testCase TestName
"missing"      Assertion
test_checkNetworkMagic_missing
      , TestName -> Assertion -> TestTree
testCase TestName
"corrupt"      Assertion
test_checkNetworkMagic_corrupt
      , TestName -> Assertion -> TestTree
testCase TestName
"empty"        Assertion
test_checkNetworkMagic_empty
      ]
    , TestName -> [TestTree] -> TestTree
testGroup TestName
"lockDb"
      [ TestName -> (ReleaseDelay -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"reacquire a released lock"   ReleaseDelay -> Property
prop_reacquire_lock
      , TestName -> Assertion -> TestTree
testCase     TestName
"acquire a held lock"         Assertion
test_acquire_held_lock
      , TestName -> (ActualAndMaxDelay -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait to acquire a held lock" ActualAndMaxDelay -> Property
prop_wait_to_acquire_lock
      ]
    ]

{-------------------------------------------------------------------------------
  checkDbMarker
-------------------------------------------------------------------------------}

expectedNetworkMagic :: NetworkMagic
expectedNetworkMagic :: NetworkMagic
expectedNetworkMagic = Word32 -> NetworkMagic
NetworkMagic Word32
1910

mountPoint :: MountPoint
mountPoint :: MountPoint
mountPoint = TestName -> MountPoint
MountPoint TestName
"root"

fullPath :: FilePath
fullPath :: TestName
fullPath = MountPoint -> FsPath -> TestName
fsToFilePath
    MountPoint
mountPoint ([Text] -> FsPath
fsPathFromList [Text
dbMarkerFile])

runCheck :: Files -> (Either DbMarkerError (), Files)
runCheck :: Files -> (Either DbMarkerError (), Files)
runCheck Files
files = (forall s. IOSim s (Either DbMarkerError (), Files))
-> (Either DbMarkerError (), Files)
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s (Either DbMarkerError (), Files))
 -> (Either DbMarkerError (), Files))
-> (forall s. IOSim s (Either DbMarkerError (), Files))
-> (Either DbMarkerError (), Files)
forall a b. (a -> b) -> a -> b
$ do
    ((Either DbMarkerError (), MockFS)
 -> (Either DbMarkerError (), Files))
-> IOSim s (Either DbMarkerError (), MockFS)
-> IOSim s (Either DbMarkerError (), Files)
forall a b. (a -> b) -> IOSim s a -> IOSim s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((MockFS -> Files)
-> (Either DbMarkerError (), MockFS)
-> (Either DbMarkerError (), Files)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second MockFS -> Files
Mock.mockFiles) (IOSim s (Either DbMarkerError (), MockFS)
 -> IOSim s (Either DbMarkerError (), Files))
-> IOSim s (Either DbMarkerError (), MockFS)
-> IOSim s (Either DbMarkerError (), Files)
forall a b. (a -> b) -> a -> b
$
      MockFS
-> (HasFS (IOSim s) HandleMock
    -> IOSim s (Either DbMarkerError ()))
-> IOSim s (Either DbMarkerError (), MockFS)
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m, PrimMonad m) =>
MockFS -> (HasFS m HandleMock -> m a) -> m (a, MockFS)
runSimFS MockFS
Mock.empty { Mock.mockFiles = files } ((HasFS (IOSim s) HandleMock -> IOSim s (Either DbMarkerError ()))
 -> IOSim s (Either DbMarkerError (), MockFS))
-> (HasFS (IOSim s) HandleMock
    -> IOSim s (Either DbMarkerError ()))
-> IOSim s (Either DbMarkerError (), MockFS)
forall a b. (a -> b) -> a -> b
$ \HasFS (IOSim s) HandleMock
hasFS ->
        HasFS (IOSim s) HandleMock
-> MountPoint -> NetworkMagic -> IOSim s (Either DbMarkerError ())
forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h
-> MountPoint -> NetworkMagic -> m (Either DbMarkerError ())
checkDbMarker HasFS (IOSim s) HandleMock
hasFS MountPoint
mountPoint NetworkMagic
expectedNetworkMagic

test_checkNetworkMagic_match :: Assertion
test_checkNetworkMagic_match :: Assertion
test_checkNetworkMagic_match = Either DbMarkerError ()
res Either DbMarkerError () -> Either DbMarkerError () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= () -> Either DbMarkerError ()
forall a b. b -> Either a b
Right ()
  where
    fs :: Files
fs = Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder (Folder ByteString -> Files) -> Folder ByteString -> Files
forall a b. (a -> b) -> a -> b
$ [(Text, Files)] -> Folder ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Text
dbMarkerFile, ByteString -> Files
forall a. a -> FsTree a
File (ByteString -> Files) -> ByteString -> Files
forall a b. (a -> b) -> a -> b
$ NetworkMagic -> ByteString
dbMarkerContents NetworkMagic
expectedNetworkMagic)
      , (Text
"immutable",  Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      , (Text
"ledger",     Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      , (Text
"volatile",   Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      ]
    (Either DbMarkerError ()
res, Files
_) = Files -> (Either DbMarkerError (), Files)
runCheck Files
fs

test_checkNetworkMagic_mismatch :: Assertion
test_checkNetworkMagic_mismatch :: Assertion
test_checkNetworkMagic_mismatch = Either DbMarkerError ()
res Either DbMarkerError () -> Either DbMarkerError () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= DbMarkerError -> Either DbMarkerError ()
forall a b. a -> Either a b
Left DbMarkerError
e
  where
    fs :: Files
fs = Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder (Folder ByteString -> Files) -> Folder ByteString -> Files
forall a b. (a -> b) -> a -> b
$ [(Text, Files)] -> Folder ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Text
dbMarkerFile, ByteString -> Files
forall a. a -> FsTree a
File (ByteString -> Files) -> ByteString -> Files
forall a b. (a -> b) -> a -> b
$ NetworkMagic -> ByteString
dbMarkerContents NetworkMagic
actual)
      , (Text
"immutable",  Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      , (Text
"ledger",     Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      , (Text
"volatile",   Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      ]
    (Either DbMarkerError ()
res, Files
_) = Files -> (Either DbMarkerError (), Files)
runCheck Files
fs
    actual :: NetworkMagic
actual = Word32 -> NetworkMagic
NetworkMagic Word32
10
    e :: DbMarkerError
e = TestName -> NetworkMagic -> NetworkMagic -> DbMarkerError
NetworkMagicMismatch
      TestName
fullPath
      NetworkMagic
actual
      NetworkMagic
expectedNetworkMagic

test_checkNetworkMagic_empty_folder :: Assertion
test_checkNetworkMagic_empty_folder :: Assertion
test_checkNetworkMagic_empty_folder = do
    Either DbMarkerError ()
res Either DbMarkerError () -> Either DbMarkerError () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= () -> Either DbMarkerError ()
forall a b. b -> Either a b
Right ()
    Files
fs' Files -> Files -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Files
expectedFs'
  where
    fs :: FsTree a
fs = Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder Folder a
forall a. Monoid a => a
mempty
    (Either DbMarkerError ()
res, Files
fs') = Files -> (Either DbMarkerError (), Files)
runCheck Files
forall {a}. FsTree a
fs
    expectedFs' :: Files
expectedFs' = Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder (Folder ByteString -> Files) -> Folder ByteString -> Files
forall a b. (a -> b) -> a -> b
$ [(Text, Files)] -> Folder ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Text
dbMarkerFile, ByteString -> Files
forall a. a -> FsTree a
File (ByteString -> Files) -> ByteString -> Files
forall a b. (a -> b) -> a -> b
$ NetworkMagic -> ByteString
dbMarkerContents NetworkMagic
expectedNetworkMagic) ]

test_checkNetworkMagic_missing :: Assertion
test_checkNetworkMagic_missing :: Assertion
test_checkNetworkMagic_missing = Either DbMarkerError ()
res Either DbMarkerError () -> Either DbMarkerError () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= DbMarkerError -> Either DbMarkerError ()
forall a b. a -> Either a b
Left DbMarkerError
e
  where
    fs :: Files
fs = Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder (Folder ByteString -> Files) -> Folder ByteString -> Files
forall a b. (a -> b) -> a -> b
$ [(Text, Files)] -> Folder ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Text
"passwords.txt", ByteString -> Files
forall a. a -> FsTree a
File ByteString
"qwerty\n123456\n")
      ]
    (Either DbMarkerError ()
res, Files
_) = Files -> (Either DbMarkerError (), Files)
runCheck Files
fs
    e :: DbMarkerError
e = TestName -> DbMarkerError
NoDbMarkerAndNotEmpty TestName
fullPath

test_checkNetworkMagic_corrupt :: Assertion
test_checkNetworkMagic_corrupt :: Assertion
test_checkNetworkMagic_corrupt = Either DbMarkerError ()
res Either DbMarkerError () -> Either DbMarkerError () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= DbMarkerError -> Either DbMarkerError ()
forall a b. a -> Either a b
Left DbMarkerError
e
  where
    fs :: Files
fs = Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder (Folder ByteString -> Files) -> Folder ByteString -> Files
forall a b. (a -> b) -> a -> b
$ [(Text, Files)] -> Folder ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Text
dbMarkerFile, ByteString -> Files
forall a. a -> FsTree a
File ByteString
"garbage")
      , (Text
"immutable",  Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      , (Text
"ledger",     Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      , (Text
"volatile",   Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      ]
    (Either DbMarkerError ()
res, Files
_) = Files -> (Either DbMarkerError (), Files)
runCheck Files
fs
    e :: DbMarkerError
e = TestName -> DbMarkerError
CorruptDbMarker TestName
fullPath

test_checkNetworkMagic_empty :: Assertion
test_checkNetworkMagic_empty :: Assertion
test_checkNetworkMagic_empty = Either DbMarkerError ()
res Either DbMarkerError () -> Either DbMarkerError () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= DbMarkerError -> Either DbMarkerError ()
forall a b. a -> Either a b
Left DbMarkerError
e
  where
    fs :: Files
fs = Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder (Folder ByteString -> Files) -> Folder ByteString -> Files
forall a b. (a -> b) -> a -> b
$ [(Text, Files)] -> Folder ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Text
dbMarkerFile, ByteString -> Files
forall a. a -> FsTree a
File ByteString
"")
      , (Text
"immutable",  Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      , (Text
"ledger",     Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      , (Text
"volatile",   Folder ByteString -> Files
forall a. Folder a -> FsTree a
Folder Folder ByteString
forall a. Monoid a => a
mempty)
      ]
    (Either DbMarkerError ()
res, Files
_) = Files -> (Either DbMarkerError (), Files)
runCheck Files
fs
    e :: DbMarkerError
e = TestName -> DbMarkerError
CorruptDbMarker TestName
fullPath

{-------------------------------------------------------------------------------
  lockDb
-------------------------------------------------------------------------------}

-- | We use the mock lock to test whether we can release and reacquire the
-- lock, because the real lock might release lazily, causing the reacquisition
-- to fail.
prop_reacquire_lock :: ReleaseDelay -> Property
prop_reacquire_lock :: ReleaseDelay -> Property
prop_reacquire_lock (ReleaseDelay DiffTime
releaseDelay) =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ do
      FileLock (IOSim s)
fileLock <- Maybe DiffTime -> IOSim s (FileLock (IOSim s))
forall s. Maybe DiffTime -> IOSim s (FileLock (IOSim s))
mockFileLock (DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
releaseDelay)
      -- Lock and unlock it
      FileLock (IOSim s) -> IOSim s ()
forall (m :: * -> *).
(IOLike m, MonadTimer m) =>
FileLock m -> m ()
touchLock FileLock (IOSim s)
fileLock

      -- Lock and unlock it again, which might fail:
      IOSim s () -> IOSim s (Either DbLocked ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either DbLocked a)
tryL (FileLock (IOSim s) -> IOSim s ()
forall (m :: * -> *).
(IOLike m, MonadTimer m) =>
FileLock m -> m ()
touchLock FileLock (IOSim s)
fileLock) IOSim s (Either DbLocked ())
-> (Either DbLocked () -> Property) -> IOSim s Property
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        -- If we failed to obtain the lock, it must be because the release
        -- delay we simulate is greater than or equal to the timeout
        Left  DbLocked
_  -> TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
label TestName
"timed out" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ DiffTime
releaseDelay DiffTime -> DiffTime -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`ge` DiffTime
timeout
        Right () -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  where
    timeout :: DiffTime
timeout = Integer -> DiffTime
secondsToDiffTime Integer
2

    touchLock :: (IOLike m, MonadTimer m) => FileLock m -> m ()
    touchLock :: forall (m :: * -> *).
(IOLike m, MonadTimer m) =>
FileLock m -> m ()
touchLock FileLock m
fileLock =
      FileLock m -> MountPoint -> FsPath -> DiffTime -> m () -> m ()
forall (m :: * -> *) a.
(IOLike m, MonadTimer m) =>
FileLock m -> MountPoint -> FsPath -> DiffTime -> m a -> m a
withLockDB_
        FileLock m
fileLock
        MountPoint
mountPoint
        FsPath
dbLockFsPath
        DiffTime
timeout
        (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Test with a real lock that while holding the lock, we cannot reacquire
-- it.
test_acquire_held_lock :: Assertion
test_acquire_held_lock :: Assertion
test_acquire_held_lock = (TestName -> Assertion) -> Assertion
forall a. (TestName -> IO a) -> IO a
withTempDir ((TestName -> Assertion) -> Assertion)
-> (TestName -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \TestName
dbPath -> do
    let dbMountPoint :: MountPoint
dbMountPoint = TestName -> MountPoint
MountPoint TestName
dbPath

    -- While holding the lock, try to acquire it again, which should fail
    Either DbLocked (Either DbLocked ())
res <-
      IO (Either DbLocked ())
-> IO (Either DbLocked (Either DbLocked ()))
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either DbLocked a)
tryL (IO (Either DbLocked ())
 -> IO (Either DbLocked (Either DbLocked ())))
-> IO (Either DbLocked ())
-> IO (Either DbLocked (Either DbLocked ()))
forall a b. (a -> b) -> a -> b
$ MountPoint
-> DiffTime -> IO (Either DbLocked ()) -> IO (Either DbLocked ())
forall a. MountPoint -> DiffTime -> IO a -> IO a
withLock MountPoint
dbMountPoint (Integer -> DiffTime
secondsToDiffTime Integer
0) (IO (Either DbLocked ()) -> IO (Either DbLocked ()))
-> IO (Either DbLocked ()) -> IO (Either DbLocked ())
forall a b. (a -> b) -> a -> b
$
               Assertion -> IO (Either DbLocked ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either DbLocked a)
tryL (Assertion -> IO (Either DbLocked ()))
-> Assertion -> IO (Either DbLocked ())
forall a b. (a -> b) -> a -> b
$ MountPoint -> DiffTime -> Assertion -> Assertion
forall a. MountPoint -> DiffTime -> IO a -> IO a
withLock MountPoint
dbMountPoint (Integer -> DiffTime
millisecondsToDiffTime Integer
10) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
                        () -> Assertion
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- The outer 'Right' means that the first call to 'withLock'
    -- succeeded, the inner 'Left' means that the second call to
    -- 'touchLock' failed.
    Either DbLocked (Either DbLocked ())
res Either DbLocked (Either DbLocked ())
-> Either DbLocked (Either DbLocked ()) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (DbLocked -> Either DbLocked (Either DbLocked ())
forall a b. a -> Either a b
Left (TestName -> DbLocked
DbLocked (MountPoint -> FsPath -> TestName
fsToFilePath MountPoint
dbMountPoint FsPath
dbLockFsPath)))
  where
    withTempDir :: (FilePath -> IO a) -> IO a
    withTempDir :: forall a. (TestName -> IO a) -> IO a
withTempDir TestName -> IO a
k = do
      TestName
sysTmpDir <- IO TestName
getTemporaryDirectory
      TestName -> TestName -> (TestName -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
TestName -> TestName -> (TestName -> m a) -> m a
withTempDirectory TestName
sysTmpDir TestName
"ouroboros-network-test" TestName -> IO a
k

    withLock :: MountPoint -> DiffTime -> IO a -> IO a
    withLock :: forall a. MountPoint -> DiffTime -> IO a -> IO a
withLock MountPoint
dbMountPoint DiffTime
lockTimeout =
      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
dbMountPoint
        FsPath
dbLockFsPath
        DiffTime
lockTimeout

tryL :: MonadCatch m => m a -> m (Either DbLocked a)
tryL :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either DbLocked a)
tryL = m a -> m (Either DbLocked a)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try

-- | Test that we can acquire and already held lock by waiting for it.
--
-- Property:
--   A maximum delay of MAX can cope with any hold up of ACTUAL < MAX.
--
--   Note that we exclude ACTUAL == MAX, as it is \"racy\".
--
prop_wait_to_acquire_lock :: ActualAndMaxDelay -> Property
prop_wait_to_acquire_lock :: ActualAndMaxDelay -> Property
prop_wait_to_acquire_lock ActualAndMaxDelay { DiffTime
actualDelay :: DiffTime
actualDelay :: ActualAndMaxDelay -> DiffTime
actualDelay, DiffTime
maxDelay :: DiffTime
maxDelay :: ActualAndMaxDelay -> DiffTime
maxDelay } =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ do
      -- We don't simulate delayed releases because the test depends on
      -- precise timing.
      FileLock (IOSim s)
fileLock <- Maybe DiffTime -> IOSim s (FileLock (IOSim s))
forall s. Maybe DiffTime -> IOSim s (FileLock (IOSim s))
mockFileLock Maybe DiffTime
forall a. Maybe a
Nothing

      -- Hold the lock for 'actualDelay' and then signal we have released it
      let bgThread :: IOSim s ()
bgThread =
            -- The lock will not be held, so just use the default parameters
            -- to acquire it
            FileLock (IOSim s) -> DiffTime -> IOSim s () -> IOSim s ()
forall (m :: * -> *) a.
(IOLike m, MonadTimer m) =>
FileLock m -> DiffTime -> m a -> m a
withLock FileLock (IOSim s)
fileLock DiffTime
dbLockTimeout (IOSim s () -> IOSim s ()) -> IOSim s () -> IOSim s ()
forall a b. (a -> b) -> a -> b
$
              -- Hold the lock for ACTUAL
              DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
actualDelay

      IOSim s ()
-> (Async (IOSim s) () -> IOSim s Property) -> IOSim s Property
forall a b.
IOSim s a -> (Async (IOSim s) a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync IOSim s ()
bgThread ((Async (IOSim s) () -> IOSim s Property) -> IOSim s Property)
-> (Async (IOSim s) () -> IOSim s Property) -> IOSim s Property
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
asyncBgThread -> do
        Async (IOSim s) () -> IOSim s ()
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
Async m a -> m ()
link Async (IOSim s) ()
asyncBgThread
        -- Try to obtain the held lock, waiting MAX for it
        --
        -- The test will fail when an exception is thrown below because it
        -- timed out while waiting on the lock.
        FileLock (IOSim s)
-> DiffTime -> IOSim s Property -> IOSim s Property
forall (m :: * -> *) a.
(IOLike m, MonadTimer m) =>
FileLock m -> DiffTime -> m a -> m a
withLock FileLock (IOSim s)
fileLock DiffTime
maxDelay (IOSim s Property -> IOSim s Property)
-> IOSim s Property -> IOSim s Property
forall a b. (a -> b) -> a -> b
$
          Property -> IOSim s Property
forall a. a -> IOSim s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> IOSim s Property) -> Property -> IOSim s Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  where
    withLock
      :: (IOLike m, MonadTimer m)
      => FileLock m
      -> DiffTime
      -> m a
      -> m a
    withLock :: forall (m :: * -> *) a.
(IOLike m, MonadTimer m) =>
FileLock m -> DiffTime -> m a -> m a
withLock FileLock m
fileLock DiffTime
timeout =
      FileLock m -> MountPoint -> FsPath -> DiffTime -> m a -> m a
forall (m :: * -> *) a.
(IOLike m, MonadTimer m) =>
FileLock m -> MountPoint -> FsPath -> DiffTime -> m a -> m a
withLockDB_
        FileLock m
fileLock
        MountPoint
mountPoint
        FsPath
dbLockFsPath
        DiffTime
timeout

{-------------------------------------------------------------------------------
  Generators
-------------------------------------------------------------------------------}

-- | Simulate lazy releasing of the lock, as done by Linux and Windows.
newtype ReleaseDelay = ReleaseDelay DiffTime
  deriving (ReleaseDelay -> ReleaseDelay -> Bool
(ReleaseDelay -> ReleaseDelay -> Bool)
-> (ReleaseDelay -> ReleaseDelay -> Bool) -> Eq ReleaseDelay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReleaseDelay -> ReleaseDelay -> Bool
== :: ReleaseDelay -> ReleaseDelay -> Bool
$c/= :: ReleaseDelay -> ReleaseDelay -> Bool
/= :: ReleaseDelay -> ReleaseDelay -> Bool
Eq, Int -> ReleaseDelay -> ShowS
[ReleaseDelay] -> ShowS
ReleaseDelay -> TestName
(Int -> ReleaseDelay -> ShowS)
-> (ReleaseDelay -> TestName)
-> ([ReleaseDelay] -> ShowS)
-> Show ReleaseDelay
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReleaseDelay -> ShowS
showsPrec :: Int -> ReleaseDelay -> ShowS
$cshow :: ReleaseDelay -> TestName
show :: ReleaseDelay -> TestName
$cshowList :: [ReleaseDelay] -> ShowS
showList :: [ReleaseDelay] -> ShowS
Show)

instance Arbitrary ReleaseDelay where
  arbitrary :: Gen ReleaseDelay
arbitrary =
    DiffTime -> ReleaseDelay
ReleaseDelay (DiffTime -> ReleaseDelay)
-> (Integer -> DiffTime) -> Integer -> ReleaseDelay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DiffTime
millisecondsToDiffTime (Integer -> ReleaseDelay) -> Gen Integer -> Gen ReleaseDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
5000)
  shrink :: ReleaseDelay -> [ReleaseDelay]
shrink (ReleaseDelay DiffTime
t) =
    [DiffTime -> ReleaseDelay
ReleaseDelay (Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational Rational
t') | Rational
t' <- Rational -> [Rational]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
t)]

-- | Invariant: @actualDelay < maxDelay@
data ActualAndMaxDelay = ActualAndMaxDelay {
      ActualAndMaxDelay -> DiffTime
actualDelay :: DiffTime
    , ActualAndMaxDelay -> DiffTime
maxDelay    :: DiffTime
    }
  deriving (ActualAndMaxDelay -> ActualAndMaxDelay -> Bool
(ActualAndMaxDelay -> ActualAndMaxDelay -> Bool)
-> (ActualAndMaxDelay -> ActualAndMaxDelay -> Bool)
-> Eq ActualAndMaxDelay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ActualAndMaxDelay -> ActualAndMaxDelay -> Bool
== :: ActualAndMaxDelay -> ActualAndMaxDelay -> Bool
$c/= :: ActualAndMaxDelay -> ActualAndMaxDelay -> Bool
/= :: ActualAndMaxDelay -> ActualAndMaxDelay -> Bool
Eq, Int -> ActualAndMaxDelay -> ShowS
[ActualAndMaxDelay] -> ShowS
ActualAndMaxDelay -> TestName
(Int -> ActualAndMaxDelay -> ShowS)
-> (ActualAndMaxDelay -> TestName)
-> ([ActualAndMaxDelay] -> ShowS)
-> Show ActualAndMaxDelay
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ActualAndMaxDelay -> ShowS
showsPrec :: Int -> ActualAndMaxDelay -> ShowS
$cshow :: ActualAndMaxDelay -> TestName
show :: ActualAndMaxDelay -> TestName
$cshowList :: [ActualAndMaxDelay] -> ShowS
showList :: [ActualAndMaxDelay] -> ShowS
Show)

instance Arbitrary ActualAndMaxDelay where
    arbitrary :: Gen ActualAndMaxDelay
arbitrary = do
        Integer
maxDelayMs    <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
2000)
        Integer
actualDelayMs <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
maxDelayMs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
        ActualAndMaxDelay -> Gen ActualAndMaxDelay
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ActualAndMaxDelay {
            actualDelay :: DiffTime
actualDelay = Integer -> DiffTime
millisecondsToDiffTime Integer
actualDelayMs
          , maxDelay :: DiffTime
maxDelay    = Integer -> DiffTime
millisecondsToDiffTime Integer
maxDelayMs
          }

    shrink :: ActualAndMaxDelay -> [ActualAndMaxDelay]
shrink (ActualAndMaxDelay DiffTime
actualDelay DiffTime
maxDelay) =
      [ DiffTime -> DiffTime -> ActualAndMaxDelay
ActualAndMaxDelay DiffTime
actualDelay' DiffTime
maxDelay
      | DiffTime
actualDelay' <- Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> DiffTime) -> [Rational] -> [DiffTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> [Rational]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
actualDelay)
      ] [ActualAndMaxDelay] -> [ActualAndMaxDelay] -> [ActualAndMaxDelay]
forall a. Semigroup a => a -> a -> a
<>
      [ DiffTime -> DiffTime -> ActualAndMaxDelay
ActualAndMaxDelay DiffTime
actualDelay DiffTime
maxDelay
      | DiffTime
maxDelay' <- Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> DiffTime) -> [Rational] -> [DiffTime]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> [Rational]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
maxDelay)
      , DiffTime
actualDelay DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
maxDelay'
      ]

millisecondsToDiffTime :: Integer -> DiffTime
millisecondsToDiffTime :: Integer -> DiffTime
millisecondsToDiffTime = (DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1000) (DiffTime -> DiffTime)
-> (Integer -> DiffTime) -> Integer -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DiffTime
secondsToDiffTime