From b721b81467e9553218bedfb269570fb315c2f5ce Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Wed, 22 May 2024 23:17:17 +0100 Subject: [PATCH] Fix #5925 Add file-watch-hook for post-processing --- ChangeLog.md | 3 + doc/maintainers/stack_errors.md | 3 +- doc/yaml_configuration.md | 46 ++++++++++++++ src/Stack/Build.hs | 11 +++- src/Stack/Config.hs | 20 +++++- src/Stack/FileWatch.hs | 98 ++++++++++++++++++++++------- src/Stack/Types/Config.hs | 3 + src/Stack/Types/Config/Exception.hs | 6 ++ src/Stack/Types/ConfigMonoid.hs | 7 +++ 9 files changed, 171 insertions(+), 26 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index e09c95828d..a6b6969bd2 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -68,6 +68,9 @@ Other enhancements: * Add the `ls globals` command to list all global packages for the version of GHC specified by the snapshot. * Add `stack -h` (equivalent to `stack --help`). +* In YAML configuration files, the `file-watch-hook` key is introduced to allow + `--file-watch` post-processing to be customised with a executable or `sh` + shell script. Bug fixes: diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md index 4273a2a279..1f6b757892 100644 --- a/doc/maintainers/stack_errors.md +++ b/doc/maintainers/stack_errors.md @@ -5,7 +5,7 @@ In connection with considering Stack's support of the [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks to take stock of the errors that Stack itself can raise, by reference to the -`master` branch of the Stack repository. Last updated: 2024-05-17. +`master` branch of the Stack repository. Last updated: 2024-06-03. * `Stack.main`: catches exceptions from action `commandLineHandler`. @@ -403,6 +403,7 @@ to take stock of the errors that Stack itself can raise, by reference to the [S-2040] | UnableToExtractArchive Text (Path Abs File) [S-1641] | BadStackVersionException VersionRange [S-8773] | NoSuchDirectory FilePath + [S-4335] | NoSuchFile FilePath [S-3938] | ParseGHCVariantException String [S-8530] | BadStackRoot (Path Abs Dir) [S-7613] | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 2656f28793..24ac329b16 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -1111,6 +1111,21 @@ Other paths added by Stack - things like the project's binary directory and the compiler's binary directory - will take precedence over those specified here (the automatic paths get prepended). +### file-watch-hook + +:octicons-tag-24: UNRELEASED + +Specifies the location of an executable or `sh` shell script to be run after +each attempted build with +[`build --file-watch`](build_command.md#-file-watch-flag). An absolute or +relative path can be specified. Changes to the configuration after the +initial `build --file-watch` command are ignored. + +If the project-level configuration is provided in the `global-project` directory +in the [Stack root](stack_root.md), a relative path is assumed to be relative to +the current directory. Otherwise, it is assumed to be relative to the directory +of the project-level configuration file. + ### ghc-build [:octicons-tag-24: 1.3.0](https://github.com/commercialhaskell/stack/releases/tag/v1.3.0) @@ -2138,3 +2153,34 @@ case $HOOK_GHC_TYPE in ;; esac ~~~ + +### `--file-watch` post-processing + +:octicons-tag-24: UNRELEASED + +On Unix-like operating systems and Windows, Stack's `build --file-watch` +post-processing can be fully customised by specifying an executable or a `sh` +shell script (a 'hook') using the [`file-watch-hook`](#file-watch-hook) +configuration option. On Unix-like operating systems, the script file must be +made executable. A script is run by the `sh` application (which is provided by +MSYS2 on Windows). + +The following environment variables are always available to the executable or script: + +* `HOOK_FW_RESULT` (Equal to `""` if the build did not fail. Equal to the result + of `displayException e`, if exception `e` thown during the build.) + +An example script is: + +~~~sh +#!/bin/sh + +set -eu + +if [ -z "$HOOK_FW_RESULT" ]; then + echo "Success! Waiting for next file change." +else + echo "Build failed with exception:" + echo $HOOK_FW_RESULT +fi +~~~ diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 9540d36e01..904b1f2fc6 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -112,15 +112,20 @@ buildCmd opts = do prettyThrowIO GHCProfOptionInvalid local (over globalOptsL modifyGO) $ case opts.fileWatch of - FileWatchPoll -> fileWatchPoll (inner . Just) - FileWatch -> fileWatch (inner . Just) + FileWatchPoll -> withFileWatchHook fileWatchPoll + FileWatch -> withFileWatchHook fileWatch NoFileWatch -> inner Nothing where + withFileWatchHook fileWatchAction = + -- This loads the full configuration in order to obtain the file-watch-hook + -- setting. That is likely not the most efficient approach. + withConfig YesReexec $ withEnvConfig NeedTargets opts $ + fileWatchAction (inner . Just) inner :: Maybe (Set (Path Abs File) -> IO ()) -> RIO Runner () inner setLocalFiles = withConfig YesReexec $ withEnvConfig NeedTargets opts $ - Stack.Build.build setLocalFiles + Stack.Build.build setLocalFiles -- Read the build command from the CLI and enable it to run modifyGO = case opts.command of diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 55e1662d9a..3181113c2b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -72,7 +72,7 @@ import Path.IO ( XdgDirectory (..), canonicalizePath, doesFileExist , ensureDir, forgivingAbsence, getAppUserDataDir , getCurrentDir, getXdgDir, resolveDir, resolveDir' - , resolveFile' + , resolveFile, resolveFile' ) import RIO.List ( unzip ) import RIO.Process @@ -381,6 +381,23 @@ configFromConfigMonoid -- resolveDirMaybe. `catchAny` const (throwIO (NoSuchDirectory userPath)) + fileWatchHook <- + case getFirst configMonoid.fileWatchHook of + Nothing -> pure Nothing + Just userPath -> + ( case mproject of + -- Not in a project + Nothing -> Just <$> resolveFile' userPath + -- Resolves to the project dir and appends the user path if it is + -- relative + Just (_, configYaml) -> + Just <$> resolveFile (parent configYaml) userPath + ) + -- TODO: Either catch specific exceptions or add a + -- parseRelAsAbsFileMaybe utility and use it along with + -- resolveFileMaybe. + `catchAny` + const (throwIO (NoSuchFile userPath)) jobs <- case getFirst configMonoid.jobs of Nothing -> liftIO getNumProcessors @@ -539,6 +556,7 @@ configFromConfigMonoid , compilerCheck , compilerRepository , localBin + , fileWatchHook , requireStackVersion , jobs , overrideGccPath diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs index 3ed8a601c1..9e97b74dcd 100644 --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} module Stack.FileWatch ( WatchMode (WatchModePoll) @@ -11,10 +12,19 @@ import Control.Concurrent.STM ( check ) import qualified Data.Map.Merge.Strict as Map import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import qualified Data.Text as T import GHC.IO.Exception ( IOErrorType (InvalidArgument), IOException (..) ) -import Path ( parent ) +import Path ( fileExtension, parent ) +import Path.IO ( doesFileExist, executable, getPermissions ) +import RIO.Process + ( EnvVars, HasProcessContext (..), proc, runProcess + , withModifyEnvVars + ) +import System.Permissions ( osIsWindows ) import Stack.Prelude +import Stack.Types.Config ( Config (..), HasConfig (..) ) +import Stack.Types.Runner ( HasRunner (..), Runner (..) ) import System.FSNotify ( WatchConfig, WatchMode (..), confWatchMode, defaultConfig , eventPath, watchDir, withManagerConf @@ -22,14 +32,14 @@ import System.FSNotify import System.IO ( getLine ) fileWatch :: - HasTerm env - => ((Set (Path Abs File) -> IO ()) -> RIO env ()) + (HasConfig env, HasTerm env) + => ((Set (Path Abs File) -> IO ()) -> RIO Runner ()) -> RIO env () fileWatch = fileWatchConf defaultConfig fileWatchPoll :: - HasTerm env - => ((Set (Path Abs File) -> IO ()) -> RIO env ()) + (HasConfig env, HasTerm env) + => ((Set (Path Abs File) -> IO ()) -> RIO Runner ()) -> RIO env () fileWatchPoll = fileWatchConf $ defaultConfig { confWatchMode = WatchModePoll 1000000 } @@ -39,11 +49,13 @@ fileWatchPoll = -- The action provided takes a callback that is used to set the files to be -- watched. When any of those files are changed, we rerun the action again. fileWatchConf :: - HasTerm env + (HasConfig env, HasTerm env) => WatchConfig - -> ((Set (Path Abs File) -> IO ()) -> RIO env ()) + -> ((Set (Path Abs File) -> IO ()) -> RIO Runner ()) -> RIO env () -fileWatchConf cfg inner = +fileWatchConf cfg inner = do + runner <- view runnerL + mHook <- view $ configL . to (.fileWatchHook) withRunInIO $ \run -> withManagerConf cfg $ \manager -> do allFiles <- newTVarIO Set.empty dirtyVar <- newTVarIO True @@ -134,7 +146,7 @@ fileWatchConf cfg inner = dirty <- readTVar dirtyVar check dirty - eres <- tryAny $ inner setWatched + eres <- tryAny $ runRIO runner (inner setWatched) -- Clear dirtiness flag after the build to avoid an infinite loop caused -- by the build itself triggering dirtiness. This could be viewed as a @@ -143,19 +155,63 @@ fileWatchConf cfg inner = -- https://github.com/commercialhaskell/stack/issues/822 atomically $ writeTVar dirtyVar False - case eres of - Left e -> - case fromException e of - Just ExitSuccess -> - prettyInfo $ style Good $ fromString $ displayException e - _ -> case fromException e :: Maybe PrettyException of - Just pe -> prettyError $ pretty pe - _ -> prettyInfo $ style Error $ fromString $ displayException e - _ -> prettyInfo $ - style Good (flow "Success! Waiting for next file change.") + let defaultAction = case eres of + Left e -> + case fromException e of + Just ExitSuccess -> + prettyInfo $ style Good $ fromString $ displayException e + _ -> case fromException e :: Maybe PrettyException of + Just pe -> prettyError $ pretty pe + _ -> prettyInfo $ style Error $ fromString $ displayException e + _ -> prettyInfo $ + style Good (flow "Success! Waiting for next file change.") + + case mHook of + Nothing -> defaultAction + Just hook -> do + hookIsExecutable <- handleIO (\_ -> pure False) $ if osIsWindows + then + -- can't really detect executable on windows, only file extension + doesFileExist hook + else executable <$> getPermissions hook + if hookIsExecutable + then runFileWatchHook eres hook + else do + prettyWarn $ + flow "File watch hook not executable. Falling back on default." + defaultAction prettyInfoL [ "Type" , style Shell "help" , flow "for the available commands. Press enter to force a rebuild." ] + +runFileWatchHook :: + (HasProcessContext env, HasTerm env) + => Either SomeException () + -> Path Abs File + -> RIO env () +runFileWatchHook buildResult hook = + withModifyEnvVars insertBuildResultInEnv $ do + let (cmd, args) = if osIsWindows && isShFile + then ("sh", [toFilePath hook]) + else (toFilePath hook, []) + menv <- view processContextL + exit <- withProcessContext menv $ proc cmd args runProcess + case exit of + ExitSuccess -> pure () + ExitFailure i -> do + prettyWarnL + [ flow "File watch hook exited with code:" + , style Error (fromString $ show i) <> "." + ] + pure () + where + insertBuildResultInEnv :: EnvVars -> EnvVars + insertBuildResultInEnv = Map.insert "HOOK_FW_RESULT" $ case buildResult of + Left e -> T.pack $ displayException e + Right _ -> "" + isShFile = case fileExtension hook of + Just ".sh" -> True + _ -> False diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 17e474450d..f3198e7c58 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -110,6 +110,9 @@ data Config = Config -- ^ Specifies the repository containing the compiler sources , localBin :: !(Path Abs Dir) -- ^ Directory we should install executables into + , fileWatchHook :: !(Maybe (Path Abs File)) + -- ^ Optional path of executable used to override --file-watch + -- post-processing. , requireStackVersion :: !VersionRange -- ^ Require a version of Stack within this range. , jobs :: !Int diff --git a/src/Stack/Types/Config/Exception.hs b/src/Stack/Types/Config/Exception.hs index 4e87b111d2..89669e2bca 100644 --- a/src/Stack/Types/Config/Exception.hs +++ b/src/Stack/Types/Config/Exception.hs @@ -33,6 +33,7 @@ data ConfigException | UnableToExtractArchive Text (Path Abs File) | BadStackVersionException VersionRange | NoSuchDirectory FilePath + | NoSuchFile FilePath | ParseGHCVariantException String | BadStackRoot (Path Abs Dir) | Won'tCreateStackRootInDirectoryOwnedByDifferentUser @@ -97,6 +98,11 @@ instance Exception ConfigException where , "No directory could be located matching the supplied path: " , dir ] + displayException (NoSuchFile file) = concat + [ "Error: [S-4335]\n" + , "No file could be located matching the supplied path: " + , file + ] displayException (ParseGHCVariantException v) = concat [ "Error: [S-3938]\n" , "Invalid ghc-variant value: " diff --git a/src/Stack/Types/ConfigMonoid.hs b/src/Stack/Types/ConfigMonoid.hs index 0e80edba47..5c954bed38 100644 --- a/src/Stack/Types/ConfigMonoid.hs +++ b/src/Stack/Types/ConfigMonoid.hs @@ -119,6 +119,8 @@ data ConfigMonoid = ConfigMonoid -- ^ See: 'configConcurrentTests' , localBinPath :: !(First FilePath) -- ^ Used to override the binary installation dir + , fileWatchHook :: !(First FilePath) + -- ^ Path to executable used to override --file-watch post-processing. , templateParameters :: !(Map Text Text) -- ^ Template parameters. , scmInit :: !(First SCM) @@ -265,6 +267,7 @@ parseConfigMonoidObject rootDir obj = do hpackForce <- FirstFalse <$> obj ..:? configMonoidHpackForceName concurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName localBinPath <- First <$> obj ..:? configMonoidLocalBinPathName + fileWatchHook <- First <$> obj ..:? configMonoidFileWatchHookName templates <- obj ..:? "templates" (scmInit, templateParameters) <- case templates of @@ -373,6 +376,7 @@ parseConfigMonoidObject rootDir obj = do , hpackForce , concurrentTests , localBinPath + , fileWatchHook , templateParameters , scmInit , ghcOptionsByName @@ -495,6 +499,9 @@ configMonoidConcurrentTestsName = "concurrent-tests" configMonoidLocalBinPathName :: Text configMonoidLocalBinPathName = "local-bin-path" +configMonoidFileWatchHookName :: Text +configMonoidFileWatchHookName = "file-watch-hook" + configMonoidScmInitName :: Text configMonoidScmInitName = "scm-init"