content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE TypeApplications #-}
  
  {-# OPTIONS_HADDOCK hide #-}
  
  -- |
  -- Copyright: 2020 Input Output (Hong Kong) Ltd., 2021-2022 Input Output Global Inc. (IOG), 2023-2025 Intersect
  -- License: Apache-2.0
  
  module System.IO.Extra
      (
      -- * I/O application-specific helpers
      -- ** Read
        hGetBytes
      , hGetBech32
      , hGetXPrv
      , hGetXPub
      , hGetXP__
      , hGetScriptHash
      , hGetSomeMnemonic
      , hGetSomeMnemonicInteractively
      , hGetPassphraseMnemonic
      , hGetPassphraseBytes
  
      -- ** Write
      , hPutBytes
      , hPutString
      , hPutStringNoNewLn
  
      -- * I/O Helpers
      , prettyIOException
      , progName
      , markCharsRedAtIndices
      , noNewline
      ) where
  
  import Prelude
  
  import Cardano.Address.Derivation
      ( XPrv, XPub, xprvFromBytes, xpubFromBytes )
  import Cardano.Address.Script
      ( ScriptHash, scriptHashFromBytes )
  import Cardano.Mnemonic
      ( MkSomeMnemonicError (..), SomeMnemonic, mkSomeMnemonic )
  import Codec.Binary.Bech32
      ( HumanReadablePart, humanReadablePartToText )
  import Codec.Binary.Encoding
      ( AbstractEncoding (..)
      , Encoding
      , detectEncoding
      , encode
      , fromBase16
      , fromBase58
      , fromBase64
      , fromBech32
      )
  import Control.Exception
      ( IOException, bracket )
  import Control.Monad
      ( unless )
  import Data.ByteString
      ( ByteString )
  import Data.List
      ( nub, sort )
  import Data.Text
      ( Text )
  import Data.Word
      ( Word8 )
  import Options.Applicative.Style
      ( PassphraseInfo (..), PassphraseInput (..), PassphraseInputMode (..) )
  import System.Console.ANSI
      ( Color (..)
      , ColorIntensity (..)
      , ConsoleLayer (..)
      , SGR (..)
      , hCursorBackward
      , setSGRCode
      )
  import System.Environment
      ( getProgName )
  import System.Exit
      ( exitFailure )
  import System.IO
      ( BufferMode (..)
      , Handle
      , hGetBuffering
      , hGetChar
      , hGetEcho
      , hPutChar
      , hSetBuffering
      , hSetEcho
      , stderr
      )
  import System.IO.Unsafe
      ( unsafePerformIO )
  
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Char8 as B8
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import qualified Data.Text.IO as TIO
  --
  -- I/O Read
  --
  
  -- | Read some bytes from the console, and decode them if the encoding is recognized.
  hGetBytes :: Handle -> IO ByteString
  hGetBytes h = do
      raw <- B8.filter noNewline <$> B8.hGetContents h
      case detectEncoding (T.unpack $ T.decodeUtf8 raw) of
          Just (EBase16  ) -> decodeBytes fromBase16 raw
          Just (EBech32{}) -> decodeBytes (fmap snd . fromBech32 markCharsRedAtIndices) raw
          Just (EBase58  ) -> decodeBytes fromBase58 raw
          Nothing          -> fail
              "Couldn't detect input encoding? Data on stdin must be encoded as \
              \bech16, bech32 or base58."
  
  decodeBytes
      :: (bin -> Either String result)
      -> bin
      -> IO result
  decodeBytes from = either fail pure . from
  
  -- | Read some bytes encoded in Bech32, only allowing the given prefixes.
  hGetBech32 :: Handle -> [HumanReadablePart] -> IO (HumanReadablePart, ByteString)
  hGetBech32 h allowedPrefixes = do
      raw <- B8.filter noNewline <$> B8.hGetContents h
      (hrp, bytes) <- decodeBytes (fromBech32 markCharsRedAtIndices) raw
      unless (hrp `elem` allowedPrefixes) $ fail
          $ "Invalid human-readable prefix. Prefix ought to be one of: "
          <> show (showHrp <$> allowedPrefixes)
      pure (hrp, bytes)
    where
      showHrp :: HumanReadablePart -> String
      showHrp = T.unpack . humanReadablePartToText
  
  -- | Read some English mnemonic words from the console, or fail.
  hGetSomeMnemonic :: Handle -> IO SomeMnemonic
  hGetSomeMnemonic h = do
      wrds <- T.words . T.filter noNewline . T.decodeUtf8 <$> B8.hGetContents h
      case mkSomeMnemonic @'[ 9, 12, 15, 18, 21, 24 ] wrds of
          Left (MkSomeMnemonicError e) -> fail e
          Right mw -> pure mw
  
  -- | Read an encoded private key from the console, or fail.
  hGetXPrv :: Handle -> [HumanReadablePart] -> IO (HumanReadablePart, XPrv)
  hGetXPrv h allowedPrefixes = do
      (hrp, bytes) <- hGetBech32 h allowedPrefixes
      case xprvFromBytes bytes of
          Nothing  -> fail "Couldn't convert bytes into extended private key."
          Just key -> pure (hrp, key)
  
  -- | Read an encoded public key from the console, or fail.
  hGetXPub :: Handle -> [HumanReadablePart] -> IO (HumanReadablePart, XPub)
  hGetXPub h allowedPrefixes = do
      (hrp, bytes) <- hGetBech32 h allowedPrefixes
      case xpubFromBytes bytes of
          Nothing  -> fail "Couldn't convert bytes into extended public key."
          Just key -> pure (hrp, key)
  
  -- | Read a script hash from the console, or fail.
  hGetScriptHash :: Handle -> IO ScriptHash
  hGetScriptHash h = do
      bytes <- hGetBytes h
      case scriptHashFromBytes bytes of
          Nothing  -> fail "Couldn't convert bytes into script hash."
          Just scriptHash -> pure scriptHash
  
  -- | Read either an encoded public or private key from the console, or fail.
  hGetXP__
      :: Handle
      -> [HumanReadablePart]
      -> IO (Either (HumanReadablePart, XPub) (HumanReadablePart, XPrv))
  hGetXP__ h allowedPrefixes = do
      (hrp, bytes) <- hGetBech32 h allowedPrefixes
      case (xpubFromBytes bytes, xprvFromBytes bytes) of
          (Just xpub,         _) -> pure (Left  (hrp, xpub))
          (_        , Just xprv) -> pure (Right (hrp, xprv))
          _                      -> fail
              "Couldn't convert bytes into neither extended public or private keys."
  
  withBuffering :: Handle -> BufferMode -> IO a -> IO a
  withBuffering h buffering action = bracket aFirst aLast aBetween
    where
      aFirst = (hGetBuffering h <* hSetBuffering h buffering)
      aLast = hSetBuffering h
      aBetween = const action
  
  withEcho :: Handle -> Bool -> IO a -> IO a
  withEcho h echo action = bracket aFirst aLast aBetween
    where
      aFirst = (hGetEcho h <* hSetEcho h echo)
      aLast = hSetEcho h
      aBetween = const action
  
  -- | Gather user inputs until a newline is met, hiding what's typed with a
  -- placeholder character.
  hGetSensitiveLine
      :: (Handle, Handle)
      -> PassphraseInputMode
      -> String
      -> IO Text
  hGetSensitiveLine (hstdin, hstderr) mode prompt =
      withBuffering hstderr NoBuffering $
      withBuffering hstdin NoBuffering $
      withEcho hstdin False $ do
          hPutString hstderr prompt
          getLineSensitive '*'
    where
      backspace = toEnum 127
  
      getLineSensitive :: Char -> IO Text
      getLineSensitive placeholder =
          getLineSensitive' mempty
        where
          getLineSensitive' line = do
              hGetChar hstdin >>= \case
                  '\n' -> do
                      hPutChar hstderr '\n'
                      return line
                  c | c == backspace ->
                      if T.null line
                          then getLineSensitive' line
                          else do
                              hCursorBackward hstderr  1
                              hPutChar hstderr ' '
                              hCursorBackward hstderr 1
                              getLineSensitive' (T.init line)
                  c -> do
                      case mode of
                          Sensitive ->
                              hPutChar hstderr placeholder
                          Explicit ->
                              hPutChar hstderr c
                          Silent ->
                              pure ()
                      getLineSensitive' (line <> T.singleton c)
  
  -- | Prompt user and read some English mnemonic words from stdin.
  hGetSomeMnemonicInteractively
      :: (Handle, Handle)
      -> PassphraseInputMode
      -> String
      -> IO SomeMnemonic
  hGetSomeMnemonicInteractively (hstdin, hstderr) mode prompt = do
      wrds <- T.words . T.filter noNewline <$>
              hGetSensitiveLine (hstdin, hstderr) mode prompt
      case mkSomeMnemonic @'[ 9, 12, 15, 18, 21, 24 ] wrds of
          Left (MkSomeMnemonicError e) -> fail e
          Right mw -> pure mw
  
  -- | Read mnemonic passphrase from either file or interactively.
  hGetPassphraseMnemonic
      :: (Handle, Handle)
      -> PassphraseInputMode
      -> PassphraseInput
      -> String
      -> IO SomeMnemonic
  hGetPassphraseMnemonic (hstdin, hstderr) mode input prompt =
      case input of
          Interactive ->
              hGetPassphraseMnemonicInteractively (hstdin, hstderr) mode prompt
          FromFile path ->
              hGetPassphraseMnemonicFromFile path
  
  -- | Read the mnemonic passphrase (second factor) from file.
  hGetPassphraseMnemonicFromFile
      :: FilePath
      -> IO SomeMnemonic
  hGetPassphraseMnemonicFromFile path = do
      wrds <- T.words . T.filter noNewline . T.decodeUtf8 <$> BS.readFile path
      case mkSomeMnemonic @'[ 9, 12 ] wrds of
          Left (MkSomeMnemonicError e) -> fail e
          Right mw -> pure mw
  
  -- | Prompt user and read the mnemonic passphrase (second factor) interactively.
  hGetPassphraseMnemonicInteractively
      :: (Handle, Handle)
      -> PassphraseInputMode
      -> String
      -> IO SomeMnemonic
  hGetPassphraseMnemonicInteractively (hstdin, hstderr) mode prompt = do
      wrds <- T.words . T.filter noNewline <$>
              hGetSensitiveLine (hstdin, hstderr) mode prompt
      case mkSomeMnemonic @'[ 9, 12 ] wrds of
          Left (MkSomeMnemonicError e) -> fail e
          Right mw -> pure mw
  
  -- | Read passphrase from either file or interactively, and decode them accoring to passphrase info.
  hGetPassphraseBytes
      :: (Handle, Handle)
      -> PassphraseInputMode
      -> PassphraseInput
      -> String
      -> PassphraseInfo
      -> IO ByteString
  hGetPassphraseBytes (hstdin, hstderr) mode input prompt info =
      case input of
          Interactive ->
              hGetPassphraseBytesInteractively (hstdin, hstderr) mode prompt info
          FromFile path ->
              hGetPassphraseBytesFromFile path info
  
  -- | Read some bytes from the file, and decode them accoring to passphrase info.
  hGetPassphraseBytesFromFile
      :: FilePath
      -> PassphraseInfo
      -> IO ByteString
  hGetPassphraseBytesFromFile path = \case
      Hex -> do
         raw <- B8.filter noNewline . T.encodeUtf8 <$> TIO.readFile path
         decodeBytes fromBase16 raw
      Base64 -> do
         raw <- B8.filter noNewline . T.encodeUtf8 <$> TIO.readFile path
         decodeBytes fromBase64 raw
      Utf8 -> do
         B8.filter noNewline . T.encodeUtf8 <$> TIO.readFile path
      Octets -> do
         txt <- TIO.readFile path
         let bytes = read @[Word8] (T.unpack txt)
         pure $ BS.pack bytes
      _          -> fail
              "Data in file must be encoded as hex, base64, utf8 or octet array."
  
  -- | Read some bytes from the console, and decode them accoring to passphrase info.
  hGetPassphraseBytesInteractively
      :: (Handle, Handle)
      -> PassphraseInputMode
      -> String
      -> PassphraseInfo
      -> IO ByteString
  hGetPassphraseBytesInteractively (hstdin, hstderr) mode prompt = \case
      Hex -> do
         raw <- B8.filter noNewline . T.encodeUtf8 <$> hGetSensitiveLine (hstdin, hstderr) mode prompt
         decodeBytes fromBase16 raw
      Base64 -> do
         raw <- B8.filter noNewline . T.encodeUtf8 <$> hGetSensitiveLine (hstdin, hstderr) mode prompt
         decodeBytes fromBase64 raw
      Utf8 -> do
         txt <- hGetSensitiveLine (hstdin, hstderr) mode prompt
         pure $ T.encodeUtf8 txt
      Octets -> do
         txt <- hGetSensitiveLine (hstdin, hstderr) mode prompt
         let bytes = read @[Word8] (T.unpack txt)
         pure $ BS.pack bytes
      _          -> fail
              "Data on stdin must be encoded as hex, base64, utf8 or octet array."
  
  --
  -- I/O Write
  --
  
  -- | Print bytes to the console with the given encoding.
  hPutBytes :: Handle -> ByteString -> Encoding -> IO ()
  hPutBytes h bytes =
      B8.hPutStr h . flip encode bytes
  
  -- | Print string to the console with newline appended.
  hPutString :: Handle -> String -> IO ()
  hPutString h =
      B8.hPutStrLn h . T.encodeUtf8 . T.pack
  
  -- | Print string to the console without newline appended.
  hPutStringNoNewLn :: Handle -> String -> IO ()
  hPutStringNoNewLn h =
      B8.hPutStr h . T.encodeUtf8 . T.pack
  
  --
  -- Helpers
  --
  
  noNewline :: Char -> Bool
  noNewline = (`notElem` ['\n', '\r'])
  
  -- | Fail with a colored red error message.
  prettyIOException :: IOException -> IO a
  prettyIOException e = do
      B8.hPutStrLn stderr $ T.encodeUtf8 $ T.pack $ show e
      exitFailure
  
  -- | Mark all characters from a given string as red (in a console).
  markCharsRedAtIndices :: Integral i => [i] -> String -> String
  markCharsRedAtIndices ixs = go 0 (sort $ nub ixs)
    where
      go _c [] [] = mempty
      go c (i:is) (s:ss)
          | c == i    = red ++ s:def ++ go (c + 1) is ss
          | otherwise = s : go (c + 1) (i:is) ss
      go _ [] ss = ss
      go _ _ [] = [] -- NOTE: Really an error case.
  
      red = setSGRCode [SetColor Foreground Vivid Red]
      def = setSGRCode [Reset]
  
  -- | Get program name to avoid hard-coding it in documentation excerpt.
  progName :: String
  progName = unsafePerformIO getProgName
  {-# NOINLINE progName #-}
  