avoid over-long filenames for side lock files

diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs
index 4caf5a06b3d239a84366769a57d37eebad08d98d..d367759c3e37a9a7bdf8bcec29e2b3ca84a7374d 100644 (file)
--- 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.