{- | Module, carrying logic of @UNPACK@ instruction. This is nearly symmetric to adjacent Pack.hs module. When implementing this the following sources were used: * https://pastebin.com/8gfXaRvp * https://gitlab.com/tezos/tezos/-/blob/767de2b6665ec2cc21e41e6348f8a0b369d26450/src/proto_alpha/lib_protocol/script_ir_translator.ml#L2501 * https://github.com/tezbridge/tezbridge-crypto/blob/f7d93d8d04201557972e839967758cff5bbe5345/PsddFKi3/codec.js#L513 -} 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 ---------------------------------------------------------------------------- -- Helpers ---------------------------------------------------------------------------- -- | Any decoding error. newtype UnpackError = UnpackError { unUnpackError :: Text } deriving stock (Show, Eq) instance Buildable UnpackError where build (UnpackError msg) = build msg instance Exception UnpackError where displayException = pretty -- | Alias for label attaching. (?) :: Get a -> String -> Get a (?) = flip Get.label infix 0 ? -- | Get a bytestring of the given length leaving no references to the -- original data in serialized form. getByteStringCopy :: Int -> Get ByteString getByteStringCopy = fmap BS.copy . Get.getByteString -- | Get remaining available bytes. -- -- Note that reading all remaining decoded input may be expensive and is thus -- discouraged, use can use this function only when you know that amount -- of data to be consumed is limited, e.g. within 'decodeAsBytes' call. getRemainingByteStringCopy :: Get ByteString getRemainingByteStringCopy = do lbs <- Get.getRemainingLazyByteString -- Avoiding memory overflows in case bad length to 'Get.isolate' was provided. -- Normally this function is used only to decode primitives, 'Signature' in -- the worst case, so we could set little length, but since this is a hack -- anyway let's make sure it never obstructs our work. when (length lbs > 640000) $ fail "Too big length for an entity" return (LBS.toStrict lbs) -- | Read a byte and match it against given value. 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' |+ ")" -- | Fail with "unknown tag" error. unknownTag :: String -> Word8 -> Get a unknownTag desc tag = fail . fmt $ "Unknown " <> build desc <> " tag: 0x" <> hexF tag -- | Read a byte describing the primitive going further and match it against -- expected tag in the given conditions. -- -- Aside of context description, you have to specify number of arguments which -- given instruction accepts when written in Michelson. For instance, @PUSH@ -- accepts two arguments - type and value. 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" -- Intermediate values of tag are also used and designate that annotations -- are also attached to the packed data. But they are never produced by -- @PACK@, neither @UNPACK@ seem to expect them, so for now we pretend -- that annotations do not exist. ensureEnd :: Get () ensureEnd = unlessM Get.isEmpty $ do remainder <- Get.getRemainingLazyByteString fail $ "Expected end of entry, unconsumed bytes \ \(" +| length remainder |+ "): " +|| encodeHex (LBS.toStrict remainder) ||+ "" -- | Like 'many', but doesn't backtrack if next entry failed to parse -- yet there are some bytes to consume ahead. -- -- This function exists primarily for better error messages. manyForced :: Get a -> Get [a] manyForced decode = do emp <- Get.isEmpty if emp then return [] else (:) <$> decode <*> manyForced decode -- | Describes how 'decodeWithTag' should decode tag-dependent data. -- We expect bytes of such structure: 'tdTag' followed by a bytestring -- which will be parsed with 'tdDecoder'. data TaggedDecoder a = TaggedDecoder { tdTag :: Word8 , tdDecoder :: Get a } -- | Alias for 'TaggedDecoder' constructor. (#:) :: Word8 -> Get a -> TaggedDecoder a (#:) = TaggedDecoder infixr 0 #: -- Common decoder for the case when packed data starts with a tag (1 -- byte) that specifies how to decode remaining data. decodeWithTag :: String -> [TaggedDecoder a] -> Get a decodeWithTag what decoders = Get.label what $ do tag <- Get.label (what <> " tag") Get.getWord8 -- Number of decoders is usually small, so linear runtime lookup should be ok. 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 ---------------------------------------------------------------------------- -- Michelson serialisation ---------------------------------------------------------------------------- {- Implementation notes: * We need to know which exact type we unpack to. For instance, serialized signatures are indistinguishable from plain serialized bytes, so if we want to return "Value" (typed or untyped), we need to know currently expected type. The reference implementation does the same. * It occured to be easier to decode to typed values and untyped instructions. When decoding lambda, we type check given instruction, and when decoding @PUSH@ call we untype decoded value. One may say that this gives unreasonable performance overhead, but with the current definition of "Value" types (typed and untyped) we cannot avoid it anyway, because when deserializing bytearray-like data (keys, signatures, ...), we have to convert raw bytes to human-readable 'Text' and later parse them to bytes back at type check stage. We console ourselves that lambdas are rarely packed. -} -- | Deserialize bytes into the given value. -- Suitable for @UNPACK@ operation only. unpackValue :: (UnpackedValScope t) => LByteString -> Either UnpackError (T.Value t) unpackValue = launchGet (finalizeDecoder decodeValue) -- | Like 'unpackValue', for strict byte array. unpackValue' :: (UnpackedValScope t) => ByteString -> Either UnpackError (T.Value t) unpackValue' = unpackValue . LBS.fromStrict -- | Deserialize an instruction into the given value. unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp] unpackInstr' = launchGet (finalizeDecoder decodeOps) . LBS.fromStrict -- | Turn composable decoder into a final decoder which will be run over data. 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 -- | Read length of something (list, string, ...). decodeLength :: Get Int decodeLength = Get.label "Length" $ do len <- Get.getWord32be -- @martoon: I'm not sure whether returning 'Int' is valid here. -- Strictly speaking, it may be 'Word32', but there seems to be no easy way -- to check the reference implementation on that. -- One more reason to go with just 'Int' for now is that we need to be able to -- deserialize byte arrays, and 'BS.ByteString' keeps length of type 'Int' -- inside. 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") -- | Given decoder for list content, get a whole list decoder. 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) -- | Read a numeric value. 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 -- | Type check instruction occured from a lambda. 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 = (starNotes, noAnn) ::& SNil _ :/ instr' <- typeCheckList uinstr inp case instr' of instr ::: out' -> case eqHST1 @out out' of Right Refl -> pure $ RfNormal instr Left err -> -- dummy types, we have no full information to build untyped -- 'T' anyway 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 = -- In Tezos @UNPACK@ instruction does not depend on environment. -- -- We initialize each of the fields as 'error' (rather than just defining -- the whole datatype as 'error') to make source of error more obvious -- if access to one of these fields is performed after all. TypeCheckEnv { tcExtFrames = error "runInstrImpl(UNPACK): tcExtFrames touched" --- ^ This is safe because @UNPACK@ never produces Ext instructions , tcContractParam = error "runInstrImpl(UNPACK): tcContractParam touched" --- ^ Used only in @SELF@ interpretation, --- but there is no way for @SELF@ to appear in packed data , tcContracts = error "runInstrImpl(UNPACK): tcContracts touched" --- ^ Used only in typechecking of @contract@ values, --- but it's not possible to unpack to ones. } 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 -- Instructions with annotations from here on (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 -- T with annotations from here on (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) ---------------------------------------------------------------------------- -- Annotations ---------------------------------------------------------------------------- -- | Utility function to fill a constructor with an empty annotation decodeNoAnn :: forall (t :: Kind.Type). Get (Annotation t) decodeNoAnn = pure noAnn -- | Decodes an annotations' string and uses the provided `Parser` to parse -- untyped annotations from it. This has to produce at least one annotation -- (Annotations' String parsing will fail otherwise) 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