Skip to content

Commit 1b8a03f

Browse files
snoybergborsboom
snoyberg
authored and
borsboom
committed
Use Stack exe download logic in Stack.Setup
1 parent eb1aba0 commit 1b8a03f

4 files changed

Lines changed: 219 additions & 261 deletions

File tree

‎src/Network/HTTP/Download.hs‎

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ module Network.HTTP.Download
1717
, httpJSON
1818
, parseRequest
1919
, parseUrlThrow
20+
, setGithubHeaders
2021
) where
2122

2223
import Control.Exception (Exception)
@@ -35,10 +36,10 @@ import Data.Text.Encoding.Error (lenientDecode)
3536
import Data.Text.Encoding (decodeUtf8With)
3637
import Data.Typeable (Typeable)
3738
import Network.HTTP.Client (Request, Response, path, checkResponse, parseUrlThrow, parseRequest)
38-
import Network.HTTP.Client.Conduit (
39-
requestHeaders)
39+
import Network.HTTP.Client.Conduit (requestHeaders)
4040
import Network.HTTP.Download.Verified
41-
import Network.HTTP.Simple (httpJSON, withResponse, getResponseBody, getResponseHeaders, getResponseStatusCode)
41+
import Network.HTTP.Simple (httpJSON, withResponse, getResponseBody, getResponseHeaders, getResponseStatusCode,
42+
setRequestHeader)
4243
import Path (Abs, File, Path, toFilePath)
4344
import System.Directory (createDirectoryIfMissing,
4445
removeFile)
@@ -113,3 +114,8 @@ redownload req0 dest = do
113114
data DownloadException = RedownloadFailed Request (Path Abs File) (Response ())
114115
deriving (Show, Typeable)
115116
instance Exception DownloadException
117+
118+
-- | Set the user-agent request header
119+
setGithubHeaders :: Request -> Request
120+
setGithubHeaders = setRequestHeader "User-Agent" ["The Haskell Stack"]
121+
. setRequestHeader "Accept" ["application/vnd.github.v3+json"]

‎src/Stack/New.hs‎

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -291,15 +291,15 @@ listTemplates = do
291291
-- | Get the set of templates.
292292
getTemplates :: StackM env m => m (Set TemplateName)
293293
getTemplates = do
294-
req <- liftM addHeaders (parseUrlThrow defaultTemplatesList)
294+
req <- liftM setGithubHeaders (parseUrlThrow defaultTemplatesList)
295295
resp <- catch (httpJSON req) (throwM . FailedToDownloadTemplates)
296296
case getResponseStatusCode resp of
297297
200 -> return $ unTemplateSet $ getResponseBody resp
298298
code -> throwM (BadTemplatesResponse code)
299299

300300
getTemplateInfo :: StackM env m => m (Map Text TemplateInfo)
301301
getTemplateInfo = do
302-
req <- liftM addHeaders (parseUrlThrow defaultTemplateInfoUrl)
302+
req <- liftM setGithubHeaders (parseUrlThrow defaultTemplateInfoUrl)
303303
resp <- catch (liftM Right $ httpLbs req) (\(ex :: HttpException) -> return . Left $ "Failed to download template info. The HTTP error was: " <> show ex)
304304
case resp >>= is200 of
305305
Left err -> do
@@ -317,10 +317,6 @@ getTemplateInfo = do
317317
200 -> return resp
318318
code -> Left $ "Unexpected status code while retrieving templates info: " <> show code
319319

320-
addHeaders :: Request -> Request
321-
addHeaders = setRequestHeader "User-Agent" ["The Haskell Stack"]
322-
. setRequestHeader "Accept" ["application/vnd.github.v3+json"]
323-
324320
newtype TemplateSet = TemplateSet { unTemplateSet :: Set TemplateName }
325321
instance FromJSON TemplateSet where
326322
parseJSON = fmap TemplateSet . parseTemplateSet

‎src/Stack/Setup.hs‎

Lines changed: 192 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -20,12 +20,21 @@ module Stack.Setup
2020
, SetupOpts (..)
2121
, defaultSetupInfoYaml
2222
, removeHaskellEnvVars
23+
24+
-- * Stack binary download
25+
, StackReleaseInfo
26+
, getDownloadVersion
27+
, stackVersion
28+
, preferredPlatforms
29+
, downloadStackReleaseInfo
30+
, downloadStackExe
2331
) where
2432

