Testing

.gitea/workflows/pr-review.yml

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

src/Bot/Claude.hs

@@ -11,7 +11,10 @@ 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
@@ -65,15 +68,20 @@ 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", T.unpack prompt
+    [ "-p"
     , "--output-format", "json"
-    , "--max-turns", "3"
+    , "--max-turns", "1"
-    , "--tools", ""
+    , "--prompt-file", promptFile
-    , "--json-schema", reviewJsonSchema
+    , "--json-schema", schemaFile
     ] ""
-  putStrLn $ "Claude stdout: " <> take 2000 stdout
+  removeFile promptFile
-  putStrLn $ "Claude stderr: " <> take 2000 stderr_
+  removeFile schemaFile
   case exitCode of
     ExitSuccess -> pure $ parseClaudeJsonOutput stdout
     ExitFailure code ->
@@ -81,61 +89,54 @@ 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", T.unpack prompt
+    [ "-p"
     , "--output-format", "json"
-    , "--max-turns", "3"
+    , "--max-turns", "1"
-    , "--tools", ""
+    , "--prompt-file", promptFile
     ] ""
+  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: { "structured_output": <structured output> }
+-- Parse Claude's JSON envelope: { "result": <structured output> }
 parseClaudeJsonOutput :: String -> Either String ReviewOutput
 parseClaudeJsonOutput raw =
   case eitherDecode (strToLBS raw) of
     Right val ->
-      case parseMaybe extractField val of
+      case parseMaybe extractResult val of
         Just (String resultText) ->
-          -- structured_output is a JSON string that needs to be parsed again
+          -- result is a JSON string that needs to be parsed again
           eitherDecode (BL.fromStrict $ TE.encodeUtf8 resultText)
         Just resultVal ->
-          -- structured_output is already a JSON object
+          -- result is already a JSON object
           case fromJSON resultVal of
             Success v -> Right v
-            Error e   -> Left $ "Failed to parse structured_output: " <> e
+            Error e   -> Left $ "Failed to parse result object: " <> e
-        Nothing ->
+        Nothing -> Left "Missing 'result' field in Claude output"
-          -- 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
+    extractResult :: Value -> Parser Value
-    extractField = withObject "envelope" (.: "structured_output")
+    extractResult = withObject "envelope" (.: "result")
-    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 extractField val of
+      case parseMaybe extractResult val of
         Just (String resultText) -> Right resultText
         Just _  -> Left "Expected string 'result' in Claude output"
-        Nothing ->
+        Nothing -> Left "Missing 'result' field in Claude output"
-          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
+    extractResult :: Value -> Parser Value
-    extractField = withObject "envelope" (.: "result")
+    extractResult = 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_NUMBER" ""
+  runId      <- lookupEnvText "GITHUB_RUN_ID" ""
   trigger    <- lookupEnvText "INPUT_TRIGGER_PHRASE" "@claude"
 
   let repoText = T.pack repository

src/Bot/Event.hs

@@ -34,7 +34,6 @@ data IssueCommentEvent = IssueCommentEvent
   { iceAction      :: Text
   , iceIsPull      :: Bool
   , iceNumber      :: Int
-  , iceCommentId   :: Int
   , iceCommentBody :: Text
   , iceSender      :: Text
   }
@@ -43,7 +42,6 @@ data PRReviewEvent = PRReviewEvent
   { prreAction     :: Text
   , prreNumber     :: Int
   , prreTitle      :: Text
-  , prreReviewId   :: Int
   , prreReviewBody :: Text
   , prreSender     :: Text
   }
@@ -52,7 +50,6 @@ data PRReviewCommentEvent = PRReviewCommentEvent
   { prrceAction      :: Text
   , prrceNumber      :: Int
   , prrceTitle       :: Text
-  , prrceCommentId   :: Int
   , prrceCommentBody :: Text
   , prrceSender      :: Text
   }
