[broken] Attempt at moving github status updates to toplevel task

src/App.hs

@@ -14,11 +14,11 @@ import qualified System.FilePath as FilePath
 import System.FilePath ((</>))
 import System.Directory ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory, createDirectory )
 import qualified Data.ByteString.Char8 as B8
-import Control.Concurrent.Async (async, wait, cancel)
+import Control.Concurrent.Async (async, wait)
 import Control.Exception.Base (handle, throwIO)
 import System.IO.Error (isEOFError, IOError)
 import System.Posix.ByteString (stdOutput, fdToHandle, handleToFd)
-import System.Posix (Fd, dup, stdError)
+import System.Posix (Fd, dup, stdError, closeFd)
 import CliArgs
 import System.FileLock (withFileLock, SharedExclusive (Exclusive))
 import Data.FileEmbed (embedStringFile)
@@ -124,6 +124,8 @@ main = do
     responsePipeReadFd <- handleToFd responsePipeRead
     hSetBuffering responsePipeWrite LineBuffering
 
+    toplevelRequestPipe <- toplevelStream "_taskrunner_toplevel_request_pipe" requestPipeWriteFd
+
     parentEnv <- getEnvironment
 
     cwd <- getCurrentDirectory
@@ -144,7 +146,14 @@ main = do
 
     (subprocessStderrRead, subprocessStderr) <- createPipe
 
-    appState <- AppState settings jobName buildId isToplevel <$> newIORef Nothing <*> newIORef Nothing <*> newIORef False <*> pure toplevelStderr <*> pure subprocessStderr <*> pure logFile
+    appState <- AppState settings jobName buildId isToplevel
+      <$> newIORef Nothing
+      <*> newIORef Nothing
+      <*> newIORef False
+      <*> pure toplevelStderr
+      <*> pure toplevelRequestPipe
+      <*> pure subprocessStderr
+      <*> pure logFile
       <*> newIORef Nothing
 
     logDebug appState $ "Running command: " <> show (args.cmd : args.args)
@@ -197,21 +206,8 @@ main = do
               branch <- getCurrentBranch appState
               RemoteCache.setLatestBuildHash appState s (toText appState.jobName) branch h.hash
 
-    timeoutStream appState "stdout" $ wait stdoutHandler
-
-    -- We duplicate `subprocessStderr` before actually passing it to a
-    -- subprocess, so the original handle doesn't get closed by
-    -- `createProcess`. We must close it manually.
-    hClose appState.subprocessStderr
-    timeoutStream appState "stderr" $ wait stderrHandler
-    timeoutStream appState "stderr" $ wait subprocessStderrHandler
-
-    cancel cmdHandler
-
     let shouldReportStatus = (maybe False (.commitStatus) m_snapshotArgs && not skipped) || not isSuccess
 
-    hClose logFile
-
     logViewUrl <-
       if settings.uploadLogs then do
         s <- RemoteCache.getRemoteCacheSettingsFromEnv
@@ -220,13 +216,28 @@ main = do
         pure Nothing
 
     when (appState.settings.enableCommitStatus && shouldReportStatus) do
-      updateCommitStatus appState StatusRequest
+      requestUpdateCommitStatus appState StatusRequest
         { state = if isSuccess then "success" else "failure"
         , target_url = logViewUrl
         , description = Nothing
         , context = toText appState.jobName
         }
 
+    closeFd requestPipeWriteFd
+    hClose toplevelRequestPipe
+    timeoutStream appState "requestPipe" $ wait cmdHandler
+
+    timeoutStream appState "stdout" $ wait stdoutHandler
+
+    -- We duplicate `subprocessStderr` before actually passing it to a
+    -- subprocess, so the original handle doesn't get closed by
+    -- `createProcess`. We must close it manually.
+    hClose appState.subprocessStderr
+    timeoutStream appState "stderr" $ wait stderrHandler
+    timeoutStream appState "stderr" $ wait subprocessStderrHandler
+
+    hClose logFile
+
     exitWith exitCode
 
 saveHashInfo :: MonadIO m => AppState -> HashInfo -> m ()
@@ -371,6 +382,17 @@ commandHandler appState requestPipe responsePipe =
                       pure "exit 1")
                 pure $ Just $ encodeUtf8 response
 
+          ["updateCommitStatus", arg] -> do
+            logDebug appState $ "Running cmdpipe command: " <> show cmd
+            case Aeson.eitherDecode (encodeUtf8 arg) of
+              Left err -> do
+                logError appState $ "updateCommitStatus: invalid argument: " <> toText err
+              Right request ->
+                updateCommitStatus appState request
+
+            -- No reply, because this command can be issued concurrently
+            pure Nothing
+
           "debug":args -> do
             -- debug - debug message which should land in our log, but originates from a subtask
 
