avoid over-long filenames for side lock files

1 files changed, 10 insertions, 3 deletions

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.