{-# LANGUAGE TypeApplications #-}

module DMQ.Handlers.TopLevel (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 Control.Exception
import Control.Monad.Class.MonadAsync (ExceptionInLinkedThread (..))
import System.Environment
import System.Exit
import System.IO

import Ouroboros.Network.Diffusion qualified as Network


-- | 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
      , (Failure -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler Failure -> IO a
forall a. Failure -> IO a
handleDiffusionError
      , (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. If a linked thread throws ExitSuccess,
    -- then we rethrow ExitSuccess.
    rethrowAsyncExceptions :: SomeAsyncException -> IO a
    rethrowAsyncExceptions :: forall a. SomeAsyncException -> IO a
rethrowAsyncExceptions full :: SomeAsyncException
full@(SomeAsyncException e
e) =
      case SomeException -> Maybe ExceptionInLinkedThread
forall e. Exception e => SomeException -> Maybe e
fromException (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e) of
        Just (ExceptionInLinkedThread String
_ SomeException
eInner)
          | Just ExitCode
ExitSuccess <- SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
eInner
          -> ExitCode -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ExitCode
ExitSuccess
        Maybe ExceptionInLinkedThread
_ -> SomeAsyncException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeAsyncException
full

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

    -- Handle errors thrown by the diffusion.
    handleDiffusionError :: Network.Failure -> IO a
    handleDiffusionError :: forall a. Failure -> IO a
handleDiffusionError Failure
full =
      case Failure
full of
        Network.DiffusionError SomeException
e
          | Just SomeAsyncException
e' <- forall e. Exception e => SomeException -> Maybe e
fromException @SomeAsyncException SomeException
e
          -> SomeAsyncException -> IO a
forall a. SomeAsyncException -> IO a
rethrowAsyncExceptions SomeAsyncException
e'

          | Just ExitCode
e' <- forall e. Exception e => SomeException -> Maybe e
fromException @ExitCode SomeException
e
          -> ExitCode -> IO a
forall a. ExitCode -> IO a
rethrowExitCode ExitCode
e'

        Failure
_ -> Failure -> IO a
forall e a. Exception e => e -> IO a
handleException Failure
full

    -- Print all other exceptions
    handleSomeException :: SomeException -> IO a
    handleSomeException :: forall a. SomeException -> IO a
handleSomeException = SomeException -> IO a
forall e a. Exception e => e -> IO a
handleException

    --
    -- utils
    --

    -- A helper function to handle an exception.
    handleException :: Exception e => e -> IO a
    handleException :: forall e a. Exception e => e -> IO a
handleException e
e = do
      Handle -> IO ()
hFlush Handle
stdout
      progname <- IO String
getProgName
      hPutStr stderr (renderException 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.
    renderException :: Exception e => String -> e -> String
    renderException :: forall e. Exception e => String -> e -> String
renderException String
progname e
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    = e -> String
forall a. Show a => a -> String
show e
e
        displayOutput :: String
displayOutput = e -> String
forall e. Exception e => e -> String
displayException e
e