{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}

module PlutusLedgerApi.V1.Bytes
    ( LedgerBytes (..)
    , LedgerBytesError (..)
    , fromHex
    , bytes
    , fromBytes
    , encodeByteString
    ) where

import Control.DeepSeq (NFData)
import Control.Exception (Exception)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.ByteString.Internal (c2w, w2c)
import Data.Either.Extras (unsafeFromEither)
import Data.Function ((&))
import Data.String (IsString (..))
import Data.Text qualified as Text
import Data.Text.Encoding qualified as TE
import Data.Typeable (Typeable)
import Data.Word (Word8)
import GHC.Generics (Generic)
import PlutusTx (FromData, ToData, UnsafeFromData, makeLift)
import PlutusTx.Blueprint (HasBlueprintDefinition, HasBlueprintSchema (..), SchemaInfo (title),
                           withSchemaInfo)
import PlutusTx.Prelude qualified as P
import Prettyprinter.Extras (Pretty, PrettyShow (..))

{- | An error that is encountered when converting a `ByteString` to a `LedgerBytes`. -}
data LedgerBytesError =
    UnpairedDigit -- ^ Odd number of bytes in the original bytestring.
    | NotHexit !Char -- ^ A non-hex digit character ([^A-Fa-f0-9]) encountered during decoding.
    deriving stock (Int -> LedgerBytesError -> ShowS
[LedgerBytesError] -> ShowS
LedgerBytesError -> String
(Int -> LedgerBytesError -> ShowS)
-> (LedgerBytesError -> String)
-> ([LedgerBytesError] -> ShowS)
-> Show LedgerBytesError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerBytesError -> ShowS
showsPrec :: Int -> LedgerBytesError -> ShowS
$cshow :: LedgerBytesError -> String
show :: LedgerBytesError -> String
$cshowList :: [LedgerBytesError] -> ShowS
showList :: [LedgerBytesError] -> ShowS
Show)
    deriving anyclass (Show LedgerBytesError
Typeable LedgerBytesError
(Typeable LedgerBytesError, Show LedgerBytesError) =>
(LedgerBytesError -> SomeException)
-> (SomeException -> Maybe LedgerBytesError)
-> (LedgerBytesError -> String)
-> Exception LedgerBytesError
SomeException -> Maybe LedgerBytesError
LedgerBytesError -> String
LedgerBytesError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: LedgerBytesError -> SomeException
toException :: LedgerBytesError -> SomeException
$cfromException :: SomeException -> Maybe LedgerBytesError
fromException :: SomeException -> Maybe LedgerBytesError
$cdisplayException :: LedgerBytesError -> String
displayException :: LedgerBytesError -> String
Exception)

{- | Convert a hex-encoded (Base16) `ByteString` to a `LedgerBytes`.
     May return an error (`LedgerBytesError`).
-}
fromHex :: BS.ByteString -> Either LedgerBytesError LedgerBytes
fromHex :: ByteString -> Either LedgerBytesError LedgerBytes
fromHex = (ByteString -> LedgerBytes)
-> Either LedgerBytesError ByteString
-> Either LedgerBytesError LedgerBytes
forall a b.
(a -> b) -> Either LedgerBytesError a -> Either LedgerBytesError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BuiltinByteString -> LedgerBytes
LedgerBytes (BuiltinByteString -> LedgerBytes)
-> (ByteString -> BuiltinByteString) -> ByteString -> LedgerBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
P.toBuiltin) (Either LedgerBytesError ByteString
 -> Either LedgerBytesError LedgerBytes)
-> (ByteString -> Either LedgerBytesError ByteString)
-> ByteString
-> Either LedgerBytesError LedgerBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either LedgerBytesError ByteString
asBSLiteral
    where

    handleChar :: Word8 -> Either LedgerBytesError Word8
    handleChar :: Word8 -> Either LedgerBytesError Word8
handleChar Word8
x
        | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Char -> Word8
c2w Char
'0' Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Word8
c2w Char
'9' = Word8 -> Either LedgerBytesError Word8
forall a b. b -> Either a b
Right (Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Char -> Word8
c2w Char
'0') -- hexits 0-9
        | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Char -> Word8
c2w Char
'a' Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Word8
c2w Char
'f' = Word8 -> Either LedgerBytesError Word8
forall a b. b -> Either a b
Right (Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Char -> Word8
c2w Char
'a' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
10) -- hexits a-f
        | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Char -> Word8
c2w Char
'A' Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Word8
c2w Char
'F' = Word8 -> Either LedgerBytesError Word8
forall a b. b -> Either a b
Right (Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Char -> Word8
c2w Char
'A' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
10) -- hexits A-F
        | Bool
