Merge pull request #6597 from commercialhaskell/fix5925

Fix #5925 Add file-watch-hook for post-processing

Author: mpilgrem

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:
 

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)

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

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

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

src/Stack/FileWatch.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings   #-}
 
 module Stack.FileWatch
   ( WatchMode (WatchModePoll)
@@ -11,25 +12,34 @@ 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
                    )
 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

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

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

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"