Cabal/src/Distribution/Simple/ConfigureScript.hs

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