module Restyler.Setup
    ( restylerSetup
    )
where

import Restyler.Prelude

import qualified Data.Yaml as Yaml
import GitHub.Endpoints.PullRequests
import Restyler.App.Class
import Restyler.App.Error
import Restyler.Config
import Restyler.Git
import Restyler.Options
import Restyler.PullRequest
import Restyler.RestyledPullRequest
-- import Restyler.PullRequest.Restyled
-- import Restyler.PullRequestSpec

restylerSetup
    :: ( HasCallStack
       , HasLogFunc env
       , HasOptions env
       , HasWorkingDirectory env
       , HasSystem env
       , HasExit env
       , HasProcess env
       , HasDownloadFile env
       , HasGitHub env
       )
    => RIO env (PullRequest, Maybe RestyledPullRequest, Config)
restylerSetup :: RIO env (PullRequest, Maybe RestyledPullRequest, Config)
restylerSetup = do
    Options {..} <- Getting Options env Options -> RIO env Options
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Options env Options
forall env. HasOptions env => Lens' env Options
optionsL

    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "Restyler starting"
    PullRequest
pullRequest <-
        (AppError -> AppError)
-> RIO env PullRequest -> RIO env PullRequest
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> AppError) -> m a -> m a
mapAppError AppError -> AppError
toPullRequestFetchError (RIO env PullRequest -> RIO env PullRequest)
-> RIO env PullRequest -> RIO env PullRequest
forall a b. (a -> b) -> a -> b
$ GenRequest 'MtJSON Any PullRequest -> RIO env PullRequest
forall env (m :: MediaType *) a (k :: RW).
(HasGitHub env, ParseResponse m a) =>
GenRequest m k a -> RIO env a
runGitHub (GenRequest 'MtJSON Any PullRequest -> RIO env PullRequest)
-> GenRequest 'MtJSON Any PullRequest -> RIO env PullRequest
forall a b. (a -> b) -> a -> b
$ Name Owner
-> Name Repo -> IssueNumber -> GenRequest 'MtJSON Any PullRequest
forall (k :: RW).
Name Owner -> Name Repo -> IssueNumber -> Request k PullRequest
pullRequestR
            Name Owner
oOwner
            Name Repo
oRepo
            IssueNumber
oPullRequest

    Maybe RestyledPullRequest
mRestyledPullRequest <- PullRequest -> RIO env (Maybe RestyledPullRequest)
forall env.
HasGitHub env =>
PullRequest -> RIO env (Maybe RestyledPullRequest)
findRestyledPullRequest PullRequest
pullRequest

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PullRequest -> Bool
pullRequestIsClosed PullRequest
pullRequest) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        (RestyledPullRequest -> RIO env ())
-> Maybe RestyledPullRequest -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ RestyledPullRequest -> RIO env ()
forall env.
(HasLogFunc env, HasGitHub env) =>
RestyledPullRequest -> RIO env ()
closeRestyledPullRequest Maybe RestyledPullRequest
mRestyledPullRequest
        Utf8Builder -> RIO env ()
forall env a.
(HasLogFunc env, HasExit env) =>
Utf8Builder -> RIO env a
exitWithInfo "Source Pull Request is closed"

    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "Cloning repository"
    PullRequest -> RIO env ()
forall env.
(HasCallStack, HasOptions env, HasWorkingDirectory env,
 HasSystem env, HasProcess env) =>
PullRequest -> RIO env ()
setupClone PullRequest
pullRequest

    Config
config <- (ConfigError -> AppError) -> RIO env Config -> RIO env Config
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> AppError) -> m a -> m a
mapAppError ConfigError -> AppError
ConfigurationError RIO env Config
forall env.
(HasLogFunc env, HasSystem env, HasDownloadFile env) =>
RIO env Config
loadConfig
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
cEnabled Config
config) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall env a.
(HasLogFunc env, HasExit env) =>
Utf8Builder -> RIO env a
exitWithInfo "Restyler disabled by config"

    Vector (Name IssueLabel)
