Detect system with libtinfo6 and download alternate GHC bindist (commercialhaskell#2302)

borsboom · borsboom · commit 05ba87e4eb00 · 2016-08-22T13:47:31.000-07:00
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -29,6 +29,8 @@ Other enhancements:
 * Support for absolute file path in `url` field of `setup-info` or `--ghc-bindist`
 * `stack setup` no longer unpacks to the system temp dir on posix systems.
   [#996](https://github.com/commercialhaskell/stack/issues/996)
+* Detects system with libtinfo6 and can download alternate GHC bindists
+  [#2302](https://github.com/commercialhaskell/stack/issues/2302).
 
 Bug fixes:
 
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -29,7 +29,6 @@ module Stack.Config
   ,packagesParser
   ,resolvePackageEntry
   ,getImplicitGlobalProjectDir
-  ,getIsGMP4
   ,getSnapshots
   ,makeConcreteResolver
   ,checkOwnership
@@ -61,8 +60,7 @@ import qualified Data.Map as Map
 import           Data.Maybe
 import           Data.Monoid.Extra
 import qualified Data.Text as T
-import           Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)
-import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import qualified Data.Yaml.Extra as Yaml
 import           Distribution.System (OS (..), Platform (..), buildPlatform)
 import qualified Distribution.Text
@@ -76,7 +74,6 @@ import           Path.Extra (toFilePathNoTrailingSep)
 import           Path.Find (findInParents)
 import           Path.IO
 import qualified Paths_stack as Meta
-import           Safe (headMay)
 import           Stack.BuildPlan
 import           Stack.Config.Build
 import           Stack.Config.Docker
@@ -324,35 +321,6 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject C
 
      return Config {..}
 
--- | Get the default 'GHCVariant'.  On older Linux systems with libgmp4, returns 'GHCGMP4'.
-getDefaultGHCVariant
-    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
-    => EnvOverride -> Platform -> m GHCVariant
-getDefaultGHCVariant menv (Platform _ Linux) = do
-    $logDebug "Checking whether stack was built with libgmp4"
-    isGMP4 <- getIsGMP4 menv
-    if isGMP4
-        then $logDebug "Stack was built with libgmp4, so the default ghc-variant will be gmp4"
-        else $logDebug "Stack was not built with libgmp4"
-    return (if isGMP4 then GHCGMP4 else GHCStandard)
-getDefaultGHCVariant _ _ = return GHCStandard
-
--- Determine whether 'stack' is linked with libgmp4 (libgmp.so.3)
-getIsGMP4
-    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
-    => EnvOverride -> m Bool
-getIsGMP4 menv = do
-    executablePath <- liftIO getExecutablePath
-    elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]
-    return $
-        case elddOut of
-            Left _ -> False
-            Right lddOut -> hasLineWithFirstWord "libgmp.so.3" lddOut
-  where
-    hasLineWithFirstWord w =
-        elem (Just w) .
-        map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode
-
 -- | Get the directory on Windows where we should install extra programs. For
 -- more information, see discussion at:
 -- https://github.com/fpco/minghc/issues/43#issuecomment-99737383
@@ -380,14 +348,10 @@ instance HasGHCVariant MiniConfig where
 
 -- | Load the 'MiniConfig'.
 loadMiniConfig
-    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
+    :: (MonadIO m)
     => Manager -> Config -> m MiniConfig
 loadMiniConfig manager config = do
-    menv <- liftIO $ configEnvOverride config minimalEnvSettings
-    ghcVariant <-
-        case configGHCVariant0 config of
-            Just ghcVariant -> return ghcVariant
-            Nothing -> getDefaultGHCVariant menv (configPlatform config)
+    let ghcVariant = fromMaybe GHCStandard (configGHCVariant0 config)
     return (MiniConfig manager ghcVariant config)
 
 -- Load the configuration, using environment variables, and defaults as
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -58,7 +58,7 @@ import qualified    Data.Text.Encoding.Error as T
 import              Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
 import              Data.Typeable (Typeable)
 import qualified    Data.Yaml as Yaml
-import              Distribution.System (OS, Arch (..), Platform (..))
+import              Distribution.System (OS (Linux), Arch (..), Platform (..))
 import qualified    Distribution.System as Cabal
 import              Distribution.Text (simpleParse)
 import              Lens.Micro (set)
@@ -70,7 +70,7 @@ import              Path.Extra (toFilePathNoTrailingSep)
 import              Path.IO hiding (findExecutable)
 import qualified    Paths_stack as Meta
 import              Prelude hiding (concat, elem, any) -- Fix AMP warning
-import              Safe (readMay)
+import              Safe (headMay, readMay)
 import              Stack.Build (build)
 import              Stack.Config (resolvePackageEntry, loadConfig)
 import              Stack.Constants (distRelativeDir, stackProgName)
@@ -215,7 +215,7 @@ setupEnv mResolveMissingGHC = do
             , soptsGHCBindistURL = Nothing
             }
 