@@ -89,15 +86,13 @@ instance FromJSON IssueCommentEvent where
       pure $ case pr of
         Just (Object _) -> True
         _               -> False
-    comment   <- o .: "comment"
+    comment <- o .: "comment"
-    commentId <- comment .: "id"
+    body    <- comment .: "body"
-    body      <- comment .: "body"
+    sender  <- parseSender o
-    sender    <- parseSender o
     pure IssueCommentEvent
       { iceAction      = action
       , iceIsPull      = isPull
       , iceNumber      = number
-      , iceCommentId   = commentId
       , iceCommentBody = body
       , iceSender      = sender
       }
@@ -108,15 +103,13 @@ instance FromJSON PRReviewEvent where
     pr     <- o .: "pull_request"
     number <- pr .: "number"
     title  <- pr .: "title"
-    review   <- o .: "review"
+    review <- o .: "review"
-    reviewId <- review .: "id"
+    body   <- review .:? "body" .!= ""
-    body     <- review .:? "body" .!= ""
+    sender <- parseSender o
-    sender   <- parseSender o
     pure PRReviewEvent
       { prreAction     = action
       , prreNumber     = number
       , prreTitle      = title
-      , prreReviewId   = reviewId
       , prreReviewBody = body
       , prreSender     = sender
       }
@@ -127,15 +120,13 @@ instance FromJSON PRReviewCommentEvent where
     pr      <- o .: "pull_request"
     number  <- pr .: "number"
     title   <- pr .: "title"
-    comment   <- o .: "comment"
+    comment <- o .: "comment"
-    commentId <- comment .: "id"
+    body    <- comment .: "body"
-    body      <- comment .: "body"
+    sender  <- parseSender o
-    sender    <- parseSender o
     pure PRReviewCommentEvent
       { prrceAction      = action
       , prrceNumber      = number
       , prrceTitle       = title
-      , prrceCommentId   = commentId
       , prrceCommentBody = body
       , prrceSender      = sender
       }

src/Bot/Gitea.hs

@@ -8,12 +8,7 @@ module Bot.Gitea
   , getPrReviews
   , createComment
   , updateComment
-  , deleteComment
   , postReview
-  , addCommentReaction
-  , removeCommentReaction
-  , addIssueReaction
-  , removeIssueReaction
   , PrInfo (..)
   , GiteaComment (..)
   , GiteaReview (..)
@@ -142,44 +137,6 @@ 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
@@ -303,29 +260,3 @@ 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, finally)
+import Control.Exception (SomeException, catch)
 import Data.Text (Text)
 import Data.Text qualified as T
 import System.IO (hPutStrLn, stderr)
@@ -24,8 +24,6 @@ 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
@@ -37,29 +35,14 @@ handleEvent cfg event = do
 
 dispatch :: Config -> GiteaClient -> Event -> Int -> IO ()
 dispatch cfg client event prNum = do
-  -- Add eyes reaction to acknowledge
+  -- Create tracking comment
-  addReaction event
+  commentId <- createComment client prNum "\x23F3 Thinking..."
-  putStrLn "Added eyes reaction"
+  putStrLn $ "Created tracking comment: " <> show commentId
 
+  -- 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)
@@ -69,27 +52,27 @@ dispatch cfg client event prNum = do
               , ""
               , T.take 2000 errMsg
               ]
-        (do _ <- createComment client prNum body; pure ())
+        updateComment client commentId body
           `catch` \(_ :: SomeException) -> pure ()
 
-  let removeReaction_ =
+  let run = do
-        removeReaction event
+        -- Gather PR context
-          `catch` \(_ :: SomeException) -> pure ()
+        ctx <- gatherContext client prNum
 
-  (run `catch` onError) `finally` removeReaction_
+        case event of
+          EvPullRequest _ -> do
+            handleReview cfg client event prNum commentId jobUrl ctx
 
