Switch to using a reaction for in-progress tracking

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

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"
+    comment   <- o .: "comment"
-    body    <- comment .: "body"
+    commentId <- comment .: "id"
-    sender  <- parseSender o
+    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"
+    review   <- o .: "review"
-    body   <- review .:? "body" .!= ""
+    reviewId <- review .: "id"
-    sender <- parseSender o
+    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"
+    comment   <- o .: "comment"
-    body    <- comment .: "body"
+    commentId <- comment .: "id"
-    sender  <- parseSender o
+    body      <- comment .: "body"
+    sender    <- parseSender o
     pure PRReviewCommentEvent
       { prrceAction      = action
       , prrceNumber      = number
       , prrceTitle       = title
+      , prrceCommentId   = commentId
       , prrceCommentBody = body
       , prrceSender      = sender
       }

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

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
+  -- Add eyes reaction to acknowledge
-  commentId <- createComment client prNum "\x23F3 Thinking..."
+  addReaction event
-  putStrLn $ "Created tracking comment: " <> show commentId
+  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
+  let removeReaction_ =
-        -- Gather PR context
+        removeReaction event
-        ctx <- gatherContext client prNum
+          `catch` \(_ :: SomeException) -> pure ()
 
-        case event of
+  (run `catch` onError) `finally` removeReaction_
-          EvPullRequest _ -> do
-            handleReview cfg client event prNum commentId jobUrl ctx
 
-          EvIssueComment _ -> do
+  where
-            handleReview cfg client event prNum commentId jobUrl ctx
+    reaction = "eyes"
-
+    addReaction = \case
-          EvPRReview prre -> do
+      EvPullRequest _       -> addIssueReaction client prNum reaction
-            handleReply cfg client (prreReviewBody prre) prNum commentId jobUrl ctx
+      EvIssueComment ice    -> addCommentReaction client (iceCommentId ice) reaction
-
+      EvPRReview prre       -> addCommentReaction client (prreReviewId prre) reaction
-          EvPRReviewComment prrce -> do
+      EvPRReviewComment prrce -> addCommentReaction client (prrceCommentId prrce) reaction
-            handleReply cfg client (prrceCommentBody prrce) prNum commentId jobUrl ctx
+    removeReaction = \case
-
+      EvPullRequest _       -> removeIssueReaction client prNum reaction
-  run `catch` onError
+      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 :: Config -> GiteaClient -> Event -> Int -> Text -> PRContext -> IO ()
-handleReview cfg client event prNum commentId jobUrl ctx = do
+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
+handleReply :: Config -> GiteaClient -> Text -> Int -> Text -> PRContext -> IO ()
-      let inlineComments = map toInlineComment (roComments review)
+handleReply cfg client triggerBody prNum jobUrl ctx = do
-      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
   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