{-# LANGUAGE LambdaCase #-}

module Restyler.App.Error
    ( AppError(..)
    , mapAppError
    , prettyAppError

    -- * Error handling
    , errorPullRequest
    , dieAppErrorHandlers

    -- * Lower-level helpers
    , warnIgnore
    )
where

import Restyler.Prelude

import qualified Data.Yaml as Yaml
import GitHub.Data (Error(..))
import GitHub.Request.Display
import Restyler.App.Class
import Restyler.Config
import Restyler.Options
import Restyler.PullRequest
import Restyler.PullRequest.Status
import Restyler.Restyler (Restyler(..))
import System.IO (hPutStrLn)
import Text.Wrap

data AppError
    = PullRequestFetchError Error
    -- ^ We couldn't fetch the @'PullRequest'@ to restyle
    | PullRequestCloneError IOException
    -- ^ We couldn't clone or checkout the PR's branch
    | ConfigurationError ConfigError
    -- ^ We couldn't load a @.restyled.yaml@
    | RestylerExitFailure Restyler Int [FilePath]
    -- ^ A Restyler we ran exited non-zero on the given paths
    | RestyleError Text
    -- ^ Unable to Restyle for a known reason (given as user-facing message)
    | GitHubError DisplayGitHubRequest Error
    -- ^ We encountered a GitHub API error during restyling
    | SystemError IOException
    -- ^ Trouble reading a file or etc
    | HttpError IOException
    -- ^ Trouble performing some HTTP request
    | OtherError SomeException
    -- ^ Escape hatch for anything else
    deriving Int -> AppError -> ShowS
[AppError] -> ShowS
AppError -> String
(Int -> AppError -> ShowS)
-> (AppError -> String) -> ([AppError] -> ShowS) -> Show AppError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AppError] -> ShowS
$cshowList :: [AppError] -> ShowS
show :: AppError -> String
$cshow :: AppError -> String
showsPrec :: Int -> AppError -> ShowS
$cshowsPrec :: Int -> AppError -> ShowS
Show

instance Exception AppError