-  where
+          EvIssueComment _ -> do
-    reaction = "eyes"
+            handleReview cfg client event prNum commentId jobUrl ctx
-    addReaction = \case
+
-      EvPullRequest _       -> addIssueReaction client prNum reaction
+          EvPRReview prre -> do
-      EvIssueComment ice    -> addCommentReaction client (iceCommentId ice) reaction
+            handleReply cfg client (prreReviewBody prre) prNum commentId jobUrl ctx
-      EvPRReview prre       -> addCommentReaction client (prreReviewId prre) reaction
+
-      EvPRReviewComment prrce -> addCommentReaction client (prrceCommentId prrce) reaction
+          EvPRReviewComment prrce -> do
-    removeReaction = \case
+            handleReply cfg client (prrceCommentBody prrce) prNum commentId jobUrl ctx
-      EvPullRequest _       -> removeIssueReaction client prNum reaction
+
-      EvIssueComment ice    -> removeCommentReaction client (iceCommentId ice) reaction
+  run `catch` onError
-      EvPRReview prre       -> removeCommentReaction client (prreReviewId prre) reaction
-      EvPRReviewComment prrce -> removeCommentReaction client (prrceCommentId prrce) reaction
 
 gatherContext :: GiteaClient -> Int -> IO PRContext
 gatherContext client prNum = do
@@ -104,8 +87,8 @@ gatherContext client prNum = do
     , ctxReviews  = reviews
     }
 
-handleReview :: Config -> GiteaClient -> Event -> Int -> Text -> PRContext -> IO ()
+handleReview :: Config -> GiteaClient -> Event -> Int -> Int -> Text -> PRContext -> IO ()
-handleReview cfg client event prNum jobUrl ctx = do
+handleReview cfg client event prNum commentId jobUrl ctx = do
   let prompt = buildReviewPrompt cfg event ctx
   result <- invokeClaudeReview prompt
   case result of
@@ -116,23 +99,28 @@ handleReview cfg client event prNum jobUrl ctx = do
             , ""
             , T.pack err
             ]
-      _ <- createComment client prNum body
+      updateComment client commentId body
-      pure ()
 
     Right review -> do
+      -- Update tracking comment with summary
       let sender = eventSender event
-          summary = T.unlines
+          body = T.unlines
             [ "**Claude** reviewed @" <> sender <> "'s PR \x2014 [View job run](" <> jobUrl <> ")"
             , ""
             , "---"
             , ""
             , roSummary review
             ]
-          inlineComments = map toInlineComment (roComments review)
+      updateComment client commentId body
-      postReviewWithFallback client prNum summary inlineComments
 
-handleReply :: Config -> GiteaClient -> Text -> Int -> Text -> PRContext -> IO ()
+      -- Post review with inline comments if any
-handleReply cfg client triggerBody prNum jobUrl ctx = do
+      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
   let prompt = buildReplyPrompt cfg triggerBody ctx
   result <- invokeClaudeReply prompt
   case result of
@@ -143,8 +131,7 @@ handleReply cfg client triggerBody prNum jobUrl ctx = do
             , ""
             , T.pack err
             ]
-      _ <- createComment client prNum body
+      updateComment client commentId body
-      pure ()
 
     Right replyText -> do
       let body = T.unlines
@@ -154,8 +141,7 @@ handleReply cfg client triggerBody prNum jobUrl ctx = do
             , ""
             , replyText
             ]
-      _ <- createComment client prNum body
+      updateComment client commentId body
-      pure ()
 
 toInlineComment :: ClaudeComment -> InlineComment
 toInlineComment cc = InlineComment
@@ -180,22 +166,3 @@ 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 = "(^|[[:space:]])" <> escapeRegex (T.unpack phrase) <> "([[:space:].,!?;:]|$)"
+    pattern = "(^|\\s)" <> escapeRegex (T.unpack phrase) <> "([\\s.,!?;:]|$)"
 
 escapeRegex :: String -> String
 escapeRegex = concatMap esc