{-# 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.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
  = -- | Odd number of bytes in the original bytestring.
    UnpairedDigit
  | -- | A non-hex digit character ([^A-Fa-f0-9]) encountered during decoding.
    NotHexit !Char
  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)
  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)