From 93becd5020383a4f915c624fae039a8b29c2b591 Mon Sep 17 00:00:00 2001 From: Brian McKenna Date: Thu, 26 Feb 2026 06:56:36 +1100 Subject: [PATCH] Switch to using a reaction for in-progress tracking --- src/Bot/Claude.hs | 15 ++++++-- src/Bot/Event.hs | 27 ++++++++++----- src/Bot/Gitea.hs | 69 +++++++++++++++++++++++++++++++++++++ src/Bot/Review.hs | 88 +++++++++++++++++++++++++++-------------------- 4 files changed, 150 insertions(+), 49 deletions(-) diff --git a/src/Bot/Claude.hs b/src/Bot/Claude.hs index 208afc8..bf6a078 100644 --- a/src/Bot/Claude.hs +++ b/src/Bot/Claude.hs @@ -106,11 +106,17 @@ parseClaudeJsonOutput raw = case fromJSON resultVal of Success v -> Right v Error e -> Left $ "Failed to parse structured_output: " <> e - Nothing -> Left "Missing 'structured_output' field in Claude output" + Nothing -> + -- Check if Claude reported an error (e.g. max turns reached) + case parseMaybe extractSubtype val of + Just subtype -> Left $ "Claude failed with: " <> T.unpack subtype + Nothing -> Left "Missing 'structured_output' field in Claude output" Left err -> Left $ "Failed to parse Claude JSON: " <> err where extractField :: Value -> Parser Value extractField = withObject "envelope" (.: "structured_output") + extractSubtype :: Value -> Parser Text + extractSubtype = withObject "envelope" (.: "subtype") -- Parse Claude's JSON envelope for freeform text: { "result": "..." } parseClaudeTextOutput :: String -> Either String Text @@ -120,11 +126,16 @@ parseClaudeTextOutput raw = case parseMaybe extractField val of Just (String resultText) -> Right resultText Just _ -> Left "Expected string 'result' in Claude output" - Nothing -> Left "Missing 'result' field in Claude output" + Nothing -> + case parseMaybe extractSubtype val of + Just subtype -> Left $ "Claude failed with: " <> T.unpack subtype + Nothing -> Left "Missing 'result' field in Claude output" Left err -> Left $ "Failed to parse Claude JSON: " <> err where extractField :: Value -> Parser Value extractField = withObject "envelope" (.: "result") + extractSubtype :: Value -> Parser Text + extractSubtype = withObject "envelope" (.: "subtype") strToLBS :: String -> BL.ByteString strToLBS = BL.fromStrict . TE.encodeUtf8 . T.pack diff --git a/src/Bot/Event.hs b/src/Bot/Event.hs index f915403..3f62fbb 100644 --- a/src/Bot/Event.hs +++ b/src/Bot/Event.hs @@ -34,6 +34,7 @@ data IssueCommentEvent = IssueCommentEvent { iceAction :: Text , iceIsPull :: Bool , iceNumber :: Int + , iceCommentId :: Int , iceCommentBody :: Text , iceSender :: Text } @@ -42,6 +43,7 @@ data PRReviewEvent = PRReviewEvent { prreAction :: Text , prreNumber :: Int , prreTitle :: Text + , prreReviewId :: Int , prreReviewBody :: Text , prreSender :: Text } @@ -50,6 +52,7 @@ data PRReviewCommentEvent = PRReviewCommentEvent { prrceAction :: Text , prrceNumber :: Int , prrceTitle :: Text + , prrceCommentId :: Int , prrceCommentBody :: Text , prrceSender :: Text } @@ -86,13 +89,15 @@ instance FromJSON IssueCommentEvent where pure $ case pr of Just (Object _) -> True _ -> False - comment <- o .: "comment" - body <- comment .: "body" - sender <- parseSender o + comment <- o .: "comment" + commentId <- comment .: "id" + body <- comment .: "body" + sender <- parseSender o pure IssueCommentEvent { iceAction = action , iceIsPull = isPull , iceNumber = number + , iceCommentId = commentId , iceCommentBody = body , iceSender = sender } @@ -103,13 +108,15 @@ instance FromJSON PRReviewEvent where pr <- o .: "pull_request" number <- pr .: "number" title <- pr .: "title" - review <- o .: "review" - body <- review .:? "body" .!= "" - sender <- parseSender o + review <- o .: "review" + reviewId <- review .: "id" + body <- review .:? "body" .!= "" + sender <- parseSender o pure PRReviewEvent { prreAction = action , prreNumber = number , prreTitle = title + , prreReviewId = reviewId , prreReviewBody = body , prreSender = sender } @@ -120,13 +127,15 @@ instance FromJSON PRReviewCommentEvent where pr <- o .: "pull_request" number <- pr .: "number" title <- pr .: "title" - comment <- o .: "comment" - body <- comment .: "body" - sender <- parseSender o + comment <- o .: "comment" + commentId <- comment .: "id" + body <- comment .: "body" + sender <- parseSender o pure PRReviewCommentEvent { prrceAction = action , prrceNumber = number , prrceTitle = title + , prrceCommentId = commentId , prrceCommentBody = body , prrceSender = sender } diff --git a/src/Bot/Gitea.hs b/src/Bot/Gitea.hs index 6adc24c..34e856b 100644 --- a/src/Bot/Gitea.hs +++ b/src/Bot/Gitea.hs @@ -8,7 +8,12 @@ module Bot.Gitea , getPrReviews , createComment , updateComment + , deleteComment , postReview + , addCommentReaction + , removeCommentReaction + , addIssueReaction + , removeIssueReaction , PrInfo (..) , GiteaComment (..) , GiteaReview (..) @@ -137,6 +142,44 @@ apiPostRaw gc path body = do resp <- httpLbs req (gcManager gc) pure (statusCode $ responseStatus resp, responseBody resp) +apiDeleteWithBody :: GiteaClient -> Text -> Value -> IO () +apiDeleteWithBody gc path body = do + let url = T.unpack (gcBaseUrl gc <> path) + initReq <- parseRequest url + let req = initReq + { method = "DELETE" + , requestHeaders = + [ ("Authorization", "token " <> TE.encodeUtf8 (gcToken gc)) + , ("Accept", "application/json") + , ("Content-Type", "application/json") + ] + , requestBody = RequestBodyLBS (encode body) + } + resp <- httpLbs req (gcManager gc) + let sc = statusCode (responseStatus resp) + if sc >= 200 && sc < 300 + then pure () + else fail $ "API DELETE " <> url <> " failed with status " <> show sc + <> ": " <> BS.unpack (BL.toStrict $ responseBody resp) + +apiDelete :: GiteaClient -> Text -> IO () +apiDelete gc path = do + let url = T.unpack (gcBaseUrl gc <> path) + initReq <- parseRequest url + let req = initReq + { method = "DELETE" + , requestHeaders = + [ ("Authorization", "token " <> TE.encodeUtf8 (gcToken gc)) + , ("Accept", "application/json") + ] + } + resp <- httpLbs req (gcManager gc) + let sc = statusCode (responseStatus resp) + if sc >= 200 && sc < 300 + then pure () + else fail $ "API DELETE " <> url <> " failed with status " <> show sc + <> ": " <> BS.unpack (BL.toStrict $ responseBody resp) + -- API operations getCurrentUser :: GiteaClient -> IO Text @@ -260,3 +303,29 @@ postReview gc prNum body comments = do then pure () else fail $ "postReview failed with status " <> show sc <> ": " <> BS.unpack (BL.toStrict respBody) + +deleteComment :: GiteaClient -> Int -> IO () +deleteComment gc commentId = + apiDelete gc (repoPath gc <> "/issues/comments/" <> T.pack (show commentId)) + +addCommentReaction :: GiteaClient -> Int -> Text -> IO () +addCommentReaction gc commentId reaction = do + let payload = object ["content" .= reaction] + _ <- apiPostRaw gc (repoPath gc <> "/issues/comments/" <> T.pack (show commentId) <> "/reactions") payload + pure () + +removeCommentReaction :: GiteaClient -> Int -> Text -> IO () +removeCommentReaction gc commentId reaction = do + let payload = object ["content" .= reaction] + apiDeleteWithBody gc (repoPath gc <> "/issues/comments/" <> T.pack (show commentId) <> "/reactions") payload + +addIssueReaction :: GiteaClient -> Int -> Text -> IO () +addIssueReaction gc issueNum reaction = do + let payload = object ["content" .= reaction] + _ <- apiPostRaw gc (repoPath gc <> "/issues/" <> T.pack (show issueNum) <> "/reactions") payload + pure () + +removeIssueReaction :: GiteaClient -> Int -> Text -> IO () +removeIssueReaction gc issueNum reaction = do + let payload = object ["content" .= reaction] + apiDeleteWithBody gc (repoPath gc <> "/issues/" <> T.pack (show issueNum) <> "/reactions") payload diff --git a/src/Bot/Review.hs b/src/Bot/Review.hs index d49f505..5fdbdb5 100644 --- a/src/Bot/Review.hs +++ b/src/Bot/Review.hs @@ -2,7 +2,7 @@ module Bot.Review ( handleEvent ) where -import Control.Exception (SomeException, catch) +import Control.Exception (SomeException, catch, finally) import Data.Text (Text) import Data.Text qualified as T import System.IO (hPutStrLn, stderr) @@ -37,14 +37,29 @@ handleEvent cfg event = do dispatch :: Config -> GiteaClient -> Event -> Int -> IO () dispatch cfg client event prNum = do - -- Create tracking comment - commentId <- createComment client prNum "\x23F3 Thinking..." - putStrLn $ "Created tracking comment: " <> show commentId + -- Add eyes reaction to acknowledge + addReaction event + putStrLn "Added eyes reaction" - -- Ensure tracking comment is updated even on error let jobUrl = cfgGiteaUrl cfg <> "/" <> cfgRepoOwner cfg <> "/" <> cfgRepoName cfg <> "/actions/runs/" <> cfgRunId cfg + let run = do + ctx <- gatherContext client prNum + + case event of + EvPullRequest _ -> + handleReview cfg client event prNum jobUrl ctx + + EvIssueComment ice -> + handleReply cfg client (iceCommentBody ice) prNum jobUrl ctx + + EvPRReview prre -> + handleReply cfg client (prreReviewBody prre) prNum jobUrl ctx + + EvPRReviewComment prrce -> + handleReply cfg client (prrceCommentBody prrce) prNum jobUrl ctx + let onError :: SomeException -> IO () onError ex = do let errMsg = T.pack (show ex) @@ -54,27 +69,27 @@ dispatch cfg client event prNum = do , "" , T.take 2000 errMsg ] - updateComment client commentId body + (do _ <- createComment client prNum body; pure ()) `catch` \(_ :: SomeException) -> pure () - let run = do - -- Gather PR context - ctx <- gatherContext client prNum + let removeReaction_ = + removeReaction event + `catch` \(_ :: SomeException) -> pure () - case event of - EvPullRequest _ -> do - handleReview cfg client event prNum commentId jobUrl ctx + (run `catch` onError) `finally` removeReaction_ - EvIssueComment _ -> do - handleReview cfg client event prNum commentId jobUrl ctx - - EvPRReview prre -> do - handleReply cfg client (prreReviewBody prre) prNum commentId jobUrl ctx - - EvPRReviewComment prrce -> do - handleReply cfg client (prrceCommentBody prrce) prNum commentId jobUrl ctx - - run `catch` onError + where + reaction = "eyes" + addReaction = \case + EvPullRequest _ -> addIssueReaction client prNum reaction + EvIssueComment ice -> addCommentReaction client (iceCommentId ice) reaction + EvPRReview prre -> addCommentReaction client (prreReviewId prre) reaction + EvPRReviewComment prrce -> addCommentReaction client (prrceCommentId prrce) reaction + removeReaction = \case + EvPullRequest _ -> removeIssueReaction client prNum reaction + EvIssueComment ice -> removeCommentReaction client (iceCommentId ice) reaction + EvPRReview prre -> removeCommentReaction client (prreReviewId prre) reaction + EvPRReviewComment prrce -> removeCommentReaction client (prrceCommentId prrce) reaction gatherContext :: GiteaClient -> Int -> IO PRContext gatherContext client prNum = do @@ -89,8 +104,8 @@ gatherContext client prNum = do , ctxReviews = reviews } -handleReview :: Config -> GiteaClient -> Event -> Int -> Int -> Text -> PRContext -> IO () -handleReview cfg client event prNum commentId jobUrl ctx = do +handleReview :: Config -> GiteaClient -> Event -> Int -> Text -> PRContext -> IO () +handleReview cfg client event prNum jobUrl ctx = do let prompt = buildReviewPrompt cfg event ctx result <- invokeClaudeReview prompt case result of @@ -101,28 +116,23 @@ handleReview cfg client event prNum commentId jobUrl ctx = do , "" , T.pack err ] - updateComment client commentId body + _ <- createComment client prNum body + pure () Right review -> do - -- Update tracking comment with summary let sender = eventSender event - body = T.unlines + summary = T.unlines [ "**Claude** reviewed @" <> sender <> "'s PR \x2014 [View job run](" <> jobUrl <> ")" , "" , "---" , "" , roSummary review ] - updateComment client commentId body + inlineComments = map toInlineComment (roComments review) + postReviewWithFallback client prNum summary inlineComments - -- Post review with inline comments if any - let inlineComments = map toInlineComment (roComments review) - if null inlineComments - then pure () - else postReviewWithFallback client prNum (roSummary review) inlineComments - -handleReply :: Config -> GiteaClient -> Text -> Int -> Int -> Text -> PRContext -> IO () -handleReply cfg client triggerBody _prNum commentId jobUrl ctx = do +handleReply :: Config -> GiteaClient -> Text -> Int -> Text -> PRContext -> IO () +handleReply cfg client triggerBody prNum jobUrl ctx = do let prompt = buildReplyPrompt cfg triggerBody ctx result <- invokeClaudeReply prompt case result of @@ -133,7 +143,8 @@ handleReply cfg client triggerBody _prNum commentId jobUrl ctx = do , "" , T.pack err ] - updateComment client commentId body + _ <- createComment client prNum body + pure () Right replyText -> do let body = T.unlines @@ -143,7 +154,8 @@ handleReply cfg client triggerBody _prNum commentId jobUrl ctx = do , "" , replyText ] - updateComment client commentId body + _ <- createComment client prNum body + pure () toInlineComment :: ClaudeComment -> InlineComment toInlineComment cc = InlineComment