otherwise = LedgerBytesError -> Either LedgerBytesError Word8
forall a b. a -> Either a b
Left (LedgerBytesError -> Either LedgerBytesError Word8)
-> LedgerBytesError -> Either LedgerBytesError Word8
forall a b. (a -> b) -> a -> b
$ Char -> LedgerBytesError
NotHexit (Word8 -> Char
w2c Word8
x)

    -- turns a pair of bytes such as "a6" into a single Word8
    handlePair :: Word8 -> Word8 -> Either LedgerBytesError Word8
    handlePair :: Word8 -> Word8 -> Either LedgerBytesError Word8
handlePair Word8
c Word8
c' = do
      Word8
n <- Word8 -> Either LedgerBytesError Word8
handleChar Word8
c
      Word8
n' <- Word8 -> Either LedgerBytesError Word8
handleChar Word8
c'
      Word8 -> Either LedgerBytesError Word8
forall a. a -> Either LedgerBytesError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Either LedgerBytesError Word8)
-> Word8 -> Either LedgerBytesError Word8
forall a b. (a -> b) -> a -> b
$ (Word8
16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
n) Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
n'

    asBytes :: [Word8] -> Either LedgerBytesError [Word8]
    asBytes :: [Word8] -> Either LedgerBytesError [Word8]
asBytes []        = [Word8] -> Either LedgerBytesError [Word8]
forall a b. b -> Either a b
Right [Word8]
forall a. Monoid a => a
mempty
    asBytes (Word8
c:Word8
c':[Word8]
cs) = (:) (Word8 -> [Word8] -> [Word8])
-> Either LedgerBytesError Word8
-> Either LedgerBytesError ([Word8] -> [Word8])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Word8 -> Either LedgerBytesError Word8
handlePair Word8
c Word8
c' Either LedgerBytesError ([Word8] -> [Word8])
-> Either LedgerBytesError [Word8]
-> Either LedgerBytesError [Word8]
forall a b.
Either LedgerBytesError (a -> b)
-> Either LedgerBytesError a -> Either LedgerBytesError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Word8] -> Either LedgerBytesError [Word8]
asBytes [Word8]
cs
    asBytes [Word8]
_         = LedgerBytesError -> Either LedgerBytesError [Word8]
forall a b. a -> Either a b
Left LedgerBytesError
UnpairedDigit

    -- parses a bytestring such as @a6b4@ into an actual bytestring
    asBSLiteral :: BS.ByteString -> Either LedgerBytesError BS.ByteString
    asBSLiteral :: ByteString -> Either LedgerBytesError ByteString
asBSLiteral = ([Word8] -> Either LedgerBytesError [Word8])
-> ByteString -> Either LedgerBytesError ByteString
withBytes [Word8] -> Either LedgerBytesError [Word8]
asBytes
     where
      withBytes ::
        ([Word8] -> Either LedgerBytesError [Word8]) ->
        BS.ByteString ->
        Either LedgerBytesError BS.ByteString
      withBytes :: ([Word8] -> Either LedgerBytesError [Word8])
-> ByteString -> Either LedgerBytesError ByteString
withBytes [Word8] -> Either LedgerBytesError [Word8]
f = ([Word8] -> ByteString)
-> Either LedgerBytesError [Word8]
-> Either LedgerBytesError ByteString
forall a b.
(a -> b) -> Either LedgerBytesError a -> Either LedgerBytesError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> ByteString
BS.pack (Either LedgerBytesError [Word8]
 -> Either LedgerBytesError ByteString)
