{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.Helpers
  ( HelpersError (..)
  , printWarning
  , deprecationWarning
  , ensureNewFile
  , ensureNewFileLBS
  , pPrintCBOR
  , readCBOR
  , renderHelpersError
  , validateCBOR
  , printEraDeprecationWarning
  )
where

import           Cardano.Api (AnyCardanoEra (..), CardanoEra (ConwayEra), ToCardanoEra (..))
import qualified Cardano.Api.Ledger as L

import           Cardano.Chain.Block (decCBORABlockOrBoundary)
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Chain.UTxO as UTxO
import           Cardano.CLI.Pretty (Doc, pretty, pshow)
import           Cardano.CLI.Types.Common

import           Codec.CBOR.Pretty (prettyHexEnc)
import           Codec.CBOR.Read (DeserialiseFailure, deserialiseFromBytes)
import           Codec.CBOR.Term (decodeTerm, encodeTerm)
import           Control.Exception (Exception (..), IOException)
import           Control.Monad (unless, when)
import           Control.Monad.IO.Class (MonadIO (..))
import           Control.Monad.Trans.Except (ExceptT)
import           Control.Monad.Trans.Except.Extra (handleIOExceptT, left)
import           Data.Bifunctor (Bifunctor (..))
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB
import           Data.Functor (void)
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import           Data.Typeable (Typeable)
import qualified System.Console.ANSI as ANSI
import           System.Console.ANSI
import qualified System.Directory as IO
import qualified System.IO as IO

data HelpersError
  = CBORPrettyPrintError !DeserialiseFailure
  | CBORDecodingError !DeserialiseFailure
  | IOError' !FilePath !IOException
  | OutputMustNotAlreadyExist FilePath
  | ReadCBORFileFailure !FilePath !Text
  deriving Int -> HelpersError -> ShowS
[HelpersError] -> ShowS
HelpersError -> String
(Int -> HelpersError -> ShowS)
-> (HelpersError -> String)
-> ([HelpersError] -> ShowS)
-> Show HelpersError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HelpersError -> ShowS
showsPrec :: Int -> HelpersError -> ShowS
$cshow :: HelpersError -> String
show :: HelpersError -> String
$cshowList :: [HelpersError] -> ShowS
showList :: [HelpersError] -> ShowS
Show

renderHelpersError :: HelpersError -> Doc ann
renderHelpersError :: forall ann. HelpersError -> Doc ann
renderHelpersError = \case
  OutputMustNotAlreadyExist String
fp ->
    Doc ann
"Output file/directory must not already exist: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fp
  ReadCBORFileFailure String
fp Text
err' ->
    Doc ann
"CBOR read failure at: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fp Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow Text
err'
  CBORPrettyPrintError DeserialiseFailure
err' ->
    Doc ann
"Error with CBOR decoding: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> DeserialiseFailure -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow DeserialiseFailure
err'
  CBORDecodingError DeserialiseFailure
err' ->
    Doc ann
"Error with CBOR decoding: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> DeserialiseFailure -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow DeserialiseFailure
err'
  IOError' String
fp IOException
ioE ->
    Doc ann
"Error at: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fp Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" Error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IOException -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow IOException
ioE

decodeCBOR
  :: LB.ByteString
  -> (forall s. L.Decoder s a)
  -> Either HelpersError (LB.ByteString, a)
decodeCBOR :: forall a.
ByteString
-> (forall s. Decoder s a) -> Either HelpersError (ByteString, a)
decodeCBOR ByteString
bs forall s. Decoder s a
decoder =
  (DeserialiseFailure -> HelpersError)
-> Either DeserialiseFailure (ByteString, a)
-> Either HelpersError (ByteString, a)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DeserialiseFailure -> HelpersError
CBORDecodingError (Either DeserialiseFailure (ByteString, a)
 -> Either HelpersError (ByteString, a))
-> Either DeserialiseFailure (ByteString, a)
-> Either HelpersError (ByteString, a)
forall a b. (a -> b) -> a -> b
$ (forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s a
forall s. Decoder s a
decoder ByteString
bs

printWarning :: MonadIO m => String -> m ()
printWarning :: forall (m :: * -> *). MonadIO m => String -> m ()
printWarning String
warning = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Handle -> [SGR] -> IO ()
ANSI.hSetSGR Handle
IO.stderr [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Yellow]
  Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
warning
  Handle -> [SGR] -> IO ()
ANSI.hSetSGR Handle
IO.stderr [SGR
Reset]
  -- We need to flush, or otherwise what's on stdout may have the wrong colour
  -- since it's likely sharing a console with stderr
  Handle -> IO ()
IO.hFlush Handle
IO.stderr

deprecationWarning :: String -> IO ()
deprecationWarning :: String -> IO ()
deprecationWarning String
cmd =
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
printWarning (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"This CLI command is deprecated.  Please use " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cmd String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" command instead."

-- | Checks if a path exists and throws and error if it does.
ensureNewFile :: (FilePath -> a -> IO ()) -> FilePath -> a -> ExceptT HelpersError IO ()
ensureNewFile :: forall a.
(String -> a -> IO ()) -> String -> a -> ExceptT HelpersError IO ()
ensureNewFile String -> a -> IO ()
writer String
outFile a
blob = do
  Bool
exists <- IO Bool -> ExceptT HelpersError IO Bool
forall a. IO a -> ExceptT HelpersError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT HelpersError IO Bool)
-> IO Bool -> ExceptT HelpersError IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
IO.doesPathExist String
outFile
  Bool -> ExceptT HelpersError IO () -> ExceptT HelpersError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (ExceptT HelpersError IO () -> ExceptT HelpersError IO ())
-> ExceptT HelpersError IO () -> ExceptT HelpersError IO ()
forall a b. (a -> b) -> a -> b
$
    HelpersError -> ExceptT HelpersError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (HelpersError -> ExceptT HelpersError IO ())
-> HelpersError -> ExceptT HelpersError IO ()
forall a b. (a -> b) -> a -> b
$
      String -> HelpersError
OutputMustNotAlreadyExist String
outFile
  IO () -> ExceptT HelpersError IO ()
forall a. IO a -> ExceptT HelpersError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT HelpersError IO ())
-> IO () -> ExceptT HelpersError IO ()
forall a b. (a -> b) -> a -> b
$ String -> a -> IO ()
writer String
outFile a
blob

ensureNewFileLBS :: FilePath -> ByteString -> ExceptT HelpersError IO ()
ensureNewFileLBS :: String -> ByteString -> ExceptT HelpersError IO ()
ensureNewFileLBS = (String -> ByteString -> IO ())
-> String -> ByteString -> ExceptT HelpersError IO ()
forall a.
(String -> a -> IO ()) -> String -> a -> ExceptT HelpersError IO ()
ensureNewFile String -> ByteString -> IO ()
BS.writeFile

pPrintCBOR :: LB.ByteString -> ExceptT HelpersError IO ()
pPrintCBOR :: ByteString -> ExceptT HelpersError IO ()
pPrintCBOR ByteString
bs = do
  case (forall s. Decoder s Term)
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s Term
forall s. Decoder s Term
decodeTerm ByteString
bs of
    Left DeserialiseFailure
err -> HelpersError -> ExceptT HelpersError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (HelpersError -> ExceptT HelpersError IO ())
-> HelpersError -> ExceptT HelpersError IO ()
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure -> HelpersError
CBORPrettyPrintError DeserialiseFailure
err
    Right (ByteString
remaining, Term
decodedVal) -> do
      IO () -> ExceptT HelpersError IO ()
forall a. IO a -> ExceptT HelpersError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT HelpersError IO ())
-> (Encoding -> IO ()) -> Encoding -> ExceptT HelpersError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.putStrLn (Text -> IO ()) -> (Encoding -> Text) -> Encoding -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (Encoding -> String) -> Encoding -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> String
prettyHexEnc (Encoding -> ExceptT HelpersError IO ())
-> Encoding -> ExceptT HelpersError IO ()
forall a b. (a -> b) -> a -> b
$ Term -> Encoding
encodeTerm Term
decodedVal
      Bool -> ExceptT HelpersError IO () -> ExceptT HelpersError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
LB.null ByteString
remaining) (ExceptT HelpersError IO () -> ExceptT HelpersError IO ())
-> ExceptT HelpersError IO () -> ExceptT HelpersError IO ()
forall a b. (a -> b) -> a -> b
$
        ByteString -> ExceptT HelpersError IO ()
pPrintCBOR ByteString
remaining

readCBOR :: FilePath -> ExceptT HelpersError IO LB.ByteString
readCBOR :: String -> ExceptT HelpersError IO ByteString
readCBOR String
fp =
  (IOException -> HelpersError)
-> IO ByteString -> ExceptT HelpersError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT
    (String -> Text -> HelpersError
ReadCBORFileFailure String
fp (Text -> HelpersError)
-> (IOException -> Text) -> IOException -> HelpersError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (IOException -> String) -> IOException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall e. Exception e => e -> String
displayException)
    (String -> IO ByteString
LB.readFile String
fp)

validateCBOR :: CBORObject -> LB.ByteString -> Either HelpersError Text
validateCBOR :: CBORObject -> ByteString -> Either HelpersError Text
validateCBOR CBORObject
cborObject ByteString
bs =
  case CBORObject
cborObject of
    CBORBlockByron EpochSlots
epochSlots -> do
      Either HelpersError (ByteString, ABlockOrBoundary ByteSpan)
-> Either HelpersError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either HelpersError (ByteString, ABlockOrBoundary ByteSpan)
 -> Either HelpersError ())
