module Restyler.Comment
    ( leaveRestyledComment
    , clearRestyledComments
    )
where

import Restyler.Prelude

import qualified Data.Text as T
import qualified Data.Vector as V
import GitHub.Endpoints.Issues.Comments
import Restyler.App.Class
import Restyler.App.Error (warnIgnore)
import qualified Restyler.Content as Content
import Restyler.PullRequest

-- | Leave a comment on the original PR, mentioning the given Restyled PR
leaveRestyledComment
    :: (HasCallStack, HasGitHub env)
    => PullRequest -- ^ Original PR
    -> IssueNumber -- ^ Restyled PR Number
    -> RIO env ()
leaveRestyledComment :: PullRequest -> IssueNumber -> RIO env ()
leaveRestyledComment pullRequest :: PullRequest
pullRequest n :: IssueNumber
n = GenRequest 'MtJSON 'RW Comment -> RIO env ()
forall env (m :: MediaType *) a (k :: RW).
(HasGitHub env, ParseResponse m a) =>
GenRequest m k a -> RIO env ()
runGitHub_ (GenRequest 'MtJSON 'RW Comment -> RIO env ())
-> GenRequest 'MtJSON 'RW Comment -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Name Owner
-> Name Repo
-> IssueNumber
-> Text
-> GenRequest 'MtJSON 'RW Comment
createCommentR
    (HasCallStack => PullRequest -> Name Owner
PullRequest -> Name Owner
pullRequestOwnerName PullRequest
pullRequest)
    (HasCallStack => PullRequest -> Name Repo
PullRequest -> Name Repo
pullRequestRepoName PullRequest
pullRequest)
    (PullRequest -> IssueNumber
pullRequestNumber PullRequest
pullRequest)
    (IssueNumber -> Text
Content.commentBody IssueNumber
n)

-- | Locate any comments left by us on the origin PR and delete them
clearRestyledComments
    :: (HasCallStack, HasLogFunc env, HasGitHub env)
    => PullRequest
    -> RIO env ()
clearRestyledComments :: PullRequest -> RIO env ()
clearRestyledComments pullRequest :: PullRequest
pullRequest = do
    Vector IssueComment
comments <- GenRequest 'MtJSON Any (Vector IssueComment)
-> RIO env (Vector IssueComment)
forall env (m :: MediaType *) a (k :: RW).
(HasGitHub env, ParseResponse m a) =>
GenRequest m k a -> RIO env a
runGitHub (GenRequest 'MtJSON Any (Vector IssueComment)
 -> RIO env (Vector IssueComment))
-> GenRequest 'MtJSON Any (Vector IssueComment)
-> RIO env (Vector IssueComment)
forall a b. (a -> b) -> a -> b
$ Name Owner
-> Name Repo
-> IssueNumber
-> FetchCount
-> GenRequest 'MtJSON Any (Vector IssueComment)
forall (k :: RW).
Name Owner
-> Name Repo
-> IssueNumber
-> FetchCount
-> Request k (Vector IssueComment)
commentsR
        (HasCallStack => PullRequest -> Name Owner
PullRequest -> Name Owner
pullRequestOwnerName PullRequest
pullRequest)
        (HasCallStack => PullRequest -> Name Repo
PullRequest -> Name Repo
pullRequestRepoName PullRequest
pullRequest)
        (PullRequest -> IssueNumber
pullRequestNumber PullRequest
pullRequest)
        FetchCount
FetchAll

    Vector IssueComment -> (IssueComment -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((IssueComment -> Bool)
-> Vector IssueComment -> Vector IssueComment
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter IssueComment -> Bool
isRestyledComment Vector IssueComment
comments) ((IssueComment -> RIO env ()) -> RIO env ())
-> (IssueComment -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \comment :: IssueComment
comment -> do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo
            (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Deleting comment "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (IssueComment -> Int
issueCommentId IssueComment
comment)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> " by "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (IssueComment -> Text
commentUserName IssueComment
comment)

        -- FIXME: I think deleteCommentR is broken. GitHub's Request fixes
        -- MtJSON, which is not MtUnit, and so we are expecting to parse a JSON
        -- response here, but GitHub is (rightfully) returning 204 No Content
        -- and failing to parse. I need to reproduce this minimally and report
        -- it, for now we just make comment-deletion best-effort.
        (SomeException -> RIO env ()) -> RIO env () -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny SomeException -> RIO env ()
forall a env. (Display a, HasLogFunc env) => a -> RIO env ()
warnIgnore (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ GenRequest 'MtUnit 'RW () -> RIO env ()
forall env (m :: MediaType *) a (k :: RW).
(HasGitHub env, ParseResponse m a) =>
GenRequest m k a -> RIO env ()
runGitHub_ (GenRequest 'MtUnit 'RW () -> RIO env ())
-> GenRequest 'MtUnit 'RW () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Name Owner -> Name Repo -> Id Comment -> GenRequest 'MtUnit 'RW ()
deleteCommentR
            (HasCallStack => PullRequest -> Name Owner
PullRequest -> Name Owner
pullRequestOwnerName PullRequest
pullRequest)
            (HasCallStack => PullRequest -> Name Repo
PullRequest -> Name Repo
pullRequestRepoName PullRequest
pullRequest)
            (Proxy Comment -> Int -> Id Comment
forall (proxy :: * -> *) entity. proxy entity -> Int -> Id entity
mkId Proxy Comment
forall k (t :: k). Proxy t
Proxy (Int -> Id Comment) -> Int -> Id Comment
forall a b. (a -> b) -> a -> b
$ IssueComment -> Int
issueCommentId IssueComment
comment)

commentUserName :: IssueComment -> Text
commentUserName :: IssueComment -> Text
commentUserName = Name User -> Text
forall entity. Name entity -> Text
untagName (Name User -> Text)
-> (IssueComment -> Name User) -> IssueComment -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleUser -> Name User
simpleUserLogin (SimpleUser -> Name User)
-> (IssueComment -> SimpleUser) -> IssueComment -> Name User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IssueComment -> SimpleUser
issueCommentUser

isRestyledComment :: IssueComment -> Bool
isRestyledComment :: IssueComment -> Bool
isRestyledComment = Text -> Bool
isRestyledBotUserName (Text -> Bool) -> (IssueComment -> Text) -> IssueComment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IssueComment -> Text
commentUserName

isRestyledBotUserName :: Text -> Bool
isRestyledBotUserName :: Text -> Bool
isRestyledBotUserName =
    Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> (Text -> Bool) -> Text -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ("restyled-io" Text -> Text -> Bool
`T.isPrefixOf`) (Text -> Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ("[bot]" Text -> Text -> Bool
`T.isSuffixOf`)