Use file instead of dir locking haskell#187 (haskell#203)

* Use file instead of dir locking haskell#187 This commit simply imports the code from the filelock package verbatim into a subdirectory, filelock. Depending on filelock as an external package instead would be more straightforward, but I'm not sure what the rules for external dependencies are here. * Switch to upstream filelock Given that the extra dependency doesn't seem to be a problem, remove the inlined code. If in fact the dependency should be avoided, just ignore this commit and use the parent.

Author: snoyberg

hackage-security/hackage-security.cabal

@@ -103,6 +103,7 @@ library
  Cabal >= 1.14 && < 2.2,
  containers >= 0.4 && < 0.6,
  ed25519 >= 0.0 && < 0.1,
+ filelock >= 0.1.1 && < 0.2,
  filepath >= 1.2 && < 1.5,
  mtl >= 2.2 && < 2.3,
  parsec >= 3.1 && < 3.2,

hackage-security/src/Hackage/Security/Util/IO.hs

@@ -11,6 +11,7 @@ import Control.Exception
 import Data.Time
 import System.IO hiding (openTempFile, withFile)
 import System.IO.Error
+import qualified System.FileLock as FL
 
 import Hackage.Security.Util.Path
 
@@ -30,22 +31,19 @@ handleDoesNotExist act =
  then return Nothing
  else throwIO e
 
--- | Attempt to create a filesystem lock in the specified directory
+-- | Attempt to create a filesystem lock in the specified directory.
 --
--- Given a file @/path/to@, we do this by attempting to create the directory
--- @//path/to/hackage-security-lock@, and deleting the directory again
--- afterwards. Creating a directory that already exists will throw an exception
--- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way
--- to implement a lock file.
+-- This will use OS-specific file locking primitives, and throw an
+-- exception if the lock is already present.
 withDirLock :: Path Absolute -> IO a -> IO a
-withDirLock dir = bracket_ takeLock releaseLock
+withDirLock dir act = do
+ res <- FL.withTryFileLock lock FL.Exclusive (const act)
+ case res of
+ Just a -> return a
+ Nothing -> error $ "withFileLock: lock already exists: " ++ lock
  where
- lock :: Path Absolute
- lock = dir </> fragment "hackage-security-lock"
-
- takeLock, releaseLock :: IO ()
- takeLock = createDirectory lock
- releaseLock = removeDirectory lock
+ lock :: FilePath
+ lock = toFilePath $ dir </> fragment "hackage-security-lock"
 
 {-------------------------------------------------------------------------------
  Debugging

stack.yaml

@@ -10,3 +10,4 @@ packages:
 - precompute-fileinfo
 extra-deps:
 - http-client-0.5.5
+- filelock-0.1.1.2