-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Packing utilities.
module Lorentz.Pack
  ( lPackValueRaw
  , lUnpackValueRaw
  , lPackValue
  , lUnpackValue
  , lEncodeValue
  , valueToScriptExpr
  , expressionToScriptExpr
  ) where

import qualified Data.ByteString as BS
import Data.Constraint ((\\))

import Lorentz.Bytes
import Lorentz.Constraints
import Michelson.Interpret.Pack
import Michelson.Interpret.Unpack
import Michelson.Typed
import Morley.Micheline (Expression, encodeExpression')
import Tezos.Crypto (blake2b)

lPackValueRaw
  :: forall a.
     (NicePackedValue a)
  => a -> ByteString
lPackValueRaw :: a -> ByteString
lPackValueRaw =
  Value (ToT a) -> ByteString
forall (t :: T). PackedValScope t => Value t -> ByteString
packValue' (Value (ToT a) -> ByteString)
-> (a -> Value (ToT a)) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value (ToT a)
forall a. IsoValue a => a -> Value (ToT a)
toVal (PackedValScope (ToT a) => a -> ByteString)
-> (((SingI (ToT a), FailOnOperationFound (ContainsOp (ToT a)),
      FailOnBigMapFound (ContainsBigMap (ToT a)),
      FailOnTicketFound (ContainsTicket (ToT a))),
     KnownValue a)
    :- PackedValScope (ToT a))
-> a
-> ByteString
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ ((SingI (ToT a), FailOnOperationFound (ContainsOp (ToT a)),
  FailOnBigMapFound (ContainsBigMap (ToT a)),
  FailOnTicketFound (ContainsTicket (ToT a))),
 KnownValue a)
:- PackedValScope (ToT a)
forall a. NicePackedValue a :- PackedValScope (ToT a)
nicePackedValueEvi @a

lUnpackValueRaw
  :: forall a.
     (NiceUnpackedValue a)
  => ByteString -> Either UnpackError a
lUnpackValueRaw :: ByteString -> Either UnpackError a
lUnpackValueRaw =
  (Value (ToT a) -> a)
-> Either UnpackError (Value (ToT a)) -> Either UnpackError a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value (ToT a) -> a
forall a. IsoValue a => Value (ToT a) -> a
fromVal (Either UnpackError (Value (ToT a)) -> Either UnpackError a)
-> (ByteString -> Either UnpackError (Value (ToT a)))
-> ByteString
-> Either UnpackError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnpackError (Value (ToT a))
forall (t :: T).
UnpackedValScope t =>
ByteString -> Either UnpackError (Value t)
unpackValue' (UnpackedValScope (ToT a) => ByteString -> Either UnpackError a)
-> ((((SingI (ToT a), FailOnOperationFound (ContainsOp (ToT a)),
       FailOnBigMapFound (ContainsBigMap (ToT a)),
       FailOnTicketFound (ContainsTicket (ToT a))),
      (SingI (ToT a), FailOnOperationFound (ContainsOp (ToT a)),
       FailOnBigMapFound (ContainsBigMap (ToT a)),
       FailOnContractFound (ContainsContract (ToT a)),
       FailOnTicketFound (ContainsTicket (ToT a)))),
     KnownValue a)
    :- UnpackedValScope (ToT a))
-> ByteString
-> Either UnpackError a
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ (((SingI (ToT a), FailOnOperationFound (ContainsOp (ToT a)),
   FailOnBigMapFound (ContainsBigMap (ToT a)),
   FailOnTicketFound (ContainsTicket (ToT a))),
  (SingI (ToT a), FailOnOperationFound (ContainsOp (ToT a)),
   FailOnBigMapFound (ContainsBigMap (ToT a)),
   FailOnContractFound (ContainsContract (ToT a)),
   FailOnTicketFound (ContainsTicket (ToT a)))),
 KnownValue a)
:- UnpackedValScope (ToT a)
forall a. NiceUnpackedValue a :- UnpackedValScope (ToT a)
niceUnpackedValueEvi @a

lPackValue
  :: forall a.
     (NicePackedValue a)
  => a -> Packed a
lPackValue :: a -> Packed a
lPackValue =
  ByteString -> Packed a
forall a. ByteString -> Packed a
Packed (ByteString -> Packed a) -> (a -> ByteString) -> a -> Packed a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValueRaw

lUnpackValue
  :: forall a.
     (NiceUnpackedValue a)
  => Packed a -> Either UnpackError a
lUnpackValue :: Packed a -> Either UnpackError a
lUnpackValue =
  ByteString -> Either UnpackError a
forall a. NiceUnpackedValue a => ByteString -> Either UnpackError a
lUnpackValueRaw (ByteString -> Either UnpackError a)
-> (Packed a -> ByteString) -> Packed a -> Either UnpackError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Packed a -> ByteString
forall a. Packed a -> ByteString
unPacked

lEncodeValue
  :: forall a. (NicePrintedValue a)
  => a -> ByteString
lEncodeValue :: a -> ByteString
lEncodeValue = Value (ToT a) -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary' (Value (ToT a) -> ByteString)
-> (a -> Value (ToT a)) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value (ToT a)
forall a. IsoValue a => a -> Value (ToT a)
toVal ((SingI (ToT a), HasNoOp (ToT a)) => a -> ByteString)
-> (((SingI (ToT a), FailOnOperationFound (ContainsOp (ToT a))),
     KnownValue a)
    :- (SingI (ToT a), HasNoOp (ToT a)))
-> a
-> ByteString
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ ((SingI (ToT a), FailOnOperationFound (ContainsOp (ToT a))),
 KnownValue a)
:- (SingI (ToT a), HasNoOp (ToT a))
forall a. NicePrintedValue a :- PrintedValScope (ToT a)
nicePrintedValueEvi @a

-- | This function transforms Lorentz values into @script_expr@.
--
-- @script_expr@ is used in RPC as an argument in entrypoint
-- designed for getting value by key from the big_map in Babylon.
-- In order to convert value to the @script_expr@ we have to pack it,
-- take blake2b hash and add specific @expr@ prefix. Take a look at
-- <https://gitlab.com/tezos/tezos/blob/6e25ae8eb385d9975a30388c7a7aa2a9a65bf184/src/proto_005_PsBabyM1/lib_protocol/script_expr_hash.ml>
-- and <https://gitlab.com/tezos/tezos/blob/6e25ae8eb385d9975a30388c7a7aa2a9a65bf184/src/proto_005_PsBabyM1/lib_protocol/contract_services.ml#L136>
-- for more information.
valueToScriptExpr
  :: forall t. (NicePackedValue t)
  => t -> ByteString
valueToScriptExpr :: t -> ByteString
valueToScriptExpr = ByteString -> ByteString
addScriptExprPrefix (ByteString -> ByteString) -> (t -> ByteString) -> t -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
blake2b (ByteString -> ByteString) -> (t -> ByteString) -> t -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValueRaw

-- | Similar to 'valueToScriptExpr', but for values encoded as 'Expression's.
-- This is only used in tests.
expressionToScriptExpr :: Expression -> ByteString
expressionToScriptExpr :: Expression -> ByteString
expressionToScriptExpr = ByteString -> ByteString
addScriptExprPrefix (ByteString -> ByteString)
-> (Expression -> ByteString) -> Expression -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
blake2b (ByteString -> ByteString)
-> (Expression -> ByteString) -> Expression -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
mappend ByteString
forall s. IsString s => s
packValuePrefix (ByteString -> ByteString)
-> (Expression -> ByteString) -> Expression -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> ByteString
encodeExpression'

addScriptExprPrefix :: ByteString -> ByteString
addScriptExprPrefix :: ByteString -> ByteString
addScriptExprPrefix = ([Word8] -> ByteString
BS.pack [Word8
0x0D, Word8
0x2C, Word8
0x40, Word8
0x1B] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)