{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Bcc.CLI.Helpers
  ( HelpersError(..)
  , deprecationWarning
  , ensureNewFile
  , ensureNewFileLBS
  , pPrintCBOR
  , readCBOR
  , renderHelpersError
  , textShow
  , validateCBOR
  , hushM
  ) where

import           Bcc.Prelude
import           Prelude (String)

import           Codec.CBOR.Pretty (prettyHexEnc)
import           Codec.CBOR.Read (DeserialiseFailure, deserialiseFromBytes)
import           Codec.CBOR.Term (decodeTerm, encodeTerm)
import           Control.Monad.Trans.Except.Extra (handleIOExceptT, left)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as Text
import           System.Console.ANSI
import qualified System.Console.ANSI as ANSI
import qualified System.IO as IO

import           Bcc.Binary (Decoder, fromCBOR)
import           Bcc.CLI.Types
import           Bcc.Chain.Block (fromCBORABlockOrBoundary)
import qualified Bcc.Chain.Delegation as Delegation
import qualified Bcc.Chain.UTxO as UTxO
import qualified Bcc.Chain.Update as Update

import qualified System.Directory 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
showList :: [HelpersError] -> ShowS
$cshowList :: [HelpersError] -> ShowS
show :: HelpersError -> String
$cshow :: HelpersError -> String
showsPrec :: Int -> HelpersError -> ShowS
$cshowsPrec :: Int -> HelpersError -> ShowS
Show

renderHelpersError :: HelpersError -> Text
renderHelpersError :: HelpersError -> Text
renderHelpersError HelpersError
err =
  case HelpersError
err of
    OutputMustNotAlreadyExist String
fp -> Text
"Output file/directory must not already exist: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
fp
    ReadCBORFileFailure String
fp Text
err' -> Text
"CBOR read failure at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Text -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Text
err')
    CBORPrettyPrintError DeserialiseFailure
err' -> Text
"Error with CBOR decoding: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (DeserialiseFailure -> String
forall a b. (Show a, ConvertText String b) => a -> b
show DeserialiseFailure
err')
    CBORDecodingError DeserialiseFailure
err' -> Text
"Error with CBOR decoding: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (DeserialiseFailure -> String
forall a b. (Show a, ConvertText String b) => a -> b
show DeserialiseFailure
err')
    IOError' String
fp IOException
ioE -> Text
"Error at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (IOException -> String
forall a b. (Show a, ConvertText String b) => a -> b
show IOException
ioE)

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

deprecationWarning :: String -> IO ()
deprecationWarning :: String -> IO ()
deprecationWarning String
cmd = 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: 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."
  Handle -> [SGR] -> IO ()
ANSI.hSetSGR Handle
IO.stderr [SGR
Reset]

-- | Checks if a path exists and throws and error if it does.
ensureNewFile :: (FilePath -> a -> IO ()) -> FilePath -> a -> ExceptT HelpersError IO ()
ensureNewFile :: (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 (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 (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 :: LByteString -> ExceptT HelpersError IO ()
pPrintCBOR :: LByteString -> ExceptT HelpersError IO ()
pPrintCBOR LByteString
bs = do
  case (forall s. Decoder s Term)
-> LByteString -> Either DeserialiseFailure (LByteString, Term)
forall a.
(forall s. Decoder s a)
-> LByteString -> Either DeserialiseFailure (LByteString, a)
deserialiseFromBytes forall s. Decoder s Term
decodeTerm LByteString
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 (LByteString
remaining, Term
decodedVal) -> do
      IO () -> ExceptT HelpersError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT HelpersError IO ())
-> (Encoding -> IO ()) -> Encoding -> ExceptT HelpersError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> IO ()
putTextLn (Text -> IO ()) -> (Encoding -> Text) -> Encoding -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> (Encoding -> String) -> Encoding -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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 (LByteString -> Bool
LB.null LByteString
remaining) (ExceptT HelpersError IO () -> ExceptT HelpersError IO ())
-> ExceptT HelpersError IO () -> ExceptT HelpersError IO ()
forall a b. (a -> b) -> a -> b
$
        LByteString -> ExceptT HelpersError IO ()
pPrintCBOR LByteString
remaining

readCBOR :: FilePath -> ExceptT HelpersError IO LByteString
readCBOR :: String -> ExceptT HelpersError IO LByteString
readCBOR String
fp =
  (IOException -> HelpersError)
-> IO LByteString -> ExceptT HelpersError IO LByteString
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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Text) -> (IOException -> String) -> IOException -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IOException -> String
forall e. Exception e => e -> String
displayException)
    (String -> IO LByteString
LB.readFile String
fp)

