module Bcc.CLI.TopHandler
  ( toplevelExceptionHandler
  ) where

-- The code in this module derives from multiple authors over many years.
-- It is all under the BSD3 license below.
--
-- Copyright (c) 2021 The-Blockchain-Company
--               2017 Edward Z. Yang
--               2015 Edsko de Vries
--               2009 Duncan Coutts
--               2007 Galois Inc.
--               2003 Entropic Jones, Simon Marlow
--
-- Copyright (c) 2003-2017, Cabal Development Team.
-- See the AUTHORS file for the full list of copyright holders.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     * Redistributions in binary form must reproduce the above
--       copyright notice, this list of conditions and the following
--       disclaimer in the documentation and/or other materials provided
--       with the distribution.
--
--     * Neither the name of Entropic Jones nor the names of other
--       contributors may be used to endorse or promote products derived
--       from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

import           Prelude

import           Control.Exception

import           System.Environment
import           System.Exit
import           System.IO


-- | An exception handler to use for a program top level, as an alternative to
-- the default top level handler provided by GHC.
--
-- Use like:
--
-- > main :: IO ()
-- > main = toplevelExceptionHandler $ do
-- >   ...
--
toplevelExceptionHandler :: IO a -> IO a
toplevelExceptionHandler :: IO a -> IO a
toplevelExceptionHandler IO a
prog = do
    -- Use line buffering in case we have to print big error messages, because
    -- by default stderr to a terminal device is NoBuffering which is slow.
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
    IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
catches IO a
prog [
        (SomeAsyncException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler SomeAsyncException -> IO a
forall a. SomeAsyncException -> IO a
rethrowAsyncExceptions
      , (ExitCode -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ExitCode -> IO a
forall a. ExitCode -> IO a
rethrowExitCode
      , (SomeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler SomeException -> IO a
forall a. SomeException -> IO a
handleSomeException
      ]
  where
    -- Let async exceptions rise to the top for the default GHC top-handler.
    -- This includes things like CTRL-C.
    rethrowAsyncExceptions :: SomeAsyncException -> IO a
    rethrowAsyncExceptions :: SomeAsyncException -> IO a
rethrowAsyncExceptions = SomeAsyncException -> IO a
forall e a. Exception e => e -> IO a
throwIO

    -- We don't want to print ExitCode, and it should be handled by the default
    -- top handler because that sets the actual OS process exit code.
    rethrowExitCode :: ExitCode -> IO a
    rethrowExitCode :: ExitCode -> IO a
rethrowExitCode = ExitCode -> IO a
forall e a. Exception e => e -> IO a
throwIO

    -- Print all other exceptions
    handleSomeException :: SomeException -> IO a
    handleSomeException :: SomeException -> IO a
handleSomeException SomeException
e = do
      Handle -> IO ()
hFlush Handle
stdout
      String
progname <- IO String
getProgName
      Handle -> String -> IO ()
hPutStr Handle
stderr (String -> SomeException -> String
renderSomeException String
progname SomeException
e)
      ExitCode -> IO a
forall e a. Exception e => e -> IO a
throwIO (Int -> ExitCode
ExitFailure Int
1)

    -- Print the human-readable output of 'displayException' if it differs
    -- from the default output (of 'show'), so that the user/sysadmin
    -- sees something readable in the log.
    renderSomeException :: String -> SomeException -> String
    renderSomeException :: String -> SomeException -> String
renderSomeException String
progname SomeException
e
      | String
showOutput String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
displayOutput
      = String
showOutput String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
progname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
displayOutput

      | Bool
otherwise
      = String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
progname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showOutput
      where
        showOutput :: String
showOutput    = SomeException -> String
forall a. Show a => a -> String
show SomeException
e
        displayOutput :: String
displayOutput = SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e