Allow binary upgrades #1238

ChangeLog.md

@@ -21,6 +21,11 @@ Major changes:
   installation should now include a `stack setup` line or use the `--install-ghc`
   flag.
   [#2221](https://github.com/commercialhaskell/stack/issues/2221)
+* Stack is now capable of doing binary upgrades instead of always
+  recompiling a new version from source. In order to take advantage of
+  this, you should do a binary installation so that your platform is
+  properly configured, and from then on `stack upgrade` will default
+  to binary upgrades.
 
 Behavior changes:
 

src/Stack/Upgrade.hs

@@ -1,19 +1,38 @@
+{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TemplateHaskell       #-}
-module Stack.Upgrade (upgrade) where
+module Stack.Upgrade
+    ( upgrade
+    , UpgradeOpts
+    , upgradeOpts
+    ) where
 
-import           Control.Monad               (when)
+import           Control.Monad.Catch         (catch, throwM)
+import           Control.Exception.Enclosed  (catchAny)
+import           Control.Monad               (guard, join, unless, when)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
-import           Data.Foldable               (forM_)
+import           Control.Monad.Trans.Resource(runResourceT)
+import           Data.Aeson                  (Value (Array, Object, String))
+import           Data.Conduit                ((=$=))
+import           Data.Conduit.Binary         (sinkFile)
+import qualified Data.Conduit.Tar            as Tar
+import           Data.Conduit.Zlib           (ungzip)
+import           Data.Foldable               (fold, forM_)
+import qualified Data.HashMap.Strict         as HashMap
 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         (parseUrlThrow)
+import           Network.HTTP.Simple         (Request, httpJSON, httpSink,
+                                              setRequestHeader, getResponseBody)
+import           Options.Applicative
 import           Path
 import           Path.IO
 import qualified Paths_stack as Paths
@@ -29,16 +48,182 @@ import           Stack.Types.Config
 import           Stack.Types.Internal
 import           Stack.Types.Resolver
 import           Stack.Types.StackT
-import           System.Process              (readProcess)
+import qualified System.Directory            as IO
+import           System.Exit                 (ExitCode (ExitSuccess))
+import qualified System.IO                   as IO
+import qualified System.FilePath             as FP
+import           System.Process              (rawSystem, readProcess)
 import           System.Process.Run
 
+#if !WINDOWS
+import           System.Posix.Files (setFileMode)
+#endif
+
+upgradeOpts :: Maybe T.Text -- ^ default platform
+            -> Parser UpgradeOpts
+upgradeOpts mDefPlatform = UpgradeOpts
+    <$> (sourceOnly <|> optional binaryOpts)
+    <*> (binaryOnly <|> optional sourceOpts)
+  where
+    binaryOnly = flag' Nothing (long "binary-only" <> help "Do not use a source upgrade path")
+    sourceOnly = flag' Nothing (long "source-only" <> help "Do not use a binary upgrade path")
+
+    binaryOpts = BinaryOpts
+        <$> fmap T.pack (strOption
+              ( long "binary-platform"
+             <> help "Platform type for archive to download"
+             <> (maybe mempty (value . T.unpack) mDefPlatform)
+             <> showDefault))
+
+    sourceOpts = SourceOpts
+        <$> ((\fromGit repo -> if fromGit then Just repo else Nothing)
+                <$> switch
+                    ( long "git"
+                    <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )
+                <*> strOption
+                    ( long "git-repo"
+                    <> help "Clone from specified git repository"
+                    <> value "https://github.com/commercialhaskell/stack"
+                    <> showDefault ))
+
+data BinaryOpts = BinaryOpts
+    { _boPlatform :: !T.Text
+    }
+    deriving Show
+data SourceOpts = SourceOpts
+    { _soRepo :: !(Maybe String)
+    }
+    deriving Show
+
+data UpgradeOpts = UpgradeOpts
+    { _uoBinary :: !(Maybe BinaryOpts)
+    , _uoSource :: !(Maybe SourceOpts)
+    }
+    deriving Show
+
 upgrade :: (StackM env m, HasConfig env)
         => ConfigMonoid
-        -> Maybe String -- ^ git repository to use
         -> Maybe AbstractResolver
         -> Maybe String -- ^ git hash at time of building, if known
+        -> UpgradeOpts
         -> m ()
-upgrade gConfigMonoid gitRepo mresolver builtHash =
+upgrade gConfigMonoid mresolver builtHash uo@(UpgradeOpts mbo mso) =
+    case (mbo, mso) of
+        -- FIXME It would be far nicer to capture this case in the
+        -- options parser itself so we get better error messages, but
+        -- I can't think of a way to make it happen.
+        (Nothing, Nothing) -> error "You must allow either binary or source upgrade paths"
+        (Just bo, Nothing) -> binary bo
+        (Nothing, Just so) -> source so
+        (Just bo, Just so) -> binary bo `catchAny` \e -> do
+            $logWarn "Exception occured when trying to perform binary upgrade:"
+            $logWarn $ T.pack $ show e
+            $logWarn "Falling back to source upgrade"
+
+            source so
+  where
+    binary bo = binaryUpgrade bo
+    source so = sourceUpgrade gConfigMonoid mresolver builtHash so
+
+binaryUpgrade
+  :: (StackM env m, HasConfig env)
+  => BinaryOpts
+  -> m ()
+binaryUpgrade (BinaryOpts platform) = do
+    $logInfo $ "Querying for archive location for platform: " <> platform
+    archiveURL <- liftIO $ findArchive platform
+
+    $logInfo $ "Downloading from: " <> archiveURL
+
+    config <- askConfig
+    let destFile = toFilePath (configLocalBin config </> $(mkRelFile "stack"))
+#if WINDOWS
+                        FP.<.> "exe"
+#endif
+        tmpFile = destFile FP.<.> "tmp"
+
+    liftIO $ do
+      case () of
+        ()
+          | ".tar.gz" `T.isSuffixOf` archiveURL -> handleTarball archiveURL tmpFile
+          | ".zip" `T.isSuffixOf` archiveURL -> error "FIXME: Handle zip files"
+          | otherwise -> error $ "Unknown archive format for Stack archive: " ++ T.unpack archiveURL
+
+    $logInfo "Download complete, testing executable"
+
+    liftIO $ do
+      absTmpFile <- IO.canonicalizePath tmpFile
+
+#if !WINDOWS
+      setFileMode absTmpFile 0o755
+#endif
+
+      -- Sanity check!
+      ec <- rawSystem absTmpFile ["--version"]
+
+      unless (ec == ExitSuccess)
+              $ error $ "Non-success exit code from running newly downloaded executable"
+
+      IO.renameFile tmpFile destFile
+
+    $logInfo $ T.pack $ "New stack executable available at " ++ destFile
+  where
+    setUserAgent :: Request -> Request
+    setUserAgent = setRequestHeader "User-Agent" ["Haskell Stack Upgrade"]
+
+    findArchive :: T.Text -> IO T.Text
+    findArchive pattern = do
+        val <- getResponseBody <$> httpJSON req
+        let ret = do
+                Object top <- return val
+                Array assets <- HashMap.lookup "assets" top
+                getFirst $ fold $ fmap (First . findMatch pattern') assets
+        case ret of
+            Just url -> return url
+            Nothing -> error $ "Could not find Stack archive for platform: " ++ T.unpack pattern
+      where
+        -- FIXME make the Github repo configurable?
+        req = setUserAgent "https://api.github.com/repos/commercialhaskell/stack/releases/latest"
+
+        pattern' = mconcat ["-", pattern, "."]
+
+        findMatch pattern' (Object o) = do
+            String name <- HashMap.lookup "name" o
+            guard $ not $ ".asc" `T.isSuffixOf` name
+            guard $ pattern' `T.isInfixOf` name
+            String url <- HashMap.lookup "browser_download_url" o
+            Just url
+        findMatch _ _ = Nothing
+
+    handleTarball :: T.Text -> IO.FilePath -> IO ()
+    handleTarball url tmpFile = do
+        req <- fmap setUserAgent $ parseUrlThrow $ T.unpack url
+        runResourceT $ httpSink req $ \_ -> ungzip =$= Tar.untar =$= loop
+            `catch` \e ->
+                case e of
+                Tar.NoMoreHeaders -> error $ concat
+                    [ "Stack executable "
+                    , show exeName
+                    , " not found in archive from "
+                    , T.unpack url
+                    ]
+                _ -> throwM e
+      where
+        -- The takeBaseName drops the .gz, dropExtension drops the .tar
+        exeName = FP.dropExtension (FP.takeBaseName (T.unpack url)) FP.</> "stack"
+        loop = join $ Tar.withEntry $ \h ->
+            if Tar.headerFilePath h == exeName
+                then sinkFile tmpFile >> return (return ())
+                else return loop
+
+sourceUpgrade
+  :: (StackM env m, HasConfig env)
+  => ConfigMonoid
+  -> Maybe AbstractResolver
+  -> Maybe String
+  -> SourceOpts
+  -> m ()
+sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) =
   withSystemTempDir "stack-upgrade" $ \tmp -> do
     menv <- getMinimalEnvOverride
     mdir <- case gitRepo of

src/main/Main.hs

@@ -283,16 +283,9 @@ commandLineHandler progName isInterpreter = complicatedOptions
                     updateCmd
                     (pure ())
         addCommand' "upgrade"
-                    "Upgrade to the latest stack (experimental)"
+                    "Upgrade to the latest stack"
                     upgradeCmd
-                    ((,) <$> switch
-                              ( long "git"
-                             <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )
-                         <*> strOption
-                              ( long "git-repo"
-                             <> help "Clone from specified git repository"
-                             <> value "https://github.com/commercialhaskell/stack"
-                             <> showDefault ))
+                    (upgradeOpts Nothing) -- FIXME insert the default platform to use
         addCommand'
             "upload"
             "Upload a package to Hackage"
@@ -638,16 +631,16 @@ updateCmd :: () -> GlobalOpts -> IO ()
 updateCmd () go = withConfigAndLock go $
     getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices
 
-upgradeCmd :: (Bool, String) -> GlobalOpts -> IO ()
-upgradeCmd (fromGit, repo) go = withGlobalConfigAndLock go $
+upgradeCmd :: UpgradeOpts -> GlobalOpts -> IO ()
+upgradeCmd upgradeOpts go = withGlobalConfigAndLock go $
     upgrade (globalConfigMonoid go)
-            (if fromGit then Just repo else Nothing)
             (globalResolver go)
 #ifdef USE_GIT_INFO
             (find (/= "UNKNOWN") [$gitHash])
 #else
             Nothing
 #endif
+            upgradeOpts
 
 -- | Upload to Hackage
 uploadCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO ()

stack-7.8.yaml

@@ -76,6 +76,8 @@ extra-deps:
 - text-metrics-0.1.0
 - pid1-0.1.0.0
 - file-embed-0.0.10
+- tar-conduit-0.1.0
+# FIXME We'll need some newer deps for tar-conduit
 flags:
   time-locale-compat:
     old-locale: false

stack-8.0.yaml

@@ -1,4 +1,4 @@
-resolver: lts-7.0
+resolver: lts-7.8
 image:
   containers:
     - base: "fpco/stack-base" # see ./etc/docker/stack-base/Dockerfile
@@ -16,3 +16,4 @@ extra-deps:
 - pid1-0.1.0.0
 - store-0.3
 - store-core-0.3
+- tar-conduit-0.1.0

stack.cabal

@@ -243,6 +243,7 @@ library
                    , stm >= 2.4.4
                    , streaming-commons >= 0.1.10.0
                    , tar >= 0.5.0.3 && < 0.6
+                   , tar-conduit
                    , template-haskell >= 2.9.0.0 && < 2.12
                    , temporary >= 1.2.0.3
                    , text >= 1.2.0.4

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-6.14
+resolver: lts-6.23
 # docker:
 #   enable: true
 #   repo: fpco/stack-full
@@ -22,6 +22,7 @@ extra-deps:
 - optparse-applicative-0.13.0.0
 - text-metrics-0.1.0
 - pid1-0.1.0.0
+- tar-conduit-0.1.0
 flags:
   stack:
     hide-dependency-versions: true