Switch to using a reaction for in-progress tracking

.gitea/workflows/pr-review.yml

@@ -4,7 +4,7 @@ on:
   issue_comment:
     types: [created]
   pull_request:
-    types: [opened, synchronize, ready_for_review, reopened]
+    types: [opened, reopened, ready_for_review]
   pull_request_review:
     types: [submitted]
   pull_request_review_comment:
@@ -14,10 +14,8 @@ jobs:
   claude-bot:
     runs-on: native
     if: >-
-      (github.event_name == 'pull_request') ||
-      (github.event_name == 'pull_request_review') ||
-      (github.event_name == 'pull_request_review_comment') ||
-      (github.event_name == 'issue_comment' && github.event.issue.pull_request)
+      github.actor != 'obsidiandeploy' &&
+      (github.event_name != 'issue_comment' || github.event.issue.pull_request)
     steps:
       - uses: actions/checkout@v4
       - name: Run Claude Bot

src/Bot/Claude.hs

@@ -11,10 +11,7 @@ import Data.ByteString.Lazy qualified as BL
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
-import Data.Text.IO qualified as TIO
-import System.Directory (getTemporaryDirectory, removeFile)
 import System.Exit (ExitCode (..))
-import System.FilePath ((</>))
 import System.Process (readProcessWithExitCode)
 
 data ReviewOutput = ReviewOutput
@@ -68,20 +65,15 @@ reviewJsonSchema = unlines
 
 invokeClaudeReview :: Text -> IO (Either String ReviewOutput)
 invokeClaudeReview prompt = do
-  tmpDir <- getTemporaryDirectory
-  let promptFile = tmpDir </> "claude-review-prompt.txt"
-      schemaFile = tmpDir </> "claude-review-schema.json"
-  TIO.writeFile promptFile prompt
-  writeFile schemaFile reviewJsonSchema
   (exitCode, stdout, stderr_) <- readProcessWithExitCode "claude"
-    [ "-p"
+    [ "-p", T.unpack prompt
     , "--output-format", "json"
-    , "--max-turns", "1"
-    , "--prompt-file", promptFile
-    , "--json-schema", schemaFile
+    , "--max-turns", "3"
+    , "--tools", ""
+    , "--json-schema", reviewJsonSchema
     ] ""
-  removeFile promptFile
-  removeFile schemaFile
+  putStrLn $ "Claude stdout: " <> take 2000 stdout
+  putStrLn $ "Claude stderr: " <> take 2000 stderr_
   case exitCode of
     ExitSuccess -> pure $ parseClaudeJsonOutput stdout
     ExitFailure code ->
@@ -89,54 +81,61 @@ invokeClaudeReview prompt = do
 
 invokeClaudeReply :: Text -> IO (Either String Text)
 invokeClaudeReply prompt = do
-  tmpDir <- getTemporaryDirectory
-  let promptFile = tmpDir </> "claude-reply-prompt.txt"
-  TIO.writeFile promptFile prompt
   (exitCode, stdout, stderr_) <- readProcessWithExitCode "claude"
-    [ "-p"
+    [ "-p", T.unpack prompt
     , "--output-format", "json"
-    , "--max-turns", "1"
-    , "--prompt-file", promptFile
+    , "--max-turns", "3"
+    , "--tools", ""
     ] ""
-  removeFile promptFile
   case exitCode of
     ExitSuccess -> pure $ parseClaudeTextOutput stdout
     ExitFailure code ->
       pure $ Left $ "claude exited with code " <> show code <> ": " <> stderr_
 
--- Parse Claude's JSON envelope: { "result": <structured output> }
+-- Parse Claude's JSON envelope: { "structured_output": <structured output> }
 parseClaudeJsonOutput :: String -> Either String ReviewOutput
 parseClaudeJsonOutput raw =
   case eitherDecode (strToLBS raw) of
     Right val ->
-      case parseMaybe extractResult val of
+      case parseMaybe extractField val of
         Just (String resultText) ->
-          -- result is a JSON string that needs to be parsed again
+          -- structured_output is a JSON string that needs to be parsed again
           eitherDecode (BL.fromStrict $ TE.encodeUtf8 resultText)
         Just resultVal ->
-          -- result is already a JSON object
+          -- structured_output is already a JSON object
           case fromJSON resultVal of
             Success v -> Right v
-            Error e   -> Left $ "Failed to parse result object: " <> e
-        Nothing -> Left "Missing 'result' field in Claude output"
+            Error e   -> Left $ "Failed to parse structured_output: " <> e
+        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
-    extractResult :: Value -> Parser Value
-    extractResult = withObject "envelope" (.: "result")
+    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
 parseClaudeTextOutput raw =
   case eitherDecode (strToLBS raw) of
     Right val ->
-      case parseMaybe extractResult val of
+      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
-    extractResult :: Value -> Parser Value
-    extractResult = withObject "envelope" (.: "result")
+    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/Config.hs

@@ -28,7 +28,7 @@ loadConfig = do
   repository <- requireEnv "GITHUB_REPOSITORY"
   eventName  <- requireEnv "GITHUB_EVENT_NAME"
   eventPath  <- requireEnv "GITHUB_EVENT_PATH"
-  runId      <- lookupEnvText "GITHUB_RUN_ID" ""
+  runId      <- lookupEnvText "GITHUB_RUN_NUMBER" ""
   trigger    <- lookupEnvText "INPUT_TRIGGER_PHRASE" "@claude"
 
   let repoText = T.pack repository

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
       }

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)
@@ -24,6 +24,8 @@ handleEvent cfg event = do
   putStrLn $ "Bot user: " <> T.unpack botUser
 
   -- Check trigger
