{-# 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 (..))
data GeneralException
= UnknownFailureException
| 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 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
runCardanoApplicationWithFeatures
:: forall m. MonadIO m
=> [CardanoFeature]
-> CardanoApplication
-> m ()
runCardanoApplicationWithFeatures :: [CardanoFeature] -> CardanoApplication -> m ()
runCardanoApplicationWithFeatures [CardanoFeature]
cardanoFeatures CardanoApplication
cardanoApplication = do
[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
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
cancelShutdownFeatures :: [CA.Async IO a] -> IO ()
cancelShutdownFeatures :: [Async IO a] -> IO ()
cancelShutdownFeatures [Async IO a]
asyncCardanoFeatures = do
[()]
_ <- (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)
[()]
_ <- (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)
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()