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
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