diff --git a/ChangeLog.md b/ChangeLog.md index 0634b0ba29..6b58e9e502 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -59,6 +59,8 @@ Other enhancements: * `stack upload` supports authentication with a Hackage API key (via `HACKAGE_KEY` environment variable). +* Add GHC installation hooks wrt [#5585](https://github.com/commercialhaskell/stack/pull/5585) + Bug fixes: * Ensure that `extra-path` works for case-insensitive `PATH`s on Windows. diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index c9fb821067..62d935abe1 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -1199,3 +1199,65 @@ This field is convenient in setups that restrict access to GitHub, for instance Since 2.5.0 + +## Hooks + +### GHC installation hooks (experimental) + +Stack's installation procedure can be fully customized by placing a shell script at +`~/.stack/hooks/ghc-install.sh` and making it executable. + +The script **must** return an exit code of `0` and the standard output **must** be the +absolute path to the ghc binary that was installed. Otherwise stack will ignore +the hook and possibly fall back to its own installation procedure. + +Hooks are not run when `system-ghc: true`. + +When `install-ghc: false`, hooks are still run, +which allows you to ensure that only your hook will install GHC and stack won't default +to its own installation logic, even when the hook fails. + +An example hook is: + +```sh +#!/bin/sh + +set -eu + +case $HOOK_GHC_TYPE in + bindist) + # install GHC here, not printing to stdout, e.g.: + # command install $HOOK_GHC_VERSION >/dev/null + ;; + git) + >&2 echo "Hook doesn't support installing from source" + exit 1 + ;; + *) + >&2 echo "Unsupported GHC installation type: $HOOK_GHC_TYPE" + exit 2 + ;; +esac + +echo "location/to/ghc/executable" +``` + +The following environment variables are always passed to the hook: + +* `HOOK_GHC_TYPE = "bindist" | "git" | "ghcjs"` + +For "bindist", additional variables are: + +* `HOOK_GHC_VERSION = ` + +For "git", additional variables are: + +* `HOOK_GHC_COMMIT = ` +* `HOOK_GHC_FLAVOR = ` + +For "ghcjs", additional variables are: + +* `HOOK_GHC_VERSION = ` +* `HOOK_GHCJS_VERSION = ` + +Since 2.8.X diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 62dcd3112e..50988d0283 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -52,7 +52,9 @@ import Data.List hiding (concat, elem, maximumBy, any) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Text.Encoding.Error as T import qualified Data.Yaml as Yaml import Distribution.System (OS, Arch (..), Platform (..)) @@ -445,21 +447,18 @@ ensureCompilerAndMsys => SetupOpts -> RIO env (CompilerPaths, ExtraDirs) ensureCompilerAndMsys sopts = do + getSetupInfo' <- memoizeRef getSetupInfo + mmsys2Tool <- ensureMsys sopts getSetupInfo' + msysPaths <- maybe (pure Nothing) (fmap Just . extraDirs) mmsys2Tool + actual <- either throwIO pure $ wantedToActual $ soptsWantedCompiler sopts didWarn <- warnUnsupportedCompiler $ getGhcVersion actual - getSetupInfo' <- memoizeRef getSetupInfo (cp, ghcPaths) <- ensureCompiler sopts getSetupInfo' warnUnsupportedCompilerCabal cp didWarn - mmsys2Tool <- ensureMsys sopts getSetupInfo' - paths <- - case mmsys2Tool of - Nothing -> pure ghcPaths - Just msys2Tool -> do - msys2Paths <- extraDirs msys2Tool - pure $ ghcPaths <> msys2Paths + let paths = maybe ghcPaths (ghcPaths <>) msysPaths pure (cp, paths) -- | See @@ -602,13 +601,18 @@ installGhcBindist sopts getSetupInfo' installed = do -- | Ensure compiler is installed, without worrying about msys ensureCompiler - :: forall env. (HasBuildConfig env, HasGHCVariant env) + :: forall env. (HasConfig env, HasBuildConfig env, HasGHCVariant env) => SetupOpts -> Memoized SetupInfo -> RIO env (CompilerPaths, ExtraDirs) ensureCompiler sopts getSetupInfo' = do let wanted = soptsWantedCompiler sopts wc <- either throwIO (pure . whichCompiler) $ wantedToActual wanted + + hook <- ghcInstallHook + hookIsExecutable <- handleIO (\_ -> pure False) $ if osIsWindows + then doesFileExist hook -- can't really detect executable on windows, only file extension + else executable <$> getPermissions hook Platform expectedArch _ <- view platformL @@ -629,20 +633,78 @@ ensureCompiler sopts getSetupInfo' = do Right cp -> pure $ Just cp mcp <- - if soptsUseSystem sopts - then do - logDebug "Getting system compiler version" - runConduit $ - sourceSystemCompilers wanted .| - concatMapMC checkCompiler .| - await - else return Nothing + if | soptsUseSystem sopts -> do + logDebug "Getting system compiler version" + runConduit $ + sourceSystemCompilers wanted .| + concatMapMC checkCompiler .| + await + | hookIsExecutable -> do + -- if the hook fails, we fall through to stacks sandboxed installation + hookGHC <- runGHCInstallHook sopts hook + maybe (pure Nothing) checkCompiler hookGHC + | otherwise -> return Nothing case mcp of Nothing -> ensureSandboxedCompiler sopts getSetupInfo' Just cp -> do let paths = ExtraDirs { edBins = [parent $ cpCompiler cp], edInclude = [], edLib = [] } pure (cp, paths) + +-- | Runs @STACK_ROOT\/hooks\/ghc-install.sh@. +-- +-- Reads and possibly validates the output of the process as the GHC +-- binary and returns it. +runGHCInstallHook + :: HasBuildConfig env + => SetupOpts + -> Path Abs File + -> RIO env (Maybe (Path Abs File)) +runGHCInstallHook sopts hook = do + logDebug "Getting hook installed compiler version" + let wanted = soptsWantedCompiler sopts + menv0 <- view processContextL + menv <- mkProcessContext (Map.union (wantedCompilerToEnv wanted) $ + removeHaskellEnvVars (view envVarsL menv0)) + (exit, out) <- withProcessContext menv $ proc "sh" [toFilePath hook] readProcessStdout + case exit of + ExitSuccess -> do + let ghcPath = stripNewline . TL.unpack . TL.decodeUtf8With T.lenientDecode $ out + case parseAbsFile ghcPath of + Just compiler -> do + when (soptsSanityCheck sopts) $ sanityCheck compiler + logDebug ("Using GHC compiler at: " <> fromString (toFilePath compiler)) + pure (Just compiler) + Nothing -> do + logWarn ("Path to GHC binary is not a valid path: " <> fromString ghcPath) + pure Nothing + ExitFailure i -> do + logWarn ("GHC install hook exited with code: " <> fromString (show i)) + pure Nothing + where + wantedCompilerToEnv :: WantedCompiler -> EnvVars + wantedCompilerToEnv (WCGhc ver) = + Map.fromList [("HOOK_GHC_TYPE", "bindist") + ,("HOOK_GHC_VERSION", T.pack (versionString ver)) + ] + wantedCompilerToEnv (WCGhcGit commit flavor) = + Map.fromList [("HOOK_GHC_TYPE", "git") + ,("HOOK_GHC_COMMIT", commit) + ,("HOOK_GHC_FLAVOR", flavor) + ,("HOOK_GHC_FLAVOUR", flavor) + ] + wantedCompilerToEnv (WCGhcjs ghcjs_ver ghc_ver) = + Map.fromList [("HOOK_GHC_TYPE", "ghcjs") + ,("HOOK_GHC_VERSION", T.pack (versionString ghc_ver)) + ,("HOOK_GHCJS_VERSION", T.pack (versionString ghcjs_ver)) + ] + newlines :: [Char] + newlines = ['\n', '\r'] + + stripNewline :: String -> String + stripNewline str = filter (flip notElem newlines) str + + ensureSandboxedCompiler :: HasBuildConfig env => SetupOpts diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index fa5ecc0a59..9bb0f1361f 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -11,6 +11,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -128,6 +129,7 @@ module Stack.Types.Config ,shaPath ,shaPathForBytes ,workDirL + ,ghcInstallHook -- * Command-related types ,AddCommand -- ** Eval @@ -1320,6 +1322,18 @@ askLatestSnapshotUrl = view $ configL.to configLatestSnapshot workDirL :: HasConfig env => Lens' env (Path Rel Dir) workDirL = configL.lens configWorkDir (\x y -> x { configWorkDir = y }) +-- | @STACK_ROOT\/hooks\/@ +hooksDir :: HasConfig env => RIO env (Path Abs Dir) +hooksDir = do + sr <- view $ configL.to configStackRoot + pure (sr [reldir|hooks|]) + +-- | @STACK_ROOT\/hooks\/ghc-install.sh@ +ghcInstallHook :: HasConfig env => RIO env (Path Abs File) +ghcInstallHook = do + hd <- hooksDir + pure (hd [relfile|ghc-install.sh|]) + -- | Per-project work dir getProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir) getProjectWorkDir = do diff --git a/test/integration/tests/ghc-install-hooks/Main.hs b/test/integration/tests/ghc-install-hooks/Main.hs new file mode 100644 index 0000000000..491eb11761 --- /dev/null +++ b/test/integration/tests/ghc-install-hooks/Main.hs @@ -0,0 +1,7 @@ +import System.Process (rawSystem) +import Control.Exception (throwIO) +import StackTest +import Control.Monad (unless) + +main :: IO () +main = rawSystem "sh" ["run.sh"] >>= throwIO diff --git a/test/integration/tests/ghc-install-hooks/files/.gitignore b/test/integration/tests/ghc-install-hooks/files/.gitignore new file mode 100644 index 0000000000..17906d378e --- /dev/null +++ b/test/integration/tests/ghc-install-hooks/files/.gitignore @@ -0,0 +1 @@ +/fake-root/ diff --git a/test/integration/tests/ghc-install-hooks/files/foo.hs b/test/integration/tests/ghc-install-hooks/files/foo.hs new file mode 100644 index 0000000000..623c600c18 --- /dev/null +++ b/test/integration/tests/ghc-install-hooks/files/foo.hs @@ -0,0 +1 @@ +main = putStrLn "Looks like everything is working!" diff --git a/test/integration/tests/ghc-install-hooks/files/run.sh b/test/integration/tests/ghc-install-hooks/files/run.sh new file mode 100755 index 0000000000..0d4196566e --- /dev/null +++ b/test/integration/tests/ghc-install-hooks/files/run.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env sh + +set -exu + +stack_bin=$("$STACK_EXE" path --resolver ghc-8.6.5 --compiler-bin) + +export STACK_ROOT=$(pwd)/fake-root + +mkdir -p "${STACK_ROOT}"/hooks + +echo "echo '${stack_bin}/ghc'" > "${STACK_ROOT}"/hooks/ghc-install.sh +chmod +x "${STACK_ROOT}"/hooks/ghc-install.sh + +"$STACK_EXE" --no-install-ghc --resolver ghc-8.6.5 ghc -- --info +"$STACK_EXE" --no-install-ghc --resolver ghc-8.6.5 runghc foo.hs