brian.mckenna/os-ai-pr-bot
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Switch to using a reaction for in-progress tracking

Browse Source
This commit is contained in:
Brian McKenna 2026-02-26 06:56:36 +11:00
parent af967210c6
commit 93becd5020
4 changed files with 150 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
src/Bot/Claude.hs
View File

@ -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

27
src/Bot/Event.hs
View File

@ -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
}

69
src/Bot/Gitea.hs
View File

@ -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

88
src/Bot/Review.hs
View File

@ -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