33+
import qualified Codec.Archive.Tar as Tar
2534
import Control.Applicative
2635
import Control.Concurrent.Async.Lifted (Concurrently(..))
2736
import Control.Exception.Safe (catchIO, tryAny)
28-
import Control.Monad (liftM, when, join, void, unless)
37+
import Control.Monad (liftM, when, join, void, unless, guard)
2938
import Control.Monad.Catch
3039
import Control.Monad.IO.Class (MonadIO, liftIO)
3140
import Control.Monad.Logger
@@ -38,11 +47,14 @@ import qualified Data.ByteString as S
3847
import qualified Data.ByteString.Char8 as S8
3948
import qualified Data.ByteString.Lazy as LBS
4049
import Data.Char (isSpace)
41-
import Data.Conduit (Conduit, (=$), await, yield, awaitForever)
50+
import Data.Conduit (Conduit, (=$), await, yield, awaitForever, (.|))
51+
import Data.Conduit.Lazy (lazyConsume)
4252
import Data.Conduit.Lift (evalStateC)
4353
import qualified Data.Conduit.List as CL
54+
import Data.Conduit.Zlib (ungzip)
4455
import Data.Either
4556
import Data.Foldable hiding (concatMap, or, maximum)
57+
import qualified Data.HashMap.Strict as HashMap
4658
import Data.IORef
4759
import Data.IORef.RunOnce (runOnce)
4860
import Data.List hiding (concat, elem, maximumBy, any)
@@ -65,9 +77,8 @@ import Distribution.System (OS (Linux), Arch (..), Platform (..))
6577
import qualified Distribution.System as Cabal
6678
import Distribution.Text (simpleParse)
6779
import Lens.Micro (set)
68-
import Network.HTTP.Client (parseUrlThrow)
69-
import Network.HTTP.Simple (getResponseBody, httpLBS)
70-
import Network.HTTP.Download.Verified
80+
import Network.HTTP.Simple (getResponseBody, httpLBS, withResponse, getResponseStatusCode)
81+
import Network.HTTP.Download
7182
import Path
7283
import Path.Extra (toFilePathNoTrailingSep)
7384
import Path.IO hiding (findExecutable)
@@ -103,6 +114,10 @@ import System.Process.Read
103114
import System.Process.Run (runCmd, Cmd(..))
104115
import Text.Printf (printf)
105116

117+
#if !WINDOWS
118+
import System.Posix.Files (setFileMode)
119+
#endif
120+
106121
-- | Default location of the stack-setup.yaml file
107122
defaultSetupInfoYaml :: String
108123
defaultSetupInfoYaml =
@@ -186,10 +201,10 @@ instance Show SetupException where
186201
"stack does not yet support using --ghc-variant with GHCJS"
187202
show GHCJSNotBooted =
188203
"GHCJS does not yet have its boot packages installed. Use \"stack setup\" to attempt to run ghcjs-boot."
189-
show (DockerStackExeNotFound stackVersion osKey) = concat
204+
show (DockerStackExeNotFound stackVersion' osKey) = concat
190205
[ stackProgName
191206
, "-"
192-
, versionString stackVersion
207+
, versionString stackVersion'
193208
, " executable not found for "
194209
, T.unpack osKey
195210
, "\nUse the '"
@@ -593,42 +608,16 @@ ensureDockerStackExe containerPlatform = do
593608
config <- asks getConfig
594609
containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)
595610
let programsPath = configLocalProgramsBase config </> containerPlatformDir
596-
stackVersion = fromCabalVersion Meta.version
597611
tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)
598-
stackExePath <- (</> $(mkRelFile "stack")) <$> installDir programsPath tool
612+
stackExeDir <- installDir programsPath tool
613+
let stackExePath = stackExeDir </> $(mkRelFile "stack")
599614
stackExeExists <- doesFileExist stackExePath
600-
unless stackExeExists $
601-
do
602-
$logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"]
603-
si <- getSetupInfo defaultSetupInfoYaml
604-
osKey <- getOSKey containerPlatform
605-
info <-
606-
case Map.lookup osKey (siStack si) of
607-
Just versions ->
608-
case Map.lookup stackVersion versions of
609-
Just x -> return x
610-
Nothing ->
611-
case mapMaybe (matchMinor stackVersion) (Map.keys versions) of
612-
(v:_) ->
613-
case Map.lookup v versions of
614-
Just x -> return x
615-
Nothing -> throwM (DockerStackExeNotFound v osKey)
616-
[] -> throwM (DockerStackExeNotFound stackVersion osKey)
617-
Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)
618-
_ <-
619-
downloadAndInstallTool
620-
programsPath
621-
si
622-
info
623-
tool
624-
installDockerStackExe
625-
return ()
615+
unless stackExeExists $ do
616+
$logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"]
617+
sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackVersion))
618+
let platforms = preferredPlatforms (containerPlatform, PlatformVariantNone)
619+
downloadStackExe platforms sri stackExeDir (const $ return ())
626620
return stackExePath
627-
where
628-
matchMinor stackVersion v =
629-
if checkVersion MatchMinor stackVersion v
630-
then Just v
631-
else Nothing
632621