-- | Run a computation, and modify any thrown exceptions to @'AppError'@s
mapAppError :: (MonadUnliftIO m, Exception e) => (e -> AppError) -> m a -> m a
mapAppError :: (e -> AppError) -> m a -> m a
mapAppError f :: e -> AppError
f = (e -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle ((e -> m a) -> m a -> m a) -> (e -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ AppError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (AppError -> m a) -> (e -> AppError) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> AppError
f

prettyAppError :: AppError -> String
prettyAppError :: AppError -> String
prettyAppError =
    String -> String -> ShowS
forall a. (Semigroup a, IsString a) => a -> a -> a -> a
format (String -> String -> ShowS)
-> (AppError -> String) -> AppError -> String -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppError -> String
toErrorTitle (AppError -> String -> ShowS)
-> (AppError -> String) -> AppError -> ShowS
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppError -> String
toErrorBody (AppError -> ShowS) -> (AppError -> String) -> AppError -> String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppError -> String
toErrorDocumentation
    where format :: a -> a -> a -> a
format title :: a
title body :: a
body docs :: a
docs = a
title a -> a -> a
forall a. Semigroup a => a -> a -> a
<> ":\n\n" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
body a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
docs

toErrorTitle :: AppError -> String
toErrorTitle :: AppError -> String
toErrorTitle = ShowS
trouble ShowS -> (AppError -> String) -> AppError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    PullRequestFetchError _ -> "fetching your Pull Request from GitHub"
    PullRequestCloneError _ -> "cloning your Pull Request branch"
    ConfigurationError _ -> "with your configuration"
    RestylerExitFailure r :: Restyler
r _ _ -> "with the " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Restyler -> String
rName Restyler
r String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " restyler"
    RestyleError _ -> "restyling"
    GitHubError _ _ -> "communicating with GitHub"
    SystemError _ -> "running a system command"
    HttpError _ -> "performing an HTTP request"
    OtherError _ -> "with something unexpected"
    where trouble :: ShowS
trouble = ("We had trouble " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)

toErrorBody :: AppError -> String
toErrorBody :: AppError -> String
toErrorBody = ShowS
reflow ShowS -> (AppError -> String) -> AppError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    PullRequestFetchError e :: Error
e -> Error -> String
showGitHubError Error
e
    PullRequestCloneError e :: IOException
e -> IOException -> String
forall a. Show a => a -> String
show IOException
e
    ConfigurationError (ConfigErrorInvalidYaml yaml :: ByteString
yaml e :: ParseException
e) -> [String] -> String
unlines
        [ "Yaml parse exception:"
        , ParseException -> String
Yaml.prettyPrintParseException ParseException
e
        , ""
        , "Original input:"
        , Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
yaml
        ]
    ConfigurationError (ConfigErrorInvalidRestylers errs :: [String]
errs) -> [String] -> String
unlines [String]
errs
    ConfigurationError (ConfigErrorInvalidRestylersYaml e :: SomeException
e) -> [String] -> String
unlines
        [ "Error loading restylers.yaml definition:"
        , SomeException -> String
forall a. Show a => a -> String
show SomeException
e
        , ""
        , "==="
        , ""
        , "This could be caused by an invalid or too-old restylers_version in"
        , "your configuration. Consider removing or updating it."
        , ""
        , "If that's not the case, this is a bug in our system that we are"
        , "hopefully already working to fix."
        ]
    RestylerExitFailure _ s :: Int
s paths :: [String]
paths ->
        "Exited non-zero ("
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
s
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ") for the following paths, "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
paths
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "."
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "\nError information may be present in the stderr output above."
    RestyleError msg :: Text
msg -> Text -> String
unpack Text
msg
    GitHubError req :: DisplayGitHubRequest
req e :: Error
e -> "Request: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DisplayGitHubRequest -> String
forall a. Show a => a -> String
show DisplayGitHubRequest
req String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Error -> String
showGitHubError Error
e
    SystemError e :: IOException
e -> IOException -> String
forall a. Show a => a -> String
show IOException
e
    HttpError e :: IOException
e -> IOException -> String
forall a. Show a => a -> String
show IOException
e
    OtherError e :: SomeException
e -> SomeException -> String
forall a. Show a => a -> String
show SomeException
e

toErrorDocumentation :: AppError -> String
toErrorDocumentation :: AppError -> String
toErrorDocumentation = [String] -> String
formatDocs ([String] -> String)
-> (AppError -> [String]) -> AppError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    ConfigurationError ConfigErrorInvalidRestylersYaml{} ->
        ["https://github.com/restyled-io/restyled.io/wiki/Restyler-Versions"]
    ConfigurationError _ ->
        [ "https://github.com/restyled-io/restyled.io/wiki/Common-Errors:-.restyled.yaml"
        ]
    RestylerExitFailure r :: Restyler
r _ _ -> Restyler -> [String]
rDocumentation Restyler
r
    RestyleError _ ->
        [ "https://github.com/restyled-io/restyled.io/wiki/Common-Errors:-Restyle-Error"
        ]
    _ -> []
  where
    formatDocs :: [String] -> String
formatDocs [] = "\n"
    formatDocs [url :: String
url] = "\nPlease see " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
url String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "\n"
    formatDocs urls :: [String]
urls = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ "\nPlease see" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("  - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [String]
urls

showGitHubError :: Error -> String
showGitHubError :: Error -> String
showGitHubError = \case
    HTTPError e :: HttpException
e -> "HTTP exception: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HttpException -> String
forall a. Show a => a -> String
show HttpException
e
    ParseError e :: Text
e -> "Unable to parse response: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
e
    JsonError e :: Text
e -> "Malformed response: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
e
    UserError e :: Text
e -> "User error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
e

reflow :: String -> String
reflow :: ShowS
reflow = ShowS
indent ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
wrap
  where
    indent :: ShowS
indent = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    wrap :: ShowS
wrap = Text -> String
unpack (Text -> String) -> (String -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapSettings -> Int -> Text -> Text
wrapText WrapSettings
wrapSettings 80 (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
    wrapSettings :: WrapSettings
wrapSettings =
        WrapSettings :: Bool -> Bool -> WrapSettings
WrapSettings { preserveIndentation :: Bool
preserveIndentation = Bool
True, breakLongWords :: Bool
breakLongWords = Bool
False }

-- | Error the original @'PullRequest'@ and re-throw the exception
errorPullRequest
    :: ( HasLogFunc env
       , HasOptions env
       , HasConfig env
       , HasPullRequest env
       , HasGitHub env
       )
    => SomeException
    -> RIO env ()
errorPullRequest :: SomeException -> RIO env ()
errorPullRequest = (SomeException -> RIO env ()) -> SomeException -> RIO env ()
forall (f :: * -> *).
Applicative f =>
(SomeException -> f ()) -> SomeException -> f ()
exceptExit ((SomeException -> RIO env ()) -> SomeException -> RIO env ())
-> (SomeException -> RIO env ()) -> SomeException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \ex :: SomeException
ex -> do
    Maybe URL
mJobUrl <- Options -> Maybe URL
oJobUrl (Options -> Maybe URL) -> RIO env Options -> RIO env (Maybe URL)
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
    (URL -> RIO env ()) -> Maybe URL -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ URL -> RIO env ()
forall env.
(HasLogFunc env, HasConfig env, HasPullRequest env,
 HasGitHub env) =>
URL -> RIO env ()
errorPullRequestUrl Maybe URL
mJobUrl
    SomeException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
ex

-- | Actually error the @'PullRequest'@, given the job-url to link to
errorPullRequestUrl
    :: (HasLogFunc env, HasConfig env, HasPullRequest env, HasGitHub env)
    => URL
    -> RIO env ()
errorPullRequestUrl :: URL -> RIO env ()
errorPullRequestUrl url :: URL
url =
    (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
$ PullRequestStatus -> RIO env ()
forall env.
(HasLogFunc env, HasConfig env, HasPullRequest env,
 HasGitHub env) =>
PullRequestStatus -> RIO env ()
sendPullRequestStatus (PullRequestStatus -> RIO env ())
-> PullRequestStatus -> RIO env ()
forall a b. (a -> b) -> a -> b
$ URL -> PullRequestStatus
ErrorStatus URL
url

-- | Ignore an exception, warning about it.
warnIgnore :: (Display a, HasLogFunc env) => a -> RIO env ()
warnIgnore :: a -> RIO env ()
warnIgnore ex :: a
ex = Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Caught " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
ex Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ", ignoring."

-- | Error handlers for overall execution
--
-- Usage:
--
-- > {- main routine -} `catches` dieAppErrorHandlers
--
-- Ensures __all__ exceptions (besides @'ExitCode'@s) go through:
--
-- @
-- 'dieAppError'
-- @
--
dieAppErrorHandlers :: [Handler IO ()]
dieAppErrorHandlers :: [Handler IO ()]
dieAppErrorHandlers =
    [(AppError -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler AppError -> IO ()
forall a. AppError -> IO a
dieAppError, (SomeException -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeException -> IO ()) -> Handler IO ())
-> (SomeException -> IO ()) -> Handler IO ()
forall a b. (a -> b) -> a -> b
$ (SomeException -> IO ()) -> SomeException -> IO ()
forall (f :: * -> *).
Applicative f =>
(SomeException -> f ()) -> SomeException -> f ()
exceptExit ((SomeException -> IO ()) -> SomeException -> IO ())
-> (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ AppError -> IO ()
forall a. AppError -> IO a
dieAppError (AppError -> IO ())
-> (SomeException -> AppError) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> AppError
OtherError]

dieAppError :: AppError -> IO a
dieAppError :: AppError -> IO a
dieAppError e :: AppError
e = do
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ AppError -> String
prettyAppError AppError
e
    ExitCode -> IO a
forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith (ExitCode -> IO a) -> ExitCode -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure (Int -> ExitCode) -> Int -> ExitCode
forall a b. (a -> b) -> a -> b
$ case AppError
e of
        ConfigurationError ConfigErrorInvalidYaml{} -> 10
        ConfigurationError ConfigErrorInvalidRestylers{} -> 11
        ConfigurationError ConfigErrorInvalidRestylersYaml{} -> 12
        RestylerExitFailure{} -> 20
        RestyleError{} -> 25
        GitHubError{} -> 30
        PullRequestFetchError{} -> 31
        PullRequestCloneError{} -> 32
        HttpError{} -> 40
        SystemError{} -> 50
        OtherError{} -> 99

exceptExit :: Applicative f => (SomeException -> f ()) -> SomeException -> f ()
exceptExit :: (SomeException -> f ()) -> SomeException -> f ()
exceptExit f :: SomeException -> f ()
f ex :: SomeException
ex = f () -> (ExitCode -> f ()) -> Maybe ExitCode -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SomeException -> f ()
f SomeException
ex) ExitCode -> f ()
forall (f :: * -> *). Applicative f => ExitCode -> f ()
ignore (Maybe ExitCode -> f ()) -> Maybe ExitCode -> f ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex
  where
    ignore :: Applicative f => ExitCode -> f ()
    ignore :: ExitCode -> f ()
ignore _ = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()