From 4a1357d646eb7cf5187a360a4cb76a11d82daa0b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Sep 2015 06:25:58 +0300 Subject: [PATCH] Locking is optional (fixes #950) --- ChangeLog.md | 1 + src/main/Main.hs | 78 +++++++++++++++++++++++++++--------------------- 2 files changed, 45 insertions(+), 34 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 7c260b9cff..c3fe8ff6e3 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -25,6 +25,7 @@ Other enhancements: * Added `--cabal-verbose` flag * Added `--file-watch-poll` flag for polling instead of using filesystem events (useful for running tests in a Docker container while modifying code in the host environment. When code is injected into the container via a volume, the container won't propagate filesystem events). * Give a preemptive error message when `-prof` is given as a GHC option [#1015](https://github.com/commercialhaskell/stack/issues/1015) +* Locking is now optional, and will be turned on by setting the `STACK_LOCK` environment variable to `true` [#950](https://github.com/commercialhaskell/stack/issues/950) Bug fixes: diff --git a/src/main/Main.hs b/src/main/Main.hs index da878141a7..fad429876f 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -71,7 +71,7 @@ import Stack.Types.StackT import Stack.Upgrade import qualified Stack.Upload as Upload import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing) -import System.Environment (getProgName) +import System.Environment (getEnvironment, getProgName) import System.Exit import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock) import System.FilePath (dropTrailingPathSeparator, searchPathSeparator) @@ -581,7 +581,12 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do $logInfo "stack ghc, stack ghci, stack runghc, or stack exec" ) Nothing - (Just $ liftIO$ unlockFile lk) + (Just $ munlockFile lk) + +-- | Unlock a lock file, if the value is Just +munlockFile :: MonadIO m => Maybe FileLock -> m () +munlockFile Nothing = return () +munlockFile (Just lk) = liftIO $ unlockFile lk -- | Enforce mutual exclusion of every action running via this -- function, on this path, on this users account. @@ -592,27 +597,32 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do -- withUserFileLock :: (MonadBaseControl IO m, MonadIO m) => Path Abs Dir - -> (FileLock -> m a) + -> (Maybe FileLock -> m a) -> m a withUserFileLock dir act = do - let lockfile = $(mkRelFile "lockfile") - let pth = dir lockfile - liftIO $ createDirectoryIfMissing True (toFilePath dir) - -- Just in case of asynchronous exceptions, we need to be careful - -- when using tryLockFile here: - EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) - (\fstTry -> maybe (return ()) (liftIO . unlockFile) fstTry) - (\fstTry -> - case fstTry of - Just lk -> EL.finally (act lk) (liftIO $ unlockFile lk) - Nothing -> - do liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++ - "); other stack instance running. Waiting..." - EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive) - (liftIO . unlockFile) - (\lk -> do - liftIO $ hPutStrLn stderr "Lock acquired, proceeding." - act lk)) + env <- liftIO getEnvironment + let toLock = lookup "STACK_LOCK" env == Just "true" + if toLock + then do + let lockfile = $(mkRelFile "lockfile") + let pth = dir lockfile + liftIO $ createDirectoryIfMissing True (toFilePath dir) + -- Just in case of asynchronous exceptions, we need to be careful + -- when using tryLockFile here: + EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) + (\fstTry -> maybe (return ()) (liftIO . unlockFile) fstTry) + (\fstTry -> + case fstTry of + Just lk -> EL.finally (act $ Just lk) (liftIO $ unlockFile lk) + Nothing -> + do liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++ + "); other stack instance running. Waiting..." + EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive) + (liftIO . unlockFile) + (\lk -> do + liftIO $ hPutStrLn stderr "Lock acquired, proceeding." + act $ Just lk)) + else act Nothing withConfigAndLock :: GlobalOpts -> StackT Config IO () @@ -625,7 +635,7 @@ withConfigAndLock go@GlobalOpts{..} inner = do Nothing (runStackTGlobal manager (lcConfig lc) go inner) Nothing - (Just $ liftIO $ unlockFile lk) + (Just $ munlockFile lk) -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point. @@ -633,11 +643,11 @@ withBuildConfig :: GlobalOpts -> (StackT EnvConfig IO ()) -> IO () withBuildConfig go inner = - withBuildConfigAndLock go (\lk -> do liftIO $ unlockFile lk + withBuildConfigAndLock go (\lk -> do munlockFile lk inner) withBuildConfigAndLock :: GlobalOpts - -> (FileLock -> StackT EnvConfig IO ()) + -> (Maybe FileLock -> StackT EnvConfig IO ()) -> IO () withBuildConfigAndLock go inner = withBuildConfigExt go Nothing inner Nothing @@ -649,7 +659,7 @@ withBuildConfigExt -- OS even if Docker is enabled for builds. The build config is not -- available in this action, since that would require build tools to be -- installed on the host OS. - -> (FileLock -> StackT EnvConfig IO ()) + -> (Maybe FileLock -> StackT EnvConfig IO ()) -- ^ Action that uses the build config. If Docker is enabled for builds, -- this will be run in a Docker container. -> Maybe (StackT Config IO ()) @@ -672,7 +682,7 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do -- Hand-over-hand locking: withUserFileLock dir $ \lk2 -> do liftIO $ writeIORef curLk lk2 - liftIO $ unlockFile lk + liftIO $ munlockFile lk inner lk2 let inner'' lk = do @@ -692,7 +702,7 @@ withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore (inner'' lk0) mafter (Just $ liftIO $ do lk' <- readIORef curLk - unlockFile lk') + munlockFile lk') cleanCmd :: () -> GlobalOpts -> IO () cleanCmd () go = withBuildConfigAndLock go (\_ -> clean) @@ -711,7 +721,7 @@ buildCmd opts go = do NoFileWatch -> inner $ const $ return () where inner setLocalFiles = withBuildConfigAndLock go $ \lk -> - globalFixCodePage go $ Stack.Build.build setLocalFiles (Just lk) opts + globalFixCodePage go $ Stack.Build.build setLocalFiles lk opts getProjectRoot = do (manager, lc) <- loadConfigWithOpts go bconfig <- @@ -814,7 +824,7 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do (lcProjectRoot lc) (return (cmd, args, [], id)) -- Unlock before transferring control away, whether using docker or not: - (Just $ liftIO $ unlockFile lk) + (Just $ munlockFile lk) (runStackTGlobal manager (lcConfig lc) go $ do exec plainEnvSettings cmd args) Nothing @@ -823,10 +833,10 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do withBuildConfigAndLock go $ \lk -> do let targets = concatMap words eoPackages unless (null targets) $ globalFixCodePage go $ - Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts + Stack.Build.build (const $ return ()) lk defaultBuildOpts { boptsTargets = map T.pack targets } - liftIO $ unlockFile lk -- Unlock before transferring control away. + munlockFile lk -- Unlock before transferring control away. exec eoEnvSettings cmd args -- | Run GHCi in the context of a project. @@ -835,10 +845,10 @@ ghciCmd ghciOpts go@GlobalOpts{..} = withBuildConfigAndLock go $ \lk -> do let packageTargets = concatMap words (ghciAdditionalPackages ghciOpts) unless (null packageTargets) $ globalFixCodePage go $ - Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts + Stack.Build.build (const $ return ()) lk defaultBuildOpts { boptsTargets = map T.pack packageTargets } - liftIO $ unlockFile lk -- Don't hold the lock while in the GHCI. + munlockFile lk -- Don't hold the lock while in the GHCI. ghci ghciOpts -- | Run ide-backend in the context of a project. @@ -896,7 +906,7 @@ imgDockerCmd () go@GlobalOpts{..} = do do globalFixCodePage go $ Stack.Build.build (const (return ())) - (Just lk) + lk defaultBuildOpts Image.stageContainerImageArtifacts) (Just Image.createContainerImageFromStage)