From 3199555ed02af23b0d38554124c7033a974d8c5c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 13 Nov 2015 14:04:29 -0400 Subject: avoid over-long filenames for side lock files --- Utility/LockFile/PidLock.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'Utility/LockFile') diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index 4caf5a06b..d367759c3 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -34,6 +34,7 @@ import Data.List import Control.Applicative import Network.BSD import System.FilePath +import Data.Hash.MD5 type LockFile = FilePath @@ -59,9 +60,7 @@ readPidLock lockfile = (readish =<<) <$> catchMaybeIO (readFile lockfile) -- root filesystem doesn't support posix locks. trySideLock :: LockFile -> (Maybe Posix.LockHandle -> IO a) -> IO a trySideLock lockfile a = do - f <- absPath lockfile - let sidelock = "/dev/shm" - intercalate "_" (splitDirectories (makeRelative "/" f)) ++ ".lck" + sidelock <- sideLockFile lockfile mlck <- catchDefaultIO Nothing $ withUmask nullFileMode $ Posix.tryLockExclusive (Just mode) sidelock @@ -73,6 +72,14 @@ trySideLock lockfile a = do -- lock file there, so could not delete a stale lock. mode = combineModes (readModes ++ writeModes) +sideLockFile :: LockFile -> IO LockFile +sideLockFile lockfile = do + f <- absPath lockfile + let base = intercalate "_" (splitDirectories (makeRelative "/" f)) + let shortbase = reverse $ take 32 $ reverse base + let md5 = if base == shortbase then "" else md5s (Str base) + return $ "/dev/shm" md5 ++ shortbase ++ ".lck" + -- | Tries to take a lock; does not block when the lock is already held. -- -- The method used is atomic even on NFS without needing O_EXCL support. -- cgit v1.2.3