fix crash in stale transfer lockfile cleanup code

Need to differentiate between the lockfile not being locked, and it not
existing.

4 files changed, 23 insertions, 9 deletions

diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index ef1db879c..471b886b3 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -140,9 +140,10 @@ checkTransfer t = do
 		let lck = transferLockFile tfile
 		v <- getLockStatus lck
 		case v of
-			Just pid -> catchDefaultIO Nothing $
+			StatusLockedBy pid -> catchDefaultIO Nothing $
 				readTransferInfoFile (Just pid) tfile
-			Nothing -> do
+			StatusNoLockFile -> return Nothing
+			StatusUnLocked -> do
 				-- Take a non-blocking lock while deleting
 				-- the stale lock file.
 				r <- tryLockExclusive Nothing lck
diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs
index 65ba328df..18d9e4fc1 100644
--- a/Utility/LockFile/Posix.hs
+++ b/Utility/LockFile/Posix.hs
@@ -12,6 +12,7 @@ module Utility.LockFile.Posix (
 	tryLockExclusive,
 	checkLocked,
 	getLockStatus,
+	LockStatus(..),
 	dropLock,
 	checkSaneLock,
 ) where
@@ -66,8 +67,16 @@ openLockFile filemode lockfile = do
 checkLocked :: LockFile -> IO (Maybe Bool)
 checkLocked = maybe Nothing (Just . isJust) <$$> getLockStatus'
 
-getLockStatus :: LockFile -> IO (Maybe ProcessID)
-getLockStatus = fromMaybe Nothing <$$> getLockStatus'
+data LockStatus = StatusUnLocked | StatusLockedBy ProcessID | StatusNoLockFile
+	deriving (Eq)
+
+getLockStatus :: LockFile -> IO LockStatus
+getLockStatus lockfile = do
+	v <- getLockStatus' lockfile
+	return $ case v of
+		Nothing -> StatusNoLockFile
+		Just Nothing -> StatusUnLocked
+		Just (Just pid) -> StatusLockedBy pid
 
 getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID))
 getLockStatus' lockfile = go =<< catchMaybeIO open
diff --git a/Utility/LockPool/Posix.hs b/Utility/LockPool/Posix.hs
index e05ab9754..506d7b560 100644
--- a/Utility/LockPool/Posix.hs
+++ b/Utility/LockPool/Posix.hs
@@ -12,11 +12,13 @@ module Utility.LockPool.Posix (
 	tryLockExclusive,
 	checkLocked,
 	getLockStatus,
+	LockStatus(..),
 	dropLock,
 	checkSaneLock,
 ) where
 
 import qualified Utility.LockFile.Posix as F
+import Utility.LockFile.Posix (LockStatus(..))
 import qualified Utility.LockPool.STM as P
 import Utility.LockPool.STM (LockFile, LockMode(..))
 import Utility.LockPool.LockHandle
@@ -46,11 +48,13 @@ tryLockExclusive mode file = tryMakeLockHandle
 -- Returns Nothing when the file doesn't exist, for cases where
 -- that is different from it not being locked.
 checkLocked :: LockFile -> IO (Maybe Bool)
-checkLocked file = P.getLockStatus P.lockPool file (pure True)
+checkLocked file = P.getLockStatus P.lockPool file
+	(pure (Just True))
 	(F.checkLocked file)
 
-getLockStatus :: LockFile -> IO (Maybe ProcessID)
-getLockStatus file = P.getLockStatus P.lockPool file getProcessID
+getLockStatus :: LockFile -> IO LockStatus
+getLockStatus file = P.getLockStatus P.lockPool file
+	(StatusLockedBy <$> getProcessID)
 	(F.getLockStatus file)
 
 checkSaneLock :: LockFile -> LockHandle -> IO Bool
diff --git a/Utility/LockPool/STM.hs b/Utility/LockPool/STM.hs
index 2ab969b20..7b0d138b9 100644
--- a/Utility/LockPool/STM.hs
+++ b/Utility/LockPool/STM.hs
@@ -81,7 +81,7 @@ tryTakeLock pool file mode =
 -- danger of conflicting with locks created at the same time this is
 -- running. With the lock pool empty, anything that attempts
 -- to take a lock will block, avoiding that race.
-getLockStatus :: LockPool -> LockFile -> IO v -> IO (Maybe v) -> IO (Maybe v)
+getLockStatus :: LockPool -> LockFile -> IO v -> IO v -> IO v
 getLockStatus pool file getdefault checker = do
 	v <- atomically $ do
 		m <- takeTMVar pool
@@ -94,7 +94,7 @@ getLockStatus pool file getdefault checker = do
 				return Nothing
 			else return $ Just $ atomically $ putTMVar pool m
 	case v of
-		Nothing -> Just <$> getdefault
+		Nothing -> getdefault
 		Just restore -> bracket_ (return ()) restore checker
 
 -- Only runs action to close underlying lock file when this is the last