more RawFilePath conversion

nukeFile replaced with removeWhenExistsWith removeLink, which allows
using RawFilePath. Utility.Directory cannot use RawFilePath since setup
does not depend on posix.

This commit was sponsored by Graham Spencer on Patreon.
This commit is contained in:
Joey Hess 2020-10-29 10:33:12 -04:00
parent 8d66f7ba0f
commit e505c03bcc
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
51 changed files with 182 additions and 153 deletions

View file

@ -5,6 +5,8 @@
- License: BSD-2-clause
-}
{-# LANGUAGE OverloadedStrings #-}
module Utility.LockFile.PidLock (
LockHandle,
tryLock,
@ -34,12 +36,13 @@ import Utility.Env.Set
import qualified Utility.LockFile.Posix as Posix
import System.IO
import System.Posix.IO
import System.Posix.Types
import System.Posix.Files
import System.Posix.IO.ByteString
import System.Posix.Files.ByteString
import System.Posix.Process
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified System.FilePath.ByteString as P
import Data.Maybe
import Data.List
import Network.BSD
@ -47,7 +50,7 @@ import System.FilePath
import Control.Applicative
import Prelude
type LockFile = FilePath
type LockFile = RawFilePath
data LockHandle
= LockHandle LockFile FileStatus SideLockHandle
@ -67,7 +70,8 @@ mkPidLock = PidLock
<*> getHostName
readPidLock :: LockFile -> IO (Maybe PidLock)
readPidLock lockfile = (readish =<<) <$> catchMaybeIO (readFile lockfile)
readPidLock lockfile = (readish =<<)
<$> catchMaybeIO (readFile (fromRawFilePath lockfile))
-- To avoid races when taking over a stale pid lock, a side lock is used.
-- This is a regular posix exclusive lock.
@ -100,7 +104,7 @@ dropSideLock (Just (f, h)) = do
-- to take the side lock will only succeed once the file is
-- deleted, and so will be able to immediately see that it's taken
-- a stale lock.
_ <- tryIO $ removeFile f
_ <- tryIO $ removeFile (fromRawFilePath f)
Posix.dropLock h
-- The side lock is put in /dev/shm. This will work on most any
@ -108,17 +112,17 @@ dropSideLock (Just (f, h)) = do
-- locks. /tmp is used as a fallback.
sideLockFile :: LockFile -> IO LockFile
sideLockFile lockfile = do
f <- fromRawFilePath <$> absPath (toRawFilePath lockfile)
f <- fromRawFilePath <$> absPath lockfile
let base = intercalate "_" (splitDirectories (makeRelative "/" f))
let shortbase = reverse $ take 32 $ reverse base
let md5sum = if base == shortbase
then ""
else show (md5 (encodeBL base))
else toRawFilePath $ show (md5 (encodeBL base))
dir <- ifM (doesDirectoryExist "/dev/shm")
( return "/dev/shm"
, return "/tmp"
)
return $ dir </> md5sum ++ shortbase ++ ".lck"
return $ dir P.</> md5sum <> toRawFilePath shortbase <> ".lck"
-- | Tries to take a lock; does not block when the lock is already held.
--
@ -131,25 +135,27 @@ sideLockFile lockfile = do
-- "PIDLOCK_lockfile" environment variable, does not block either.
tryLock :: LockFile -> IO (Maybe LockHandle)
tryLock lockfile = do
abslockfile <- fromRawFilePath <$> absPath (toRawFilePath lockfile)
abslockfile <- absPath lockfile
lockenv <- pidLockEnv abslockfile
getEnv lockenv >>= \case
Nothing -> trySideLock lockfile (go abslockfile)
_ -> return (Just ParentLocked)
where
go abslockfile sidelock = do
(tmp, h) <- openTempFile (takeDirectory abslockfile) "locktmp"
setFileMode tmp (combineModes readModes)
let abslockfile' = fromRawFilePath abslockfile
(tmp, h) <- openTempFile (takeDirectory abslockfile') "locktmp"
let tmp' = toRawFilePath tmp
setFileMode tmp' (combineModes readModes)
hPutStr h . show =<< mkPidLock
hClose h
let failedlock st = do
dropLock $ LockHandle tmp st sidelock
nukeFile tmp
dropLock $ LockHandle tmp' st sidelock
removeWhenExistsWith removeLink tmp'
return Nothing
let tooklock st = return $ Just $ LockHandle abslockfile st sidelock
ifM (linkToLock sidelock tmp abslockfile)
ifM (linkToLock sidelock tmp' abslockfile)
( do
nukeFile tmp
removeWhenExistsWith removeLink tmp'
-- May not have made a hard link, so stat
-- the lockfile
lckst <- getFileStatus abslockfile
@ -157,7 +163,7 @@ tryLock lockfile = do
, do
v <- readPidLock abslockfile
hn <- getHostName
tmpst <- getFileStatus tmp
tmpst <- getFileStatus tmp'
case v of
Just pl | isJust sidelock && hn == lockingHost pl -> do
-- Since we have the sidelock,
@ -165,7 +171,7 @@ tryLock lockfile = do
-- the pidlock was taken on,
-- we know that the pidlock is
-- stale, and can take it over.
rename tmp abslockfile
rename tmp' abslockfile
tooklock tmpst
_ -> failedlock tmpst
)
@ -180,12 +186,12 @@ tryLock lockfile = do
--
-- However, not all filesystems support hard links. So, first probe
-- to see if they are supported. If not, use open with O_EXCL.
linkToLock :: SideLockHandle -> FilePath -> FilePath -> IO Bool
linkToLock :: SideLockHandle -> RawFilePath -> RawFilePath -> IO Bool
linkToLock Nothing _ _ = return False
linkToLock (Just _) src dest = do
let probe = src ++ ".lnk"
let probe = src <> ".lnk"
v <- tryIO $ createLink src probe
nukeFile probe
removeWhenExistsWith removeLink probe
case v of
Right _ -> do
_ <- tryIO $ createLink src dest
@ -200,7 +206,8 @@ linkToLock (Just _) src dest = do
(defaultFileFlags {exclusive = True})
fdToHandle fd
let cleanup = hClose
bracket setup cleanup (\h -> readFile src >>= hPutStr h)
let go h = readFile (fromRawFilePath src) >>= hPutStr h
bracket setup cleanup go
return True
where
checklinked = do
@ -228,16 +235,17 @@ linkToLock (Just _) src dest = do
-- We can detect this insanity by getting the directory contents after
-- making the link, and checking to see if 2 copies of the dest file,
-- with the SAME FILENAME exist.
checkInsaneLustre :: FilePath -> IO Bool
checkInsaneLustre :: RawFilePath -> IO Bool
checkInsaneLustre dest = do
fs <- dirContents (takeDirectory dest)
case length (filter (== dest) fs) of
let dest' = fromRawFilePath dest
fs <- dirContents (takeDirectory dest')
case length (filter (== dest') fs) of
1 -> return False -- whew!
0 -> return True -- wtf?
_ -> do
-- Try to clean up the extra copy we made
-- that has the same name. Egads.
_ <- tryIO $ removeFile dest
_ <- tryIO $ removeFile dest'
return True
-- | Waits as necessary to take a lock.
@ -253,20 +261,20 @@ waitLock (Seconds timeout) lockfile displaymessage = go timeout
| n > 0 = liftIO (tryLock lockfile) >>= \case
Nothing -> do
when (n == pred timeout) $
displaymessage $ "waiting for pid lock file " ++ lockfile ++ " which is held by another process (or may be stale)"
displaymessage $ "waiting for pid lock file " ++ fromRawFilePath lockfile ++ " which is held by another process (or may be stale)"
liftIO $ threadDelaySeconds (Seconds 1)
go (pred n)
Just lckh -> return lckh
| otherwise = do
displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile
giveup $ "Gave up waiting for pid lock file " ++ lockfile
displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile
giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile
dropLock :: LockHandle -> IO ()
dropLock (LockHandle lockfile _ sidelock) = do
-- Drop side lock first, at which point the pid lock will be
-- considered stale.
dropSideLock sidelock
nukeFile lockfile
removeWhenExistsWith removeLink lockfile
dropLock ParentLocked = return ()
getLockStatus :: LockFile -> IO LockStatus
@ -297,9 +305,9 @@ checkSaneLock _ ParentLocked = return True
-- The parent process should keep running as long as the child
-- process is running, since the child inherits the environment and will
-- not see unsetLockEnv.
pidLockEnv :: FilePath -> IO String
pidLockEnv :: RawFilePath -> IO String
pidLockEnv lockfile = do
abslockfile <- fromRawFilePath <$> absPath (toRawFilePath lockfile)
abslockfile <- fromRawFilePath <$> absPath lockfile
return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile
pidLockEnvValue :: String