commit 2a3bc7e9a49e17ce29b1645d7346662990fa9bc2 Author: Brian McKenna Date: Sat Feb 14 06:16:52 2026 +1100 Initial commit diff --git a/.gitea/workflows/pr-review.yml b/.gitea/workflows/pr-review.yml new file mode 100644 index 0000000..ea4b40a --- /dev/null +++ b/.gitea/workflows/pr-review.yml @@ -0,0 +1,37 @@ +name: Claude PR Bot + +on: + issue_comment: + types: [created] + pull_request: + types: [opened, synchronize, ready_for_review, reopened] + pull_request_review: + types: [submitted] + pull_request_review_comment: + types: [created] + +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) + steps: + - uses: actions/checkout@v4 + + - name: Install Claude Code CLI + run: curl -fsSL https://claude.ai/install.sh | bash + + - name: Download os-ai-pr-bot + run: | + curl -fsSL -o /usr/local/bin/os-ai-pr-bot \ + "${GITHUB_SERVER_URL}/api/v1/repos/${GITHUB_REPOSITORY}/releases/latest/assets/os-ai-pr-bot" \ + -H "Authorization: token ${GITHUB_TOKEN}" + chmod +x /usr/local/bin/os-ai-pr-bot + + - name: Run Claude Bot + env: + ANTHROPIC_API_KEY: ${{ secrets.ANTHROPIC_API_KEY }} + run: os-ai-pr-bot diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..48a004c --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..b9dd637 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + +import Bot.Config (loadConfig, Config (..)) +import Bot.Event (parseEvent) +import Bot.Review (handleEvent) + +main :: IO () +main = do + config <- loadConfig + parseEvent (cfgEventName config) (cfgEventPath config) >>= \case + Left err -> hPutStrLn stderr ("Event parse error: " <> err) >> exitFailure + Right event -> handleEvent config event diff --git a/os-ai-pr-bot.cabal b/os-ai-pr-bot.cabal new file mode 100644 index 0000000..c514a48 --- /dev/null +++ b/os-ai-pr-bot.cabal @@ -0,0 +1,38 @@ +cabal-version: 3.0 +name: os-ai-pr-bot +version: 0.1.0.0 +synopsis: Gitea Actions PR review bot using Claude Code +license: MIT + +executable os-ai-pr-bot + default-language: GHC2021 + hs-source-dirs: app, src + main-is: Main.hs + other-modules: + Bot.Config + Bot.Event + Bot.Trigger + Bot.Gitea + Bot.Claude + Bot.Prompt + Bot.Review + + build-depends: + , aeson >=2.0 + , base >=4.16 && <5 + , bytestring >=0.11 + , directory >=1.3 + , filepath >=1.4 + , http-client >=0.7 + , http-client-tls >=0.3 + , http-types >=0.12 + , process >=1.6 + , text >=2.0 + , time >=1.12 + , regex-tdfa >=1.3 + + default-extensions: + LambdaCase + OverloadedStrings + + ghc-options: -Wall -O2 diff --git a/src/Bot/Claude.hs b/src/Bot/Claude.hs new file mode 100644 index 0000000..df93643 --- /dev/null +++ b/src/Bot/Claude.hs @@ -0,0 +1,142 @@ +module Bot.Claude + ( ReviewOutput (..) + , ClaudeComment (..) + , invokeClaudeReview + , invokeClaudeReply + ) where + +import Data.Aeson +import Data.Aeson.Types (Parser, parseMaybe) +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 + { roSummary :: Text + , roComments :: [ClaudeComment] + } + +data ClaudeComment = ClaudeComment + { ccPath :: Text + , ccLine :: Int + , ccComment :: Text + } + +instance FromJSON ReviewOutput where + parseJSON = withObject "ReviewOutput" $ \o -> do + summary <- o .: "summary" + comments <- o .:? "comments" .!= [] + pure ReviewOutput { roSummary = summary, roComments = comments } + +instance FromJSON ClaudeComment where + parseJSON = withObject "ClaudeComment" $ \o -> do + path <- o .: "path" + line <- o .: "line" + comment <- o .: "comment" + pure ClaudeComment { ccPath = path, ccLine = line, ccComment = comment } + +reviewJsonSchema :: String +reviewJsonSchema = unlines + [ "{" + , " \"type\": \"object\"," + , " \"required\": [\"summary\", \"comments\"]," + , " \"properties\": {" + , " \"summary\": { \"type\": \"string\" }," + , " \"comments\": {" + , " \"type\": \"array\"," + , " \"items\": {" + , " \"type\": \"object\"," + , " \"required\": [\"path\", \"line\", \"comment\"]," + , " \"properties\": {" + , " \"path\": { \"type\": \"string\" }," + , " \"line\": { \"type\": \"integer\" }," + , " \"comment\": { \"type\": \"string\" }" + , " }," + , " \"additionalProperties\": false" + , " }" + , " }" + , " }," + , " \"additionalProperties\": false" + , "}" + ] + +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" + , "--output-format", "json" + , "--max-turns", "1" + , "--prompt-file", promptFile + , "--json-schema", schemaFile + ] "" + removeFile promptFile + removeFile schemaFile + case exitCode of + ExitSuccess -> pure $ parseClaudeJsonOutput stdout + ExitFailure code -> + pure $ Left $ "claude exited with code " <> show code <> ": " <> stderr_ + +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" + , "--output-format", "json" + , "--max-turns", "1" + , "--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: { "result": } +parseClaudeJsonOutput :: String -> Either String ReviewOutput +parseClaudeJsonOutput raw = + case eitherDecode (strToLBS raw) of + Right val -> + case parseMaybe extractResult val of + Just (String resultText) -> + -- result is a JSON string that needs to be parsed again + eitherDecode (BL.fromStrict $ TE.encodeUtf8 resultText) + Just resultVal -> + -- result 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" + Left err -> Left $ "Failed to parse Claude JSON: " <> err + where + extractResult :: Value -> Parser Value + extractResult = withObject "envelope" (.: "result") + +-- 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 + Just (String resultText) -> Right resultText + Just _ -> Left "Expected string 'result' in Claude output" + 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") + +strToLBS :: String -> BL.ByteString +strToLBS = BL.fromStrict . TE.encodeUtf8 . T.pack diff --git a/src/Bot/Config.hs b/src/Bot/Config.hs new file mode 100644 index 0000000..f308639 --- /dev/null +++ b/src/Bot/Config.hs @@ -0,0 +1,65 @@ +module Bot.Config + ( Config (..) + , loadConfig + ) where + +import Data.Text (Text) +import Data.Text qualified as T +import System.Environment (lookupEnv) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + +data Config = Config + { cfgGiteaUrl :: Text + , cfgGiteaToken :: Text + , cfgRepoOwner :: Text + , cfgRepoName :: Text + , cfgEventName :: Text + , cfgEventPath :: FilePath + , cfgRunId :: Text + , cfgBotUser :: Text -- filled in later by Gitea.getCurrentUser + , cfgTriggerPhrase :: Text + } + +loadConfig :: IO Config +loadConfig = do + giteaUrl <- requireEnv "GITHUB_SERVER_URL" + token <- requireEnv "GITHUB_TOKEN" + repository <- requireEnv "GITHUB_REPOSITORY" + eventName <- requireEnv "GITHUB_EVENT_NAME" + eventPath <- requireEnv "GITHUB_EVENT_PATH" + runId <- lookupEnvText "GITHUB_RUN_ID" "" + trigger <- lookupEnvText "INPUT_TRIGGER_PHRASE" "@claude" + + let repoText = T.pack repository + (owner, name) <- case T.splitOn "/" repoText of + [o, n] -> pure (o, n) + _ -> do + hPutStrLn stderr $ "Invalid GITHUB_REPOSITORY format: " <> repository + exitFailure + + pure Config + { cfgGiteaUrl = T.pack giteaUrl + , cfgGiteaToken = T.pack token + , cfgRepoOwner = owner + , cfgRepoName = name + , cfgEventName = T.pack eventName + , cfgEventPath = eventPath + , cfgRunId = runId + , cfgBotUser = "" -- set after getCurrentUser + , cfgTriggerPhrase = trigger + } + +requireEnv :: String -> IO String +requireEnv name = do + val <- lookupEnv name + case val of + Just v -> pure v + Nothing -> do + hPutStrLn stderr $ "Missing required environment variable: " <> name + exitFailure + +lookupEnvText :: String -> Text -> IO Text +lookupEnvText name def = do + val <- lookupEnv name + pure $ maybe def T.pack val diff --git a/src/Bot/Event.hs b/src/Bot/Event.hs new file mode 100644 index 0000000..f915403 --- /dev/null +++ b/src/Bot/Event.hs @@ -0,0 +1,147 @@ +module Bot.Event + ( Event (..) + , PullRequestEvent (..) + , IssueCommentEvent (..) + , PRReviewEvent (..) + , PRReviewCommentEvent (..) + , parseEvent + ) where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString.Lazy qualified as BL +import Data.Text (Text) +import Data.Text qualified as T + +data Event + = EvPullRequest PullRequestEvent + | EvIssueComment IssueCommentEvent + | EvPRReview PRReviewEvent + | EvPRReviewComment PRReviewCommentEvent + +data PullRequestEvent = PullRequestEvent + { preAction :: Text + , preNumber :: Int + , preTitle :: Text + , preBody :: Maybe Text + , preDraft :: Bool + , preSender :: Text + , preHead :: Text + , preBase :: Text + } + +data IssueCommentEvent = IssueCommentEvent + { iceAction :: Text + , iceIsPull :: Bool + , iceNumber :: Int + , iceCommentBody :: Text + , iceSender :: Text + } + +data PRReviewEvent = PRReviewEvent + { prreAction :: Text + , prreNumber :: Int + , prreTitle :: Text + , prreReviewBody :: Text + , prreSender :: Text + } + +data PRReviewCommentEvent = PRReviewCommentEvent + { prrceAction :: Text + , prrceNumber :: Int + , prrceTitle :: Text + , prrceCommentBody :: Text + , prrceSender :: Text + } + +instance FromJSON PullRequestEvent where + parseJSON = withObject "PullRequestEvent" $ \o -> do + action <- o .: "action" + pr <- o .: "pull_request" + number <- pr .: "number" + title <- pr .: "title" + body <- pr .:? "body" + draft <- pr .:? "draft" .!= False + head_ <- pr .: "head" >>= (.: "label") + base <- pr .: "base" >>= (.: "label") + sender <- parseSender o + pure PullRequestEvent + { preAction = action + , preNumber = number + , preTitle = title + , preBody = body + , preDraft = draft + , preSender = sender + , preHead = head_ + , preBase = base + } + +instance FromJSON IssueCommentEvent where + parseJSON = withObject "IssueCommentEvent" $ \o -> do + action <- o .: "action" + issue <- o .: "issue" + number <- issue .: "number" + isPull <- do + pr <- issue .:? "pull_request" :: Parser (Maybe Value) + pure $ case pr of + Just (Object _) -> True + _ -> False + comment <- o .: "comment" + body <- comment .: "body" + sender <- parseSender o + pure IssueCommentEvent + { iceAction = action + , iceIsPull = isPull + , iceNumber = number + , iceCommentBody = body + , iceSender = sender + } + +instance FromJSON PRReviewEvent where + parseJSON = withObject "PRReviewEvent" $ \o -> do + action <- o .: "action" + pr <- o .: "pull_request" + number <- pr .: "number" + title <- pr .: "title" + review <- o .: "review" + body <- review .:? "body" .!= "" + sender <- parseSender o + pure PRReviewEvent + { prreAction = action + , prreNumber = number + , prreTitle = title + , prreReviewBody = body + , prreSender = sender + } + +instance FromJSON PRReviewCommentEvent where + parseJSON = withObject "PRReviewCommentEvent" $ \o -> do + action <- o .: "action" + pr <- o .: "pull_request" + number <- pr .: "number" + title <- pr .: "title" + comment <- o .: "comment" + body <- comment .: "body" + sender <- parseSender o + pure PRReviewCommentEvent + { prrceAction = action + , prrceNumber = number + , prrceTitle = title + , prrceCommentBody = body + , prrceSender = sender + } + +parseSender :: Object -> Parser Text +parseSender o = do + sender <- o .: "sender" + sender .: "login" + +parseEvent :: Text -> FilePath -> IO (Either String Event) +parseEvent eventName path = do + bytes <- BL.readFile path + pure $ case eventName of + _ | eventName == "pull_request" -> EvPullRequest <$> eitherDecode bytes + | eventName == "issue_comment" -> EvIssueComment <$> eitherDecode bytes + | eventName == "pull_request_review" -> EvPRReview <$> eitherDecode bytes + | eventName == "pull_request_review_comment" -> EvPRReviewComment <$> eitherDecode bytes + | otherwise -> Left $ "Unsupported event type: " <> T.unpack eventName diff --git a/src/Bot/Gitea.hs b/src/Bot/Gitea.hs new file mode 100644 index 0000000..6adc24c --- /dev/null +++ b/src/Bot/Gitea.hs @@ -0,0 +1,262 @@ +module Bot.Gitea + ( GiteaClient + , newGiteaClient + , getCurrentUser + , getPrInfo + , getPrDiff + , getIssueComments + , getPrReviews + , createComment + , updateComment + , postReview + , PrInfo (..) + , GiteaComment (..) + , GiteaReview (..) + , InlineComment (..) + ) where + +import Data.Aeson +import Data.Aeson.Types (parseMaybe) +import Data.ByteString.Char8 qualified as BS +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.Time (UTCTime) +import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types.Status (statusCode) + +import Bot.Config (Config (..)) + +data GiteaClient = GiteaClient + { gcManager :: Manager + , gcBaseUrl :: Text -- e.g. "https://gitea.example.com/api/v1" + , gcToken :: Text + , gcOwner :: Text + , gcRepo :: Text + } + +newGiteaClient :: Config -> IO GiteaClient +newGiteaClient cfg = do + mgr <- newManager tlsManagerSettings + pure GiteaClient + { gcManager = mgr + , gcBaseUrl = cfgGiteaUrl cfg <> "/api/v1" + , gcToken = cfgGiteaToken cfg + , gcOwner = cfgRepoOwner cfg + , gcRepo = cfgRepoName cfg + } + +-- Helpers + +repoPath :: GiteaClient -> Text +repoPath gc = "/repos/" <> gcOwner gc <> "/" <> gcRepo gc + +apiGet :: FromJSON a => GiteaClient -> Text -> IO a +apiGet gc path = do + let url = T.unpack (gcBaseUrl gc <> path) + req <- parseRequest url + let req' = req + { requestHeaders = + [ ("Authorization", "token " <> TE.encodeUtf8 (gcToken gc)) + , ("Accept", "application/json") + ] + } + resp <- httpLbs req' (gcManager gc) + case eitherDecode (responseBody resp) of + Right v -> pure v + Left err -> fail $ "API GET " <> url <> " decode error: " <> err + +apiGetText :: GiteaClient -> Text -> IO Text +apiGetText gc path = do + let url = T.unpack (gcBaseUrl gc <> path) + req <- parseRequest url + let req' = req + { requestHeaders = + [ ("Authorization", "token " <> TE.encodeUtf8 (gcToken gc)) + , ("Accept", "text/plain") + ] + } + resp <- httpLbs req' (gcManager gc) + pure $ TE.decodeUtf8 $ BL.toStrict $ responseBody resp + +apiPost :: FromJSON a => GiteaClient -> Text -> Value -> IO a +apiPost gc path body = do + let url = T.unpack (gcBaseUrl gc <> path) + initReq <- parseRequest url + let req = initReq + { method = "POST" + , requestHeaders = + [ ("Authorization", "token " <> TE.encodeUtf8 (gcToken gc)) + , ("Accept", "application/json") + , ("Content-Type", "application/json") + ] + , requestBody = RequestBodyLBS (encode body) + } + resp <- httpLbs req (gcManager gc) + case eitherDecode (responseBody resp) of + Right v -> pure v + Left err -> fail $ "API POST " <> url <> " decode error: " <> err + <> "\nStatus: " <> show (statusCode $ responseStatus resp) + <> "\nBody: " <> show (BL.toStrict $ responseBody resp) + +apiPatch :: GiteaClient -> Text -> Value -> IO () +apiPatch gc path body = do + let url = T.unpack (gcBaseUrl gc <> path) + initReq <- parseRequest url + let req = initReq + { method = "PATCH" + , 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 PATCH " <> url <> " failed with status " <> show sc + <> ": " <> BS.unpack (BL.toStrict $ responseBody resp) + +apiPostRaw :: GiteaClient -> Text -> Value -> IO (Int, BL.ByteString) +apiPostRaw gc path body = do + let url = T.unpack (gcBaseUrl gc <> path) + initReq <- parseRequest url + let req = initReq + { method = "POST" + , requestHeaders = + [ ("Authorization", "token " <> TE.encodeUtf8 (gcToken gc)) + , ("Accept", "application/json") + , ("Content-Type", "application/json") + ] + , requestBody = RequestBodyLBS (encode body) + } + resp <- httpLbs req (gcManager gc) + pure (statusCode $ responseStatus resp, responseBody resp) + +-- API operations + +getCurrentUser :: GiteaClient -> IO Text +getCurrentUser gc = do + v <- apiGet gc "/user" :: IO Value + case parseMaybe parseLogin v of + Just login -> pure login + Nothing -> fail "GET /user: missing login field" + where + parseLogin = withObject "User" $ \o -> o .: "login" + +data PrInfo = PrInfo + { piTitle :: Text + , piBody :: Maybe Text + , piUser :: Text + , piHead :: Text + , piBase :: Text + } + +instance FromJSON PrInfo where + parseJSON = withObject "PrInfo" $ \o -> do + title <- o .: "title" + body <- o .:? "body" + user <- o .: "user" >>= (.: "login") + head_ <- o .: "head" >>= (.: "label") + base <- o .: "base" >>= (.: "label") + pure PrInfo + { piTitle = title + , piBody = body + , piUser = user + , piHead = head_ + , piBase = base + } + +getPrInfo :: GiteaClient -> Int -> IO PrInfo +getPrInfo gc n = + apiGet gc (repoPath gc <> "/pulls/" <> T.pack (show n)) + +getPrDiff :: GiteaClient -> Int -> IO Text +getPrDiff gc n = + apiGetText gc (repoPath gc <> "/pulls/" <> T.pack (show n) <> ".diff") + +data GiteaComment = GiteaComment + { gcBody :: Text + , gcUser :: Text + , gcCreatedAt :: UTCTime + } + +instance FromJSON GiteaComment where + parseJSON = withObject "GiteaComment" $ \o -> do + body <- o .: "body" + user <- o .: "user" >>= (.: "login") + createdAt <- o .: "created_at" + pure GiteaComment + { gcBody = body + , gcUser = user + , gcCreatedAt = createdAt + } + +getIssueComments :: GiteaClient -> Int -> IO [GiteaComment] +getIssueComments gc n = + apiGet gc (repoPath gc <> "/issues/" <> T.pack (show n) <> "/comments") + +data GiteaReview = GiteaReview + { grBody :: Maybe Text + , grUser :: Text + , grState :: Text + } + +instance FromJSON GiteaReview where + parseJSON = withObject "GiteaReview" $ \o -> do + body <- o .:? "body" + user <- o .: "user" >>= (.: "login") + state <- o .: "state" + pure GiteaReview + { grBody = body + , grUser = user + , grState = state + } + +getPrReviews :: GiteaClient -> Int -> IO [GiteaReview] +getPrReviews gc n = + apiGet gc (repoPath gc <> "/pulls/" <> T.pack (show n) <> "/reviews") + +-- Returns the comment ID +createComment :: GiteaClient -> Int -> Text -> IO Int +createComment gc n body = do + let payload = object ["body" .= body] + v <- apiPost gc (repoPath gc <> "/issues/" <> T.pack (show n) <> "/comments") payload + case parseMaybe parseId (v :: Value) of + Just i -> pure i + Nothing -> fail "createComment: missing 'id' field" + where + parseId = withObject "Comment" $ \o -> o .: "id" + +updateComment :: GiteaClient -> Int -> Text -> IO () +updateComment gc commentId body = do + let payload = object ["body" .= body] + apiPatch gc (repoPath gc <> "/issues/comments/" <> T.pack (show commentId)) payload + +data InlineComment = InlineComment + { icPath :: Text + , icNewPosition :: Int + , icBody :: Text + } + +postReview :: GiteaClient -> Int -> Text -> [InlineComment] -> IO () +postReview gc prNum body comments = do + let commentObjs = map (\ic -> object + [ "path" .= icPath ic + , "new_position" .= icNewPosition ic + , "body" .= icBody ic + ]) comments + payload = object + [ "body" .= body + , "event" .= ("COMMENT" :: Text) + , "comments" .= commentObjs + ] + (sc, respBody) <- apiPostRaw gc (repoPath gc <> "/pulls/" <> T.pack (show prNum) <> "/reviews") payload + if sc >= 200 && sc < 300 + then pure () + else fail $ "postReview failed with status " <> show sc + <> ": " <> BS.unpack (BL.toStrict respBody) diff --git a/src/Bot/Prompt.hs b/src/Bot/Prompt.hs new file mode 100644 index 0000000..64f2c39 --- /dev/null +++ b/src/Bot/Prompt.hs @@ -0,0 +1,150 @@ +module Bot.Prompt + ( PRContext (..) + , buildReviewPrompt + , buildReplyPrompt + ) where + +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (formatTime, defaultTimeLocale) + +import Bot.Config (Config (..)) +import Bot.Event +import Bot.Gitea (PrInfo (..), GiteaComment (..), GiteaReview (..)) + +data PRContext = PRContext + { ctxPrInfo :: PrInfo + , ctxDiff :: Text + , ctxComments :: [GiteaComment] + , ctxReviews :: [GiteaReview] + } + +buildReviewPrompt :: Config -> Event -> PRContext -> Text +buildReviewPrompt cfg event ctx = + T.unlines + [ "You are Claude, an AI assistant reviewing a Gitea pull request." + , "" + , "" + , "PR Title: " <> piTitle (ctxPrInfo ctx) + , "PR Author: " <> piUser (ctxPrInfo ctx) + , "PR Branch: " <> piHead (ctxPrInfo ctx) <> " → " <> piBase (ctxPrInfo ctx) + , "" + , "" + , "" + , fromMaybe "No description provided" (piBody (ctxPrInfo ctx)) + , "" + , "" + , "" + , formatComments (ctxComments ctx) + , "" + , "" + , "" + , formatReviews (ctxReviews ctx) + , "" + , "" + , "" + , ctxDiff ctx + , "" + , "" + , "" + , "repository: " <> cfgRepoOwner cfg <> "/" <> cfgRepoName cfg + , "pr_number: " <> T.pack (show (eventPRNumber event)) + , "trigger: " <> triggerContext cfg event + , "triggered_by: " <> eventSender event + , "" + , "" + , triggerCommentSection event + , "Provide a thorough code review. Focus on bugs, security, correctness, and suggestions." + , "Output your response as JSON with two fields:" + , " - \"summary\": a markdown summary of your review" + , " - \"comments\": an array of inline comments, each with \"path\" (file path), \"line\" (line number in the new file), and \"comment\" (your feedback)" + , "If you have no inline comments, return an empty array for \"comments\"." + ] + +buildReplyPrompt :: Config -> Text -> PRContext -> Text +buildReplyPrompt cfg triggerBody ctx = + T.unlines + [ "You are Claude, an AI assistant helping with a Gitea pull request." + , "" + , "" + , "PR Title: " <> piTitle (ctxPrInfo ctx) + , "PR Author: " <> piUser (ctxPrInfo ctx) + , "PR Branch: " <> piHead (ctxPrInfo ctx) <> " → " <> piBase (ctxPrInfo ctx) + , "" + , "" + , "" + , fromMaybe "No description provided" (piBody (ctxPrInfo ctx)) + , "" + , "" + , "" + , formatComments (ctxComments ctx) + , "" + , "" + , "" + , formatReviews (ctxReviews ctx) + , "" + , "" + , "" + , ctxDiff ctx + , "" + , "" + , "" + , "repository: " <> cfgRepoOwner cfg <> "/" <> cfgRepoName cfg + , "" + , "" + , "" + , triggerBody + , "" + , "" + , "Respond helpfully and concisely to the comment above in the context of this pull request." + ] + +-- Helpers + +formatComments :: [GiteaComment] -> Text +formatComments [] = "No comments" +formatComments cs = T.intercalate "\n" $ map formatComment cs + where + formatComment c = + "[" <> gcUser c <> " at " <> fmtTime (gcCreatedAt c) <> "]: " <> gcBody c + fmtTime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" + +formatReviews :: [GiteaReview] -> Text +formatReviews [] = "No review comments" +formatReviews rs = T.intercalate "\n" $ map formatReview rs + where + formatReview r = + "[Review by " <> grUser r <> "]: " <> grState r + <> maybe "" (\b -> "\n " <> b) (grBody r) + +eventPRNumber :: Event -> Int +eventPRNumber = \case + EvPullRequest pre -> preNumber pre + EvIssueComment ice -> iceNumber ice + EvPRReview prre -> prreNumber prre + EvPRReviewComment prrce -> prrceNumber prrce + +eventSender :: Event -> Text +eventSender = \case + EvPullRequest pre -> preSender pre + EvIssueComment ice -> iceSender ice + EvPRReview prre -> prreSender prre + EvPRReviewComment prrce -> prrceSender prrce + +triggerContext :: Config -> Event -> Text +triggerContext cfg = \case + EvPullRequest pre -> "pull request " <> preAction pre + EvIssueComment _ -> "issue comment with '" <> cfgTriggerPhrase cfg <> "'" + EvPRReview _ -> "PR review with '" <> cfgTriggerPhrase cfg <> "'" + EvPRReviewComment _ -> "PR review comment with '" <> cfgTriggerPhrase cfg <> "'" + +triggerCommentSection :: Event -> Text +triggerCommentSection = \case + EvIssueComment ice -> + "\n" <> iceCommentBody ice <> "\n\n\n" + EvPRReview prre -> + "\n" <> prreReviewBody prre <> "\n\n\n" + EvPRReviewComment prrce -> + "\n" <> prrceCommentBody prrce <> "\n\n\n" + _ -> "" diff --git a/src/Bot/Review.hs b/src/Bot/Review.hs new file mode 100644 index 0000000..f3636f6 --- /dev/null +++ b/src/Bot/Review.hs @@ -0,0 +1,168 @@ +module Bot.Review + ( handleEvent + ) where + +import Control.Exception (SomeException, catch) +import Data.Text (Text) +import Data.Text qualified as T +import System.IO (hPutStrLn, stderr) + +import Bot.Claude +import Bot.Config (Config (..)) +import Bot.Event +import Bot.Gitea +import Bot.Prompt +import Bot.Trigger + +handleEvent :: Config -> Event -> IO () +handleEvent cfg event = do + client <- newGiteaClient cfg + + -- Auto-detect bot username for loop prevention + botUser <- getCurrentUser client + let cfg' = cfg { cfgBotUser = botUser } + putStrLn $ "Bot user: " <> T.unpack botUser + + -- Check trigger + case checkTrigger cfg' event of + NotTriggered -> putStrLn "No trigger found, exiting." + Triggered prNum -> do + -- Loop prevention: skip events from bot itself + let sender = eventSender event + if sender == cfgBotUser cfg' + then putStrLn $ "Skipping event from bot user: " <> T.unpack sender + else dispatch cfg' client event prNum + +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 + + -- Ensure tracking comment is updated even on error + let jobUrl = cfgGiteaUrl cfg <> "/" <> cfgRepoOwner cfg <> "/" <> cfgRepoName cfg + <> "/actions/runs/" <> cfgRunId cfg + + let onError :: SomeException -> IO () + onError ex = do + let errMsg = T.pack (show ex) + hPutStrLn stderr $ "Error: " <> T.unpack errMsg + let body = T.unlines + [ "**Claude** encountered an error \x2014 [View job run](" <> jobUrl <> ")" + , "" + , T.take 2000 errMsg + ] + updateComment client commentId body + `catch` \(_ :: SomeException) -> pure () + + let run = do + -- Gather PR context + ctx <- gatherContext client prNum + + case event of + EvPullRequest _ -> do + handleReview cfg client event prNum commentId jobUrl ctx + + 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 + +gatherContext :: GiteaClient -> Int -> IO PRContext +gatherContext client prNum = do + prInfo <- getPrInfo client prNum + diff <- getPrDiff client prNum + comments <- getIssueComments client prNum + reviews <- getPrReviews client prNum + pure PRContext + { ctxPrInfo = prInfo + , ctxDiff = diff + , ctxComments = comments + , ctxReviews = reviews + } + +handleReview :: Config -> GiteaClient -> Event -> Int -> Int -> Text -> PRContext -> IO () +handleReview cfg client event prNum commentId jobUrl ctx = do + let prompt = buildReviewPrompt cfg event ctx + result <- invokeClaudeReview prompt + case result of + Left err -> do + hPutStrLn stderr $ "Claude review error: " <> err + let body = T.unlines + [ "**Claude** encountered an error \x2014 [View job run](" <> jobUrl <> ")" + , "" + , T.pack err + ] + updateComment client commentId body + + Right review -> do + -- Update tracking comment with summary + let sender = eventSender event + body = T.unlines + [ "**Claude** reviewed @" <> sender <> "'s PR \x2014 [View job run](" <> jobUrl <> ")" + , "" + , "---" + , "" + , roSummary review + ] + updateComment client commentId body + + -- 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 + let prompt = buildReplyPrompt cfg triggerBody ctx + result <- invokeClaudeReply prompt + case result of + Left err -> do + hPutStrLn stderr $ "Claude reply error: " <> err + let body = T.unlines + [ "**Claude** encountered an error \x2014 [View job run](" <> jobUrl <> ")" + , "" + , T.pack err + ] + updateComment client commentId body + + Right replyText -> do + let body = T.unlines + [ "**Claude** responded \x2014 [View job run](" <> jobUrl <> ")" + , "" + , "---" + , "" + , replyText + ] + updateComment client commentId body + +toInlineComment :: ClaudeComment -> InlineComment +toInlineComment cc = InlineComment + { icPath = ccPath cc + , icNewPosition = ccLine cc + , icBody = ccComment cc + } + +-- Try posting review with inline comments; on failure, retry with summary only +postReviewWithFallback :: GiteaClient -> Int -> Text -> [InlineComment] -> IO () +postReviewWithFallback client prNum summary comments = do + postReview client prNum summary comments + `catch` \(_ :: SomeException) -> do + hPutStrLn stderr "Failed to post review with inline comments, retrying without..." + postReview client prNum summary [] + `catch` \(_ :: SomeException) -> + hPutStrLn stderr "Failed to post summary-only review as well." + +eventSender :: Event -> Text +eventSender = \case + EvPullRequest pre -> preSender pre + EvIssueComment ice -> iceSender ice + EvPRReview prre -> prreSender prre + EvPRReviewComment prrce -> prrceSender prrce diff --git a/src/Bot/Trigger.hs b/src/Bot/Trigger.hs new file mode 100644 index 0000000..8ac9a78 --- /dev/null +++ b/src/Bot/Trigger.hs @@ -0,0 +1,62 @@ +module Bot.Trigger + ( TriggerResult (..) + , checkTrigger + ) where + +import Data.Text (Text) +import Data.Text qualified as T +import Text.Regex.TDFA ((=~)) + +import Bot.Config (Config (..)) +import Bot.Event + +data TriggerResult + = Triggered { trPRNumber :: Int } + | NotTriggered + +checkTrigger :: Config -> Event -> TriggerResult +checkTrigger cfg = \case + EvPullRequest pre + | preAction pre `elem` ["opened", "reopened", "ready_for_review"] -> + if matchesTrigger phrase (preTitle pre) + || maybe False (matchesTrigger phrase) (preBody pre) + then Triggered (preNumber pre) + else NotTriggered + | otherwise -> NotTriggered + + EvIssueComment ice + | iceAction ice == "created" && iceIsPull ice -> + if matchesTrigger phrase (iceCommentBody ice) + then Triggered (iceNumber ice) + else NotTriggered + | otherwise -> NotTriggered + + EvPRReview prre + | prreAction prre == "submitted" -> + if matchesTrigger phrase (prreReviewBody prre) + then Triggered (prreNumber prre) + else NotTriggered + | otherwise -> NotTriggered + + EvPRReviewComment prrce + | prrceAction prrce == "created" -> + if matchesTrigger phrase (prrceCommentBody prrce) + then Triggered (prrceNumber prrce) + else NotTriggered + | otherwise -> NotTriggered + where + phrase = cfgTriggerPhrase cfg + +matchesTrigger :: Text -> Text -> Bool +matchesTrigger phrase text = + T.unpack text =~ pattern + where + pattern :: String + pattern = "(^|\\s)" <> escapeRegex (T.unpack phrase) <> "([\\s.,!?;:]|$)" + +escapeRegex :: String -> String +escapeRegex = concatMap esc + where + esc c + | c `elem` (".*+?^${}()|[]\\" :: String) = ['\\', c] + | otherwise = [c]