Skip to content

Commit

Permalink
Merge pull request #8648 from Ericson2314/autoconf-refactor
Browse files Browse the repository at this point in the history 
Tiny refactor of how Cabal handles configure scripts
  • Loading branch information
@Ericson2314
Ericson2314 authored Jan 3, 2023
2 parents 7babda9 + 10c3c45 commit eada3ba
Show file tree
Hide file tree
Showing 4 changed files with 211 additions and 164 deletions.
1 change: 1 addition & 0 deletions Cabal/Cabal.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -325,6 +325,7 @@ library
Distribution.Simple.GHC.EnvironmentParser
Distribution.Simple.GHC.Internal
Distribution.Simple.GHC.ImplInfo
Distribution.Simple.ConfigureScript
Distribution.ZinzaPrelude
Paths_Cabal

Expand Down
167 changes: 3 additions & 164 deletions Cabal/src/Distribution/Simple.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple
Expand Down Expand Up @@ -70,7 +69,6 @@ import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
import Distribution.Simple.PackageDescription
import Distribution.Simple.Program
import Distribution.Simple.Program.Db
import Distribution.Simple.PreProcess
import Distribution.Simple.Setup
import Distribution.Simple.Command
Expand All @@ -81,40 +79,29 @@ import Distribution.Simple.Register

import Distribution.Simple.Configure

import Distribution.Simple.ConfigureScript
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Bench
import Distribution.Simple.BuildPaths
import Distribution.Simple.Test
import Distribution.Simple.Install
import Distribution.Simple.Haddock
import Distribution.Simple.Utils
import Distribution.Utils.NubList
import Distribution.Verbosity
import Language.Haskell.Extension
import Distribution.Version
import Distribution.License
import Distribution.Pretty
import Distribution.System (buildPlatform)

-- Base
import System.Environment (getArgs, getProgName)
import System.Directory (removeFile, doesFileExist
,doesDirectoryExist, removeDirectoryRecursive)
import System.FilePath (searchPathSeparator, takeDirectory, (</>),
splitDirectories, dropDrive)
#ifdef mingw32_HOST_OS
import System.FilePath (normalise, splitDrive)
#endif
import System.FilePath (takeDirectory, (</>))
import Distribution.Compat.ResponseFile (expandResponse)
import Distribution.Compat.Directory (makeAbsolute)
import Distribution.Compat.Environment (getEnvironment)
import Distribution.Compat.GetShortPathName (getShortPathName)

import Data.List (unionBy, (\\))

import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map

-- | A simple implementation of @main@ for a Cabal setup script.
-- It reads the package description file using IO, and performs the
-- action specified on the command line.
Expand Down Expand Up @@ -619,7 +606,7 @@ autoconfUserHooks
confExists <- doesFileExist $ (baseDir lbi) </> "configure"
if confExists
then runConfigureScript verbosity
backwardsCompatHack flags lbi
flags lbi
else die' verbosity "configure script not found."

pbi <- getHookedBuildInfo verbosity (buildDir lbi)
Expand All @@ -628,8 +615,6 @@ autoconfUserHooks
lbi' = lbi { localPkgDescr = pkg_descr' }
postConf simpleUserHooks args flags pkg_descr' lbi'

backwardsCompatHack = False

readHookWithArgs :: (a -> Flag Verbosity)
-> (a -> Flag FilePath)
-> Args -> a
Expand All @@ -650,152 +635,6 @@ autoconfUserHooks
where
verbosity = fromFlag (get_verbosity flags)

runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo
-> IO ()
runConfigureScript verbosity backwardsCompatHack flags lbi = do
env <- getEnvironment
let programDb = withPrograms lbi
(ccProg, ccFlags) <- configureCCompiler verbosity programDb
ccProgShort <- getShortPathName ccProg
-- The C compiler's compilation and linker flags (e.g.
-- "C compiler flags" and "Gcc Linker flags" from GHC) have already
-- been merged into ccFlags, so we set both CFLAGS and LDFLAGS
-- to ccFlags
-- We don't try and tell configure which ld to use, as we don't have
-- a way to pass its flags too
configureFile <- makeAbsolute $
fromMaybe "." (takeDirectory <$> cabalFilePath lbi) </> "configure"
-- autoconf is fussy about filenames, and has a set of forbidden
-- characters that can't appear in the build directory, etc:
-- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions
--
-- This has caused hard-to-debug failures in the past (#5368), so we
-- detect some cases early and warn with a clear message. Windows's
-- use of backslashes is problematic here, so we'll switch to
-- slashes, but we do still want to fail on backslashes in POSIX
-- paths.
--
-- TODO: We don't check for colons, tildes or leading dashes. We
-- also should check the builddir's path, destdir, and all other
-- paths as well.
let configureFile' = toUnix configureFile
for_ badAutoconfCharacters $ \(c, cname) ->
when (c `elem` dropDrive configureFile') $
warn verbosity $ concat
[ "The path to the './configure' script, '", configureFile'
, "', contains the character '", [c], "' (", cname, ")."
, " This may cause the script to fail with an obscure error, or for"
, " building the package to fail later."
]

let -- Convert a flag name to name of environment variable to represent its
-- value for the configure script.
flagEnvVar :: FlagName -> String
flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag)
where f c
| isAlphaNum c = c
| otherwise = '_'
-- A map from such env vars to every flag name and value where the name
-- name maps to that that env var.
cabalFlagMap :: Map String (NonEmpty (FlagName, Bool))
cabalFlagMap = Map.fromListWith (<>)
[ (flagEnvVar flag, (flag, bool) :| [])
| (flag, bool) <- unFlagAssignment $ flagAssignment lbi
]
-- A map from env vars to flag names to the single flag we will go with
cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <-
flip Map.traverseWithKey cabalFlagMap $ \ envVar -> \case
-- No conflict: no problem
singleFlag :| [] -> pure singleFlag
-- Conflict: warn and discard all but first
collidingFlags@(firstFlag :| _ : _) -> do
let quote s = "'" ++ s ++ "'"
toName = quote . unFlagName . fst
renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags
warn verbosity $ unwords
[ "Flags", renderedList, "all map to the same environment variable"
, quote envVar, "causing a collision."
, "The value first flag", toName firstFlag, "will be used."
]
pure firstFlag

let cabalFlagEnv = [ (envVar, Just val)
| (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted
, let val = if bool then "1" else "0"
] ++
[ ( "CABAL_FLAGS"
, Just $ unwords [ showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi ]
)
]
let extraPath = fromNubList $ configProgramPathExtra flags
let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags))
$ lookup "CFLAGS" env
spSep = [searchPathSeparator]
pathEnv = maybe (intercalate spSep extraPath)
((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env
overEnv = ("CFLAGS", Just cflagsEnv) :
[("PATH", Just pathEnv) | not (null extraPath)] ++
cabalFlagEnv
hp = hostPlatform lbi
maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)]
args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag
shProg = simpleProgram "sh"
progDb = modifyProgramSearchPath
(\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
shConfiguredProg <- lookupProgram shProg
`fmap` configureProgram verbosity shProg progDb
case shConfiguredProg of
Just sh -> runProgramInvocation verbosity $
(programInvocation (sh {programOverrideEnv = overEnv}) args')
{ progInvokeCwd = Just (buildDir lbi) }
Nothing -> die' verbosity notFoundMsg
where
args = configureArgs backwardsCompatHack flags

notFoundMsg = "The package has a './configure' script. "
++ "If you are on Windows, This requires a "
++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "
++ "If you are not on Windows, ensure that an 'sh' command "
++ "is discoverable in your path."

-- | Convert Windows path to Unix ones
toUnix :: String -> String
#ifdef mingw32_HOST_OS
toUnix s = let tmp = normalise s
(l, rest) = case splitDrive tmp of
([], x) -> ("/" , x)
(h:_, x) -> ('/':h:"/", x)
parts = splitDirectories rest
in l ++ intercalate "/" parts
#else
toUnix s = intercalate "/" $ splitDirectories s
#endif

badAutoconfCharacters :: [(Char, String)]
badAutoconfCharacters =
[ (' ', "space")
, ('\t', "tab")
, ('\n', "newline")
, ('\0', "null")
, ('"', "double quote")
, ('#', "hash")
, ('$', "dollar sign")
, ('&', "ampersand")
, ('\'', "single quote")
, ('(', "left bracket")
, (')', "right bracket")
, ('*', "star")
, (';', "semicolon")
, ('<', "less-than sign")
, ('=', "equals sign")
, ('>', "greater-than sign")
, ('?', "question mark")
, ('[', "left square bracket")
, ('\\', "backslash")
, ('`', "backtick")
, ('|', "pipe")
]

getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
getHookedBuildInfo verbosity build_dir = do
maybe_infoFile <- findHookedPackageDesc verbosity build_dir
Expand Down
Loading

0 comments on commit eada3ba

Please sign in to comment.