module Restyler.PullRequest.Status
    ( PullRequestStatus(..)
    , sendPullRequestStatus
    )
where

import Restyler.Prelude

import GitHub.Endpoints.Repos.Statuses
import Restyler.App.Class
import Restyler.Config
import Restyler.Config.Statuses
import Restyler.PullRequest

data PullRequestStatus
    = NoDifferencesStatus (Maybe URL)
    -- ^ We found no differences after restyling
    | DifferencesStatus (Maybe URL)
    -- ^ We found differences and opened a restyled @'PullRequest'@
    | ErrorStatus URL
    -- ^ We encountered an error and can link to a Job

-- | Send a @'PullRequestStatus'@ for the original Pull Request
sendPullRequestStatus
    :: (HasLogFunc env, HasConfig env, HasPullRequest env, HasGitHub env)
    => PullRequestStatus
    -> RIO env ()
sendPullRequestStatus :: PullRequestStatus -> RIO env ()
sendPullRequestStatus status :: PullRequestStatus
status =
    (Config -> Bool) -> RIO env () -> RIO env ()
forall env.
HasConfig env =>
(Config -> Bool) -> RIO env () -> RIO env ()
whenConfig ((Statuses -> PullRequestStatus -> Bool
`shouldSendStatus` PullRequestStatus
status) (Statuses -> Bool) -> (Config -> Statuses) -> Config -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Statuses
cStatuses) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        PullRequest
pullRequest <- Getting PullRequest env PullRequest -> RIO env PullRequest
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PullRequest env PullRequest
forall env. HasPullRequest env => Lens' env PullRequest
pullRequestL
        PullRequest -> PullRequestStatus -> RIO env ()
forall env.
(HasLogFunc env, HasGitHub env) =>
PullRequest -> PullRequestStatus -> RIO env ()
createHeadShaStatus PullRequest
pullRequest PullRequestStatus
status

createHeadShaStatus
    :: (HasLogFunc env, HasGitHub env)
    => PullRequest
    -> PullRequestStatus
    -> RIO env ()
createHeadShaStatus :: PullRequest -> PullRequestStatus -> RIO env ()
createHeadShaStatus pullRequest :: PullRequest
pullRequest status :: PullRequestStatus
status = 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
$ "Setting status of " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
shortStatus Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> " for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
shortSha
    GenRequest 'MtJSON 'RW Status -> RIO env ()
forall env (m :: MediaType *) a (k :: RW).
(HasGitHub env, ParseResponse m a) =>
GenRequest m k a -> RIO env ()
runGitHub_ (GenRequest 'MtJSON 'RW Status -> RIO env ())
-> GenRequest 'MtJSON 'RW Status -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Name Owner
-> Name Repo
-> Name Commit
-> NewStatus
-> GenRequest 'MtJSON 'RW Status
createStatusR Name Owner
owner Name Repo
name Name Commit
sha (NewStatus -> GenRequest 'MtJSON 'RW Status)
-> NewStatus -> GenRequest 'MtJSON 'RW Status
forall a b. (a -> b) -> a -> b
$ PullRequestStatus -> NewStatus
statusToStatus PullRequestStatus
status
  where
    owner :: Name Owner
owner = HasCallStack => PullRequest -> Name Owner
PullRequest -> Name Owner
pullRequestOwnerName PullRequest
pullRequest
    name :: Name Repo
name = HasCallStack => PullRequest -> Name Repo
PullRequest -> Name Repo
pullRequestRepoName PullRequest
pullRequest
    sha :: Name Commit
sha = Proxy Commit -> Text -> Name Commit
forall (proxy :: * -> *) entity.
proxy entity -> Text -> Name entity
mkName Proxy Commit
forall k (t :: k). Proxy t
Proxy (Text -> Name Commit) -> Text -> Name Commit
forall a b. (a -> b) -> a -> b
$ PullRequest -> Text
pullRequestHeadSha PullRequest
pullRequest
    shortSha :: Utf8Builder
shortSha = String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take 7 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ PullRequest -> Text
pullRequestHeadSha PullRequest
pullRequest
    shortStatus :: Utf8Builder
shortStatus = case PullRequestStatus
status of
        NoDifferencesStatus _ -> "no differences"
        DifferencesStatus _ -> "differences"
        ErrorStatus _ -> "error"

shouldSendStatus :: Statuses -> PullRequestStatus -> Bool
shouldSendStatus :: Statuses -> PullRequestStatus -> Bool
shouldSendStatus Statuses {..} (NoDifferencesStatus _) = Bool
sNoDifferences
shouldSendStatus Statuses {..} (DifferencesStatus _) = Bool
sDifferences
shouldSendStatus Statuses {..} (ErrorStatus _) = Bool
sError

statusToStatus :: PullRequestStatus -> NewStatus
statusToStatus :: PullRequestStatus -> NewStatus
statusToStatus (NoDifferencesStatus mUrl :: Maybe URL
mUrl) = $WNewStatus :: StatusState -> Maybe URL -> Maybe Text -> Maybe Text -> NewStatus
NewStatus
    { newStatusState :: StatusState
newStatusState = StatusState
StatusSuccess
    , newStatusTargetUrl :: Maybe URL
newStatusTargetUrl = Maybe URL
mUrl
    , newStatusDescription :: Maybe Text
newStatusDescription = Text -> Maybe Text
forall a. a -> Maybe a
Just "No differences"
    , newStatusContext :: Maybe Text
newStatusContext = Text -> Maybe Text
forall a. a -> Maybe a
Just "restyled"
    }
statusToStatus (DifferencesStatus mUrl :: Maybe URL
mUrl) = $WNewStatus :: StatusState -> Maybe URL -> Maybe Text -> Maybe Text -> NewStatus
NewStatus
    { newStatusState :: StatusState
newStatusState = StatusState
StatusFailure
    , newStatusTargetUrl :: Maybe URL
newStatusTargetUrl = Maybe URL
mUrl
    , newStatusDescription :: Maybe Text
newStatusDescription = Text -> Maybe Text
forall a. a -> Maybe a
Just "Restyling found differences"
    , newStatusContext :: Maybe Text
newStatusContext = Text -> Maybe Text
forall a. a -> Maybe a
Just "restyled"
    }
statusToStatus (ErrorStatus url :: URL
url) = $WNewStatus :: StatusState -> Maybe URL -> Maybe Text -> Maybe Text -> NewStatus
NewStatus
    { newStatusState :: StatusState
newStatusState = StatusState
StatusError
    , newStatusTargetUrl :: Maybe URL
newStatusTargetUrl = URL -> Maybe URL
forall a. a -> Maybe a
Just URL
url
    , newStatusDescription :: Maybe Text
newStatusDescription = Text -> Maybe Text
forall a. a -> Maybe a
Just "Error restyling"
    , newStatusContext :: Maybe Text
newStatusContext = Text -> Maybe Text
forall a. a -> Maybe a
Just "restyled"
    }