{-# 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 )