{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.CLI.Parser
  ( readerFromAttoParser
  , readFractionAsRational
  , readIdOutputFormat
  , readRational
  , readRationalUnitInterval
  , readStringOfMaxLength
  , readURIOfMaxLength
  , commandWithMetavar
  , eDNSName
  , stringToAnchorScheme
  , deprecatedReadKeyOutputFormat
  )
where

import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Type.Common

import Data.Attoparsec.ByteString.Char8 qualified as Atto
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BSC
import Data.Char (toLower)
import Data.Foldable
import Data.Ratio ((%))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Options.Applicative qualified as Opt
import Vary

readIdOutputFormat :: Opt.ReadM (Vary [FormatBech32, FormatHex])
readIdOutputFormat :: ReadM (Vary '[FormatBech32, FormatHex])
readIdOutputFormat = do
  String
s <- forall s. IsString s => ReadM s
Opt.str @String
  case String
s of
    String
"hex" -> Vary '[FormatBech32, FormatHex]
-> ReadM (Vary '[FormatBech32, FormatHex])
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vary '[FormatBech32, FormatHex]
 -> ReadM (Vary '[FormatBech32, FormatHex]))
-> Vary '[FormatBech32, FormatHex]
-> ReadM (Vary '[FormatBech32, FormatHex])
forall a b. (a -> b) -> a -> b
$ FormatHex -> Vary '[FormatBech32, FormatHex]
forall a (l :: [*]). (a :| l) => a -> Vary l
Vary.from FormatHex
FormatHex
    String
"bech32" -> Vary '[FormatBech32, FormatHex]
-> ReadM (Vary '[FormatBech32, FormatHex])
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vary '[FormatBech32, FormatHex]
 -> ReadM (Vary '[FormatBech32, FormatHex]))
-> Vary '[FormatBech32, FormatHex]
-> ReadM (Vary '[FormatBech32, FormatHex])
forall a b. (a -> b) -> a -> b
$ FormatBech32 -> Vary '[FormatBech32, FormatHex]
forall a (l :: [*]). (a :| l) => a -> Vary l
Vary.from FormatBech32
FormatBech32
    String
_ ->
      String -> ReadM (Vary '[FormatBech32, FormatHex])
forall a. String -> ReadM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ReadM (Vary '[FormatBech32, FormatHex]))
-> String -> ReadM (Vary '[FormatBech32, FormatHex])
forall a b. (a -> b) -> a -> b
$
        [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          [ String
"Invalid output format: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
s
          , String
". Accepted output formats are \"hex\" and \"bech32\"."
          ]

deprecatedReadKeyOutputFormat :: Opt.ReadM (Vary [FormatBech32, FormatTextEnvelope])
deprecatedReadKeyOutputFormat :: ReadM (Vary '[FormatBech32, FormatTextEnvelope])
deprecatedReadKeyOutputFormat = do
  String
s <- forall s. IsString s => ReadM s
Opt.str @String
  case String
s of
    String
"text-envelope" -> Vary '[FormatBech32, FormatTextEnvelope]
-> ReadM (Vary '[FormatBech32, FormatTextEnvelope])
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormatTextEnvelope -> Vary '[FormatBech32, FormatTextEnvelope]
forall a (l :: [*]). (a :| l) => a -> Vary l
Vary.from FormatTextEnvelope
FormatTextEnvelope)
    String
"bech32" -> Vary '[FormatBech32, FormatTextEnvelope]
-> ReadM (Vary '[FormatBech32, FormatTextEnvelope])
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormatBech32 -> Vary '[FormatBech32, FormatTextEnvelope]
forall a (l :: [*]). (a :| l) => a -> Vary l
Vary.from FormatBech32
FormatBech32)
    String
_ ->
      String -> ReadM (Vary '[FormatBech32, FormatTextEnvelope])
forall a. String -> ReadM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ReadM (Vary '[FormatBech32, FormatTextEnvelope]))
-> String -> ReadM (Vary '[FormatBech32, FormatTextEnvelope])
forall a b. (a -> b) -> a -> b
$
        [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          [ String
"Invalid key output format: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
s
          , String
". Accepted output formats are \"text-envelope\" and \"bech32\"."
          ]

readURIOfMaxLength :: Int -> Opt.ReadM Text
readURIOfMaxLength :: Int -> ReadM Text
readURIOfMaxLength Int
maxLen =
  String -> Text
Text.pack (String -> Text) -> ReadM String -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ReadM String
readStringOfMaxLength Int
maxLen

readStringOfMaxLength :: Int -> Opt.ReadM String
readStringOfMaxLength :: Int -> ReadM String
readStringOfMaxLength Int
maxLen = do
  String
s <- ReadM String
forall s. IsString s => ReadM s
Opt.str
  let strLen :: Int
strLen = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
  if Int
strLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxLen
    then String -> ReadM String
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s
    else
      String -> ReadM String
forall a. String -> ReadM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ReadM String) -> String -> ReadM String
forall a b. (a -> b) -> a -> b
$
        [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          [ String
"The provided string must have at most 64 characters, but it has "
          , Int -> String
forall a. Show a => a -> String
show Int
strLen
          , String
" characters."
          ]

readRationalUnitInterval :: Opt.ReadM Rational
readRationalUnitInterval :: ReadM Rational
readRationalUnitInterval = ReadM Rational
readRational ReadM Rational -> (Rational -> ReadM Rational) -> ReadM Rational
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rational -> ReadM Rational
checkUnitInterval
 where
  checkUnitInterval :: Rational -> Opt.ReadM Rational
  checkUnitInterval :: Rational -> ReadM Rational
checkUnitInterval Rational
q
    | Rational
q Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0 Bool -> Bool -> Bool
&& Rational
q Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
1 = Rational -> ReadM Rational
forall a. a -> ReadM a
forall (m :: * -> *) a. Monad m => a -> m a
return Rational
q
    | Bool
otherwise = String -> ReadM Rational
forall a. String -> ReadM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Please enter a value in the range [0,1]"

readFractionAsRational :: Opt.ReadM Rational
readFractionAsRational :: ReadM Rational
readFractionAsRational = Parser Rational -> ReadM Rational
forall a. Parser a -> ReadM a
readerFromAttoParser Parser Rational
fractionalAsRational
 where
  fractionalAsRational :: Atto.Parser Rational
  fractionalAsRational :: Parser Rational
fractionalAsRational = Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
(%) (Integer -> Integer -> Rational)
-> Parser ByteString Integer
-> Parser ByteString (Integer -> Rational)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Integral a => Parser a
Atto.decimal @Integer Parser ByteString Integer
-> Parser ByteString Char -> Parser ByteString Integer
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
Atto.char Char
'/') Parser ByteString (Integer -> Rational)
-> Parser ByteString Integer -> Parser Rational
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Integral a => Parser a
Atto.decimal @Integer

readRational :: Opt.ReadM Rational
readRational :: ReadM Rational
readRational =
  [ReadM Rational] -> ReadM Rational
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ Scientific -> Rational
forall a. Real a => a -> Rational
toRational (Scientific -> Rational) -> ReadM Scientific -> ReadM Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Scientific -> ReadM Scientific
forall a. Parser a -> ReadM a
readerFromAttoParser Parser Scientific
Atto.scientific
    , ReadM Rational
readFractionAsRational
    ]

readerFromAttoParser :: Atto.Parser a -> Opt.ReadM a
readerFromAttoParser :: forall a. Parser a -> ReadM a
readerFromAttoParser Parser a
p =
  (String -> Either String a) -> ReadM a
forall a. (String -> Either String a) -> ReadM a
Opt.eitherReader (Parser a -> ByteString -> Either String a
forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly (Parser a
p Parser a -> Parser ByteString () -> Parser a
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Atto.endOfInput) (ByteString -> Either String a)
-> (String -> ByteString) -> String -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BSC.pack)

commandWithMetavar :: String -> Opt.ParserInfo a -> Opt.Mod Opt.CommandFields a
commandWithMetavar :: forall a. String -> ParserInfo a -> Mod CommandFields a
commandWithMetavar String
cmdName ParserInfo a
pInfo = String -> ParserInfo a -> Mod CommandFields a
forall a. String -> ParserInfo a -> Mod CommandFields a
Opt.command String
cmdName ParserInfo a
pInfo Mod CommandFields a -> Mod CommandFields a -> Mod CommandFields a
forall a. Semigroup a => a -> a -> a
<> String -> Mod CommandFields a
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
cmdName

-- | Converts a string to an 'AnchorScheme' if it is a valid scheme and is in the
-- 'SupportedScheme' list, otherwise it returns 'Left'.
stringToAnchorScheme :: SupportedSchemes -> String -> Either String AnchorScheme
stringToAnchorScheme :: SupportedSchemes -> String -> Either String AnchorScheme
stringToAnchorScheme SupportedSchemes
supportedSchemes String
schemaString = do
  case String -> Maybe AnchorScheme
convertToAnchorScheme (String -> Maybe AnchorScheme) -> String -> Maybe AnchorScheme
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
schemaString of
    Just AnchorScheme
scheme | AnchorScheme
scheme AnchorScheme -> SupportedSchemes -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` SupportedSchemes
supportedSchemes -> AnchorScheme -> Either String AnchorScheme
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnchorScheme
scheme
    Maybe AnchorScheme
_ -> String -> Either String AnchorScheme
forall a b. a -> Either a b
Left (String -> Either String AnchorScheme)
-> String -> Either String AnchorScheme
forall a b. (a -> b) -> a -> b
$ String
"Unsupported URL scheme: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
schemaString
 where
  convertToAnchorScheme :: String -> Maybe AnchorScheme
  convertToAnchorScheme :: String -> Maybe AnchorScheme
convertToAnchorScheme String
"file:" = AnchorScheme -> Maybe AnchorScheme
forall a. a -> Maybe a
Just AnchorScheme
FileScheme
  convertToAnchorScheme String
"http:" = AnchorScheme -> Maybe AnchorScheme
forall a. a -> Maybe a
Just AnchorScheme
HttpScheme
  convertToAnchorScheme String
"https:" = AnchorScheme -> Maybe AnchorScheme
forall a. a -> Maybe a
Just AnchorScheme
HttpsScheme
  convertToAnchorScheme String
"ipfs:" = AnchorScheme -> Maybe AnchorScheme
forall a. a -> Maybe a
Just AnchorScheme
IpfsScheme
  convertToAnchorScheme String
_ = Maybe AnchorScheme
forall a. Maybe a
Nothing

eDNSName :: String -> Either String ByteString
eDNSName :: String -> Either String ByteString
eDNSName String
str =
  -- We're using 'Shelley.textToDns' to validate the string.
  case Int -> Text -> Maybe DnsName
forall (m :: * -> *). MonadFail m => Int -> Text -> m DnsName
L.textToDns Int
128 (String -> Text
Text.pack String
str) of
    Maybe DnsName
Nothing -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String
"DNS name is more than 64 bytes: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str
    Just DnsName
dnsName -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> (DnsName -> ByteString) -> DnsName -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> (DnsName -> Text) -> DnsName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DnsName -> Text
L.dnsToText (DnsName -> Either String ByteString)
-> DnsName -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ DnsName
dnsName