-> (ByteString -> Either LedgerBytesError [Word8])
-> ByteString
-> Either LedgerBytesError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Either LedgerBytesError [Word8]
f ([Word8] -> Either LedgerBytesError [Word8])
-> (ByteString -> [Word8])
-> ByteString
-> Either LedgerBytesError [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

newtype LedgerBytes = LedgerBytes { LedgerBytes -> BuiltinByteString
getLedgerBytes :: P.BuiltinByteString }
    deriving stock (LedgerBytes -> LedgerBytes -> Bool
(LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> Bool) -> Eq LedgerBytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LedgerBytes -> LedgerBytes -> Bool
== :: LedgerBytes -> LedgerBytes -> Bool
$c/= :: LedgerBytes -> LedgerBytes -> Bool
/= :: LedgerBytes -> LedgerBytes -> Bool
Eq, Eq LedgerBytes
Eq LedgerBytes =>
(LedgerBytes -> LedgerBytes -> Ordering)
-> (LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> LedgerBytes)
-> (LedgerBytes -> LedgerBytes -> LedgerBytes)
-> Ord LedgerBytes
LedgerBytes -> LedgerBytes -> Bool
LedgerBytes -> LedgerBytes -> Ordering
LedgerBytes -> LedgerBytes -> LedgerBytes
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LedgerBytes -> LedgerBytes -> Ordering
compare :: LedgerBytes -> LedgerBytes -> Ordering
$c< :: LedgerBytes -> LedgerBytes -> Bool
< :: LedgerBytes -> LedgerBytes -> Bool
$c<= :: LedgerBytes -> LedgerBytes -> Bool
<= :: LedgerBytes -> LedgerBytes -> Bool
$c> :: LedgerBytes -> LedgerBytes -> Bool
> :: LedgerBytes -> LedgerBytes -> Bool
$c>= :: LedgerBytes -> LedgerBytes -> Bool
>= :: LedgerBytes -> LedgerBytes -> Bool
$cmax :: LedgerBytes -> LedgerBytes -> LedgerBytes
max :: LedgerBytes -> LedgerBytes -> LedgerBytes
$cmin :: LedgerBytes -> LedgerBytes -> LedgerBytes
min :: LedgerBytes -> LedgerBytes -> LedgerBytes
Ord, (forall x. LedgerBytes -> Rep LedgerBytes x)
-> (forall x. Rep LedgerBytes x -> LedgerBytes)
-> Generic LedgerBytes
forall x. Rep LedgerBytes x -> LedgerBytes
forall x. LedgerBytes -> Rep LedgerBytes x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LedgerBytes -> Rep LedgerBytes x
from :: forall x. LedgerBytes -> Rep LedgerBytes x
$cto :: forall x. Rep LedgerBytes x -> LedgerBytes
to :: forall x. Rep LedgerBytes x -> LedgerBytes
Generic, Typeable)
    deriving newtype (LedgerBytes -> LedgerBytes -> Bool
(LedgerBytes -> LedgerBytes -> Bool) -> Eq LedgerBytes
forall a. (a -> a -> Bool) -> Eq a
$c== :: LedgerBytes -> LedgerBytes -> Bool
== :: LedgerBytes -> LedgerBytes -> Bool
P.Eq, Eq LedgerBytes
Eq LedgerBytes =>
(LedgerBytes -> LedgerBytes -> Ordering)
-> (LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> Bool)
-> (LedgerBytes -> LedgerBytes -> LedgerBytes)
-> (LedgerBytes -> LedgerBytes -> LedgerBytes)
-> Ord LedgerBytes
LedgerBytes -> LedgerBytes -> Bool
LedgerBytes -> LedgerBytes -> Ordering
LedgerBytes -> LedgerBytes -> LedgerBytes
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LedgerBytes -> LedgerBytes -> Ordering
compare :: LedgerBytes -> LedgerBytes -> Ordering
$c< :: LedgerBytes -> LedgerBytes -> Bool
< :: LedgerBytes -> LedgerBytes -> Bool
$c<= :: LedgerBytes -> LedgerBytes -> Bool
<= :: LedgerBytes -> LedgerBytes -> Bool
$c> :: LedgerBytes -> LedgerBytes -> Bool
> :: LedgerBytes -> LedgerBytes -> Bool
$c>= :: LedgerBytes -> LedgerBytes -> Bool
>= :: LedgerBytes -> LedgerBytes -> Bool
$cmax :: LedgerBytes -> LedgerBytes -> LedgerBytes
max :: LedgerBytes -> LedgerBytes -> LedgerBytes
$cmin :: LedgerBytes -> LedgerBytes -> LedgerBytes
min :: LedgerBytes -> LedgerBytes -> LedgerBytes
P.Ord, LedgerBytes -> BuiltinData
(LedgerBytes -> BuiltinData) -> ToData LedgerBytes
forall a. (a -> BuiltinData) -> ToData a
$ctoBuiltinData :: LedgerBytes -> BuiltinData
toBuiltinData :: LedgerBytes -> BuiltinData
PlutusTx.ToData, BuiltinData -> Maybe LedgerBytes
(BuiltinData -> Maybe LedgerBytes) -> FromData LedgerBytes
forall a. (BuiltinData -> Maybe a) -> FromData a
$cfromBuiltinData :: BuiltinData -> Maybe LedgerBytes
fromBuiltinData :: BuiltinData -> Maybe LedgerBytes
PlutusTx.FromData, BuiltinData -> LedgerBytes
(BuiltinData -> LedgerBytes) -> UnsafeFromData LedgerBytes
forall a. (BuiltinData -> a) -> UnsafeFromData a
$cunsafeFromBuiltinData :: BuiltinData -> LedgerBytes
unsafeFromBuiltinData :: BuiltinData -> LedgerBytes
PlutusTx.UnsafeFromData)
    deriving anyclass (LedgerBytes -> ()
(LedgerBytes -> ()) -> NFData LedgerBytes
forall a. (a -> ()) -> NFData a
$crnf :: LedgerBytes -> ()
rnf :: LedgerBytes -> ()
NFData, DefinitionId
DefinitionId -> HasBlueprintDefinition LedgerBytes
forall t. DefinitionId -> HasBlueprintDefinition t
$cdefinitionId :: DefinitionId
definitionId :: DefinitionId
HasBlueprintDefinition)
    deriving (forall ann. LedgerBytes -> Doc ann)
-> (forall ann. [LedgerBytes] -> Doc ann) -> Pretty LedgerBytes
forall ann. [LedgerBytes] -> Doc ann
forall ann. LedgerBytes -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
$cpretty :: forall ann. LedgerBytes -> Doc ann
pretty :: forall ann. LedgerBytes -> Doc ann
$cprettyList :: forall ann. [LedgerBytes] -> Doc ann
prettyList :: forall ann. [LedgerBytes] -> Doc ann
Pretty via (PrettyShow LedgerBytes)

instance HasBlueprintSchema LedgerBytes referencedTypes where
  {-# INLINEABLE schema #-}
  schema :: Schema referencedTypes
schema =
    forall t (referencedTypes :: [*]).
HasBlueprintSchema t referencedTypes =>
Schema referencedTypes
schema @P.BuiltinByteString
      Schema referencedTypes
-> (Schema referencedTypes -> Schema referencedTypes)
-> Schema referencedTypes
forall a b. a -> (a -> b) -> b
& (SchemaInfo -> SchemaInfo)
-> Schema referencedTypes -> Schema referencedTypes
forall (referencedTypes :: [*]).
(SchemaInfo -> SchemaInfo)
-> Schema referencedTypes -> Schema referencedTypes
withSchemaInfo \SchemaInfo
info -> SchemaInfo
info{title = Just "LedgerBytes"}

-- | Lift a Haskell bytestring to the Plutus abstraction 'LedgerBytes'
fromBytes :: BS.ByteString -> LedgerBytes
fromBytes :: ByteString -> LedgerBytes
fromBytes = BuiltinByteString -> LedgerBytes
LedgerBytes (BuiltinByteString -> LedgerBytes)
-> (ByteString -> BuiltinByteString) -> ByteString -> LedgerBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
P.toBuiltin

-- | Extract the Haskell bytestring from inside the Plutus opaque 'LedgerBytes'.
bytes :: LedgerBytes -> BS.ByteString
bytes :: LedgerBytes -> ByteString
bytes = BuiltinByteString -> ByteString
BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
P.fromBuiltin (BuiltinByteString -> ByteString)
-> (LedgerBytes -> BuiltinByteString) -> LedgerBytes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerBytes -> BuiltinByteString
getLedgerBytes

{- | Read in arbitrary 'LedgerBytes' as a \"string\" (of characters).

This is mostly used together with GHC's /OverloadedStrings/ extension
to specify at the source code any 'LedgerBytes' constants,
by utilizing Haskell's double-quoted string syntax.

IMPORTANT: the 'LedgerBytes' are expected to be already hex-encoded (base16); otherwise,
'LedgerBytesError' will be raised as an 'GHC.Exception.Exception'.
-}
instance IsString LedgerBytes where
    fromString :: String -> LedgerBytes
fromString = Either LedgerBytesError LedgerBytes -> LedgerBytes
forall e a. Exception e => Either e a -> a
unsafeFromEither (Either LedgerBytesError LedgerBytes -> LedgerBytes)
-> (String -> Either LedgerBytesError LedgerBytes)
-> String
-> LedgerBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either LedgerBytesError LedgerBytes
fromHex (ByteString -> Either LedgerBytesError LedgerBytes)
-> (String -> ByteString)
-> String
-> Either LedgerBytesError LedgerBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a. IsString a => String -> a
fromString

{- | The `Show` instance of `LedgerBytes` is its Base16/Hex encoded bytestring,
decoded with UTF-8, unpacked to `String`. -}
instance Show LedgerBytes where
    show :: LedgerBytes -> String
show = Text -> String
Text.unpack (Text -> String) -> (LedgerBytes -> Text) -> LedgerBytes -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeByteString (ByteString -> Text)
-> (LedgerBytes -> ByteString) -> LedgerBytes -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerBytes -> ByteString
bytes

{- | Encode a ByteString value to Base16 (i.e. hexadecimal), then
decode with UTF-8 to a `Text`. -}
encodeByteString :: BS.ByteString -> Text.Text
encodeByteString :: ByteString -> Text
encodeByteString = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode

----------------------------------------------------------------------------------------------------
-- TH Splices --------------------------------------------------------------------------------------

$(makeLift ''LedgerBytes)