module Cardano.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) 2019 Input Output Global Inc (IOG).
--               2017 Edward Z. Yang
--               2015 Edsko de Vries
--               2009 Duncan Coutts
--               2007 Galois Inc.
--               2003 Isaac 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 Isaac 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 :: forall a. 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 :: forall a. SomeAsyncException -> IO a
rethrowAsyncExceptions = SomeAsyncException -> IO a
forall e a. (HasCallStack, 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 :: forall a. ExitCode -> IO a
rethrowExitCode = ExitCode -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO

  -- Print all other exceptions
  handleSomeException :: SomeException -> IO a
  handleSomeException :: forall a. SomeException -> IO a
handleSomeException SomeException
e = do
    Handle -> IO ()
hFlush Handle
stdout
    progname <- IO [Char]
getProgName
    hPutStr stderr (renderSomeException progname e)
    throwIO (ExitFailure 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 :: [Char] -> SomeException -> [Char]
renderSomeException [Char]
progname SomeException
e
    | [Char]
showOutput [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
displayOutput =
        [Char]
showOutput [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
progname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
displayOutput
    | Bool
otherwise =
        [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
progname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
showOutput
   where
    showOutput :: [Char]
showOutput = SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
    displayOutput :: [Char]
displayOutput = SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
e