validateCBOR :: CBORObject -> LByteString -> Either HelpersError Text
validateCBOR :: CBORObject -> LByteString -> Either HelpersError Text
validateCBOR CBORObject
cborObject LByteString
bs =
  case CBORObject
cborObject of
    CBORBlockCole EpochSlots
epochSlots -> do
      () ()
-> Either HelpersError (LByteString, ABlockOrBoundary ByteSpan)
-> Either HelpersError ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LByteString
-> (forall s. Decoder s (ABlockOrBoundary ByteSpan))
-> Either HelpersError (LByteString, ABlockOrBoundary ByteSpan)
forall a.
LByteString
-> (forall s. Decoder s a) -> Either HelpersError (LByteString, a)
decodeCBOR LByteString
bs (EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
forall s. EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
fromCBORABlockOrBoundary EpochSlots
epochSlots)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Cole block."

    CBORObject
CBORDelegationCertificateCole -> do
      () ()
-> Either HelpersError (LByteString, Certificate)
-> Either HelpersError ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LByteString
-> (forall s. Decoder s Certificate)
-> Either HelpersError (LByteString, Certificate)
forall a.
LByteString
-> (forall s. Decoder s a) -> Either HelpersError (LByteString, a)
decodeCBOR LByteString
bs (forall s. Decoder s Certificate
forall a s. FromCBOR a => Decoder s a
fromCBOR :: Decoder s Delegation.Certificate)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Cole delegation certificate."

    CBORObject
CBORTxCole -> do
      () ()
-> Either HelpersError (LByteString, Tx) -> Either HelpersError ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LByteString
-> (forall s. Decoder s Tx)
-> Either HelpersError (LByteString, Tx)
forall a.
LByteString
-> (forall s. Decoder s a) -> Either HelpersError (LByteString, a)
decodeCBOR LByteString
bs (forall s. Decoder s Tx
forall a s. FromCBOR a => Decoder s a
fromCBOR :: Decoder s UTxO.Tx)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Cole Tx."

    CBORObject
CBORUpdateProposalCole -> do
      () ()
-> Either HelpersError (LByteString, Proposal)
-> Either HelpersError ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LByteString
-> (forall s. Decoder s Proposal)
-> Either HelpersError (LByteString, Proposal)
forall a.
LByteString
-> (forall s. Decoder s a) -> Either HelpersError (LByteString, a)
decodeCBOR LByteString
bs (forall s. Decoder s Proposal
forall a s. FromCBOR a => Decoder s a
fromCBOR :: Decoder s Update.Proposal)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Cole update proposal."

    CBORObject
CBORVoteCole -> do
      () ()
-> Either HelpersError (LByteString, Vote)
-> Either HelpersError ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LByteString
-> (forall s. Decoder s Vote)
-> Either HelpersError (LByteString, Vote)
forall a.
LByteString
-> (forall s. Decoder s a) -> Either HelpersError (LByteString, a)
decodeCBOR LByteString
bs (forall s. Decoder s Vote
forall a s. FromCBOR a => Decoder s a
fromCBOR :: Decoder s Update.Vote)
      Text -> Either HelpersError Text
forall a b. b -> Either a b
Right Text
"Valid Cole vote."

textShow :: Show a => a -> Text
textShow :: a -> Text
textShow = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> String
forall a b. (Show a, ConvertText String b) => a -> b
show

-- | Convert an Either to a Maybe and execute the supplied handler
-- in the Left case.
hushM :: forall e m a. Monad m => Either e a -> (e -> m ()) -> m (Maybe a)
hushM :: Either e a -> (e -> m ()) -> m (Maybe a)
hushM Either e a
r e -> m ()
f = case Either e a
r of
  Right a
a -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  Left e
e -> e -> m ()
f e
e m () -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing