module Stack.Upgrade (upgrade) where
import Control.Monad (when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Control
import Data.Foldable (forM_)
import qualified Data.Map as Map
import Data.Maybe (isNothing)
import Data.Monoid.Extra
import qualified Data.Text as T
import Lens.Micro (set)
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO
import qualified Paths_stack as Paths
import Stack.Build
import Stack.Config
import Stack.Fetch
import Stack.PackageIndex
import Stack.Setup
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
import Stack.Types.Config
import Stack.Types.Internal
import Stack.Types.StackT
import System.Process (readProcess)
import System.Process.Run
upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
=> ConfigMonoid
-> Maybe String
-> Maybe AbstractResolver
-> Maybe String
-> m ()
upgrade gConfigMonoid gitRepo mresolver builtHash =
withSystemTempDir "stack-upgrade" $ \tmp -> do
menv <- getMinimalEnvOverride
mdir <- case gitRepo of
Just repo -> do
remote <- liftIO $ readProcess "git" ["ls-remote", repo, "master"] []
let latestCommit = head . words $ remote
when (isNothing builtHash) $
$logWarn $ "Information about the commit this version of stack was "
<> "built from is not available due to how it was built. "
<> "Will continue by assuming an upgrade is needed "
<> "because we have no information to the contrary."
if builtHash == Just latestCommit
then do
$logInfo "Already up-to-date, no upgrade required"
return Nothing
else do
$logInfo "Cloning stack"
let args = [ "clone", repo , "stack", "--depth", "1", "--recursive"]
runCmd (Cmd (Just tmp) "git" menv args) Nothing
return $ Just $ tmp </> $(mkRelDir "stack")
Nothing -> do
updateAllIndices menv
caches <- getPackageCaches
let latest = Map.fromListWith max
$ map toTuple
$ Map.keys
$ Map.delete (PackageIdentifier
$(mkPackageName "stack")
$(mkVersion "9.9.9"))
caches
case Map.lookup $(mkPackageName "stack") latest of
Nothing -> error "No stack found in package indices"
Just version | version <= fromCabalVersion Paths.version -> do
$logInfo "Already at latest version, no upgrade required"
return Nothing
Just version -> do
let ident = PackageIdentifier $(mkPackageName "stack") version
paths <- unpackPackageIdents menv tmp Nothing
$ Map.singleton ident Nothing
case Map.lookup ident paths of
Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found"
Just path -> return $ Just path
forM_ mdir $ \dir -> do
lc <- loadConfig
gConfigMonoid
mresolver
(Just $ dir </> $(mkRelFile "stack.yaml"))
bconfig <- lcLoadBuildConfig lc Nothing
envConfig1 <- runInnerStackT bconfig $ setupEnv $ Just $
"Try rerunning with --install-ghc to install the correct GHC into " <>
T.pack (toFilePath (configLocalPrograms (getConfig bconfig)))
runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True envConfig1) $
build (const $ return ()) Nothing defaultBuildOptsCLI
{ boptsCLITargets = ["stack"]
}