labels <- PullRequest -> RIO env (Vector (Name IssueLabel))
forall env.
HasGitHub env =>
PullRequest -> RIO env (Vector (Name IssueLabel))
getPullRequestLabelNames PullRequest
pullRequest
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Vector (Name IssueLabel)
labels Vector (Name IssueLabel) -> Set (Name IssueLabel) -> Bool
forall (t1 :: * -> *) (t2 :: * -> *) a.
(Foldable t1, Foldable t2, Ord a) =>
t1 a -> t2 a -> Bool
`intersects` Config -> Set (Name IssueLabel)
cIgnoreLabels Config
config)
        (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall env a.
(HasLogFunc env, HasExit env) =>
Utf8Builder -> RIO env a
exitWithInfo "Ignoring PR based on its labels"

    case Maybe RestyledPullRequest
mRestyledPullRequest of
        Nothing -> do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "No existing Restyled PR"
            FilePath -> RIO env ()
forall env. HasProcess env => FilePath -> RIO env ()
gitCheckout (FilePath -> RIO env ()) -> FilePath -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ PullRequest -> Text
pullRequestRestyledHeadRef PullRequest
pullRequest
        Just pr :: RestyledPullRequest
pr -> 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
$ "Existing Restyled PR is " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RestyledPullRequest -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RestyledPullRequest
pr
            FilePath -> RIO env ()
forall env. HasProcess env => FilePath -> RIO env ()
gitCheckout (FilePath -> RIO env ()) -> FilePath -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ RestyledPullRequest -> Text
restyledPullRequestHeadRef RestyledPullRequest
pr

    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
$ "Restyling " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PullRequest -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PullRequest
pullRequest
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Config -> Utf8Builder
displayConfigYaml Config
config
    (PullRequest, Maybe RestyledPullRequest, Config)
-> RIO env (PullRequest, Maybe RestyledPullRequest, Config)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PullRequest
pullRequest, Maybe RestyledPullRequest
mRestyledPullRequest, Config
config)

displayConfigYaml :: Config -> Utf8Builder
displayConfigYaml :: Config -> Utf8Builder
displayConfigYaml =
    FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString
        (FilePath -> Utf8Builder)
-> (Config -> FilePath) -> Config -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
unpack
        (Text -> FilePath) -> (Config -> Text) -> Config -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("Resolved configuration\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
        (Text -> Text) -> (Config -> Text) -> Config -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8
        (ByteString -> Text) -> (Config -> ByteString) -> Config -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode

setupClone
    :: ( HasCallStack
       , HasOptions env
       , HasWorkingDirectory env
       , HasSystem env
       , HasProcess env
       )
    => PullRequest
    -> RIO env ()
setupClone :: PullRequest -> RIO env ()
setupClone pullRequest :: PullRequest
pullRequest = (AppError -> AppError) -> RIO env () -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> AppError) -> m a -> m a
mapAppError AppError -> AppError
toPullRequestCloneError (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath
dir <- Getting FilePath env FilePath -> RIO env FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath env FilePath
forall env. HasWorkingDirectory env => Lens' env FilePath
workingDirectoryL
    Text
token <- Options -> Text
oAccessToken (Options -> Text) -> RIO env Options -> RIO env Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting Options env Options -> RIO env Options
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Options env Options
forall env. HasOptions env => Lens' env Options
optionsL

    let cloneUrl :: FilePath
cloneUrl = Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> PullRequest -> Text
Text -> PullRequest -> Text
pullRequestCloneUrlToken Text
token PullRequest
pullRequest
    FilePath -> FilePath -> RIO env ()
forall env. HasProcess env => FilePath -> FilePath -> RIO env ()
gitClone FilePath
cloneUrl FilePath
dir
    FilePath -> RIO env ()
forall env. HasSystem env => FilePath -> RIO env ()
setCurrentDirectory FilePath
dir

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PullRequest -> Bool
pullRequestIsNonDefaultBranch PullRequest
pullRequest) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> RIO env ()
forall env. HasProcess env => FilePath -> FilePath -> RIO env ()
gitFetch
        (Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ PullRequest -> Text
pullRequestBaseRef PullRequest
pullRequest)
        (Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ PullRequest -> Text
pullRequestBaseRef PullRequest
pullRequest)

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PullRequest -> Bool
pullRequestIsFork PullRequest
pullRequest) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> RIO env ()
forall env. HasProcess env => FilePath -> FilePath -> RIO env ()
gitFetch
        (Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ PullRequest -> Text
pullRequestRemoteHeadRef PullRequest
pullRequest)
        (Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ PullRequest -> Text
pullRequestLocalHeadRef PullRequest
pullRequest)

    FilePath -> RIO env ()
forall env. HasProcess env => FilePath -> RIO env ()
gitCheckoutExisting (FilePath -> RIO env ()) -> FilePath -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ PullRequest -> Text
pullRequestLocalHeadRef PullRequest
pullRequest

toPullRequestFetchError :: AppError -> AppError
toPullRequestFetchError :: AppError -> AppError
toPullRequestFetchError (GitHubError _ e :: Error
e) = Error -> AppError
PullRequestFetchError Error
e
toPullRequestFetchError e :: AppError
e = AppError
e

toPullRequestCloneError :: AppError -> AppError
toPullRequestCloneError :: AppError -> AppError
toPullRequestCloneError (SystemError e :: IOException
e) = IOException -> AppError
PullRequestCloneError IOException
e
toPullRequestCloneError e :: AppError
e = AppError
e