-    mghcBin <- ensureCompiler sopts
+    (mghcBin, compilerBuild) <- ensureCompiler sopts
 
     -- Modify the initial environment to include the GHC path, if a local GHC
     -- is being used
@@ -237,6 +237,7 @@ setupEnv mResolveMissingGHC = do
             { envConfigBuildConfig = bconfig
             , envConfigCabalVersion = cabalVer
             , envConfigCompilerVersion = compilerVer
+            , envConfigCompilerBuild = compilerBuild
             , envConfigPackages = Map.fromList $ concat packages
             }
 
@@ -315,6 +316,7 @@ setupEnv mResolveMissingGHC = do
             }
         , envConfigCabalVersion = cabalVer
         , envConfigCompilerVersion = compilerVer
+        , envConfigCompilerBuild = compilerBuild
         , envConfigPackages = envConfigPackages envConfig0
         }
 
@@ -332,7 +334,7 @@ addIncludeLib (ExtraDirs _bins includes libs) config = config
 -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary
 ensureCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)
                => SetupOpts
-               -> m (Maybe ExtraDirs)
+               -> m (Maybe ExtraDirs, CompilerBuild)
 ensureCompiler sopts = do
     let wc = whichCompiler (soptsWantedCompiler sopts)
     when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do
@@ -363,7 +365,7 @@ ensureCompiler sopts = do
 
         -- If we need to install a GHC or MSYS, try to do so
         -- Return the additional directory paths of GHC & MSYS.
-    mtools <- if needLocal
+    (mtools, compilerBuild) <- if needLocal
         then do
             getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager)
 
@@ -373,17 +375,20 @@ ensureCompiler sopts = do
             -- Install GHC
             ghcVariant <- asks getGHCVariant
             config <- asks getConfig
-            ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)
-            let installedCompiler =
+            (installedCompiler, compilerBuild) <-
                     case wc of
-                        Ghc -> getInstalledTool installed ghcPkgName (isWanted . GhcVersion)
-                        Ghcjs -> getInstalledGhcjs installed isWanted
+                        Ghc -> do
+                            ghcBuild <- getGhcBuild menv0
+                            ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)
+                            return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild)
+                        Ghcjs -> return (getInstalledGhcjs installed isWanted, CompilerBuildStandard)
             compilerTool <- case installedCompiler of
                 Just tool -> return tool
                 Nothing
                     | soptsInstallIfMissing sopts -> do
                         si <- getSetupInfo'
                         downloadAndInstallCompiler
+                            compilerBuild
                             si
                             (soptsWantedCompiler sopts)
                             (soptsCompilerCheck sopts)
@@ -393,6 +398,7 @@ ensureCompiler sopts = do
                             msystem
                             (soptsWantedCompiler sopts, expectedArch)
                             ghcVariant
