{-# LANGUAGE OverloadedStrings #-}

-- | Helper functions for parsing

module Cardano.Prelude.Base16
  ( Base16ParseError(..)

  , decodeEitherBase16
  , parseBase16
  )
where

import Cardano.Prelude.Base
import Data.String
import Formatting (bprint, shown)
import Formatting.Buildable (Buildable(build))

import qualified Cardano.Prelude.Base16.Internal as B16
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text.Encoding as Text

{- HLINT ignore "Use isDigit" -}

newtype Base16ParseError =
  Base16IncorrectSuffix ByteString
  deriving (Base16ParseError -> Base16ParseError -> Bool
(Base16ParseError -> Base16ParseError -> Bool)
-> (Base16ParseError -> Base16ParseError -> Bool)
-> Eq Base16ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Base16ParseError -> Base16ParseError -> Bool
$c/= :: Base16ParseError -> Base16ParseError -> Bool
== :: Base16ParseError -> Base16ParseError -> Bool
$c== :: Base16ParseError -> Base16ParseError -> Bool
Eq, Int -> Base16ParseError -> ShowS
[Base16ParseError] -> ShowS
Base16ParseError -> String
(Int -> Base16ParseError -> ShowS)
-> (Base16ParseError -> String)
-> ([Base16ParseError] -> ShowS)
-> Show Base16ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Base16ParseError] -> ShowS
$cshowList :: [Base16ParseError] -> ShowS
show :: Base16ParseError -> String
$cshow :: Base16ParseError -> String
showsPrec :: Int -> Base16ParseError -> ShowS
$cshowsPrec :: Int -> Base16ParseError -> ShowS
Show)

instance Buildable Base16ParseError where
  build :: Base16ParseError -> Builder
build (Base16IncorrectSuffix ByteString
suffix) =
    Format Builder (ByteString -> Builder) -> ByteString -> Builder
forall a. Format Builder a -> a
bprint (Format (ByteString -> Builder) (ByteString -> Builder)
"Base16 parsing failed with incorrect suffix " Format (ByteString -> Builder) (ByteString -> Builder)
-> Format Builder (ByteString -> Builder)
-> Format Builder (ByteString -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (ByteString -> Builder)
forall a r. Show a => Format r (a -> r)
shown) ByteString
suffix

parseBase16 :: Text -> Either Base16ParseError ByteString
parseBase16 :: Text -> Either Base16ParseError ByteString
parseBase16 Text
s = do
  let (ByteString
bs, ByteString
suffix) = ByteString -> (ByteString, ByteString)
B16.decode (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
s
  Bool -> Either Base16ParseError () -> Either Base16ParseError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
suffix) (Either Base16ParseError () -> Either Base16ParseError ())
-> (Base16ParseError -> Either Base16ParseError ())
-> Base16ParseError
-> Either Base16ParseError ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Base16ParseError -> Either Base16ParseError ()
forall a b. a -> Either a b
Left (Base16ParseError -> Either Base16ParseError ())
-> Base16ParseError -> Either Base16ParseError ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Base16ParseError
Base16IncorrectSuffix ByteString
suffix
  ByteString -> Either Base16ParseError ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

decodeEitherBase16 :: ByteString -> Either String ByteString
decodeEitherBase16 :: ByteString -> Either String ByteString
decodeEitherBase16 ByteString
bs = case ByteString -> (ByteString, ByteString)
B16.decode ByteString
bs of
  (ByteString
decodedBs, ByteString
"") -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
decodedBs
  (ByteString
_, ByteString
_) -> 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
"invalid character at offset: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (ByteString -> Int
BS.length ((Char -> Bool) -> ByteString -> ByteString
BS.takeWhile Char -> Bool
isHex ByteString
bs))
  where isHex :: Char -> Bool
        isHex :: Char -> Bool
isHex Char
w =
          (Char
w Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
w Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9') Bool -> Bool -> Bool
||
          (Char
w Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
w Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f') Bool -> Bool -> Bool
||
          (Char
w Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
w Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F')