Runners.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Utilities for running stack commands.
module Stack.Runners
    ( withGlobalConfigAndLock
    , withConfigAndLock
    , withMiniConfigAndLock
    , withBuildConfigAndLock
    , withBuildConfig
    , withBuildConfigExt
    , loadConfigWithOpts
    , loadCompilerVersion
    , withUserFileLock
    , munlockFile
    ) where

import           Control.Monad hiding (forM)
import           Control.Monad.Logger
import           Control.Exception.Lifted as EL
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Control
import           Data.IORef
import           Data.Traversable
import           Network.HTTP.Client
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)
import           Stack.Types.Config
import           Stack.Types.StackT
import           System.Environment (getEnvironment)
import           System.IO
import           System.FileLock

loadCompilerVersion :: Manager
                    -> GlobalOpts
                    -> LoadConfig (StackLoggingT IO)
                    -> IO CompilerVersion
loadCompilerVersion manager go lc = do
    bconfig <- runStackLoggingTGlobal manager go $
      lcLoadBuildConfig lc (globalCompiler go)
    return $ bcWantedCompiler 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 :: (MonadBaseControl IO m, MonadIO 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:
            EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)
                       (maybe (return ()) (liftIO . unlockFile))
                       (\fstTry ->
                        case fstTry of
                          Just lk -> EL.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..."
                               EL.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
    -> StackT Config IO ()
    -> IO ()
withConfigAndLock go@GlobalOpts{..} inner = do
    (manager, lc) <- loadConfigWithOpts go
    withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->
        runStackTGlobal manager (lcConfig lc) go $
            Docker.reexecWithOptionalContainer
                (lcProjectRoot lc)
                Nothing
                (runStackTGlobal manager (lcConfig lc) go inner)
                Nothing
                (Just $ munlockFile lk)

-- | Loads global config, ignoring any configuration which would be
-- loaded due to $PWD.
withGlobalConfigAndLock
    :: GlobalOpts
    -> StackT Config IO ()
    -> IO ()
withGlobalConfigAndLock go@GlobalOpts{..} inner = do
    manager <- newTLSManager
    lc <- runStackLoggingTGlobal manager go $
        loadConfigMaybeProject globalConfigMonoid Nothing Nothing
    withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk ->
        runStackTGlobal manager (lcConfig lc) go inner

-- For now the non-locking version just unlocks immediately.
-- That is, there's still a serialization point.
withBuildConfig
    :: GlobalOpts
    -> StackT EnvConfig IO ()
    -> IO ()
withBuildConfig go inner =
    withBuildConfigAndLock go (\lk -> do munlockFile lk
                                         inner)

withBuildConfigAndLock
    :: GlobalOpts
    -> (Maybe FileLock -> StackT EnvConfig IO ())
    -> IO ()
withBuildConfigAndLock go inner =
    withBuildConfigExt go Nothing inner Nothing

withBuildConfigExt
    :: GlobalOpts
    -> Maybe (StackT Config IO ())
    -- ^ 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 -> 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 ())
    -- ^ 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 go@GlobalOpts{..} mbefore inner mafter = do
    (manager, lc) <- loadConfigWithOpts go

    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 <- runStackLoggingTGlobal manager go $
                  lcLoadBuildConfig lc globalCompiler
              envConfig <-
                 runStackTGlobal
                     manager bconfig go
                     (setupEnv Nothing)
              runStackTGlobal
                  manager
                  envConfig
                  go
                  (inner' lk)

      let getCompilerVersion = loadCompilerVersion manager go lc
      runStackTGlobal manager (lcConfig lc) go $
        Docker.reexecWithOptionalContainer
                 (lcProjectRoot lc)
                 mbefore
                 (runStackTGlobal manager (lcConfig lc) go $
                    Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0))
                 mafter
                 (Just $ liftIO $
                      do lk' <- readIORef curLk
                         munlockFile lk')

-- | Load the configuration with a manager. Convenience function used
-- throughout this module.
loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))
loadConfigWithOpts go@GlobalOpts{..} = do
    manager <- newTLSManager
    mstackYaml <- forM globalStackYaml resolveFile'
    lc <- runStackLoggingTGlobal manager go $ 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 ()
        return lc
    return (manager,lc)

withMiniConfigAndLock
    :: GlobalOpts
    -> StackT MiniConfig IO ()
    -> IO ()
withMiniConfigAndLock go@GlobalOpts{..} inner = do
    manager <- newTLSManager
    miniConfig <- runStackLoggingTGlobal manager go $ do
        lc <- loadConfigMaybeProject globalConfigMonoid globalResolver Nothing
        loadMiniConfig manager (lcConfig lc)
    runStackTGlobal manager miniConfig go 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