stack-2.7.3: src/Stack/Script.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Script
( scriptCmd
) where
import Stack.Prelude
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.Conduit.List as CL
import Data.List.Split (splitWhen)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Distribution.Compiler (CompilerFlavor (..))
import Distribution.ModuleName (ModuleName)
import qualified Distribution.PackageDescription as PD
import qualified Distribution.Types.CondTree as C
import Distribution.Types.PackageName (mkPackageName)
import Distribution.Types.VersionRange (withinRange)
import Distribution.System (Platform (..))
import qualified Pantry.SHA256 as SHA256
#if MIN_VERSION_path(0,7,0)
import Path hiding (replaceExtension)
#else
import Path
#endif
import Path.IO
import qualified Stack.Build
import Stack.Build.Installed
import Stack.Constants (osIsWindows)
import Stack.PackageDump
import Stack.Options.ScriptParser
import Stack.Runners
import Stack.Setup (withNewLocalBuildTargets)
import Stack.SourceMap (getCompilerInfo, immutableLocSha)
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.SourceMap
import System.FilePath (dropExtension, replaceExtension)
import qualified RIO.Directory as Dir
import RIO.Process
import qualified RIO.Text as T
data StackScriptException
= MutableDependenciesForScript [PackageName]
| AmbiguousModuleName ModuleName [PackageName]
deriving Typeable
instance Exception StackScriptException
instance Show StackScriptException where
show (MutableDependenciesForScript names) = unlines
$ "No mutable packages are allowed in the `script` command. Mutable packages found:"
: map (\name -> "- " ++ packageNameString name) names
show (AmbiguousModuleName mname pkgs) = unlines
$ ("Module " ++ moduleNameString mname ++ " appears in multiple packages: ")
: [unwords $ map packageNameString pkgs ]
-- | Run a Stack Script
scriptCmd :: ScriptOpts -> RIO Runner ()
scriptCmd opts = do
-- Some warnings in case the user somehow tries to set a
-- stack.yaml location. Note that in this functions we use
-- logError instead of logWarn because, when using the
-- interpreter mode, only error messages are shown. See:
-- https://github.com/commercialhaskell/stack/issues/3007
view (globalOptsL.to globalStackYaml) >>= \case
SYLOverride fp -> logError $
"Ignoring override stack.yaml file for script command: " <>
fromString (toFilePath fp)
SYLGlobalProject -> logError "Ignoring SYLGlobalProject for script command"
SYLDefault -> return ()
SYLNoProject _ -> assert False (return ())
file <- resolveFile' $ soFile opts
let scriptDir = parent file
modifyGO go = go
{ globalConfigMonoid = (globalConfigMonoid go)
{ configMonoidInstallGHC = FirstTrue $ Just True
}
, globalStackYaml = SYLNoProject $ soScriptExtraDeps opts
}
case soShouldRun opts of
YesRun -> pure ()
NoRun -> do
unless (null $ soArgs opts) $ throwString "--no-run incompatible with arguments"
case soCompile opts of
SEInterpret -> throwString "--no-run requires either --compile or --optimize"
SECompile -> pure ()
SEOptimize -> pure ()
-- Optimization: if we're compiling, and the executable is newer
-- than the source file, run it immediately.
local (over globalOptsL modifyGO) $
case soCompile opts of
SEInterpret -> longWay file scriptDir
SECompile -> shortCut file scriptDir
SEOptimize -> shortCut file scriptDir
where
runCompiled file = do
let exeName = toExeName $ toFilePath file
case soShouldRun opts of
YesRun -> exec exeName (soArgs opts)
NoRun -> logInfo $ "Compilation finished, executable available at " <> fromString exeName
shortCut file scriptDir = handleIO (const $ longWay file scriptDir) $ do
srcMod <- getModificationTime file
exeMod <- Dir.getModificationTime $ toExeName $ toFilePath file
if srcMod < exeMod
then runCompiled file
else longWay file scriptDir
longWay file scriptDir =
withConfig YesReexec $
withDefaultEnvConfig $ do
config <- view configL
menv <- liftIO $ configProcessContextSettings config defaultEnvSettings
withProcessContext menv $ do
colorFlag <- appropriateGhcColorFlag
targetsSet <-
case soPackages opts of
[] -> do
-- Using the import parser
getPackagesFromImports (soFile opts)
packages -> do
let targets = concatMap wordsComma packages
targets' <- mapM parsePackageNameThrowing targets
return $ Set.fromList targets'
unless (Set.null targetsSet) $ do
-- Optimization: use the relatively cheap ghc-pkg list
-- --simple-output to check which packages are installed
-- already. If all needed packages are available, we can
-- skip the (rather expensive) build call below.
GhcPkgExe pkg <- view $ compilerPathsL.to cpPkg
bss <- sinkProcessStdout (toFilePath pkg)
["list", "--simple-output"] CL.consume -- FIXME use the package info from envConfigPackages, or is that crazy?
let installed = Set.fromList
$ map toPackageName
$ words
$ S8.unpack
$ S8.concat bss
if Set.null $ Set.difference (Set.map packageNameString targetsSet) installed
then logDebug "All packages already installed"
else do
logDebug "Missing packages, performing installation"
let targets = map (T.pack . packageNameString) $ Set.toList targetsSet
withNewLocalBuildTargets targets $ Stack.Build.build Nothing
let ghcArgs = concat
[ ["-i", "-i" ++ toFilePath scriptDir]
, ["-hide-all-packages"]
, maybeToList colorFlag
, map (\x -> "-package" ++ x)
$ Set.toList
$ Set.insert "base"
$ Set.map packageNameString targetsSet
, case soCompile opts of
SEInterpret -> []
SECompile -> []
SEOptimize -> ["-O2"]
, soGhcOptions opts
]
case soCompile opts of
SEInterpret -> do
interpret <- view $ compilerPathsL.to cpInterpreter
exec (toFilePath interpret)
(ghcArgs ++ toFilePath file : soArgs opts)
_ -> do
-- Use readProcessStdout_ so that (1) if GHC does send any output
-- to stdout, we capture it and stop it from being sent to our
-- stdout, which could break scripts, and (2) if there's an
-- exception, the standard output we did capture will be reported
-- to the user.
compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath
withWorkingDir (toFilePath scriptDir) $ proc
compilerExeName
(ghcArgs ++ [toFilePath file])
(void . readProcessStdout_)
runCompiled file
toPackageName = reverse . drop 1 . dropWhile (/= '-') . reverse
-- Like words, but splits on both commas and spaces
wordsComma = splitWhen (\c -> c == ' ' || c == ',')
toExeName fp =
if osIsWindows
then replaceExtension fp "exe"
else dropExtension fp
getPackagesFromImports
:: FilePath -- ^ script filename
-> RIO EnvConfig (Set PackageName)
getPackagesFromImports scriptFP = do
(pns, mns) <- liftIO $ parseImports <$> S8.readFile scriptFP
if Set.null mns
then return pns
else Set.union pns <$> getPackagesFromModuleNames mns
getPackagesFromModuleNames
:: Set ModuleName
-> RIO EnvConfig (Set PackageName)
getPackagesFromModuleNames mns = do
hash <- hashSnapshot
withSnapshotCache hash mapSnapshotPackageModules $ \getModulePackages -> do
pns <- forM (Set.toList mns) $ \mn -> do
pkgs <- getModulePackages mn
case pkgs of
[] -> return Set.empty
[pn] -> return $ Set.singleton pn
_ -> throwM $ AmbiguousModuleName mn pkgs
return $ Set.unions pns `Set.difference` blacklist
hashSnapshot :: RIO EnvConfig SnapshotCacheHash
hashSnapshot = do
sourceMap <- view $ envConfigL . to envConfigSourceMap
compilerInfo <- getCompilerInfo
let eitherPliHash (pn, dep) | PLImmutable pli <- dpLocation dep =
Right $ immutableLocSha pli
| otherwise =
Left pn
deps = Map.toList (smDeps sourceMap)
case partitionEithers (map eitherPliHash deps) of
([], pliHashes) -> do
let hashedContent = mconcat $ compilerInfo : pliHashes
pure $ SnapshotCacheHash (SHA256.hashLazyBytes $ toLazyByteString hashedContent)
(mutables, _) ->
throwM $ MutableDependenciesForScript mutables
mapSnapshotPackageModules :: RIO EnvConfig (Map PackageName (Set ModuleName))
mapSnapshotPackageModules = do
sourceMap <- view $ envConfigL . to envConfigSourceMap
installMap <- toInstallMap sourceMap
(_installedMap, globalDumpPkgs, snapshotDumpPkgs, _localDumpPkgs) <-
getInstalled installMap
let globals = dumpedPackageModules (smGlobal sourceMap) globalDumpPkgs
notHidden = Map.filter (not . dpHidden)
notHiddenDeps = notHidden $ smDeps sourceMap
installedDeps = dumpedPackageModules notHiddenDeps snapshotDumpPkgs
dumpPkgs = Set.fromList $ map (pkgName . dpPackageIdent) snapshotDumpPkgs
notInstalledDeps = Map.withoutKeys notHiddenDeps dumpPkgs
otherDeps <- for notInstalledDeps $ \dep -> do
gpd <- liftIO $ cpGPD (dpCommon dep)
Set.fromList <$> allExposedModules gpd
-- source map construction process should guarantee unique package names
-- in these maps
return $ globals <> installedDeps <> otherDeps
dumpedPackageModules :: Map PackageName a
-> [DumpPackage]
-> Map PackageName (Set ModuleName)
dumpedPackageModules pkgs dumpPkgs =
let pnames = Map.keysSet pkgs `Set.difference` blacklist
in Map.fromList
[ (pn, dpExposedModules)
| DumpPackage {..} <- dumpPkgs
, let PackageIdentifier pn _ = dpPackageIdent
, pn `Set.member` pnames
]
allExposedModules :: PD.GenericPackageDescription -> RIO EnvConfig [ModuleName]
allExposedModules gpd = do
Platform curArch curOs <- view platformL
curCompiler <- view actualCompilerVersionL
let checkCond (PD.OS os) = pure $ os == curOs
checkCond (PD.Arch arch) = pure $ arch == curArch
checkCond (PD.Impl compiler range) = case curCompiler of
ACGhc version ->
pure $ compiler == GHC && version `withinRange` range
ACGhcGit {} ->
pure $ compiler == GHC
-- currently we don't do flag checking here
checkCond other = Left other
mlibrary = snd . C.simplifyCondTree checkCond <$> PD.condLibrary gpd
pure $ case mlibrary of
Just lib -> PD.exposedModules lib ++
map PD.moduleReexportName (PD.reexportedModules lib)
Nothing -> mempty
-- | The Stackage project introduced the concept of hidden packages,
-- to deal with conflicting module names. However, this is a
-- relatively recent addition (at time of writing). See:
-- http://www.snoyman.com/blog/2017/01/conflicting-module-names. To
-- kick this thing off a bit better, we're included a blacklist of
-- packages that should never be auto-parsed in.
blacklist :: Set PackageName
blacklist = Set.fromList
[ mkPackageName "async-dejafu"
, mkPackageName "monads-tf"
, mkPackageName "crypto-api"
, mkPackageName "fay-base"
, mkPackageName "hashmap"
, mkPackageName "hxt-unicode"
, mkPackageName "hledger-web"
, mkPackageName "plot-gtk3"
, mkPackageName "gtk3"
, mkPackageName "regex-pcre-builtin"
, mkPackageName "regex-compat-tdfa"
, mkPackageName "log"
, mkPackageName "zip"
, mkPackageName "monad-extras"
, mkPackageName "control-monad-free"
, mkPackageName "prompt"
, mkPackageName "kawhi"
, mkPackageName "language-c"
, mkPackageName "gl"
, mkPackageName "svg-tree"
, mkPackageName "Glob"
, mkPackageName "nanospec"
, mkPackageName "HTF"
, mkPackageName "courier"
, mkPackageName "newtype-generics"
, mkPackageName "objective"
, mkPackageName "binary-ieee754"
, mkPackageName "rerebase"
, mkPackageName "cipher-aes"
, mkPackageName "cipher-blowfish"
, mkPackageName "cipher-camellia"
, mkPackageName "cipher-des"
, mkPackageName "cipher-rc4"
, mkPackageName "crypto-cipher-types"
, mkPackageName "crypto-numbers"
, mkPackageName "crypto-pubkey"
, mkPackageName "crypto-random"
, mkPackageName "cryptohash"
, mkPackageName "cryptohash-conduit"
, mkPackageName "cryptohash-md5"
, mkPackageName "cryptohash-sha1"
, mkPackageName "cryptohash-sha256"
]
parseImports :: ByteString -> (Set PackageName, Set ModuleName)
parseImports =
fold . mapMaybe (parseLine . stripCR') . S8.lines
where
-- Remove any carriage return character present at the end, to
-- support Windows-style line endings (CRLF)
stripCR' bs
| S8.null bs = bs
| S8.last bs == '\r' = S8.init bs
| otherwise = bs
stripPrefix x y
| x `S8.isPrefixOf` y = Just $ S8.drop (S8.length x) y
| otherwise = Nothing
parseLine bs0 = do
bs1 <- stripPrefix "import " bs0
let bs2 = S8.dropWhile (== ' ') bs1
bs3 = fromMaybe bs2 $ stripPrefix "qualified " bs2
case stripPrefix "\"" bs3 of
Just bs4 -> do
pn <- parsePackageNameThrowing $ S8.unpack $ S8.takeWhile (/= '"') bs4
Just (Set.singleton pn, Set.empty)
Nothing -> Just
( Set.empty
, Set.singleton
$ fromString
$ T.unpack
$ decodeUtf8With lenientDecode
$ S8.takeWhile (\c -> c /= ' ' && c /= '(') bs3
)