Initial commit
This commit is contained in:
Brian McKenna
commit
2a3bc7e9a4
37
.gitea/workflows/pr-review.yml
Normal file
37
.gitea/workflows/pr-review.yml
Normal file
@ -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
|
||||
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
||||
dist-newstyle
|
||||
15
app/Main.hs
Normal file
15
app/Main.hs
Normal file
@ -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
|
||||
38
os-ai-pr-bot.cabal
Normal file
38
os-ai-pr-bot.cabal
Normal file
@ -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
|
||||
142
src/Bot/Claude.hs
Normal file
142
src/Bot/Claude.hs
Normal file
@ -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": <structured output> }
|
||||
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
|
||||
65
src/Bot/Config.hs
Normal file
65
src/Bot/Config.hs
Normal file
@ -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
|
||||
147
src/Bot/Event.hs
Normal file
147
src/Bot/Event.hs
Normal file
@ -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
|
||||
262
src/Bot/Gitea.hs
Normal file
262
src/Bot/Gitea.hs
Normal file
@ -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)
|
||||
150
src/Bot/Prompt.hs
Normal file
150
src/Bot/Prompt.hs
Normal file
@ -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."
|
||||
, ""
|
||||
, "<context>"
|
||||
, "PR Title: " <> piTitle (ctxPrInfo ctx)
|
||||
, "PR Author: " <> piUser (ctxPrInfo ctx)
|
||||
, "PR Branch: " <> piHead (ctxPrInfo ctx) <> " → " <> piBase (ctxPrInfo ctx)
|
||||
, "</context>"
|
||||
, ""
|
||||
, "<pr_body>"
|
||||
, fromMaybe "No description provided" (piBody (ctxPrInfo ctx))
|
||||
, "</pr_body>"
|
||||
, ""
|
||||
, "<comments>"
|
||||
, formatComments (ctxComments ctx)
|
||||
, "</comments>"
|
||||
, ""
|
||||
, "<review_comments>"
|
||||
, formatReviews (ctxReviews ctx)
|
||||
, "</review_comments>"
|
||||
, ""
|
||||
, "<diff>"
|
||||
, ctxDiff ctx
|
||||
, "</diff>"
|
||||
, ""
|
||||
, "<metadata>"
|
||||
, "repository: " <> cfgRepoOwner cfg <> "/" <> cfgRepoName cfg
|
||||
, "pr_number: " <> T.pack (show (eventPRNumber event))
|
||||
, "trigger: " <> triggerContext cfg event
|
||||
, "triggered_by: " <> eventSender event
|
||||
, "</metadata>"
|
||||
, ""
|
||||
, 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."
|
||||
, ""
|
||||
, "<context>"
|
||||
, "PR Title: " <> piTitle (ctxPrInfo ctx)
|
||||
, "PR Author: " <> piUser (ctxPrInfo ctx)
|
||||
, "PR Branch: " <> piHead (ctxPrInfo ctx) <> " → " <> piBase (ctxPrInfo ctx)
|
||||
, "</context>"
|
||||
, ""
|
||||
, "<pr_body>"
|
||||
, fromMaybe "No description provided" (piBody (ctxPrInfo ctx))
|
||||
, "</pr_body>"
|
||||
, ""
|
||||
, "<comments>"
|
||||
, formatComments (ctxComments ctx)
|
||||
, "</comments>"
|
||||
, ""
|
||||
, "<review_comments>"
|
||||
, formatReviews (ctxReviews ctx)
|
||||
, "</review_comments>"
|
||||
, ""
|
||||
, "<diff>"
|
||||
, ctxDiff ctx
|
||||
, "</diff>"
|
||||
, ""
|
||||
, "<metadata>"
|
||||
, "repository: " <> cfgRepoOwner cfg <> "/" <> cfgRepoName cfg
|
||||
, "</metadata>"
|
||||
, ""
|
||||
, "<trigger_comment>"
|
||||
, triggerBody
|
||||
, "</trigger_comment>"
|
||||
, ""
|
||||
, "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 ->
|
||||
"<trigger_comment>\n" <> iceCommentBody ice <> "\n</trigger_comment>\n\n"
|
||||
EvPRReview prre ->
|
||||
"<trigger_comment>\n" <> prreReviewBody prre <> "\n</trigger_comment>\n\n"
|
||||
EvPRReviewComment prrce ->
|
||||
"<trigger_comment>\n" <> prrceCommentBody prrce <> "\n</trigger_comment>\n\n"
|
||||
_ -> ""
|
||||
168
src/Bot/Review.hs
Normal file
168
src/Bot/Review.hs
Normal file
@ -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
|
||||
62
src/Bot/Trigger.hs
Normal file
62
src/Bot/Trigger.hs
Normal file
@ -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]
|
||||
Loading…
x
Reference in New Issue
Block a user