Skip to content

Commit aa94dcd

Browse files
snoybergborsboom
snoyberg
authored and
borsboom
committed
Allow binary upgrades commercialhaskell#1238 
1 parent 6eaae2f commit aa94dcd

4 files changed

Lines changed: 296 additions & 19 deletions

File tree

‎ChangeLog.md‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,11 @@ Major changes:
2121
installation should now include a `stack setup` line or use the `--install-ghc`
2222
flag.
2323
[#2221](https://github.com/commercialhaskell/stack/issues/2221)
24+
* Stack is now capable of doing binary upgrades instead of always
25+
recompiling a new version from source. In order to take advantage of
26+
this, you should do a binary installation so that your platform is
27+
properly configured, and from then on `stack upgrade` will default
28+
to binary upgrades.
2429

2530
Behavior changes:
2631

‎src/Stack/Setup.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -485,7 +485,7 @@ ensureCompiler sopts = do
485485

486486
return (mpaths, compilerBuild)
487487

488-
-- | Determine which GHC build to use dependong on which shared libraries are available
488+
-- | Determine which GHC build to use depending on which shared libraries are available
489489
-- on the system.
490490
getGhcBuild
491491
:: (StackM env m, HasConfig env)

‎src/Stack/Upgrade.hs‎

Lines changed: 285 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,40 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE ConstraintKinds #-}
23
{-# LANGUAGE FlexibleContexts #-}
34
{-# LANGUAGE MultiParamTypeClasses #-}
45
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE RecordWildCards #-}
57
{-# LANGUAGE TemplateHaskell #-}
6-
module Stack.Upgrade (upgrade) where
8+
module Stack.Upgrade
9+
( upgrade
10+
, UpgradeOpts
11+
, upgradeOpts
12+
) where
713

8-
import Control.Monad (when)
14+
import qualified Codec.Archive.Tar as Tar
15+
import Control.Exception.Safe (catchAny, throwM)
16+
import Control.Monad (guard, liftM, unless, when)
917
import Control.Monad.IO.Class
1018
import Control.Monad.Logger
11-
import Data.Foldable (forM_)
19+
import Control.Monad.Reader (MonadReader, asks)
20+
import Data.Aeson (Value (Array, Object, String))
21+
import qualified Data.ByteString.Lazy as L
22+
import Data.Conduit ((.|))
23+
import Data.Conduit.Lazy (lazyConsume)
24+
import Data.Conduit.Zlib (ungzip)
25+
import Data.Foldable (fold, forM_)
26+
import qualified Data.HashMap.Strict as HashMap
1227
import qualified Data.Map as Map
1328
import Data.Maybe (isNothing)
1429
import Data.Monoid.Extra
1530
import qualified Data.Text as T
31+
import qualified Data.Version
32+
import Distribution.System (Platform (Platform), Arch (..), OS (..))
1633
import Lens.Micro (set)
34+
import Network.HTTP.Client (parseUrlThrow)
35+
import Network.HTTP.Simple (Request, httpJSON, withResponse,
36+
setRequestHeader, getResponseBody)
37+
import Options.Applicative
1738
import Path
1839
import Path.IO
1940
import qualified Paths_stack as Paths
@@ -29,16 +50,274 @@ import Stack.Types.Config
2950
import Stack.Types.Internal
3051
import Stack.Types.Resolver
3152
import Stack.Types.StackT
32-
import System.Process (readProcess)
53+
import qualified System.Directory as IO
54+
import System.Exit (ExitCode (ExitSuccess))
55+
import qualified System.FilePath as FP
56+
import System.Process (rawSystem, readProcess)
3357
import System.Process.Run
58+
import Text.ParserCombinators.ReadP (readP_to_S)
59+
60+
#if !WINDOWS
61+
import System.Posix.Files (setFileMode)
62+
#endif
63+
64+
upgradeOpts :: Parser UpgradeOpts
65+
upgradeOpts = UpgradeOpts
66+
<$> (sourceOnly <|> optional binaryOpts)
67+
<*> (binaryOnly <|> optional sourceOpts)
68+
where
69+
binaryOnly = flag' Nothing (long "binary-only" <> help "Do not use a source upgrade path")
70+
sourceOnly = flag' Nothing (long "source-only" <> help "Do not use a binary upgrade path")
71+
72+
binaryOpts = BinaryOpts
73+
<$> optional (strOption
74+
( long "binary-platform"
75+
<> help "Platform type for archive to download"
76+
<> showDefault))
77+
<*> switch
78+
(long "force-download" <>
79+
help "Download a stack executable, even if the version number is older than what we have")
80+
81+
sourceOpts = SourceOpts
82+
<$> ((\fromGit repo -> if fromGit then Just repo else Nothing)
83+
<$> switch
84+
( long "git"
85+
<> help "Clone from Git instead of downloading from Hackage (more dangerous)" )
86+
<*> strOption
87+
( long "git-repo"
88+
<> help "Clone from specified git repository"
89+
<> value "https://github.com/commercialhaskell/stack"
90+
<> showDefault ))
91+
92+
data BinaryOpts = BinaryOpts
93+
{ _boPlatform :: !(Maybe String)
94+
, _boForce :: !Bool
95+
-- ^ force a download, even if the downloaded version is older
96+
-- than what we are
97+
}
98+
deriving Show
99+
data SourceOpts = SourceOpts
100+
{ _soRepo :: !(Maybe String)
101+
}
102+
deriving Show
103+
104+
data UpgradeOpts = UpgradeOpts
105+
{ _uoBinary :: !(Maybe BinaryOpts)
106+
, _uoSource :: !(Maybe SourceOpts)
107+
}
108+
deriving Show
34109

35110
upgrade :: (StackM env m, HasConfig env)
36111
=> ConfigMonoid
37-
-> Maybe String -- ^ git repository to use
38112
-> Maybe AbstractResolver
39113
-> Maybe String -- ^ git hash at time of building, if known
114+
-> UpgradeOpts
40115
-> m ()
41-
upgrade gConfigMonoid gitRepo mresolver builtHash =
116+
upgrade gConfigMonoid mresolver builtHash (UpgradeOpts mbo mso) =
117+
case (mbo, mso) of
118+
-- FIXME It would be far nicer to capture this case in the
119+
-- options parser itself so we get better error messages, but
120+
-- I can't think of a way to make it happen.
121+
(Nothing, Nothing) -> error "You must allow either binary or source upgrade paths"
122+
(Just bo, Nothing) -> binary bo
123+
(Nothing, Just so) -> source so
124+
(Just bo, Just so) -> binary bo `catchAny` \e -> do
125+
$logWarn "Exception occured when trying to perform binary upgrade:"
126+
$logWarn $ T.pack $ show e
127+
$logWarn "Falling back to source upgrade"
128+
129+
source so
130+
where
131+
binary bo = binaryUpgrade bo
132+
source so = sourceUpgrade gConfigMonoid mresolver builtHash so
133+
134+
newtype StackReleaseInfo = StackReleaseInfo Value
135+
136+
downloadStackReleaseInfo :: MonadIO m => m StackReleaseInfo
137+
downloadStackReleaseInfo = do
138+
-- FIXME make the Github repo configurable?
139+
let req = setUserAgent "https://api.github.com/repos/commercialhaskell/stack/releases/latest"
140+
liftM (StackReleaseInfo . getResponseBody) (httpJSON req)
141+
142+
setUserAgent :: Request -> Request
143+
setUserAgent = setRequestHeader "User-Agent" ["Haskell Stack Upgrade"]
144+
145+
getDownloadVersion :: StackReleaseInfo -> Maybe Data.Version.Version
146+
getDownloadVersion (StackReleaseInfo val) = do
147+
Object o <- Just val
148+
String rawName <- HashMap.lookup "name" o
149+
case filter (null . snd)
150+
$ readP_to_S Data.Version.parseVersion
151+
$ T.unpack $ T.drop 1 rawName of
152+
(v, _):_ -> Just v
153+
[] -> Nothing
154+
155+
preferredPlatforms :: (MonadReader env m, HasPlatform env) => m [String]
156+
preferredPlatforms = do
157+
Platform arch' os' <- asks getPlatform
158+
os <-
159+
case os' of
160+
Linux -> return "linux"
161+
Windows -> return "windows"
162+
OSX -> return "osx"
163+
FreeBSD -> return "freebsd"
164+
_ -> error $ "Binary upgrade not yet supported on OS: " ++ show os'
165+
arch <-
166+
case arch' of
167+
I386 -> return "i386"
168+
X86_64 -> return "x86_64"
169+
Arm -> return "arm"
170+
_ -> error $ "Binary upgrade not yet supported on arch: " ++ show arch'
171+
hasgmp4 <- return False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")
172+
let suffixes
173+
| hasgmp4 = ["-static", "-gmp4", ""]
174+
| otherwise = ["-static", ""]
175+
return $ map (\suffix -> concat [os, "-", arch, suffix]) suffixes
176+
177+
binaryUpgrade
178+
:: (StackM env m, HasConfig env)
179+
=> BinaryOpts
180+
-> m ()
181+
binaryUpgrade (BinaryOpts mplatform force) = do
182+
platforms0 <- maybe preferredPlatforms (return . return) mplatform
183+
archiveInfo <- downloadStackReleaseInfo
184+
185+
let mdownloadVersion = getDownloadVersion archiveInfo
186+
isNewer <-
187+
case mdownloadVersion of
188+
Nothing -> do
189+
$logError "Unable to determine upstream version from Github metadata"
190+
unless force $
191+
$logError "Rerun with --force-download to force an upgrade"
192+
return False
193+
Just downloadVersion -> do
194+
$logInfo $ T.concat
195+
[ "Current Stack version: "
196+
, T.pack $ Data.Version.showVersion Paths.version
197+
, ", available download version: "
198+
, T.pack $ Data.Version.showVersion downloadVersion
199+
]
200+
return $ downloadVersion > Paths.version
201+
202+
toUpgrade <- case (force, isNewer) of
203+
(False, False) -> do
204+
$logInfo "Skipping binary upgrade, your version is already more recent"
205+
return False
206+
(True, False) -> do
207+
$logInfo "Forcing binary upgrade"
208+
return True
209+
(_, True) -> do
210+
$logInfo "Newer version detected, downloading"
211+
return True
212+
when toUpgrade $ do
213+
config <- askConfig
214+
let destFile = toFilePath (configLocalBin config </> $(mkRelFile "stack"))
215+
#if WINDOWS
216+
FP.<.> "exe"
217+
#endif
218+
219+
downloadStackExe platforms0 archiveInfo destFile
220+
221+
downloadStackExe
222+
:: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env)
223+
=> [String] -- ^ acceptable platforms
224+
-> StackReleaseInfo
225+
-> FilePath -- ^ destination
226+
-> m ()
227+
downloadStackExe platforms0 archiveInfo destFile = do
228+
archiveURL <-
229+
let loop [] = error $ "Unable to find binary Stack archive for platforms: " ++ unwords platforms0
230+
loop (p':ps) = do
231+
let p = T.pack p'
232+
$logInfo $ "Querying for archive location for platform: " <> p
233+
case findArchive archiveInfo p of
234+
Just x -> return x
235+
Nothing -> loop ps
236+
in loop platforms0
237+
238+
$logInfo $ "Downloading from: " <> archiveURL
239+
240+
liftIO $ do
241+
case () of
242+
()
243+
| ".tar.gz" `T.isSuffixOf` archiveURL -> handleTarball archiveURL
244+
| ".zip" `T.isSuffixOf` archiveURL -> error "FIXME: Handle zip files"
245+
| otherwise -> error $ "Unknown archive format for Stack archive: " ++ T.unpack archiveURL
246+
247+
$logInfo "Download complete, testing executable"
248+
249+
liftIO $ do
250+
absTmpFile <- IO.canonicalizePath tmpFile
251+
252+
#if !WINDOWS
253+
setFileMode absTmpFile 0o755
254+
#endif
255+
256+
-- Sanity check!
257+
ec <- rawSystem absTmpFile ["--version"]
258+
259+
unless (ec == ExitSuccess)
260+
$ error $ "Non-success exit code from running newly downloaded executable"
261+
262+
IO.renameFile tmpFile destFile
263+
264+
$logInfo $ T.pack $ "New stack executable available at " ++ destFile
265+
where
266+
tmpFile = destFile FP.<.> "tmp"
267+
268+
findArchive (StackReleaseInfo val) pattern = do
269+
Object top <- return val
270+
Array assets <- HashMap.lookup "assets" top
271+
getFirst $ fold $ fmap (First . findMatch pattern') assets
272+
where
273+
pattern' = mconcat ["-", pattern, "."]
274+
275+
findMatch pattern'' (Object o) = do
276+
String name <- HashMap.lookup "name" o
277+
guard $ not $ ".asc" `T.isSuffixOf` name
278+
guard $ pattern'' `T.isInfixOf` name
279+
String url <- HashMap.lookup "browser_download_url" o
280+
Just url
281+
findMatch _ _ = Nothing
282+
283+
handleTarball :: T.Text -> IO ()
284+
handleTarball url = do
285+
req <- fmap setUserAgent $ parseUrlThrow $ T.unpack url
286+
withResponse req $ \res -> do
287+
entries <- fmap (Tar.read . L.fromChunks)
288+
$ lazyConsume
289+
$ getResponseBody res .| ungzip
290+
let loop Tar.Done = error $ concat
291+
[ "Stack executable "
292+
, show exeName
293+
, " not found in archive from "
294+
, T.unpack url
295+
]
296+
loop (Tar.Fail e) = throwM e
297+
loop (Tar.Next e es)
298+
| Tar.entryPath e == exeName =
299+
case Tar.entryContent e of
300+
Tar.NormalFile lbs _ -> L.writeFile tmpFile lbs
301+
_ -> error $ concat
302+
[ "Invalid file type for tar entry named "
303+
, exeName
304+
, " downloaded from "
305+
, T.unpack url
306+
]
307+
| otherwise = loop es
308+
loop entries
309+
where
310+
-- The takeBaseName drops the .gz, dropExtension drops the .tar
311+
exeName = FP.dropExtension (FP.takeBaseName (T.unpack url)) FP.</> "stack"
312+
313+
sourceUpgrade
314+
:: (StackM env m, HasConfig env)
315+
=> ConfigMonoid
316+
-> Maybe AbstractResolver
317+
-> Maybe String
318+
-> SourceOpts
319+
-> m ()
320+
sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) =
42321
withSystemTempDir "stack-upgrade" $ \tmp -> do
43322
menv <- getMinimalEnvOverride
44323
mdir <- case gitRepo of

‎src/main/Main.hs‎

Lines changed: 5 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -283,16 +283,9 @@ commandLineHandler progName isInterpreter = complicatedOptions
283283
updateCmd
284284
(pure ())
285285
addCommand' "upgrade"
286-
"Upgrade to the latest stack (experimental)"
286+
"Upgrade to the latest stack"
287287
upgradeCmd
288-
((,) <$> switch
289-
( long "git"
290-
<> help "Clone from Git instead of downloading from Hackage (more dangerous)" )
291-
<*> strOption
292-
( long "git-repo"
293-
<> help "Clone from specified git repository"
294-
<> value "https://github.com/commercialhaskell/stack"
295-
<> showDefault ))
288+
upgradeOpts
296289
addCommand'
297290
"upload"
298291
"Upload a package to Hackage"
@@ -638,16 +631,16 @@ updateCmd :: () -> GlobalOpts -> IO ()
638631
updateCmd () go = withConfigAndLock go $
639632
getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices
640633

641-
upgradeCmd :: (Bool, String) -> GlobalOpts -> IO ()
642-
upgradeCmd (fromGit, repo) go = withGlobalConfigAndLock go $
634+
upgradeCmd :: UpgradeOpts -> GlobalOpts -> IO ()
635+
upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $
643636
upgrade (globalConfigMonoid go)
644-
(if fromGit then Just repo else Nothing)
645637
(globalResolver go)
646638
#ifdef USE_GIT_INFO
647639
(find (/= "UNKNOWN") [$gitHash])
648640
#else
649641
Nothing
650642
#endif
643+
upgradeOpts'
651644

652645
-- | Upload to Hackage
653646
uploadCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO ()

0 commit comments

Comments
 (0)