Support custom GHC installation hooks

ChangeLog.md

@@ -18,6 +18,7 @@ Other enhancements:
 * `stack upgrade` makes less assumptions about archive format. See
   [#5288](https://github.com/commercialhaskell/stack/issues/5288)
 * Add a `--no-run` flag to the `script` command when compiling.
+* Add GHC installation hooks
 
 Bug fixes:
 

doc/yaml_configuration.md

@@ -1200,3 +1200,62 @@ 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`. This is compatible with `install-ghc: false`,
+which allows you to ensure that only your hook will install a GHC version.
+
+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 = <ver>`
+
+For "git", additional variables are:
+
+* `HOOK_GHC_COMMIT = <commit>`
+* `HOOK_GHC_FLAVOR = <flavor>`
+
+For "ghcjs", additional variables are:
+
+* `HOOK_GHC_VERSION = <ver>`
+* `HOOK_GHCJS_VERSION = <ver>`
+
+Since 2.8.X

src/Stack/Setup.hs

@@ -46,7 +46,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 (..))
@@ -89,7 +91,7 @@ import              Stack.Types.Docker
 import              Stack.Types.SourceMap
 import              Stack.Types.Version
 import qualified    System.Directory as D
-import              System.Environment (getExecutablePath, lookupEnv)
+import              System.Environment (getExecutablePath, lookupEnv, getEnvironment)
 import              System.IO.Error (isPermissionError)
 import              System.FilePath (searchPathSeparator)
 import qualified    System.FilePath as FP
@@ -596,13 +598,16 @@ 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) $ executable <$> getPermissions hook
 
     Platform expectedArch _ <- view platformL
 
@@ -623,20 +628,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
+    curEnv <- Map.fromList . map (T.pack *** T.pack) <$> liftIO getEnvironment
+    let newEnv = Map.union (wantedCompilerToEnv wanted) curEnv
+    pCtx <- mkProcessContext newEnv
+    (exit, out) <- withProcessContext pCtx $ 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

src/Stack/Types/Config.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -127,6 +128,7 @@ module Stack.Types.Config
   ,shaPath
   ,shaPathForBytes
   ,workDirL
+  ,ghcInstallHook
   -- * Command-specific types
   -- ** Eval
   ,EvalOpts(..)
@@ -1302,6 +1304,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

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 = unless isWindows $ rawSystem "bash" ["run.sh"] >>= throwIO

test/integration/tests/ghc-install-hooks/files/.gitignore

@@ -0,0 +1 @@
+/fake-root/

test/integration/tests/ghc-install-hooks/files/foo.hs

@@ -0,0 +1 @@
+main = putStrLn "Looks like everything is working!"

test/integration/tests/ghc-install-hooks/files/run.sh

@@ -0,0 +1,15 @@
+#!/usr/bin/env bash
+
+set -exuo pipefail
+
+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