Merge pull request #5585 from hasufell/jospald/GHC-install-hooks

Support custom GHC installation hooks

Author: mpilgrem

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.

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 = <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

@@ -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 <https://github.com/commercialhaskell/stack/issues/4246>
@@ -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

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

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

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 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