module Michelson.Interpret.Unpack
( UnpackError (..)
, unpackValue
, unpackValue'
, UnpackEnv (..)
) 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.Map as Map
import qualified Data.Set as Set
import Data.Singletons (SingI(..))
import Data.Typeable ((:~:)(..))
import Fmt (Buildable, build, fmt, hexF, (+|), (+||), (|+), (||+))
import Text.Hex (encodeHex)
import Michelson.Text
import Michelson.TypeCheck
(HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TcOriginatedContracts,
TypeCheckEnv(..))
import Michelson.TypeCheck.Helpers (ensureDistinctAsc, eqHST1)
import Michelson.TypeCheck.Instr (typeCheckList)
import Michelson.Typed (Sing(..))
import qualified Michelson.Typed as T
import Michelson.Typed.Scope
(BigMapPresence(..), HasNoBigMap, HasNoOp, OpPresence(..), bigMapAbsense, checkBigMapPresence,
checkOpPresence, opAbsense)
import Michelson.Untyped
import Tezos.Address (Address(..))
import Tezos.Core (mkMutez, timestampFromSeconds)
import Tezos.Crypto (KeyHash(..), mkPublicKey, mkSignature)
newtype UnpackError = UnpackError { unUnpackError :: Text }
deriving (Show, Eq)
instance Buildable UnpackError where
build (UnpackError msg) = build msg
data UnpackEnv = UnpackEnv
{ ueContracts :: TcOriginatedContracts
}
(?) :: Get a -> String -> Get a
(?) = flip Get.label
infix 0 ?
getByteStringCopy :: Int -> Get ByteString
getByteStringCopy = fmap BS.copy . Get.getByteString
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 :: Text -> 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
unpackValue
:: (SingI t, HasNoOp t, HasNoBigMap t)
=> UnpackEnv -> LByteString -> Either UnpackError (T.Value t)
unpackValue env bs =
case Get.runGetOrFail (unpackDecoder env) bs of
Left (_remainder, _offset, err) -> Left . UnpackError $ toText err
Right (_remainder, _offset, res) -> Right res
unpackValue'
:: (SingI t, HasNoOp t, HasNoBigMap t)
=> UnpackEnv -> ByteString -> Either UnpackError (T.Value t)
unpackValue' env = unpackValue env . LBS.fromStrict
unpackDecoder
:: (SingI t, HasNoOp t, HasNoBigMap t)
=> UnpackEnv -> Get (T.Value t)
unpackDecoder env =
expectTag "Packed data start" 0x05 *> decodeValue env <* ensureEnd
decodeValue
:: forall t.
(SingI t, HasNoOp t, HasNoBigMap t)
=> UnpackEnv -> Get (T.Value t)
decodeValue env = Get.label "Value" $
case sing @t of
STc _ ->
T.VC <$> decodeCValue
STKey ->
decodeAsBytes $ do
expectTag "Key pad" 0x00
bs <- getByteStringCopy 32
case mkPublicKey bs of
Left err -> fail $ "Wrong public key format: " <> toString err
Right pk -> pure (T.VKey pk)
STUnit -> do
expectDescTag "Unit" 0
expectTag "Unit" 0x0B
return T.VUnit
STSignature -> do
decodeAsBytes $ do
bs <- getByteStringCopy 64
case mkSignature bs of
Left err -> fail $ "Wrong signature format: " <> toString err
Right s -> pure (T.VSignature s)
STOption _ -> do
Get.getByteString 2 >>= \case
"\x03\x06" -> pure (T.VOption Nothing)
"\x05\x09" -> T.VOption . Just <$> decodeValue env
other -> fail $ "Unknown option tag: " <> show other
STList _ -> do
decodeAsList $ T.VList <$> manyForced (decodeValue env)
STSet _ -> do
decodeAsList $ do
vals <- manyForced decodeCValue
either (fail . toString) pure $
T.VSet . Set.fromDistinctAscList <$> ensureDistinctAsc id vals
STContract _ ->
T.VContract <$> decodeAddress
STPair lt _ ->
case (checkOpPresence lt, checkBigMapPresence lt) of
(OpAbsent, BigMapAbsent) -> do
expectDescTag "Pair" 2
expectTag "Pair" 0x07
T.VPair ... (,) <$> decodeValue env <*> decodeValue env
STOr lt _ ->
case (checkOpPresence lt, checkBigMapPresence lt) of
(OpAbsent, BigMapAbsent) -> do
expectDescTag "Or" 1
Get.getWord8 >>= \case
0x05 -> T.VOr . Left <$> decodeValue env
0x08 -> T.VOr . Right <$> decodeValue env
other -> unknownTag "or constructor" other
STLambda _ _ -> do
uinstr <- decodeOps env
T.VLam <$> decodeTypeCheckLam env uinstr
STMap _ _ -> do
T.VMap <$> decodeMap env
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 ->
decodeAsBytes $ do
expectTag "key address pad" 0x00
T.CvKeyHash . KeyHash <$> getByteStringCopy 20
SCTimestamp -> do
expectTag "Timestamp" 0x00
T.CvTimestamp . timestampFromSeconds @Integer <$> decodeInt
SCAddress ->
T.CvAddress <$> decodeAddress
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 ? "Byte array content"
decodeAsBytes :: Get a -> Get a
decodeAsBytes decode = do
expectTag "Bytes" 0x0A
decodeAsBytesRaw (const decode)
decodeBytes :: Get ByteString
decodeBytes = decodeAsBytesRaw getByteStringCopy
decodeMap
:: (SingI k, SingI v, HasNoOp v, HasNoBigMap v)
=> UnpackEnv -> Get $ Map (T.CValue k) (T.Value v)
decodeMap env = Get.label "Map" $
decodeAsList $ do
es <- manyForced $ do
expectDescTag "Elt" 2
expectTag "Elt" 0x04
(,) <$> decodeCValue <*> decodeValue env
either (fail . toString) pure $
Map.fromDistinctAscList <$> ensureDistinctAsc fst es
decodeAddress :: Get Address
decodeAddress = Get.label "Address" $
decodeAsBytes $ (Get.getWord8 ? "Address tag") >>= \case
0x00 -> Get.label "Plain address" $ do
expectTag "key address pad" 0x00
KeyAddress . KeyHash <$> getByteStringCopy 20
0x01 -> Get.label "Contract address" $ do
addr <- getByteStringCopy 20
expectTag "contract address pad" 0x00
return $ ContractAddress addr
other -> unknownTag "address" other
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
decodeAnn :: forall (t :: Kind.Type). Get (Annotation t)
decodeAnn = pure noAnn
decodeTypeCheckLam
:: forall inp out m.
(Typeable inp, SingI inp, SingI out, Typeable out, MonadFail m)
=> UnpackEnv
-> [ExpandedOp]
-> m (T.Instr '[inp] '[out])
decodeTypeCheckLam UnpackEnv{..} uinstr =
either tcErrToFail pure . evaluatingState tcInitEnv . runExceptT $ do
let inp = (sing @inp, T.NStar, noAnn) ::& SNil
_ :/ instr' <- typeCheckList uinstr inp
case instr' of
instr ::: out' ->
case eqHST1 @out out' of
Right Refl ->
pure 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 instr
where
tcErrToFail err = fail $ "Type check failed: " +| err |+ ""
tcInitEnv =
TypeCheckEnv
{ tcExtFrames = error "runInstrImpl(UNPACK): tcExtFrames touched"
, tcContractParam = error "runInstrImpl(UNPACK): tcContractParam touched"
, tcContracts = ueContracts
}
decodeInstr :: UnpackEnv -> Get ExpandedInstr
decodeInstr env = Get.label "Instruction" $ do
pretag <- Get.getWord8 ? "Pre instr tag"
tag <- Get.getWord8 ? "Instr tag"
case (pretag, tag) of
(0x03, 0x20) -> pure $ DROP
(0x03, 0x21) -> pure $ DUP noAnn
(0x03, 0x4C) -> pure $ SWAP
(0x07, 0x43) -> do
an :: VarAnn <- decodeAnn
typ <- decodeType
T.withSomeSingT (T.fromUType typ) $ \(st :: Sing t) ->
case (opAbsense st, bigMapAbsense st) of
(Nothing, _) -> fail "Operation type in PUSH"
(_, Nothing) -> fail "BigMap type in PUSH"
(Just Dict, Just Dict) -> do
tval <- decodeValue @t env
return $ PUSH an typ (T.untypeValue tval)
(0x03, 0x46) -> SOME <$> decodeAnn <*> decodeAnn <*> decodeAnn
(0x05, 0x3E) -> NONE <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeType
(0x03, 0x4F) -> UNIT <$> decodeAnn <*> decodeAnn
(0x07, 0x2F) -> IF_NONE <$> decodeOps env <*> decodeOps env
(0x03, 0x42) -> PAIR <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn
(0x03, 0x16) -> CAR <$> decodeAnn <*> decodeAnn
(0x03, 0x17) -> CDR <$> decodeAnn <*> decodeAnn
(0x05, 0x33) -> LEFT <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn
<*> decodeType
(0x05, 0x44) -> RIGHT <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn
<*> decodeType
(0x07, 0x2E) -> IF_LEFT <$> decodeOps env <*> decodeOps env
(0x05, 0x3D) -> NIL <$> decodeAnn <*> decodeAnn <*> decodeType
(0x03, 0x1B) -> CONS <$> decodeAnn
(0x07, 0x2D) -> IF_CONS <$> decodeOps env <*> decodeOps env
(0x03, 0x45) -> SIZE <$> decodeAnn
(0x05, 0x24) -> EMPTY_SET <$> decodeAnn <*> decodeAnn <*> decodeComparable
(0x07, 0x23) -> EMPTY_MAP <$> decodeAnn <*> decodeAnn <*> decodeComparable
<*> decodeType
(0x05, 0x38) -> MAP <$> decodeAnn <*> decodeOps env
(0x05, 0x52) -> ITER <$> decodeOps env
(0x03, 0x39) -> MEM <$> decodeAnn
(0x03, 0x29) -> GET <$> decodeAnn
(0x03, 0x50) -> pure UPDATE
(0x07, 0x2C) -> IF <$> decodeOps env <*> decodeOps env
(0x05, 0x34) -> LOOP <$> decodeOps env
(0x05, 0x53) -> LOOP_LEFT <$> decodeOps env
(0x09, 0x31) -> do
res <- decodeAsListRaw $
LAMBDA <$> decodeAnn <*> decodeType <*> decodeType <*> decodeOps env
void decodeLength
return res
(0x03, 0x26) -> EXEC <$> decodeAnn
(0x05, 0x1F) -> DIP <$> decodeOps env
(0x03, 0x27) -> pure FAILWITH
(0x05, 0x57) -> CAST <$> decodeAnn <*> decodeType
(0x03, 0x58) -> RENAME <$> decodeAnn
(0x03, 0x0C) -> PACK <$> decodeAnn
(0x05, 0x0D) -> UNPACK <$> decodeAnn <*> decodeType
(0x03, 0x1A) -> CONCAT <$> decodeAnn
(0x03, 0x6F) -> SLICE <$> decodeAnn
(0x03, 0x56) -> ISNAT <$> decodeAnn
(0x03, 0x12) -> ADD <$> decodeAnn
(0x03, 0x4B) -> SUB <$> decodeAnn
(0x03, 0x3A) -> MUL <$> decodeAnn
(0x03, 0x22) -> EDIV <$> decodeAnn
(0x03, 0x11) -> ABS <$> decodeAnn
(0x03, 0x3B) -> pure NEG
(0x03, 0x35) -> LSL <$> decodeAnn
(0x03, 0x36) -> LSR <$> decodeAnn
(0x03, 0x41) -> OR <$> decodeAnn
(0x03, 0x14) -> AND <$> decodeAnn
(0x03, 0x51) -> XOR <$> decodeAnn
(0x03, 0x3F) -> NOT <$> decodeAnn
(0x03, 0x19) -> COMPARE <$> decodeAnn
(0x03, 0x25) -> EQ <$> decodeAnn
(0x03, 0x3C) -> NEQ <$> decodeAnn
(0x03, 0x37) -> LT <$> decodeAnn
(0x03, 0x2A) -> GT <$> decodeAnn
(0x03, 0x32) -> LE <$> decodeAnn
(0x03, 0x28) -> GE <$> decodeAnn
(0x03, 0x30) -> INT <$> decodeAnn
(0x05, 0x55) -> CONTRACT <$> decodeAnn <*> decodeType
(0x03, 0x4D) -> TRANSFER_TOKENS <$> decodeAnn
(0x03, 0x4E) -> SET_DELEGATE <$> decodeAnn
(0x03, 0x1C) -> CREATE_ACCOUNT <$> decodeAnn <*> decodeAnn
(0x05, 0x1D) ->
decodeAsList $ do
an1 <- decodeAnn
an2 <- decodeAnn
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 env
return $ CREATE_CONTRACT an1 an2 (Contract p s c)
(0x03, 0x1E) -> IMPLICIT_ACCOUNT <$> decodeAnn
(0x03, 0x40) -> NOW <$> decodeAnn
(0x03, 0x13) -> AMOUNT <$> decodeAnn
(0x03, 0x15) -> BALANCE <$> decodeAnn
(0x03, 0x18) -> CHECK_SIGNATURE <$> decodeAnn
(0x03, 0x0F) -> SHA256 <$> decodeAnn
(0x03, 0x10) -> SHA512 <$> decodeAnn
(0x03, 0x0E) -> BLAKE2B <$> decodeAnn
(0x03, 0x2B) -> HASH_KEY <$> decodeAnn
(0x03, 0x4A) -> STEPS_TO_QUOTA <$> decodeAnn
(0x03, 0x47) -> SOURCE <$> decodeAnn
(0x03, 0x48) -> SENDER <$> decodeAnn
(0x03, 0x54) -> ADDRESS <$> decodeAnn
(other1, other2) -> fail $ "Unknown instruction tag: 0x" +|
hexF other1 |+ hexF other2 |+ ""
decodeOp :: UnpackEnv -> Get ExpandedOp
decodeOp env = Get.label "Op" $ do
tag <- Get.lookAhead Get.getWord8
if tag == 0x02
then SeqEx <$> decodeOps env ? "Ops seq"
else PrimEx <$> decodeInstr env ? "One op"
decodeOps :: UnpackEnv -> Get [ExpandedOp]
decodeOps env = decodeAsList $ manyForced (decodeOp env)
decodeComparable :: Get Comparable
decodeComparable = Get.label "Comparable primitive type" $
Comparable <$> decodeCT <*> decodeAnn
decodeCT :: Get CT
decodeCT = Get.label "CT" $ do
pretag <- Get.getWord8 ? "Pre simple comparable type tag"
tag <- Get.getWord8 ? "Simple comparable type tag"
case (pretag, tag) of
(0x03, 0x5B) -> pure CInt
(0x03, 0x62) -> pure CNat
(0x03, 0x68) -> pure CString
(0x03, 0x69) -> pure CBytes
(0x03, 0x6A) -> pure CMutez
(0x03, 0x59) -> pure CBool
(0x03, 0x5D) -> pure CKeyHash
(0x03, 0x6B) -> pure CTimestamp
(0x03, 0x6E) -> pure CAddress
(other1, other2) -> fail $ "Unknown primitive tag: 0x" +|
hexF other1 |+ hexF other2 |+ ""
decodeT :: Get T
decodeT = Get.label "T" $
doDecode <|> (Tc <$> decodeCT)
where
doDecode = do
pretag <- Get.getWord8 ? "Pre complex type tag"
tag <- Get.getWord8 ? "Complex type tag"
case (pretag, tag) of
(0x03, 0x5C) -> pure TKey
(0x03, 0x6C) -> pure TUnit
(0x03, 0x67) -> pure TSignature
(0x05, 0x63) -> TOption <$> decodeAnn <*> decodeType
(0x05, 0x5F) -> TList <$> decodeType
(0x05, 0x66) -> TSet <$> decodeComparable
(0x03, 0x6D) -> pure TOperation
(0x05, 0x5A) -> TContract <$> decodeType
(0x07, 0x65) -> TPair <$> decodeAnn <*> decodeAnn <*> decodeType <*> decodeType
(0x07, 0x64) -> TOr <$> decodeAnn <*> decodeAnn <*> decodeType <*> decodeType
(0x07, 0x5E) -> TLambda <$> decodeType <*> decodeType
(0x07, 0x60) -> TMap <$> decodeComparable <*> decodeType
(0x07, 0x61) -> TBigMap <$> decodeComparable <*> decodeType
(other1, other2) -> fail $ "Unknown primitive tag: 0x" +|
hexF other1 |+ hexF other2 |+ ""
decodeType :: Get Type
decodeType = Type <$> decodeT <*> decodeAnn ? "Type"