{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -- | Utilities for running stack commands. module Stack.Runners ( withGlobalConfigAndLock , withConfigAndLock , withMiniConfigAndLock , withBuildConfigAndLock , withBuildConfigAndLockNoDocker , withBuildConfig , withBuildConfigExt , loadConfigWithOpts , loadCompilerVersion , withUserFileLock , munlockFile ) where import Stack.Prelude import Path import Path.IO import Stack.Config import qualified Stack.Docker as Docker import qualified Stack.Nix as Nix import Stack.Setup import Stack.Types.Compiler (CompilerVersion, CVType (..)) import Stack.Types.Config import Stack.Types.Runner import System.Environment (getEnvironment) import System.IO import System.FileLock -- FIXME it seems wrong that we call lcLoadBuildConfig multiple times loadCompilerVersion :: GlobalOpts -> LoadConfig -> IO (CompilerVersion 'CVWanted) loadCompilerVersion go lc = do bconfig <- lcLoadBuildConfig lc (globalCompiler go) return $ view wantedCompilerVersionL bconfig -- | Enforce mutual exclusion of every action running via this -- function, on this path, on this users account. -- -- A lock file is created inside the given directory. Currently, -- stack uses locks per-snapshot. In the future, stack may refine -- this to an even more fine-grain locking approach. -- withUserFileLock :: MonadUnliftIO m => GlobalOpts -> Path Abs Dir -> (Maybe FileLock -> m a) -> m a withUserFileLock go@GlobalOpts{} dir act = do env <- liftIO getEnvironment let toLock = lookup "STACK_LOCK" env == Just "true" if toLock then do let lockfile = $(mkRelFile "lockfile") let pth = dir lockfile ensureDir dir -- Just in case of asynchronous exceptions, we need to be careful -- when using tryLockFile here: bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) (maybe (return ()) (liftIO . unlockFile)) (\fstTry -> case fstTry of Just lk -> finally (act $ Just lk) (liftIO $ unlockFile lk) Nothing -> do let chatter = globalLogLevel go /= LevelOther "silent" when chatter $ liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++ "); other stack instance running. Waiting..." bracket (liftIO $ lockFile (toFilePath pth) Exclusive) (liftIO . unlockFile) (\lk -> do when chatter $ liftIO $ hPutStrLn stderr "Lock acquired, proceeding." act $ Just lk)) else act Nothing withConfigAndLock :: GlobalOpts -> RIO Config () -> IO () withConfigAndLock go@GlobalOpts{..} inner = loadConfigWithOpts go $ \lc -> do withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) Nothing (runRIO (lcConfig lc) inner) Nothing (Just $ munlockFile lk) -- | Loads global config, ignoring any configuration which would be -- loaded due to $PWD. withGlobalConfigAndLock :: GlobalOpts -> RIO Config () -> IO () withGlobalConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do lc <- runRIO runner $ loadConfigMaybeProject globalConfigMonoid Nothing LCSNoProject withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk -> runRIO (lcConfig lc) inner -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point. withBuildConfig :: GlobalOpts -> RIO EnvConfig () -> IO () withBuildConfig go inner = withBuildConfigAndLock go (\lk -> do munlockFile lk inner) withBuildConfigAndLock :: GlobalOpts -> (Maybe FileLock -> RIO EnvConfig ()) -> IO () withBuildConfigAndLock go inner = withBuildConfigExt False go Nothing inner Nothing -- | See issue #2010 for why this exists. Currently just used for the -- specific case of "stack clean --full". withBuildConfigAndLockNoDocker :: GlobalOpts -> (Maybe FileLock -> RIO EnvConfig ()) -> IO () withBuildConfigAndLockNoDocker go inner = withBuildConfigExt True go Nothing inner Nothing withBuildConfigExt :: Bool -> GlobalOpts -> Maybe (RIO Config ()) -- ^ Action to perform before the build. This will be run on the host -- 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. -> (Maybe FileLock -> RIO EnvConfig ()) -- ^ Action that uses the build config. If Docker is enabled for builds, -- this will be run in a Docker container. -> Maybe (RIO Config ()) -- ^ Action to perform after the build. This will be run on the host -- 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. -> IO () withBuildConfigExt skipDocker go@GlobalOpts{..} mbefore inner mafter = loadConfigWithOpts go $ \lc -> do withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do -- A local bit of state for communication between callbacks: curLk <- newIORef lk0 let inner' lk = -- Locking policy: This is only used for build commands, which -- only need to lock the snapshot, not the global lock. We -- trade in the lock here. do dir <- installationRootDeps -- Hand-over-hand locking: withUserFileLock go dir $ \lk2 -> do liftIO $ writeIORef curLk lk2 liftIO $ munlockFile lk logDebug "Starting to execute command inside EnvConfig" inner lk2 let inner'' lk = do bconfig <- lcLoadBuildConfig lc globalCompiler envConfig <- runRIO bconfig (setupEnv Nothing) runRIO envConfig (inner' lk) let getCompilerVersion = loadCompilerVersion go lc if skipDocker then runRIO (lcConfig lc) $ do forM_ mbefore id Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0) forM_ mafter id else runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore (runRIO (lcConfig lc) $ Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0)) mafter (Just $ liftIO $ do lk' <- readIORef curLk munlockFile lk') -- | Load the configuration. Convenience function used -- throughout this module. loadConfigWithOpts :: GlobalOpts -> (LoadConfig -> IO a) -> IO a loadConfigWithOpts go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do mstackYaml <- forM globalStackYaml resolveFile' runRIO runner $ do lc <- loadConfig globalConfigMonoid globalResolver mstackYaml -- If we have been relaunched in a Docker container, perform in-container initialization -- (switch UID, etc.). We do this after first loading the configuration since it must -- happen ASAP but needs a configuration. case globalDockerEntrypoint of Just de -> Docker.entrypoint (lcConfig lc) de Nothing -> return () liftIO $ inner lc withRunnerGlobal :: GlobalOpts -> (Runner -> IO a) -> IO a withRunnerGlobal GlobalOpts{..} = withRunner globalLogLevel globalTimeInLog globalTerminal globalColorWhen globalTermWidth (isJust globalReExecVersion) withMiniConfigAndLock :: GlobalOpts -> RIO MiniConfig () -> IO () withMiniConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do miniConfig <- runRIO runner $ (loadMiniConfig . lcConfig) <$> loadConfigMaybeProject globalConfigMonoid globalResolver LCSNoProject runRIO miniConfig inner -- | Unlock a lock file, if the value is Just munlockFile :: MonadIO m => Maybe FileLock -> m () munlockFile Nothing = return () munlockFile (Just lk) = liftIO $ unlockFile lk