+  putStrLn $ "Event: " <> showEvent event
+  putStrLn $ "Trigger phrase: " <> T.unpack (cfgTriggerPhrase cfg')
   case checkTrigger cfg' event of
     NotTriggered -> putStrLn "No trigger found, exiting."
     Triggered prNum -> do
@@ -35,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)
@@ -52,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
@@ -87,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
@@ -99,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
@@ -131,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
@@ -141,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
@@ -166,3 +180,22 @@ eventSender = \case
   EvIssueComment ice      -> iceSender ice
   EvPRReview prre         -> prreSender prre
   EvPRReviewComment prrce -> prrceSender prrce
+
+showEvent :: Event -> String
+showEvent = \case
+  EvPullRequest pre ->
+    "PullRequest action=" <> T.unpack (preAction pre)
+    <> " number=" <> show (preNumber pre)
+  EvIssueComment ice ->
+    "IssueComment action=" <> T.unpack (iceAction ice)
+    <> " number=" <> show (iceNumber ice)
+    <> " isPull=" <> show (iceIsPull ice)
+    <> " body=" <> show (iceCommentBody ice)
+  EvPRReview prre ->
+    "PRReview action=" <> T.unpack (prreAction prre)
+    <> " number=" <> show (prreNumber prre)
+    <> " body=" <> show (prreReviewBody prre)
+  EvPRReviewComment prrce ->
+    "PRReviewComment action=" <> T.unpack (prrceAction prrce)
+    <> " number=" <> show (prrceNumber prrce)
+    <> " body=" <> show (prrceCommentBody prrce)

src/Bot/Trigger.hs

@@ -52,7 +52,7 @@ matchesTrigger phrase text =
   T.unpack text =~ pattern
   where
     pattern :: String
-    pattern = "(^|\\s)" <> escapeRegex (T.unpack phrase) <> "([\\s.,!?;:]|$)"
+    pattern = "(^|[[:space:]])" <> escapeRegex (T.unpack phrase) <> "([[:space:].,!?;:]|$)"
 
 escapeRegex :: String -> String
 escapeRegex = concatMap esc