{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Shell.Lib
    ( GeneralException (..)
    , CardanoApplication (..)
    , runCardanoApplicationWithFeatures
    ) where

import           Cardano.Prelude hiding (Handler, async, cancel, (%))
import           Prelude (Show (..))

import           Control.Concurrent.Classy.Async (async, cancel)
import qualified Control.Concurrent.Classy.Async as CA

import qualified Data.Text as Text

import           Formatting (bprint, build, formatToString, stext, (%))
import           Formatting.Buildable (Buildable (..))

import           Cardano.Shell.Types (CardanoApplication (..),
                                      CardanoFeature (..))

--------------------------------------------------------------------------------
-- General exceptions
--------------------------------------------------------------------------------

data GeneralException
    = UnknownFailureException -- the "catch-all"
    | FileNotFoundException FilePath
    | ConfigurationError Text
    deriving (GeneralException -> GeneralException -> Bool
(GeneralException -> GeneralException -> Bool)
-> (GeneralException -> GeneralException -> Bool)
-> Eq GeneralException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GeneralException -> GeneralException -> Bool
$c/= :: GeneralException -> GeneralException -> Bool
== :: GeneralException -> GeneralException -> Bool
$c== :: GeneralException -> GeneralException -> Bool
Eq)

instance Exception GeneralException

instance Buildable GeneralException where
    build :: GeneralException -> Builder
build GeneralException
UnknownFailureException               = Format Builder Builder -> Builder
forall a. Format Builder a -> a
bprint (Format Builder Builder
"Something went wrong and we don't know what.")
    build (FileNotFoundException String
filePath)      = Format Builder (Text -> Builder) -> Text -> Builder
forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"File not found on path '"Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
%Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stextFormat Builder (Text -> Builder)
-> Format Builder Builder -> Format Builder (Text -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
%Format Builder Builder
"'.") (String -> Text
Text.pack String
filePath)
    build (ConfigurationError Text
etext)            = Format Builder (Text -> Builder) -> Text -> Builder
forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Configuration error: "Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
%Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stextFormat Builder (Text -> Builder)
-> Format Builder Builder -> Format Builder (Text -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
%Format Builder Builder
".") Text
etext

-- | Instance so we can see helpful error messages when something goes wrong.
instance Show GeneralException where
    show :: GeneralException -> String
show = Format String (GeneralException -> String)
-> GeneralException -> String
forall a. Format String a -> a
formatToString Format String (GeneralException -> String)
forall a r. Buildable a => Format r (a -> r)
Formatting.build

--------------------------------------------------------------------------------
-- Feature initialization
--------------------------------------------------------------------------------

-- Here we run all the features.
-- A general pattern. The dependency is always in a new thread, and we depend on it,
-- so when that dependency gets shut down all the other features that depend on it get
-- shut down as well.
runCardanoApplicationWithFeatures
    :: forall m. MonadIO m
    => [CardanoFeature]
    -> CardanoApplication
    -> m ()
runCardanoApplicationWithFeatures :: [CardanoFeature] -> CardanoApplication -> m ()
runCardanoApplicationWithFeatures [CardanoFeature]
cardanoFeatures CardanoApplication
cardanoApplication = do

    -- We start all the new features.
    [Async IO ()]
asyncCardanoFeatures <- (CardanoFeature -> m (Async IO ()))
-> [CardanoFeature] -> m [Async IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO (Async IO ()) -> m (Async IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async IO ()) -> m (Async IO ()))
-> (CardanoFeature -> IO (Async IO ()))
-> CardanoFeature
-> m (Async IO ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO () -> IO (Async IO ())
forall (m :: * -> *) a. MonadConc m => m a -> m (Async m a)
async (IO () -> IO (Async IO ()))
-> (CardanoFeature -> IO ()) -> CardanoFeature -> IO (Async IO ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. CardanoFeature -> IO ()
CardanoFeature
-> forall (m :: * -> *). (MonadIO m, MonadConc m) => m ()
featureStart) [CardanoFeature]
cardanoFeatures

    -- Here we run the actual application.
    -- We presume that the control-flow is now in the hands of that function.
    -- An example of top-level-last-resort-error-handling-strategy.
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ CardanoApplication -> IO ()
runCardanoApplication CardanoApplication
cardanoApplication IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally`
        [Async IO ()] -> IO ()
forall a. [Async IO a] -> IO ()
cancelShutdownFeatures [Async IO ()]
asyncCardanoFeatures

  where
    -- | The cancel and shutdown of all the features.
    cancelShutdownFeatures :: [CA.Async IO a] -> IO ()
    cancelShutdownFeatures :: [Async IO a] -> IO ()
cancelShutdownFeatures [Async IO a]
asyncCardanoFeatures = do
        -- When we reach this point, we cancel all the features.
        [()]
_ <- (Async IO a -> IO ()) -> [Async IO a] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Async IO a -> IO ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel ([Async IO a] -> [Async IO a]
forall a. [a] -> [a]
reverse [Async IO a]
asyncCardanoFeatures)

        -- Then we cleanup all the features if we need to do so.
        [()]
_ <- (CardanoFeature -> IO ()) -> [CardanoFeature] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CardanoFeature -> IO ()
CardanoFeature
-> forall (m :: * -> *). (MonadIO m, MonadConc m) => m ()
featureShutdown ([CardanoFeature] -> [CardanoFeature]
forall a. [a] -> [a]
reverse [CardanoFeature]
cardanoFeatures)

        -- Closing
        () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()