+                            compilerBuild
                             (soptsCompilerCheck sopts)
                             (soptsStackYaml sopts)
                             (fromMaybe
@@ -421,8 +427,8 @@ ensureCompiler sopts = do
                                 return Nothing
                 _ -> return Nothing
 
-            return $ Just (compilerTool, mmsys2Tool)
-        else return Nothing
+            return (Just (compilerTool, mmsys2Tool), compilerBuild)
+        else return (Nothing, CompilerBuildStandard)
 
     mpaths <- case mtools of
         Nothing -> return Nothing
@@ -452,9 +458,56 @@ ensureCompiler sopts = do
 
     when (soptsSanityCheck sopts) $ sanityCheck menv wc
 
-    return mpaths
+    return (mpaths, compilerBuild)
+
+-- | Determine which GHC build to use dependong on which shared libraries are available
+-- on the system.
+getGhcBuild
+    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m, HasPlatform env, MonadReader env m)
+    => EnvOverride -> m CompilerBuild
+getGhcBuild menv = do
+
+    -- TODO: a more reliable, flexible, and data driven approach would be to actually download small
+    -- "test" executables (from setup-info) that link to the same gmp/tinfo versions
+    -- that GHC does (i.e. built in same environment as the GHC bindist). The algorithm would go
+    -- something like this:
+    --
+    -- check for previous 'uname -a' plus compiler version/variant in cache
+    -- if cached, then use that as suffix
+    -- otherwise:
+    --     download setup-info
+    --     go through all with right prefix for os/version/variant
+    --     first try "standard" (no extra suffix), then the rest
+    --         download "compatibility check" exe if not already downloaded
+    --         try running it
+    --         if successful, then choose that
+    --             cache compiler suffix with the uname -a and ldconfig -p output hash plus compiler version
 
--- Ensure Docker container-compatible 'stack' executable is downloaded
+    platform <- asks getPlatform
+    case platform of
+        Platform _ Linux -> do
+            eldconfigOut <- tryProcessStdout Nothing menv "ldconfig" ["-p"]
+            let efirstWords = fmap (mapMaybe (headMay . T.words) .
+                    T.lines . T.decodeUtf8With T.lenientDecode) eldconfigOut
+            case efirstWords of
+                Right firstWords
+                    | "libtinfo.so.6" `elem` firstWords
+                      && not ("libtinfo.so.5" `elem` firstWords) -> do
+                        $logDebug "Found libtinfo.so.6; using tinfo6 GHC build"
+                        return (CompilerBuildSpecialized "tinfo6")
+                    | "libgmp.so.3" `elem` firstWords
+                      && not ("libgmp.so.10" `elem` firstWords) -> do
+                        $logDebug "Found libgmp.so.3; using gmp4 GHC build"
+                        return (CompilerBuildSpecialized "gmp4")
+                    | otherwise -> do
+                        $logDebug "Did not find libtinfo.so.6 or libgmp.so.3; using standard GHC build"
+                        return CompilerBuildStandard
+                Left _ -> do
+                    $logDebug "ldconfig -p failed; falling back to using standard GHC build"
+                    return CompilerBuildStandard
+        _ -> return CompilerBuildStandard
+
+-- | Ensure Docker container-compatible 'stack' executable is downloaded
 ensureDockerStackExe
     :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
     => Platform -> m (Path Abs File)
@@ -669,12 +722,13 @@ downloadAndInstallTool programsDir si downloadInfo tool installer = do
     return tool
 
 downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
-                           => SetupInfo
+                           => CompilerBuild
+                           -> SetupInfo
                            -> CompilerVersion
                            -> VersionCheck
                            -> Maybe String
                            -> m Tool
-downloadAndInstallCompiler si wanted@GhcVersion{} versionCheck mbindistURL = do
+downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindistURL = do
     ghcVariant <- asks getGHCVariant
     (selectedVersion, downloadInfo) <- case mbindistURL of
         Just bindistURL -> do
@@ -687,7 +741,7 @@ downloadAndInstallCompiler si wanted@GhcVersion{} versionCheck mbindistURL = do
                 _ ->
                     throwM WantedMustBeGHC
         _ -> do
