module Michelson.Interpret.Unpack
( UnpackError (..)
, unpackValue
, unpackValue'
, unpackInstr'
, decodeContract
) where
import Prelude hiding (EQ, Ordering(..), get)
import Control.Monad.Except (throwError)
import Data.Binary (Get)
import qualified Data.Binary.Get as Get
import qualified Data.Bits as Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Constraint (Dict(..))
import Data.Default (def)
import qualified Data.Kind as Kind
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Singletons (SingI(..))
import Data.Typeable ((:~:)(..))
import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (+||), (|+), (||+))
import Text.Hex (encodeHex)
import Michelson.Parser (Parser, ParserException(..), parseNoEnv)
import qualified Michelson.Parser.Annotations as PA
import Michelson.Text
import Michelson.TypeCheck
(HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..))
import Michelson.TypeCheck.Helpers (ensureDistinctAsc, eqHST1)
import Michelson.TypeCheck.Instr (typeCheckList)
import Michelson.Typed (RemFail(..), Sing(..), starNotes)
import qualified Michelson.Typed as T
import Michelson.Typed.EntryPoints
import Michelson.Typed.Scope
(BigMapPresence(..), ContractPresence(..), OpPresence(..), UnpackedValScope, bigMapAbsense,
checkBigMapPresence, checkContractTypePresence, checkOpPresence, contractTypeAbsense, opAbsense)
import Michelson.Untyped
import Tezos.Address (Address(..), ContractHash(..))
import Tezos.Core
import Tezos.Crypto
(KeyHash(..), KeyHashTag(..), PublicKey(..), keyHashLengthBytes, mkSignature, parseKeyHash,
parsePublicKey, parseSignature)
import qualified Tezos.Crypto.Ed25519 as Ed25519
import qualified Tezos.Crypto.P256 as P256
import qualified Tezos.Crypto.Secp256k1 as Secp256k1
newtype UnpackError = UnpackError { unUnpackError :: Text }
deriving stock (Show, Eq)
instance Buildable UnpackError where
build (UnpackError msg) = build msg
instance Exception UnpackError where
displayException = pretty
(?) :: Get a -> String -> Get a
(?) = flip Get.label
infix 0 ?
getByteStringCopy :: Int -> Get ByteString
getByteStringCopy = fmap BS.copy . Get.getByteString
getRemainingByteStringCopy :: Get ByteString
getRemainingByteStringCopy = do
lbs <- Get.getRemainingLazyByteString
when (length lbs > 640000) $ fail "Too big length for an entity"
return (LBS.toStrict lbs)
expectTag :: String -> Word8 -> Get ()
expectTag desc t =
Get.label desc $ do
t' <- Get.getWord8
unless (t == t') $
fail . fmt $ "Unexpected tag value (expected 0x" +| hexF t |+
", but got 0x" +| hexF t' |+ ")"
unknownTag :: String -> Word8 -> Get a
unknownTag desc tag =
fail . fmt $ "Unknown " <> build desc <> " tag: 0x" <> hexF tag
expectDescTag :: HasCallStack => String -> Word16 -> Get ()
expectDescTag desc argsNum =
Get.label desc $ do
tag <- Get.getWord8
unless (tag == expected) $
fail . fmt $ "Unexpected preliminary tag: 0x" <> hexF tag
where
expected = case argsNum of
0 -> 0x03
1 -> 0x05
2 -> 0x07
3 -> 0x08
_ -> error "Bad arguments num"
ensureEnd :: Get ()
ensureEnd =
unlessM Get.isEmpty $ do
remainder <- Get.getRemainingLazyByteString
fail $ "Expected end of entry, unconsumed bytes \
\(" +| length remainder |+ "): "
+|| encodeHex (LBS.toStrict remainder) ||+ ""
manyForced :: Get a -> Get [a]
manyForced decode = do
emp <- Get.isEmpty
if emp
then return []
else (:) <$> decode <*> manyForced decode
data TaggedDecoder a = TaggedDecoder
{ tdTag :: Word8
, tdDecoder :: Get a
}
(#:) :: Word8 -> Get a -> TaggedDecoder a
(#:) = TaggedDecoder
infixr 0 #:
decodeWithTag :: String -> [TaggedDecoder a] -> Get a
decodeWithTag what decoders = Get.label what $ do
tag <- Get.label (what <> " tag") Get.getWord8
case List.find ((tag ==) . tdTag) decoders of
Nothing -> unknownTag what tag
Just TaggedDecoder{..} -> tdDecoder
launchGet :: Get a -> LByteString -> Either UnpackError a
launchGet decoder bs =
case Get.runGetOrFail decoder bs of
Left (_remainder, _offset, err) -> Left . UnpackError $ toText err
Right (_remainder, _offset, res) -> Right res
unpackValue
:: (UnpackedValScope t)
=> LByteString -> Either UnpackError (T.Value t)
unpackValue = launchGet (finalizeDecoder decodeValue)
unpackValue'
:: (UnpackedValScope t)
=> ByteString -> Either UnpackError (T.Value t)
unpackValue' = unpackValue . LBS.fromStrict
unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]
unpackInstr' = launchGet (finalizeDecoder decodeOps) . LBS.fromStrict
finalizeDecoder :: Get a -> Get a
finalizeDecoder decoder =
expectTag "Packed data start" 0x05 *> decoder <* ensureEnd
decodeValue
:: forall t.
(HasCallStack, UnpackedValScope t)
=> Get (T.Value t)
decodeValue = Get.label "Value" $
case sing @t of
STc _ ->
T.VC <$> decodeCValue
STKey -> T.VKey <$> decodeAsBytesOrString
( decodeWithTag "key"
[ 0x00 #: decodeBytesLike "key Ed25519"
(fmap PublicKeyEd25519 . Ed25519.mkPublicKey)
, 0x01 #: decodeBytesLike "key Secp256k1"
(fmap PublicKeySecp256k1 . Secp256k1.mkPublicKey)
, 0x02 #: decodeBytesLike "key P256"
(fmap PublicKeyP256 . P256.mkPublicKey)
]
, parsePublicKey
)
STUnit -> do
expectDescTag "Unit" 0
expectTag "Unit" 0x0B
return T.VUnit
STSignature -> T.VSignature <$> decodeAsBytesOrString
( decodeBytesLikeMaybe "signature wrong size" mkSignature
, parseSignature
)
STChainId -> T.VChainId <$> decodeAsBytesOrString
( decodeBytesLikeMaybe "chain_id wrong size" mkChainId
, parseChainId
)
STOption _ -> do
Get.getByteString 2 >>= \case
"\x03\x06" -> pure (T.VOption Nothing)
"\x05\x09" -> T.VOption . Just <$> decodeValue
other -> fail $ "Unknown option tag: " <> show other
STList _ -> do
decodeAsList $ T.VList <$> manyForced decodeValue
STSet _ -> do
decodeAsList $ do
vals <- manyForced decodeCValue
either (fail . toString) pure $
T.VSet . Set.fromDistinctAscList <$> ensureDistinctAsc id vals
STPair lt _ ->
case (checkOpPresence lt, checkBigMapPresence lt, checkContractTypePresence lt) of
(OpAbsent, BigMapAbsent, ContractAbsent) -> do
expectDescTag "Pair" 2
expectTag "Pair" 0x07
T.VPair ... (,) <$> decodeValue <*> decodeValue
STOr lt _ ->
case (checkOpPresence lt, checkBigMapPresence lt, checkContractTypePresence lt) of
(OpAbsent, BigMapAbsent, ContractAbsent) -> do
expectDescTag "Or" 1
Get.getWord8 >>= \case
0x05 -> T.VOr . Left <$> decodeValue
0x08 -> T.VOr . Right <$> decodeValue
other -> unknownTag "or constructor" other
STLambda _ _ -> do
uinstr <- decodeOps
T.VLam <$> decodeTypeCheckLam uinstr
STMap _ _ -> do
T.VMap <$> decodeMap
decodeCValue :: forall ct. SingI ct => Get (T.CValue ct)
decodeCValue = case sing @ct of
SCInt -> do
expectTag "Int" 0x00
T.CvInt <$> decodeInt
SCNat -> do
expectTag "Nat" 0x00
T.CvNat <$> decodeInt
SCString -> do
expectTag "String" 0x01
T.CvString <$> decodeString
SCBytes -> do
expectTag "Bytes" 0x0a
T.CvBytes <$> decodeBytes
SCMutez -> do
expectTag "Mutez" 0x00
mmutez <- mkMutez <$> decodeInt
maybe (fail "Negative mutez") (pure . T.CvMutez) mmutez
SCBool -> do
expectDescTag "Bool" 0
Get.getWord8 >>= \case
0x0A -> pure (T.CvBool True)
0x03 -> pure (T.CvBool False)
other -> unknownTag "bool" other
SCKeyHash -> T.CvKeyHash <$> decodeAsBytesOrString
( decodeWithTag "key_hash" keyHashDecoders
, parseKeyHash
)
SCTimestamp -> do
expectTag "Timestamp" 0x00
T.CvTimestamp . timestampFromSeconds <$> decodeInt
SCAddress ->
T.CvAddress <$> decodeEpAddress
keyHashDecoders :: [TaggedDecoder KeyHash]
keyHashDecoders =
[ 0x00 #: KeyHash KeyHashEd25519 <$> getPayload
, 0x01 #: KeyHash KeyHashSecp256k1 <$> getPayload
, 0x02 #: KeyHash KeyHashP256 <$> getPayload
]
where
getPayload = getByteStringCopy keyHashLengthBytes
decodeLength :: Get Int
decodeLength = Get.label "Length" $ do
len <- Get.getWord32be
let len' = fromIntegral @_ @Int len
unless (fromIntegral len' == len && len' >= 0) $
fail "Length overflow"
return len'
decodeAsListRaw :: Get a -> Get a
decodeAsListRaw getElems = do
l <- decodeLength ? "List length"
Get.isolate l (getElems ? "List content")
decodeAsList :: Get a -> Get a
decodeAsList getElems = do
expectTag "List" 0x02
decodeAsListRaw getElems
decodeString :: Get MText
decodeString = do
l <- decodeLength ? "String length"
ss <- replicateM l Get.getWord8 ? "String content"
ss' <- decodeUtf8' (BS.pack ss)
& either (fail . show) pure
? "String UTF-8 decoding"
mkMText ss'
& either (fail . show) pure
? "Michelson string validity analysis"
decodeAsBytesRaw :: (Int -> Get a) -> Get a
decodeAsBytesRaw decode = do
l <- decodeLength ? "Byte array length"
decode l
decodeAsBytesOrString :: Buildable e => (Get a, Text -> Either e a) -> Get a
decodeAsBytesOrString (bytesDecoder, strParser) =
Get.getWord8 >>= \case
0x01 -> do
str <- decodeString
either (fail . pretty) pure $ strParser $ unMText str
0x0A -> do
decodeAsBytesRaw $ \l ->
Get.isolate l bytesDecoder ? "Binary content"
other -> unknownTag "text or string" other
decodeBytesLike
:: (Buildable err)
=> String -> (ByteString -> Either err a) -> Get a
decodeBytesLike what constructor = do
bs <- getRemainingByteStringCopy
case constructor bs of
Left err -> fail $ "Wrong " +| what |+ ": " +| err |+ ""
Right res -> pure res
decodeBytesLikeMaybe
:: String -> (ByteString -> Maybe a) -> Get a
decodeBytesLikeMaybe onErr constructor = do
bs <- getRemainingByteStringCopy
case constructor bs of
Nothing -> fail onErr
Just res -> pure res
decodeBytes :: Get ByteString
decodeBytes =
decodeAsBytesRaw $ Get.label "Bytes payload" . getByteStringCopy
decodeMap
:: (SingI k, UnpackedValScope v)
=> Get $ Map (T.CValue k) (T.Value v)
decodeMap = Get.label "Map" $
decodeAsList $ do
es <- manyForced $ do
expectDescTag "Elt" 2
expectTag "Elt" 0x04
(,) <$> decodeCValue <*> decodeValue
either (fail . toString) pure $
Map.fromDistinctAscList <$> ensureDistinctAsc fst es
decodeEpAddress :: Get EpAddress
decodeEpAddress = Get.label "Address (maybe with entrypoint)" $
decodeAsBytesOrString
( decodeWithTag "address"
[ 0x00 #: Get.label "Plain address" $ do
eaAddress <- KeyAddress <$>
decodeWithTag "key_hash inside address" keyHashDecoders
eaEntryPoint <- decodeEpName
return EpAddress{..}
, 0x01 #: Get.label "Contract address" $ do
eaAddress <- ContractAddress . ContractHash <$>
getByteStringCopy keyHashLengthBytes
expectTag "Contract address suffix" 0x00
eaEntryPoint <- decodeEpName
return EpAddress{..}
]
, parseEpAddress
)
decodeEpName :: Get EpName
decodeEpName = do
ss <- many Get.getWord8 ? "EpName' String content"
s <- decodeUtf8' (BS.pack ss)
& either (fail . show) pure
? "EpName' String UTF-8 decoding"
either (fail . pretty) pure $ epNameFromRefAnn (ann s)
decodeInt :: Num i => Get i
decodeInt = fromIntegral @Integer <$> loop 0 0 ? "Number"
where
loop !offset !acc = do
byte <- Get.getWord8
let hasCont = Bits.testBit byte 7
let doCont shft = if hasCont then loop (shft + offset) else pure
let addAndCont shft bytePayload =
doCont shft $ acc + Bits.shiftL (fromIntegral bytePayload) offset
let payload = Bits.clearBit byte 7
if offset > 0
then addAndCont 7 payload
else do
let sign = if Bits.testBit byte 6 then -1 else 1
let upayload = Bits.clearBit payload 6
(sign *) <$> addAndCont 6 upayload
decodeTypeCheckLam
:: forall inp out m.
(Typeable inp, SingI inp, SingI out, Typeable out, MonadFail m)
=> [ExpandedOp]
-> m (RemFail T.Instr '[inp] '[out])
decodeTypeCheckLam uinstr =
either tcErrToFail pure . evaluatingState tcInitEnv . runExceptT $ do
let inp = (sing @inp, starNotes, noAnn) ::& SNil
_ :/ instr' <- typeCheckList uinstr inp
case instr' of
instr ::: out' ->
case eqHST1 @out out' of
Right Refl ->
pure $ RfNormal instr
Left err ->
let tinp = Type TUnit noAnn
tout = Type TUnit noAnn
in throwError $
TCFailedOnInstr (LAMBDA noAnn tinp tout uinstr) (SomeHST inp)
"Unexpected lambda output type" def (Just err)
AnyOutInstr instr ->
return $ RfAlwaysFails instr
where
tcErrToFail err = fail $ "Type check failed: " +| err |+ ""
tcInitEnv =
TypeCheckEnv
{ tcExtFrames = error "runInstrImpl(UNPACK): tcExtFrames touched"
, tcContractParam = error "runInstrImpl(UNPACK): tcContractParam touched"
, tcContracts = error "runInstrImpl(UNPACK): tcContracts touched"
}
decodeInstr :: Get ExpandedInstr
decodeInstr = Get.label "Instruction" $ do
pretag <- Get.getWord8 ? "Pre instr tag"
tag <- Get.getWord8 ? "Instr tag"
case (pretag, tag) of
(0x03, 0x20) -> pure $ DROP
(0x05, 0x20) -> DROPN <$> (expectTag "'DROP n' parameter" 0x00 *> decodeInt)
(0x03, 0x21) -> DUP <$> decodeNoAnn
(0x03, 0x4C) -> pure $ SWAP
(0x05, 0x70) -> DIG <$> (expectTag "'DIG n' parameter" 0x00 *> decodeInt)
(0x05, 0x71) -> DUG <$> (expectTag "'DUG n' parameter" 0x00 *> decodeInt)
(0x07, 0x43) -> do
(typ, val) <- decodePushVal
an <- decodeNoAnn
return $ PUSH an typ val
(0x03, 0x46) -> SOME <$> decodeNoAnn <*> decodeNoAnn
(0x05, 0x3E) -> NONE <$> decodeNoAnn <*> decodeNoAnn <*> decodeType
(0x03, 0x4F) -> UNIT <$> decodeNoAnn <*> decodeNoAnn
(0x07, 0x2F) -> IF_NONE <$> decodeOps <*> decodeOps
(0x03, 0x42) -> PAIR <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn
(0x03, 0x16) -> CAR <$> decodeNoAnn <*> decodeNoAnn
(0x03, 0x17) -> CDR <$> decodeNoAnn <*> decodeNoAnn
(0x05, 0x33) -> LEFT <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn
<*> decodeType
(0x05, 0x44) -> RIGHT <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn
<*> decodeType
(0x07, 0x2E) -> IF_LEFT <$> decodeOps <*> decodeOps
(0x05, 0x3D) -> NIL <$> decodeNoAnn <*> decodeNoAnn <*> decodeType
(0x03, 0x1B) -> CONS <$> decodeNoAnn
(0x07, 0x2D) -> IF_CONS <$> decodeOps <*> decodeOps
(0x03, 0x45) -> SIZE <$> decodeNoAnn
(0x05, 0x24) -> EMPTY_SET <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable
(0x07, 0x23) -> EMPTY_MAP <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable
<*> decodeType
(0x07, 0x72) -> EMPTY_BIG_MAP <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable
<*> decodeType
(0x05, 0x38) -> MAP <$> decodeNoAnn <*> decodeOps
(0x05, 0x52) -> ITER <$> decodeOps
(0x03, 0x39) -> MEM <$> decodeNoAnn
(0x03, 0x29) -> GET <$> decodeNoAnn
(0x03, 0x50) -> UPDATE <$> decodeNoAnn
(0x07, 0x2C) -> IF <$> decodeOps <*> decodeOps
(0x05, 0x34) -> LOOP <$> decodeOps
(0x05, 0x53) -> LOOP_LEFT <$> decodeOps
(0x09, 0x31) -> do
(ti, to, ops) <- decodeAsListRaw $
(,,) <$> decodeType <*> decodeType <*> decodeOps
vAnn <- decodeVAnnDef
return $ LAMBDA vAnn ti to ops
(0x03, 0x26) -> EXEC <$> decodeNoAnn
(0x03, 0x73) -> APPLY <$> decodeNoAnn
(0x05, 0x1F) -> DIP <$> decodeOps
(0x07, 0x1F) ->
DIPN <$> (expectTag "'DIP n' parameter" 0x00 *> decodeInt) <*> decodeOps
(0x03, 0x27) -> pure FAILWITH
(0x05, 0x57) -> CAST <$> decodeNoAnn <*> decodeType
(0x03, 0x58) -> RENAME <$> decodeNoAnn
(0x03, 0x0C) -> PACK <$> decodeNoAnn
(0x05, 0x0D) -> UNPACK <$> decodeNoAnn <*> decodeNoAnn <*> decodeType
(0x03, 0x1A) -> CONCAT <$> decodeNoAnn
(0x03, 0x6F) -> SLICE <$> decodeNoAnn
(0x03, 0x56) -> ISNAT <$> decodeNoAnn
(0x03, 0x12) -> ADD <$> decodeNoAnn
(0x03, 0x4B) -> SUB <$> decodeNoAnn
(0x03, 0x3A) -> MUL <$> decodeNoAnn
(0x03, 0x22) -> EDIV <$> decodeNoAnn
(0x03, 0x11) -> ABS <$> decodeNoAnn
(0x03, 0x3B) -> NEG <$> decodeNoAnn
(0x03, 0x35) -> LSL <$> decodeNoAnn
(0x03, 0x36) -> LSR <$> decodeNoAnn
(0x03, 0x41) -> OR <$> decodeNoAnn
(0x03, 0x14) -> AND <$> decodeNoAnn
(0x03, 0x51) -> XOR <$> decodeNoAnn
(0x03, 0x3F) -> NOT <$> decodeNoAnn
(0x03, 0x19) -> COMPARE <$> decodeNoAnn
(0x03, 0x25) -> EQ <$> decodeNoAnn
(0x03, 0x3C) -> NEQ <$> decodeNoAnn
(0x03, 0x37) -> LT <$> decodeNoAnn
(0x03, 0x2A) -> GT <$> decodeNoAnn
(0x03, 0x32) -> LE <$> decodeNoAnn
(0x03, 0x28) -> GE <$> decodeNoAnn
(0x03, 0x30) -> INT <$> decodeNoAnn
(0x05, 0x55) -> CONTRACT <$> decodeNoAnn <*> decodeNoAnn <*> decodeType
(0x03, 0x4D) -> TRANSFER_TOKENS <$> decodeNoAnn
(0x03, 0x4E) -> SET_DELEGATE <$> decodeNoAnn
(0x05, 0x1D) -> do
contract <- decodeContract
CREATE_CONTRACT <$> decodeNoAnn <*> decodeNoAnn <*> pure contract
(0x03, 0x1E) -> IMPLICIT_ACCOUNT <$> decodeNoAnn
(0x03, 0x40) -> NOW <$> decodeNoAnn
(0x03, 0x13) -> AMOUNT <$> decodeNoAnn
(0x03, 0x15) -> BALANCE <$> decodeNoAnn
(0x03, 0x18) -> CHECK_SIGNATURE <$> decodeNoAnn
(0x03, 0x0F) -> SHA256 <$> decodeNoAnn
(0x03, 0x10) -> SHA512 <$> decodeNoAnn
(0x03, 0x0E) -> BLAKE2B <$> decodeNoAnn
(0x03, 0x2B) -> HASH_KEY <$> decodeNoAnn
(0x03, 0x4A) -> STEPS_TO_QUOTA <$> decodeNoAnn
(0x03, 0x47) -> SOURCE <$> decodeNoAnn
(0x03, 0x48) -> SENDER <$> decodeNoAnn
(0x03, 0x49) -> SELF <$> decodeNoAnn <*> decodeNoAnn
(0x03, 0x54) -> ADDRESS <$> decodeNoAnn
(0x03, 0x75) -> CHAIN_ID <$> decodeNoAnn
(0x04, 0x21) -> DUP <$> decodeVAnn
(0x08, 0x43) -> do
(typ, val) <- decodePushVal
an <- decodeVAnn
return $ PUSH an typ val
(0x04, 0x46) -> decodeWithTVAnns SOME
(0x06, 0x3E) -> do
t <- decodeType
decodeWithTVAnns NONE <*> pure t
(0x04, 0x4F) -> decodeWithTVAnns UNIT
(0x04, 0x42) -> decodeWithTVF2Anns PAIR
(0x04, 0x16) -> decodeWithVFAnns CAR
(0x04, 0x17) -> decodeWithVFAnns CDR
(0x06, 0x33) -> do
t <- decodeType
decodeWithTVF2Anns LEFT <*> pure t
(0x06, 0x44) -> do
t <- decodeType
decodeWithTVF2Anns RIGHT <*> pure t
(0x06, 0x3D) -> do
t <- decodeType
decodeWithTVAnns NIL <*> pure t
(0x04, 0x1B) -> CONS <$> decodeVAnn
(0x04, 0x45) -> SIZE<$> decodeVAnn
(0x06, 0x24) -> do
c <- decodeComparable
decodeWithTVAnns EMPTY_SET <*> pure c
(0x08, 0x23) -> do
c <- decodeComparable
t <- decodeType
decodeWithTVAnns EMPTY_MAP <*> pure c <*> pure t
(0x08, 0x72) -> do
c <- decodeComparable
t <- decodeType
decodeWithTVAnns EMPTY_BIG_MAP <*> pure c <*> pure t
(0x06, 0x38) -> do
o <- decodeOps
MAP <$> decodeVAnn <*> pure o
(0x04, 0x39) -> MEM <$> decodeVAnn
(0x04, 0x29) -> GET <$> decodeVAnn
(0x04, 0x50) -> UPDATE <$> decodeVAnn
(0x04, 0x26) -> EXEC <$> decodeVAnn
(0x04, 0x73) -> APPLY <$> decodeVAnn
(0x06, 0x57) -> do
t <- decodeType
CAST <$> decodeVAnn <*> pure t
(0x04, 0x58) -> RENAME <$> decodeVAnn
(0x04, 0x0C) -> PACK <$> decodeVAnn
(0x06, 0x0D) -> do
t <- decodeType
decodeWithTVAnns UNPACK <*> pure t
(0x04, 0x1A) -> CONCAT <$> decodeVAnn
(0x04, 0x6F) -> SLICE <$> decodeVAnn
(0x04, 0x56) -> ISNAT <$> decodeVAnn
(0x04, 0x12) -> ADD <$> decodeVAnn
(0x04, 0x4B) -> SUB <$> decodeVAnn
(0x04, 0x3A) -> MUL <$> decodeVAnn
(0x04, 0x22) -> EDIV <$> decodeVAnn
(0x04, 0x11) -> ABS <$> decodeVAnn
(0x04, 0x3B) -> NEG <$> decodeVAnn
(0x04, 0x35) -> LSL <$> decodeVAnn
(0x04, 0x36) -> LSR <$> decodeVAnn
(0x04, 0x41) -> OR <$> decodeVAnn
(0x04, 0x14) -> AND <$> decodeVAnn
(0x04, 0x51) -> XOR <$> decodeVAnn
(0x04, 0x3F) -> NOT <$> decodeVAnn
(0x04, 0x19) -> COMPARE <$> decodeVAnn
(0x04, 0x25) -> EQ <$> decodeVAnn
(0x04, 0x3C) -> NEQ <$> decodeVAnn
(0x04, 0x37) -> LT <$> decodeVAnn
(0x04, 0x2A) -> GT <$> decodeVAnn
(0x04, 0x32) -> LE <$> decodeVAnn
(0x04, 0x28) -> GE <$> decodeVAnn
(0x04, 0x30) -> INT <$> decodeVAnn
(0x06, 0x55) -> do
t <- decodeType
decodeWithVFAnns CONTRACT <*> pure t
(0x04, 0x4D) -> TRANSFER_TOKENS <$> decodeVAnn
(0x04, 0x4E) -> SET_DELEGATE <$> decodeVAnn
(0x06, 0x1D) -> do
contract <- decodeContract
decodeWithV2Anns CREATE_CONTRACT <*> pure contract
(0x04, 0x1E) -> IMPLICIT_ACCOUNT <$> decodeVAnn
(0x04, 0x40) -> NOW <$> decodeVAnn
(0x04, 0x13) -> AMOUNT <$> decodeVAnn
(0x04, 0x15) -> BALANCE <$> decodeVAnn
(0x04, 0x18) -> CHECK_SIGNATURE <$> decodeVAnn
(0x04, 0x0F) -> SHA256 <$> decodeVAnn
(0x04, 0x10) -> SHA512 <$> decodeVAnn
(0x04, 0x0E) -> BLAKE2B <$> decodeVAnn
(0x04, 0x2B) -> HASH_KEY <$> decodeVAnn
(0x04, 0x4A) -> STEPS_TO_QUOTA <$> decodeVAnn
(0x04, 0x47) -> SOURCE <$> decodeVAnn
(0x04, 0x48) -> SENDER <$> decodeVAnn
(0x04, 0x49) -> decodeWithVFAnns SELF
(0x04, 0x54) -> ADDRESS <$> decodeVAnn
(0x04, 0x75) -> CHAIN_ID <$> decodeVAnn
(other1, other2) -> fail $ "Unknown instruction tag: 0x" +|
hexF other1 |+ hexF other2 |+ ""
decodePushVal :: Get (Type, Value)
decodePushVal = do
typ <- decodeType
T.withSomeSingT (T.fromUType typ) $ \(st :: Sing t) ->
case (opAbsense st, bigMapAbsense st, contractTypeAbsense st) of
(Nothing, _, _) -> fail "Operation type cannot appear in PUSH"
(_, Nothing, _) -> fail "BigMap type cannot appear in PUSH"
(_, _, Nothing) -> fail "'contract' type cannot appear in PUSH"
(Just Dict, Just Dict, Just Dict) -> do
tval <- decodeValue @t
pure $ (typ, T.untypeValue tval)
decodeContract :: Get Contract
decodeContract = decodeAsList $ do
expectTag "Pre contract parameter" 0x05
expectTag "Contract parameter" 0x00
p <- decodeType
expectTag "Pre contract storage" 0x05
expectTag "Contract storage" 0x01
s <- decodeType
expectTag "Pre contract code" 0x05
expectTag "Contract code" 0x02
c <- decodeOps
pure (Contract p s c)
decodeOp :: Get ExpandedOp
decodeOp = Get.label "Op" $ do
tag <- Get.lookAhead Get.getWord8
if tag == 0x02
then SeqEx <$> decodeOps ? "Ops seq"
else PrimEx <$> decodeInstr ? "One op"
decodeOps :: Get [ExpandedOp]
decodeOps = decodeAsList $ manyForced decodeOp
decodeComparable :: Get Comparable
decodeComparable = do
(ct, tAnn, fAnn) <- decodeCTWithAnns
if fAnn == noAnn
then pure $ Comparable ct tAnn
else fail "This Comparable should not have a Field annotation"
decodeType :: Get Type
decodeType = do
(t, tAnn, fAnn) <- decodeTWithAnns
if fAnn == noAnn
then pure $ Type t tAnn
else fail "This Type should not have a Field annotation"
decodeCTWithAnns :: Get (CT, TypeAnn, FieldAnn)
decodeCTWithAnns = Get.label "Comparable primitive type" $ do
pretag <- Get.getWord8 ? "Pre simple comparable type tag"
tag <- Get.getWord8 ? "Simple comparable type tag"
let failMessage = "Unknown primitive tag: 0x" +| hexF pretag |+ hexF tag |+ ""
ct <- case tag of
0x5B -> pure CInt
0x62 -> pure CNat
0x68 -> pure CString
0x69 -> pure CBytes
0x6A -> pure CMutez
0x59 -> pure CBool
0x5D -> pure CKeyHash
0x6B -> pure CTimestamp
0x6E -> pure CAddress
_ -> fail failMessage
case pretag of
0x03 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn
0x04 -> decodeWithTFAnns (ct,,)
_ -> fail failMessage
decodeTWithAnns :: Get (T, TypeAnn, FieldAnn)
decodeTWithAnns = doDecode <|> decodeTc ? "Type"
where
decodeTc = do
(ct, tAnn, fAnn) <- decodeCTWithAnns
pure ((Tc ct), tAnn, fAnn)
doDecode = do
pretag <- Get.getWord8 ? "Pre complex type tag"
tag <- Get.getWord8 ? "Complex type tag"
case (pretag, tag) of
(0x03, 0x5C) ->
(,,) <$> pure TKey <*> decodeNoAnn <*> decodeNoAnn
(0x03, 0x6C) ->
(,,) <$> pure TUnit <*> decodeNoAnn <*> decodeNoAnn
(0x03, 0x67) ->
(,,) <$> pure TSignature <*> decodeNoAnn <*> decodeNoAnn
(0x03, 0x74) ->
(,,) <$> pure TChainId <*> decodeNoAnn <*> decodeNoAnn
(0x05, 0x63) ->
(,,) <$> (TOption <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn
(0x05, 0x5F) ->
(,,) <$> (TList <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn
(0x05, 0x66) ->
(,,) <$> (TSet <$> decodeComparable) <*> decodeNoAnn <*> decodeNoAnn
(0x03, 0x6D) ->
(,,) <$> pure TOperation <*> decodeNoAnn <*> decodeNoAnn
(0x05, 0x5A) ->
(,,) <$> (TContract <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn
(0x07, 0x65) -> do
t <- decodeTPair
(,,) <$> pure t <*> decodeNoAnn <*> decodeNoAnn
(0x07, 0x64) -> do
t <- decodeTOr
(,,) <$> pure t <*> decodeNoAnn <*> decodeNoAnn
(0x07, 0x5E) ->
(,,) <$> (TLambda <$> decodeType <*> decodeType) <*> decodeNoAnn <*> decodeNoAnn
(0x07, 0x60) ->
(,,) <$> (TMap <$> decodeComparable <*> decodeType) <*> decodeNoAnn <*> decodeNoAnn
(0x07, 0x61) ->
(,,) <$> (TBigMap <$> decodeComparable <*> decodeType) <*> decodeNoAnn <*> decodeNoAnn
(0x04, 0x5C) -> decodeWithTFAnns (TKey,,)
(0x04, 0x6C) -> decodeWithTFAnns (TUnit,,)
(0x04, 0x67) -> decodeWithTFAnns (TSignature,,)
(0x04, 0x74) -> decodeWithTFAnns (TChainId,,)
(0x06, 0x63) -> do
t <- TOption <$> decodeType
decodeWithTFAnns (t,,)
(0x06, 0x5F) -> do
t <- TList <$> decodeType
decodeWithTFAnns (t,,)
(0x06, 0x66) -> do
t <- TSet <$> decodeComparable
decodeWithTFAnns (t,,)
(0x04, 0x6D) -> decodeWithTFAnns (TOperation,,)
(0x06, 0x5A) -> do
t <- TContract <$> decodeType
decodeWithTFAnns (t,,)
(0x08, 0x65) -> do
t <- decodeTPair
decodeWithTFAnns (t,,)
(0x08, 0x64) -> do
t <- decodeTOr
decodeWithTFAnns (t,,)
(0x08, 0x5E) -> do
t <- TLambda <$> decodeType <*> decodeType
decodeWithTFAnns (t,,)
(0x08, 0x60) -> do
t <- TMap <$> decodeComparable <*> decodeType
decodeWithTFAnns (t,,)
(0x08, 0x61) -> do
t <- TBigMap <$> decodeComparable <*> decodeType
decodeWithTFAnns (t,,)
(other1, other2) -> fail $ "Unknown primitive tag: 0x" +|
hexF other1 |+ hexF other2 |+ ""
decodeTPair :: Get T
decodeTPair = do
(t1, tAnn1, fAnn1) <- decodeTWithAnns
(t2, tAnn2, fAnn2) <- decodeTWithAnns
pure $ TPair fAnn1 fAnn2 (Type t1 tAnn1) (Type t2 tAnn2)
decodeTOr :: Get T
decodeTOr = do
(t1, tAnn1, fAnn1) <- decodeTWithAnns
(t2, tAnn2, fAnn2) <- decodeTWithAnns
pure $ TOr fAnn1 fAnn2 (Type t1 tAnn1) (Type t2 tAnn2)
decodeNoAnn :: forall (t :: Kind.Type). Get (Annotation t)
decodeNoAnn = pure noAnn
decodeAnns :: Parser a -> Get a
decodeAnns annsParser = do
l <- decodeLength ? "Annotations' String length"
ss <- replicateM l Get.getWord8 ? "Annotations'String content"
s <- decodeUtf8' (BS.pack ss)
& either (fail . show) pure
? "Annotations' String UTF-8 decoding"
either (fail . displayException . ParserException) pure $ parseNoEnv annsParser "" s
decodeVAnn :: Get VarAnn
decodeVAnn = decodeAnns PA.noteV
decodeVAnnDef :: Get VarAnn
decodeVAnnDef = decodeAnns PA.noteDef
decodeWithTVAnns :: (TypeAnn -> VarAnn -> a) -> Get a
decodeWithTVAnns f = do
(tAnn, vAnn) <- decodeAnns PA.notesTV
pure $ f tAnn vAnn
decodeWithTVF2Anns :: (TypeAnn -> VarAnn -> FieldAnn -> FieldAnn -> a) -> Get a
decodeWithTVF2Anns f = do
(tAnn, vAnn, (fAnn1, fAnn2)) <- decodeAnns PA.notesTVF2Def
pure $ f tAnn vAnn fAnn1 fAnn2
decodeWithTFAnns :: (TypeAnn -> FieldAnn -> a) -> Get a
decodeWithTFAnns f = do
(tAnn, fAnn) <- decodeAnns PA.notesTF
pure $ f tAnn fAnn
decodeWithV2Anns :: (VarAnn -> VarAnn -> a) -> Get a
decodeWithV2Anns f = do
(vAnn1, vAnn2) <- decodeAnns PA.noteV2Def
pure $ f vAnn1 vAnn2
decodeWithVFAnns :: (VarAnn -> FieldAnn -> a) -> Get a
decodeWithVFAnns f = do
(vAnn, fAnn) <- decodeAnns PA.notesVF
pure $ f vAnn fAnn