@@ -381,10 +403,16 @@ commandHandler appState requestPipe responsePipe =
           _ -> do
             logError appState $ "Unknown command in command pipe: " <> show cmd
             pure (Just "exit 1")
+
         whenJust m_result \result -> do
           logDebug appState $ "cmdpipe command result: " <> show result
           B8.hPutStrLn responsePipe result
 
+
+requestUpdateCommitStatus :: MonadIO m => AppState -> StatusRequest -> m ()
+requestUpdateCommitStatus appState request =
+  liftIO $ BL8.hPutStrLn appState.toplevelRequestPipe $ Aeson.encode ["updateCommitStatus" :: Text, decodeUtf8 (Aeson.encode request)]
+
 hasInputs :: SnapshotCliArgs -> Bool
 hasInputs args = not (null args.fileInputs) || not (null args.rawInputs)
 
@@ -458,7 +486,7 @@ snapshot appState args = do
     pure (True, Nothing)
 
   when (args.commitStatus && appState.settings.enableCommitStatus) do
-    updateCommitStatus appState StatusRequest
+    requestUpdateCommitStatus appState StatusRequest
       { state = if runTask then "pending" else "success"
       , target_url = Nothing
       , description = statusDescription

src/CommitStatus.hs

@@ -25,7 +25,7 @@ data StatusRequest = StatusRequest
   , description :: Maybe T.Text
   , context     :: T.Text
   } deriving (Show, Generic)
-  deriving anyclass (ToJSON)
+  deriving anyclass (ToJSON, FromJSON)
 
 -- Define the data type for the installation token response
 newtype InstallationTokenResponse = InstallationTokenResponse
@@ -89,6 +89,8 @@ initClient appState = do
     Right tokenResponse ->
       pure tokenResponse.token
 
+  -- NOTE: we're not refreshing the token. Github docs say it expires after 1 hour. Should be enough for our builds.
+  -- If we experience auth failures, implement token refresh.
 
   pure $ GithubClient { apiUrl = T.pack apiUrl
                       , appId = T.pack appId

src/Types.hs

@@ -47,6 +47,7 @@ data AppState = AppState
   , snapshotArgsRef :: IORef (Maybe SnapshotCliArgs)
   , skipped :: IORef Bool
   , toplevelStderr :: Handle
+  , toplevelRequestPipe :: Handle
   , subprocessStderr :: Handle
   , logOutput :: Handle
 

test/t/github-commit-status-failure-nested.out

@@ -4,6 +4,5 @@
 Requested access token for installation 123
 Updated commit status for fakeowner/fakerepo to {"context":"othertask","description":"not cached","state":"pending","target_url":null}
 Updated commit status for fakeowner/fakerepo to {"context":"othertask","description":null,"state":"failure","target_url":null}
-Requested access token for installation 123
 Updated commit status for fakeowner/fakerepo to {"context":"mytask","description":null,"state":"failure","target_url":null}
 -- exit code: 1

test/t/github-commit-status-nested.out

@@ -3,7 +3,6 @@
 -- github:
 Requested access token for installation 123
 Updated commit status for fakeowner/fakerepo to {"context":"mytask","description":"not cached","state":"pending","target_url":null}
-Requested access token for installation 123
 Updated commit status for fakeowner/fakerepo to {"context":"othertask","description":"not cached","state":"pending","target_url":null}
 Updated commit status for fakeowner/fakerepo to {"context":"othertask","description":null,"state":"success","target_url":null}
 Updated commit status for fakeowner/fakerepo to {"context":"mytask","description":null,"state":"success","target_url":null}

test/t/slow/stderr-timeout.txt

@@ -1,3 +1,7 @@
 # Similar to `stdout-timeout`, but only stderr is held up.
+
+# close request pipe to test only stdout/stderr handling
+exec {_taskrunner_toplevel_request_pipe}>&- {_taskrunner_request_pipe}>&-
+
 sleep 2 >/dev/null &
 disown

test/t/slow/stdout-timeout.txt

@@ -1,3 +1,7 @@
 # By spawning a background process, we add to refcount of the pipe.
+
+# close request pipe to test only stdout/stderr handling
+exec {_taskrunner_toplevel_request_pipe}>&- {_taskrunner_request_pipe}>&-
+
 sleep 2 &
 disown

test/t/slow/stream-timeout-other-fd.txt

@@ -1,5 +1,7 @@
 # This tests that we do allow background processes, provided they don't inherit stdin/out/err.
 # Essentally this checks whether we leak the stdout/err pipes in other file descrpitors.
 
+# FIXME: this can't work, because we _do_ leak the command pipe, and we wait for it to be closed
+
 sleep 2 </dev/null >/dev/null 2>/dev/null &
 disown