From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 13 Nov 2015 18:04:29 +0000 (-0400)
Subject: avoid over-long filenames for side lock files
X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~1^2~324^2~23
X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=85345abe8bc45b6f2a5d542d0cd8db28452ed8b5;p=git-annex.git

avoid over-long filenames for side lock files
---

diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index 4caf5a06b3..d367759c3e 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.