633622
-- | Install the newest version of Cabal globally
634623
upgradeCabal :: (StackM env m, HasConfig env, HasGHCVariant env)
@@ -1093,30 +1082,6 @@ installGHCJS si archiveFile archiveType _tempDir destDir = do
10931082
copyFile optionsFile dest
10941083
$logStickyDone "Installed GHCJS."
10951084

1096-
-- Install the downloaded stack binary distribution
1097-
installDockerStackExe
1098-
:: (StackM env m, HasConfig env)
1099-
=> SetupInfo
1100-
-> Path Abs File
1101-
-> ArchiveType
1102-
-> Path Abs Dir
1103-
-> Path Abs Dir
1104-
-> m ()
1105-
installDockerStackExe _ archiveFile _ tempDir destDir = do
1106-
(_,tarTool) <-
1107-
checkDependencies $
1108-
(,) <$> checkDependency "gzip" <*> checkDependency "tar"
1109-
menv <- getMinimalEnvOverride
1110-
readProcessNull
1111-
(Just tempDir)
1112-
menv
1113-
tarTool
1114-
["xf", toFilePath archiveFile, "--strip-components", "1"]
1115-
ensureDir destDir
1116-
renameFile
1117-
(tempDir </> $(mkRelFile stackProgName))
1118-
(destDir </> $(mkRelFile stackProgName))
1119-
11201085
ensureGhcjsBooted :: (StackM env m, HasConfig env)
11211086
=> EnvOverride -> CompilerVersion -> Bool -> m ()
11221087
ensureGhcjsBooted menv cv shouldBoot = do
@@ -1675,3 +1640,166 @@ getUtf8EnvVars menv compilerVer =
16751640
fallbackPrefixes = ["C.", "en_US.", "en_"]
16761641
-- Suffixes of UTF-8 locales (case-insensitive)
16771642
utf8Suffixes = [".UTF-8", ".utf8"]
1643+
1644+
-- Binary Stack upgrades
1645+
1646+
newtype StackReleaseInfo = StackReleaseInfo Value
1647+
1648+
downloadStackReleaseInfo :: MonadIO m
1649+
=> Maybe String -- Github org
1650+
-> Maybe String -- Github repo
1651+
-> Maybe String -- ^ optional version
1652+
-> m StackReleaseInfo
1653+
downloadStackReleaseInfo morg mrepo mver = liftIO $ do
1654+
let org = fromMaybe "commercialhaskell" morg
1655+
repo = fromMaybe "stack" mrepo
1656+
let url = concat
1657+
[ "https://api.github.com/repos/"
1658+
, org
1659+
, "/"
1660+
, repo
1661+
, "/releases/"
1662+
, case mver of
1663+
Nothing -> "latest"
1664+
Just ver -> "tags/v" ++ ver
1665+
]
1666+
req <- parseRequest url
1667+
res <- httpJSON $ setGithubHeaders req
1668+
let code = getResponseStatusCode res
1669+
if code >= 200 && code < 300
1670+
then return $ StackReleaseInfo $ getResponseBody res
1671+
else error $ "Could not get release information for Stack from: " ++ url
1672+
1673+
preferredPlatforms :: (MonadReader env m, HasPlatform env)
1674+
=> m [(Bool, String)]
1675+
preferredPlatforms = do
1676+
Platform arch' os' <- asks getPlatform
1677+
(isWindows, os) <-
1678+
case os' of
1679+
Cabal.Linux -> return (False, "linux")
1680+
Cabal.Windows -> return (True, "windows")
1681+
Cabal.OSX -> return (False, "osx")
1682+
Cabal.FreeBSD -> return (False, "freebsd")
1683+
_ -> error $ "Binary upgrade not yet supported on OS: " ++ show os'
1684+
arch <-
1685+
case arch' of
1686+
I386 -> return "i386"
1687+
X86_64 -> return "x86_64"
1688+
Arm -> return "arm"
1689+
_ -> error $ "Binary upgrade not yet supported on arch: " ++ show arch'
1690+
hasgmp4 <- return False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")
1691+
let suffixes
1692+
| hasgmp4 = ["-static", "-gmp4", ""]
1693+
| otherwise = ["-static", ""]
1694+
return $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes
1695+
1696+
downloadStackExe
1697+
:: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env)
1698+
=> [(Bool, String)] -- ^ acceptable platforms
1699+
-> StackReleaseInfo
1700+
-> Path Abs Dir -- ^ destination directory
1701+
-> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming
1702+
-> m ()
1703+
downloadStackExe platforms0 archiveInfo destDir testExe = do
1704+
(isWindows, archiveURL) <-
1705+
let loop [] = error $ "Unable to find binary Stack archive for platforms: "
1706+
++ unwords (map snd platforms0)
1707+
loop ((isWindows, p'):ps) = do
1708+
let p = T.pack p'
1709+
$logInfo $ "Querying for archive location for platform: " <> p
1710+
case findArchive archiveInfo p of
1711+
Just x -> return (isWindows, x)
1712+
Nothing -> loop ps
1713+
in loop platforms0
1714+
1715+
let (destFile, tmpFile)
1716+
| isWindows =
1717+
( destDir </> $(mkRelFile "stack.exe")
1718+
, destDir </> $(mkRelFile "stack.tmp.exe")
1719+
)
1720+
| otherwise =
1721+
( destDir </> $(mkRelFile "stack")
1722+
, destDir </> $(mkRelFile "stack.tmp")
1723+
)
1724+
1725+
$logInfo $ "Downloading from: " <> archiveURL
1726+
1727+
liftIO $ do
1728+
case () of
1729+
()
1730+
| ".tar.gz" `T.isSuffixOf` archiveURL -> handleTarball tmpFile isWindows archiveURL
1731+
| ".zip" `T.isSuffixOf` archiveURL -> error "FIXME: Handle zip files"
1732+
| otherwise -> error $ "Unknown archive format for Stack archive: " ++ T.unpack archiveURL
1733+
1734+
$logInfo "Download complete, testing executable"
1735+
1736+
liftIO $ do
1737+
#if !WINDOWS
1738+
setFileMode (toFilePath tmpFile) 0o755
1739+
#endif
1740+
1741+
testExe tmpFile
1742+
1743+
renameFile tmpFile destFile
1744+
1745+
$logInfo $ T.pack $ "New stack executable available at " ++ toFilePath destFile
1746+
where
1747+
1748+
findArchive (StackReleaseInfo val) pattern = do
1749+
Object top <- return val
1750+
Array assets <- HashMap.lookup "assets" top
1751+
getFirst $ fold $ fmap (First . findMatch pattern') assets
1752+
where
1753+
pattern' = mconcat ["-", pattern, "."]
1754+
1755+
findMatch pattern'' (Object o) = do
1756+
String name <- HashMap.lookup "name" o
1757+
guard $ not $ ".asc" `T.isSuffixOf` name
1758+
guard $ pattern'' `T.isInfixOf` name
1759+
String url <- HashMap.lookup "browser_download_url" o
1760+
Just url
1761+
findMatch _ _ = Nothing
1762+
1763+
handleTarball :: Path Abs File -> Bool -> T.Text -> IO ()
1764+
handleTarball tmpFile isWindows url = do
1765+
req <- fmap setGithubHeaders $ parseUrlThrow $ T.unpack url
1766+
withResponse req $ \res -> do
1767+
entries <- fmap (Tar.read . LBS.fromChunks)
1768+
$ lazyConsume
1769+
$ getResponseBody res .| ungzip
1770+
let loop Tar.Done = error $ concat
1771+
[ "Stack executable "
1772+
, show exeName
1773+
, " not found in archive from "
1774+
, T.unpack url
1775+
]
1776+
loop (Tar.Fail e) = throwM e
1777+
loop (Tar.Next e es)
1778+
| Tar.entryPath e == exeName =
1779+
case Tar.entryContent e of
1780+
Tar.NormalFile lbs _ -> do
1781+
ensureDir destDir
1782+
LBS.writeFile (toFilePath tmpFile) lbs
1783+
_ -> error $ concat
1784+
[ "Invalid file type for tar entry named "
1785+
, exeName
1786+
, " downloaded from "
1787+
, T.unpack url
1788+
]
1789+
| otherwise = loop es
1790+
loop entries
1791+
where
1792+
-- The takeBaseName drops the .gz, dropExtension drops the .tar
1793+
exeName =
1794+
let base = FP.dropExtension (FP.takeBaseName (T.unpack url)) FP.</> "stack"
1795+
in if isWindows then base FP.<.> "exe" else base
1796+
1797+
getDownloadVersion :: StackReleaseInfo -> Maybe Version
1798+
getDownloadVersion (StackReleaseInfo val) = do
1799+
Object o <- Just val
1800+
String rawName <- HashMap.lookup "name" o
1801+
-- drop the "v" at the beginning of the name
1802+
parseVersion $ T.drop 1 rawName
1803+
1804+
stackVersion :: Version
1805+
stackVersion = fromCabalVersion Meta.version

0 commit comments

Comments
 (0)