-            ghcKey <- getGhcKey
+            ghcKey <- getGhcKey ghcBuild
             case Map.lookup ghcKey $ siGHCs si of
                 Nothing -> throwM $ UnknownOSKey ghcKey
                 Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs_
@@ -701,16 +755,19 @@ downloadAndInstallCompiler si wanted@GhcVersion{} versionCheck mbindistURL = do
         (case ghcVariant of
             GHCStandard -> ""
             v -> " (" <> T.pack (ghcVariantName v) <> ")") <>
+        (case ghcBuild of
+            CompilerBuildStandard -> ""
+            b -> " (" <> T.pack (compilerBuildName b) <> ")") <>
         " to an isolated location."
     $logInfo "This will not interfere with any system-level installation."
-    ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)
+    ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)
     let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion
     downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer
-downloadAndInstallCompiler si wanted versionCheck _mbindistUrl = do
+downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = do
     config <- asks getConfig
     ghcVariant <- asks getGHCVariant
-    case ghcVariant of
-        GHCStandard -> return ()
+    case (ghcVariant, compilerBuild) of
+        (GHCStandard, CompilerBuildStandard) -> return ()
         _ -> throwM GHCJSRequiresStandardVariant
     (selectedVersion, downloadInfo) <- case Map.lookup "source" $ siGHCJSs si of
         Nothing -> throwM $ UnknownOSKey "source"
@@ -738,12 +795,12 @@ getWantedCompilerInfo key versionCheck wanted toCV pairs_ =
         filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_)
 
 getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadCatch m)
-          => m Text
-getGhcKey = do
+          => CompilerBuild -> m Text
+getGhcKey ghcBuild = do
     ghcVariant <- asks getGHCVariant
     platform <- asks getPlatform
     osKey <- getOSKey platform
-    return $ osKey <> T.pack (ghcVariantSuffix ghcVariant)
+    return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild)
 
 getOSKey :: (MonadThrow m)
          => Platform -> m Text
diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs
@@ -82,7 +82,7 @@ setup
     -> m ()
 setup SetupCmdOpts{..} wantedCompiler compilerCheck mstack = do
     Config{..} <- asks getConfig
-    mpaths <- ensureCompiler SetupOpts
+    mpaths <- fst <$> ensureCompiler SetupOpts
         { soptsInstallIfMissing = True
         , soptsUseSystem = configSystemGHC && not scoForceReinstall
         , soptsWantedCompiler = wantedCompiler
diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs
@@ -290,7 +290,7 @@ setupCompiler compiler = do
           , "compiler available on your PATH." ]
 
     config <- asks getConfig
-    mpaths <- ensureCompiler SetupOpts
+    mpaths <- fst <$> ensureCompiler SetupOpts
         { soptsInstallIfMissing  = configInstallGHC config
         , soptsUseSystem         = configSystemGHC config
         , soptsWantedCompiler    = compiler
diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs
@@ -96,6 +96,7 @@ data StackBuildException
         (Maybe (CompilerVersion, Arch))
         (CompilerVersion, Arch)
         GHCVariant
+        CompilerBuild
         VersionCheck
         (Maybe (Path Abs File))
         Text -- recommended resolution
@@ -145,7 +146,7 @@ instance Show StackBuildException where
                ", the package id couldn't be found " <> "(via ghc-pkg describe " <>
                packageNameString name <> "). This shouldn't happen, " <>
                "please report as a bug")
-    show (CompilerVersionMismatch mactual (expected, earch) ghcVariant check mstack resolution) = concat
+    show (CompilerVersionMismatch mactual (expected, earch) ghcVariant ghcBuild check mstack resolution) = concat
                 [ case mactual of
                     Nothing -> "No compiler found, expected "
                     Just (actual, arch) -> concat
@@ -164,6 +165,7 @@ instance Show StackBuildException where
                 , " ("
                 , C.display earch
                 , ghcVariantSuffix ghcVariant
+                , compilerBuildSuffix ghcBuild
                 , ") (based on "
                 , case mstack of
                     Nothing -> "command line arguments"
diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
