Runners.hs

{-# 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