263 lines
7.8 KiB
Haskell
263 lines
7.8 KiB
Haskell
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)
|