Cabal/src/Distribution/Simple/ConfigureScript.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE LambdaCase #-}
   5 {-# LANGUAGE RankNTypes #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 -----------------------------------------------------------------------------
   8 {-# OPTIONS_GHC -fno-warn-deprecations #-}
   9
  10 -- |
  11 -- Module      :  Distribution.Simple.ConfigureScript
  12 -- Copyright   :  Isaac Jones 2003-2005
  13 -- License     :  BSD3
  14 --
  15 -- Maintainer  :  cabal-devel@haskell.org
  16 -- Portability :  portable
  17 module Distribution.Simple.ConfigureScript
  18   ( runConfigureScript
  19   ) where
  20
  21 import Distribution.Compat.Prelude
  22 import Prelude ()
  23
  24 -- local
  25 import Distribution.PackageDescription
  26 import Distribution.Pretty
  27 import Distribution.Simple.Configure (findDistPrefOrDefault)
  28 import Distribution.Simple.Errors
  29 import Distribution.Simple.LocalBuildInfo
  30 import Distribution.Simple.Program
  31 import Distribution.Simple.Program.Db
  32 import Distribution.Simple.Setup.Common
  33 import Distribution.Simple.Setup.Config
  34 import Distribution.Simple.Utils
  35 import Distribution.System (Platform, buildPlatform)
  36 import Distribution.Utils.NubList
  37 import Distribution.Utils.Path
  38
  39 -- Base
  40 import System.Directory (createDirectoryIfMissing, doesFileExist)
  41 import qualified System.FilePath as FilePath
  42 #ifdef mingw32_HOST_OS
  43 import System.FilePath    (normalise, splitDrive)
  44 #endif
  45 import Distribution.Compat.Directory (makeAbsolute)
  46 import Distribution.Compat.Environment (getEnvironment)
  47 import Distribution.Compat.GetShortPathName (getShortPathName)
  48
  49 import qualified Data.List.NonEmpty as NonEmpty
  50 import qualified Data.Map as Map
  51
  52 runConfigureScript
  53   :: ConfigFlags
  54   -> FlagAssignment
  55   -> ProgramDb
  56   -> Platform
  57   -- ^ host platform
  58   -> IO ()
  59 runConfigureScript cfg flags programDb hp = do
  60   let commonCfg = configCommonFlags cfg
  61       verbosity = fromFlag $ setupVerbosity commonCfg
  62   dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg
  63   let build_dir = dist_dir </> makeRelativePathEx "build"
  64       mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg
  65       configureScriptPath = packageRoot commonCfg </> "configure"
  66   confExists <- doesFileExist configureScriptPath
  67   unless confExists $
  68     dieWithException verbosity (ConfigureScriptNotFound configureScriptPath)
  69   configureFile <-
  70     makeAbsolute $ configureScriptPath
  71   env <- getEnvironment
  72   (ccProg, ccFlags) <- configureCCompiler verbosity programDb
  73   ccProgShort <- getShortPathName ccProg
  74   -- The C compiler's compilation and linker flags (e.g.
  75   -- "C compiler flags" and "Gcc Linker flags" from GHC) have already
  76   -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS
  77   -- to ccFlags
  78   -- We don't try and tell configure which ld to use, as we don't have
  79   -- a way to pass its flags too
  80
  81   let configureFile' = toUnix configureFile
  82   -- autoconf is fussy about filenames, and has a set of forbidden
  83   -- characters that can't appear in the build directory, etc:
  84   -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions
  85   --
  86   -- This has caused hard-to-debug failures in the past (#5368), so we
  87   -- detect some cases early and warn with a clear message. Windows's
  88   -- use of backslashes is problematic here, so we'll switch to
  89   -- slashes, but we do still want to fail on backslashes in POSIX
  90   -- paths.
  91   --
  92   -- TODO: We don't check for colons, tildes or leading dashes. We
  93   -- also should check the builddir's path, destdir, and all other
  94   -- paths as well.
  95   for_ badAutoconfCharacters $ \(c, cname) ->
  96     when (c `elem` FilePath.dropDrive configureFile') $
  97       warn verbosity $
  98         concat
  99           [ "The path to the './configure' script, '"
 100           , configureFile'
 101           , "', contains the character '"
 102           , [c]
 103           , "' ("
 104           , cname
 105           , ")."
 106           , " This may cause the script to fail with an obscure error, or for"
 107           , " building the package to fail later."
 108           ]
 109
 110   let
 111     -- Convert a flag name to name of environment variable to represent its
 112     -- value for the configure script.
 113     flagEnvVar :: FlagName -> String
 114     flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag)
 115       where
 116         f c
 117           | isAlphaNum c = c
 118           | otherwise = '_'
 119     -- A map from such env vars to every flag name and value where the name
 120     -- name maps to that that env var.
 121     cabalFlagMap :: Map String (NonEmpty (FlagName, Bool))
 122     cabalFlagMap =
 123       Map.fromListWith
 124         (<>)
 125         [ (flagEnvVar flag, (flag, bool) :| [])
 126         | (flag, bool) <- unFlagAssignment flags
 127         ]
 128   -- A map from env vars to flag names to the single flag we will go with
 129   cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <-
 130     flip Map.traverseWithKey cabalFlagMap $ \envVar -> \case
 131       -- No conflict: no problem
 132       singleFlag :| [] -> pure singleFlag
 133       -- Conflict: warn and discard all but first
 134       collidingFlags@(firstFlag :| _ : _) -> do
 135         let quote s = "'" ++ s ++ "'"
 136             toName = quote . unFlagName . fst
 137             renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags
 138         warn verbosity $
 139           unwords
 140             [ "Flags"
 141             , renderedList
 142             , "all map to the same environment variable"
 143             , quote envVar
 144             , "causing a collision."
 145             , "The value first flag"
 146             , toName firstFlag
 147             , "will be used."
 148             ]
 149         pure firstFlag
 150
 151   let cabalFlagEnv =
 152         [ (envVar, Just val)
 153         | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted
 154         , let val = if bool then "1" else "0"
 155         ]
 156           ++ [
 157                ( "CABAL_FLAGS"
 158                , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment flags]
 159                )
 160              ]
 161   let extraPath = fromNubList $ configProgramPathExtra cfg
 162   let cflagsEnv =
 163         maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $
 164           lookup "CFLAGS" env
 165       spSep = [FilePath.searchPathSeparator]
 166       pathEnv =
 167         maybe
 168           (intercalate spSep extraPath)
 169           ((intercalate spSep extraPath ++ spSep) ++)
 170           $ lookup "PATH" env
 171       overEnv =
 172         ("CFLAGS", Just cflagsEnv)
 173           : [("PATH", Just pathEnv) | not (null extraPath)]
 174           ++ cabalFlagEnv
 175       maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)]
 176       args' = configureFile' : args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag
 177       shProg = simpleProgram "sh"
 178   progDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb
 179   shConfiguredProg <-
 180     lookupProgram shProg
 181       `fmap` configureProgram verbosity shProg progDb
 182   case shConfiguredProg of
 183     Just sh -> do
 184       let build_in = interpretSymbolicPath mbWorkDir build_dir
 185       createDirectoryIfMissing True build_in
 186       runProgramInvocation verbosity $
 187         (programInvocation (sh{programOverrideEnv = overEnv}) args')
 188           { progInvokeCwd = Just build_in
 189           }
 190     Nothing -> dieWithException verbosity NotFoundMsg
 191   where
 192     args = configureArgs backwardsCompatHack cfg
 193     backwardsCompatHack = False
 194
 195 -- | Convert Windows path to Unix ones
 196 toUnix :: String -> String
 197 #ifdef mingw32_HOST_OS
 198 toUnix s = let tmp = normalise s
 199                (l, rest) = case splitDrive tmp of
 200                              ([],  x) -> ("/"      , x)
 201                              (h:_, x) -> ('/':h:"/", x)
 202                parts = FilePath.splitDirectories rest
 203            in  l ++ intercalate "/" parts
 204 #else
 205 toUnix s = intercalate "/" $ FilePath.splitDirectories s
 206 #endif
 207
 208 badAutoconfCharacters :: [(Char, String)]
 209 badAutoconfCharacters =
 210   [ (' ', "space")
 211   , ('\t', "tab")
 212   , ('\n', "newline")
 213   , ('\0', "null")
 214   , ('"', "double quote")
 215   , ('#', "hash")
 216   , ('$', "dollar sign")
 217   , ('&', "ampersand")
 218   , ('\'', "single quote")
 219   , ('(', "left bracket")
 220   , (')', "right bracket")
 221   , ('*', "star")
 222   , (';', "semicolon")
 223   , ('<', "less-than sign")
 224   , ('=', "equals sign")
 225   , ('>', "greater-than sign")
 226   , ('?', "question mark")
 227   , ('[', "left square bracket")
 228   , ('\\', "backslash")
 229   , ('`', "backtick")
 230   , ('|', "pipe")
 231   ]