-> Either HelpersError (ByteString, ABlockOrBoundary ByteSpan)
-> Either HelpersError ()
forall a b. (a -> b) -> a -> b
$ ByteString
-> (forall s. Decoder s (ABlockOrBoundary ByteSpan))
-> Either HelpersError (ByteString, ABlockOrBoundary ByteSpan)
forall a.
ByteString
-> (forall s. Decoder s a) -> Either HelpersError (ByteString, a)
decodeCBOR ByteString
bs (Version
-> Decoder s (ABlockOrBoundary ByteSpan)
-> Decoder s (ABlockOrBoundary ByteSpan)
forall s a. Version -> Decoder s a -> Decoder s a
L.toPlainDecoder Version
L.byronProtVer (EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
forall s. EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
decCBORABlockOrBoundary EpochSlots
epochSlots))
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Byron block."
    CBORObject
CBORDelegationCertificateByron -> do
      Either HelpersError (ByteString, Certificate)
-> Either HelpersError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either HelpersError (ByteString, Certificate)
 -> Either HelpersError ())
-> Either HelpersError (ByteString, Certificate)
-> Either HelpersError ()
forall a b. (a -> b) -> a -> b
$ ByteString
-> (forall s. Decoder s Certificate)
-> Either HelpersError (ByteString, Certificate)
forall a.
ByteString
-> (forall s. Decoder s a) -> Either HelpersError (ByteString, a)
decodeCBOR ByteString
bs (Decoder s Certificate
forall s. Decoder s Certificate
forall a s. FromCBOR a => Decoder s a
L.fromCBOR :: L.Decoder s Delegation.Certificate)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Byron delegation certificate."
    CBORObject
CBORTxByron -> do
      Either HelpersError (ByteString, Tx) -> Either HelpersError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either HelpersError (ByteString, Tx) -> Either HelpersError ())
-> Either HelpersError (ByteString, Tx) -> Either HelpersError ()
forall a b. (a -> b) -> a -> b
$ ByteString
-> (forall s. Decoder s Tx) -> Either HelpersError (ByteString, Tx)
forall a.
ByteString
-> (forall s. Decoder s a) -> Either HelpersError (ByteString, a)
decodeCBOR ByteString
bs (Decoder s Tx
forall s. Decoder s Tx
forall a s. FromCBOR a => Decoder s a
L.fromCBOR :: L.Decoder s UTxO.Tx)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Byron Tx."
    CBORObject
CBORUpdateProposalByron -> do
      Either HelpersError (ByteString, Proposal)
-> Either HelpersError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either HelpersError (ByteString, Proposal)
 -> Either HelpersError ())
-> Either HelpersError (ByteString, Proposal)
-> Either HelpersError ()
forall a b. (a -> b) -> a -> b
$ ByteString
-> (forall s. Decoder s Proposal)
-> Either HelpersError (ByteString, Proposal)
forall a.
ByteString
-> (forall s. Decoder s a) -> Either HelpersError (ByteString, a)
decodeCBOR ByteString
bs (Decoder s Proposal
forall s. Decoder s Proposal
forall a s. FromCBOR a => Decoder s a
L.fromCBOR :: L.Decoder s Update.Proposal)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Byron update proposal."
    CBORObject
CBORVoteByron -> do
      Either HelpersError (ByteString, Vote) -> Either HelpersError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either HelpersError (ByteString, Vote) -> Either HelpersError ())
-> Either HelpersError (ByteString, Vote) -> Either HelpersError ()
forall a b. (a -> b) -> a -> b
$ ByteString
-> (forall s. Decoder s Vote)
-> Either HelpersError (ByteString, Vote)
forall a.
ByteString
-> (forall s. Decoder s a) -> Either HelpersError (ByteString, a)
decodeCBOR ByteString
bs (Decoder s Vote
forall s. Decoder s Vote
forall a s. FromCBOR a => Decoder s a
L.fromCBOR :: L.Decoder s Update.Vote)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Byron vote."

printEraDeprecationWarning :: Typeable era => MonadIO m => ToCardanoEra eon => eon era -> m ()
printEraDeprecationWarning :: forall era (m :: * -> *) (eon :: * -> *).
(Typeable era, MonadIO m, ToCardanoEra eon) =>
eon era -> m ()
printEraDeprecationWarning eon era
era = do
  let selectedEraNum :: Int
selectedEraNum = AnyCardanoEra -> Int
forall a. Enum a => a -> Int
fromEnum (AnyCardanoEra -> Int) -> AnyCardanoEra -> Int
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> AnyCardanoEra
forall era. Typeable era => CardanoEra era -> AnyCardanoEra
AnyCardanoEra (eon era -> CardanoEra era
forall era. eon era -> CardanoEra era
forall (eon :: * -> *) era.
ToCardanoEra eon =>
eon era -> CardanoEra era
toCardanoEra eon era
era)
      currentEraNum :: Int
currentEraNum = AnyCardanoEra -> Int
forall a. Enum a => a -> Int
fromEnum (AnyCardanoEra -> Int) -> AnyCardanoEra -> Int
forall a b. (a -> b) -> a -> b
$ CardanoEra ConwayEra -> AnyCardanoEra
forall era. Typeable era => CardanoEra era -> AnyCardanoEra
AnyCardanoEra CardanoEra ConwayEra
ConwayEra
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
selectedEraNum Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
currentEraNum) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
printWarning String
"Selected era is deprecated and will be removed in the future."