Switch to using a reaction for in-progress tracking
This commit is contained in:
Brian McKenna
parent
af967210c6
commit
93becd5020
@ -106,11 +106,17 @@ parseClaudeJsonOutput raw =
|
||||
case fromJSON resultVal of
|
||||
Success v -> Right v
|
||||
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
|
||||
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 ->
|
||||
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
|
||||
|
||||
@ -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
|
||||
}
|
||||
@ -87,12 +90,14 @@ instance FromJSON IssueCommentEvent where
|
||||
Just (Object _) -> True
|
||||
_ -> False
|
||||
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
|
||||
}
|
||||
@ -104,12 +109,14 @@ instance FromJSON PRReviewEvent where
|
||||
number <- pr .: "number"
|
||||
title <- pr .: "title"
|
||||
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
|
||||
}
|
||||
@ -121,12 +128,14 @@ instance FromJSON PRReviewCommentEvent where
|
||||
number <- pr .: "number"
|
||||
title <- pr .: "title"
|
||||
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
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user