1{-# LANGUAGE NoImplicitPrelude     #-}
2{-# LANGUAGE ConstraintKinds       #-}
3{-# LANGUAGE FlexibleContexts      #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE OverloadedStrings     #-}
6module Stack.Upgrade
7    ( upgrade
8    , UpgradeOpts
9    , upgradeOpts
10    ) where
11
12import           Stack.Prelude               hiding (force, Display (..))
13import qualified Data.Text as T
14import           Distribution.Version        (mkVersion')
15import           Options.Applicative
16import           Path
17import qualified Paths_stack as Paths
18import           Stack.Build
19import           Stack.Build.Target (NeedTargets(..))
20import           Stack.Constants
21import           Stack.Runners
22import           Stack.Setup
23import           Stack.Types.Config
24import           System.Console.ANSI (hSupportsANSIWithoutEmulation)
25import           System.Process              (rawSystem, readProcess)
26import           RIO.PrettyPrint
27import           RIO.Process
28
29upgradeOpts :: Parser UpgradeOpts
30upgradeOpts = UpgradeOpts
31    <$> (sourceOnly <|> optional binaryOpts)
32    <*> (binaryOnly <|> optional sourceOpts)
33  where
34    binaryOnly = flag' Nothing (long "binary-only" <> help "Do not use a source upgrade path")
35    sourceOnly = flag' Nothing (long "source-only" <> help "Do not use a binary upgrade path")
36
37    binaryOpts = BinaryOpts
38        <$> optional (strOption
39              ( long "binary-platform"
40             <> help "Platform type for archive to download"
41             <> showDefault))
42        <*> switch
43         (long "force-download" <>
44          help "Download the latest available stack executable")
45        <*> optional (strOption
46         (long "binary-version" <>
47          help "Download a specific stack version"))
48        <*> optional (strOption
49         (long "github-org" <>
50          help "Github organization name"))
51        <*> optional (strOption
52         (long "github-repo" <>
53          help "Github repository name"))
54
55    sourceOpts = SourceOpts
56        <$> ((\fromGit repo branch -> if fromGit then Just (repo, branch) else Nothing)
57                <$> switch
58                    ( long "git"
59                    <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )
60                <*> strOption
61                    ( long "git-repo"
62                    <> help "Clone from specified git repository"
63                    <> value "https://github.com/commercialhaskell/stack"
64                    <> showDefault )
65                <*> strOption
66                    ( long "git-branch"
67                   <> help "Clone from this git branch"
68                   <> value "master"
69                   <> showDefault ))
70
71data BinaryOpts = BinaryOpts
72    { _boPlatform :: !(Maybe String)
73    , _boForce :: !Bool
74    -- ^ force a download, even if the downloaded version is older
75    -- than what we are
76    , _boVersion :: !(Maybe String)
77    -- ^ specific version to download
78    , _boGithubOrg :: !(Maybe String)
79    , _boGithubRepo :: !(Maybe String)
80    }
81    deriving Show
82newtype SourceOpts = SourceOpts (Maybe (String, String)) -- repo and branch
83    deriving Show
84
85data UpgradeOpts = UpgradeOpts
86    { _uoBinary :: !(Maybe BinaryOpts)
87    , _uoSource :: !(Maybe SourceOpts)
88    }
89    deriving Show
90
91upgrade :: Maybe String -- ^ git hash at time of building, if known
92        -> UpgradeOpts
93        -> RIO Runner ()
94upgrade builtHash (UpgradeOpts mbo mso) =
95    case (mbo, mso) of
96        -- FIXME It would be far nicer to capture this case in the
97        -- options parser itself so we get better error messages, but
98        -- I can't think of a way to make it happen.
99        (Nothing, Nothing) -> throwString "You must allow either binary or source upgrade paths"
100        (Just bo, Nothing) -> binary bo
101        (Nothing, Just so) -> source so
102        -- See #2977 - if --git or --git-repo is specified, do source upgrade.
103        (_, Just so@(SourceOpts (Just _))) -> source so
104        (Just bo, Just so) -> binary bo `catchAny` \e -> do
105            prettyWarnL
106               [ flow "Exception occured when trying to perform binary upgrade:"
107               , fromString . show $ e
108               , line <> flow "Falling back to source upgrade"
109               ]
110
111            source so
112  where
113    binary bo = binaryUpgrade bo
114    source so = sourceUpgrade builtHash so
115
116binaryUpgrade :: BinaryOpts -> RIO Runner ()
117binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = withConfig NoReexec $ do
118    platforms0 <-
119      case mplatform of
120        Nothing -> preferredPlatforms
121        Just p -> return [("windows" `T.isInfixOf` T.pack p, p)]
122    archiveInfo <- downloadStackReleaseInfo morg mrepo mver
123
124    let mdownloadVersion = getDownloadVersion archiveInfo
125        force =
126          case mver of
127            Nothing -> force'
128            Just _ -> True -- specifying a version implies we're forcing things
129    isNewer <-
130        case mdownloadVersion of
131            Nothing -> do
132                prettyErrorL $
133                    flow "Unable to determine upstream version from Github metadata"
134                  :
135                  [ line <> flow "Rerun with --force-download to force an upgrade"
136                    | not force]
137                return False
138            Just downloadVersion -> do
139                prettyInfoL
140                    [ flow "Current Stack version:"
141                    , fromString (versionString stackVersion) <> ","
142                    , flow "available download version:"
143                    , fromString (versionString downloadVersion)
144                    ]
145                return $ downloadVersion > stackVersion
146
147    toUpgrade <- case (force, isNewer) of
148        (False, False) -> do
149            prettyInfoS "Skipping binary upgrade, you are already running the most recent version"
150            return False
151        (True, False) -> do
152            prettyInfoS "Forcing binary upgrade"
153            return True
154        (_, True) -> do
155            prettyInfoS "Newer version detected, downloading"
156            return True
157    when toUpgrade $ do
158        config <- view configL
159        downloadStackExe platforms0 archiveInfo (configLocalBin config) True $ \tmpFile -> do
160            -- Sanity check!
161            ec <- rawSystem (toFilePath tmpFile) ["--version"]
162
163            unless (ec == ExitSuccess)
164                    $ throwString "Non-success exit code from running newly downloaded executable"
165
166sourceUpgrade
167  :: Maybe String
168  -> SourceOpts
169  -> RIO Runner ()
170sourceUpgrade builtHash (SourceOpts gitRepo) =
171  withSystemTempDir "stack-upgrade" $ \tmp -> do
172    mdir <- case gitRepo of
173      Just (repo, branch) -> do
174        remote <- liftIO $ System.Process.readProcess "git" ["ls-remote", repo, branch] []
175        latestCommit <-
176          case words remote of
177            [] -> throwString $ "No commits found for branch " ++ branch ++ " on repo " ++ repo
178            x:_ -> return x
179        when (isNothing builtHash) $
180            prettyWarnS $
181                       "Information about the commit this version of stack was "
182                    <> "built from is not available due to how it was built. "
183                    <> "Will continue by assuming an upgrade is needed "
184                    <> "because we have no information to the contrary."
185        if builtHash == Just latestCommit
186            then do
187                prettyInfoS "Already up-to-date, no upgrade required"
188                return Nothing
189            else do
190                prettyInfoS "Cloning stack"
191                -- NOTE: "--recursive" was added after v1.0.0 (and before the
192                -- next release).  This means that we can't use submodules in
193                -- the stack repo until we're comfortable with "stack upgrade
194                -- --git" not working for earlier versions.
195                let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch]
196                withWorkingDir (toFilePath tmp) $ proc "git" args runProcess_
197                -- On Windows 10, an upstream issue with the `git clone` command
198                -- means that command clears, but does not then restore, the
199                -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals.
200                -- The following hack re-enables the lost ANSI-capability.
201                when osIsWindows $
202                  void $ liftIO $ hSupportsANSIWithoutEmulation stdout
203                return $ Just $ tmp </> relDirStackProgName
204      -- We need to access the Pantry database to find out about the
205      -- latest Stack available on Hackage. We first use a standard
206      -- Config to do this, and once we have the source load up the
207      -- stack.yaml from inside that source.
208      Nothing -> withConfig NoReexec $ do
209        void $ updateHackageIndex
210             $ Just "Updating index to make sure we find the latest Stack version"
211        mversion <- getLatestHackageVersion YesRequireHackageIndex "stack" UsePreferredVersions
212        (PackageIdentifierRevision _ version _) <-
213          case mversion of
214            Nothing -> throwString "No stack found in package indices"
215            Just version -> pure version
216
217        if version <= mkVersion' Paths.version
218            then do
219                prettyInfoS "Already at latest version, no upgrade required"
220                return Nothing
221            else do
222                suffix <- parseRelDir $ "stack-" ++ versionString version
223                let dir = tmp </> suffix
224                mrev <- getLatestHackageRevision YesRequireHackageIndex "stack" version
225                case mrev of
226                  Nothing -> throwString "Latest version with no revision"
227                  Just (_rev, cfKey, treeKey) -> do
228                    let ident = PackageIdentifier "stack" version
229                    unpackPackageLocation dir $ PLIHackage ident cfKey treeKey
230                    pure $ Just dir
231
232    let modifyGO dir go = go
233          { globalResolver = Nothing -- always use the resolver settings in the stack.yaml file
234          , globalStackYaml = SYLOverride $ dir </> stackDotYaml
235          }
236        boptsCLI = defaultBuildOptsCLI
237          { boptsCLITargets = ["stack"]
238          }
239    forM_ mdir $ \dir ->
240      local (over globalOptsL (modifyGO dir)) $
241      withConfig NoReexec $ withEnvConfig AllowNoTargets boptsCLI $
242      local (set (buildOptsL.buildOptsInstallExesL) True) $
243      build Nothing
244