module Bitcoin.Script.Run
(
Entry , InterpreterConfig(..) , InterpreterState(..) , ScriptMonad
, checkTransaction
, isDisabledOpcode
, initialState
, executeScript , runScriptPre, runScriptFinal
, scriptStep , scriptStep'
, isFalse, isTrue
, Stream(..) , Context(..) , Hole(..)
, IfBranch(..) , IfType(..) , IfBlock(..)
, streamMoveRight
, fetchOpcode , fetchOpcodeWithinContext
, fetchIfBlock
, reconstructIfBlock
, invalid
, getState
, putState
, pushData , popData
, pushAltData , popAltData
, pushInteger , popInteger
, pushBool , popBool
, parseTxScripts
, parseTxInScripts
, parseTxOutScripts
, parseSingleTxOutScript
)
where
import Data.Int
import Data.Word
import Data.Bits
import Data.List ( unfoldr , splitAt , mapAccumL )
import Data.Maybe
import Control.Monad
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Identity
import qualified Data.ByteString as B
import Bitcoin.Misc.Bifunctor
import Bitcoin.Misc.BigInt
import Bitcoin.Misc.OctetStream
import Bitcoin.Misc.Zipper as Zipper
import Bitcoin.Crypto.Hash.SHA1
import Bitcoin.Crypto.Hash.SHA256
import Bitcoin.Crypto.Hash.RipEmd160
import Bitcoin.Crypto.EC.Curve
import Bitcoin.Crypto.EC.Key
import Bitcoin.Crypto.EC.DSA
import Bitcoin.Protocol.Hash
import Bitcoin.Protocol.Key
import Bitcoin.Protocol.Signature
import Bitcoin.BlockChain.Base
import Bitcoin.BlockChain.Parser ( serializeTx )
import Bitcoin.BlockChain.Tx
import Bitcoin.Script.Base
import Bitcoin.Script.Integer
import Bitcoin.Script.Serialize
isDisabledOpcode :: Opcode -> Bool
isDisabledOpcode op = case op of
OP_CAT -> True
OP_SUBSTR -> True
OP_LEFT -> True
OP_RIGHT -> True
OP_INVERT -> True
OP_AND -> True
OP_OR -> True
OP_XOR -> True
OP_2MUL -> True
OP_2DIV -> True
OP_MUL -> True
OP_DIV -> True
OP_MOD -> True
OP_LSHIFT -> True
OP_RSHIFT -> True
_ -> False
data Stream = Stream
{ _streamContext :: Context
, _streamZipper :: Zipper Opcode
}
deriving Show
data Context
= CtxEmpty
| CtxHole Context [Opcode] IfType Hole [Opcode]
deriving Show
data Hole
= HoleThen { _elsePart :: Maybe [Opcode] }
| HoleElse { _thenPart :: [Opcode]
, _elseExists :: Bool }
deriving Show
toListIfPart :: [Opcode] -> [Opcode]
toListIfPart ops = OP_IF : ops
toListElsePart :: Maybe [Opcode] -> [Opcode]
toListElsePart mbops = case mbops of
Nothing -> []
Just ops -> OP_ELSE : ops
flattenStreamToList :: Stream -> [Opcode]
flattenStreamToList (Stream ctx zipper) = worker ctx (zipperToList zipper) where
worker ctx list = case ctx of
CtxEmpty -> list
CtxHole outer left typ hole right -> worker outer $ case hole of
HoleThen elsePart -> ifOpcode typ : list ++ toListElsePart elsePart ++ [OP_ENDIF]
HoleElse thenPart exists -> ifOpcode typ : thenPart ++ (if exists then (OP_ELSE:list) else []) ++ [OP_ENDIF]
flattenStreamToZipper :: Stream -> Zipper Opcode
flattenStreamToZipper (Stream ctx zipper) = worker ctx zipper where
worker ctx zip@(Zipper ys xs) = case ctx of
CtxEmpty -> zip
CtxHole outer left typ hole right -> worker outer $ case hole of
HoleThen elsePart -> Zipper
(ys ++ ifOpcode typ : reverse left)
(xs ++ toListElsePart elsePart ++ OP_ENDIF : right)
HoleElse thenPart exists -> Zipper
(ys ++ (if exists then [OP_ELSE] else []) ++ reverse thenPart ++ ifOpcode typ : reverse left)
(xs ++ OP_ENDIF : right)
streamMoveRight :: Stream -> Either Stream (Opcode,Stream)
streamMoveRight fullStream@(Stream ctx zipper) =
case Zipper.moveRight zipper of
Just (x,zipper') -> Right (x, Stream ctx zipper')
Nothing -> case ctx of
CtxEmpty -> Left fullStream
CtxHole outer left typ hole right -> streamMoveRight $ Stream outer $ case hole of
HoleThen elsePart -> mkZipper (left ++ ifOpcode typ : zipperToList zipper ++ toListElsePart elsePart ++ [OP_ENDIF]) right
HoleElse thenPart exists -> mkZipper (left ++ ifOpcode typ : thenPart ++ (if exists then OP_ELSE : zipperToList zipper else []) ++ [OP_ENDIF]) right
type Entry = B.ByteString
data InterpreterState = St
{ _mainStack :: [Entry]
, _altStack :: [Entry]
, _opcodeStream :: Stream
}
deriving Show
initialState :: InterpreterState
initialState = St [] [] (Stream CtxEmpty (Zipper [] []))
data InterpreterConfig = Cfg
{ _newTx :: !(Tx RawScript RawScript)
, _curTxInIdx :: !Int
}
deriving Show
type ScriptMonad a = ExceptT String (StateT InterpreterState (ReaderT InterpreterConfig Identity)) a
checkTransaction :: forall a. Tx (Tx a RawScript, RawScript) RawScript -> Either String Bool
checkTransaction txExt = result where
result = if fee >= 0
then (go 0 insExt)
else Left "total transaction output is more than total input"
newtx = fmapFst snd txExt :: Tx RawScript RawScript
insExt = _txInputs txExt :: [TxInput (Tx a RawScript, RawScript)]
fee = txFee (fmapFst fst txExt)
go :: Int -> [TxInput (Tx a RawScript, RawScript)] -> Either String Bool
go _ [] = Right True
go j (this:rest) =
case parseSingleTxOutScript previdx prevtx_raw of
Left err -> Left err
Right prevtxei -> case parseScript (_txInScript thisin_raw) of
Nothing -> Left $ "cannot parse input script #" ++ show j
Just inscript -> case runScriptPre cfg initialState inscript of
(Left err, _ ) -> Left err
(Right _ , St mainstack _ _) ->
let prevout_raw = (_txOutputs prevtx_raw) !! previdx
ei_prevout = (_txOutputs prevtxei ) !! previdx :: TxOutput (Either RawScript Script)
state' = St mainstack [] (error "checkTransaction: stream shouldn't be evaluated")
in case _txOutScript ei_prevout of
Left _raw_ -> Left "this shouldn't happen: parsed something else we wanted to parse"
Right outscript -> if _txHash prevtx_raw /= prevhash
then Left $ "fatal error: hash of input tx #" ++ show j ++ " does not match"
else case fst $ runScriptFinal cfg state' (outscript) of
Left err -> Left err
Right b -> case b of
False -> Left $ "tx input #" ++ show j ++ " failed to check"
True -> go (j+1) rest
where
cfg = Cfg newtx j
prevtx_raw = fst (_txInScript this) :: Tx a RawScript
thisin_raw = fmap snd this :: TxInput RawScript
previdx = fromIntegral (_txInPrevOutIdx thisin_raw) :: Int
prevhash = _txInPrevOutHash thisin_raw :: Hash256
parseTxScripts :: Tx RawScript RawScript -> Either String (Tx Script Script)
parseTxScripts tx =
case mapAccumLBoth (parseHelperFun tx) (parseHelperFun tx) Nothing tx of
(Nothing ,tx') -> Right tx'
(Just err,_ ) -> Left err
parseTxInScripts :: Tx RawScript a -> Either String (Tx Script a)
parseTxInScripts tx =
case mapAccumLFst (parseHelperFun tx) Nothing tx of
(Nothing ,tx') -> Right tx'
(Just err,_ ) -> Left err
parseTxOutScripts :: Tx a RawScript -> Either String (Tx a Script)
parseTxOutScripts tx =
case mapAccumLSnd (parseHelperFun tx) Nothing tx of
(Nothing ,tx') -> Right tx'
(Just err,_ ) -> Left err
parseSingleTxOutScript :: Int -> Tx a RawScript -> Either String (Tx a (Either RawScript Script))
parseSingleTxOutScript j tx =
case mapAccumLSnd worker (Nothing,0) tx of
((Nothing ,_),tx') -> Right tx'
((Just err,_),_ ) -> Left err
where
worker :: (Maybe String,Int) -> RawScript -> ((Maybe String,Int),Either RawScript Script)
worker (mberr,k) raw = case mberr of
Just err -> ((mberr,k),undef)
Nothing -> if (k/=j)
then ((mberr,k+1),Left raw)
else case parseScript raw of
Just script -> ((mberr,k+1),Right script)
Nothing -> ((Just ("cannot parse script in output " ++ show k ++ " of tx # " ++ show (_txHash tx)),k), undef)
undef = error "parseSingleTxOutScript/worker: this shouldn't be evaluated"
parseHelperFun :: Tx a b -> Maybe String -> RawScript -> (Maybe String, Script)
parseHelperFun tx mberr rawscript =
case mberr of
Just err -> (mberr,undef)
Nothing -> case parseScript rawscript of
Just script -> (mberr, script)
Nothing -> (Just ("cannot parse script in tx # " ++ show (_txHash tx)), undef)
where
undef = error "parseHelperFun: this shouldn't be evaluated"
runScriptPre :: InterpreterConfig -> InterpreterState -> Script -> (Either String (), InterpreterState)
runScriptPre cfg st (Script opcodes) = runIdentity $ runReaderT (runStateT (runExceptT (executeScript opcodes)) st) cfg
runScriptFinal :: InterpreterConfig -> InterpreterState -> Script -> (Either String Bool, InterpreterState)
runScriptFinal cfg st (Script opcodes) = runIdentity $ runReaderT (runStateT (runExceptT action) st) cfg
where
action :: ScriptMonad Bool
action = do
executeScript opcodes
St main alt stream <- getState
case stream of
Stream CtxEmpty (Zipper finalRevOpcodes []) ->
if reverse finalRevOpcodes /= opcodes
then invalid "executeScript: shouldn't happen (script finished but the \"consumed opcodes\" are not the same as the original ones)"
else case main of
(top:_) -> return (asInteger top /= 0)
[] -> invalid "script finished but the stack is empty"
_ -> invalid $ "executeScript: shouldn't happen (script finished but there are remaining opcodes)"
executeScript :: [Opcode] -> ScriptMonad ()
executeScript opcodes =
do
when (any isDisabledOpcode opcodes) $ invalid "disabled opcode appearing in the script"
St main alt _ <- getState
putState (St main alt $ Stream CtxEmpty (zipperFromList opcodes))
worker
where
worker = do
finished <- scriptStep
unless finished worker
scriptStep :: ScriptMonad Bool
scriptStep = fetchOpcode >>= \mbop -> case mbop of
Nothing -> return True
Just op -> do
scriptStep' op
return False
scriptStep' :: Opcode -> ScriptMonad ()
scriptStep' op = case op of
OP_SMALLNUM n -> case n of
0 -> pushWords []
_ -> pushWords [fromIntegral n]
OP_1NEGATE -> pushWords [0x81]
OP_PUSHDATA w8 bs -> if is_valid_pushdata w8 bs
then pushData bs
else invalid "fatal error: invalid PUSHDATA opcode"
OP_NOP w8 -> if is_nop w8
then return ()
else invalid "fatal error: invalid NOP opcode"
OP_IF -> do
b <- popBool
let branchTaken = if b then IfBranch else ElseBranch
ifblock@(IfBlock _ ifops mbelseops) <- fetchIfBlock If branchTaken
return ()
OP_NOTIF -> do
b <- popBool
let branchTaken = if not b then IfBranch else ElseBranch
ifblock@(IfBlock _ ifops mbelseops) <- fetchIfBlock NotIf branchTaken
return ()
OP_ELSE -> invalid "naked OP_ELSE found; this shouldn't happen"
OP_ENDIF -> invalid "naked OP_ENDIF found; this shouldn't happen"
OP_VERIFY -> do { x <- popData ; if isTrue x then return () else (pushData x >> invalid "OP_VERIFY: false") }
OP_RETURN -> invalid "OP_RETURN executed"
OP_TOALTSTACK -> do { x <- popData ; pushAltData x }
OP_FROMALTSTACK -> do { x <- popAltData ; pushData x }
OP_IFDUP -> do { x <- popData ; pushData x ; when (isTrue x) (pushData x) }
OP_DEPTH -> do { xs <- getMainStack ; pushInteger (fromIntegral $ length xs) }
OP_DROP -> do { _ <- popData ; return () }
OP_DUP -> do { x <- popData ; pushData x ; pushData x }
OP_NIP -> do { x <- popData ; _ <- popData ; pushData x }
OP_OVER -> do { x <- popData ; y <- popData ; pushData y ; pushData x ; pushData y }
OP_PICK -> do
n <- popInteger ; xs <- getMainStack
when (n < 0) $ invalid "OP_PICK: negativ index"
when (fromIntegral (length xs) <= n) $ invalid "OP_PICK: stack is not deep enough"
putMainStack ( xs!!(fromIntegral n) : xs)
OP_ROLL -> do
n <- popInteger ; xs <- getMainStack
when (n < 0) $ invalid "OP_ROLL: negativ index"
when (fromIntegral (length xs) <= n) $ invalid "OP_ROLL: stack is not deep enough"
let (hd,tl) = splitAt (fromIntegral n + 1) xs
putMainStack (last hd : init hd ++ tl)
OP_ROT -> do { (a,b,c) <- popTriple ; pushTriple (c,a,b) }
OP_SWAP -> do { x <- popData ; y <- popData ; pushData x ; pushData y }
OP_TUCK -> do { x <- popData ; y <- popData ; pushData x ; pushData y ; pushData x }
OP_2DROP -> do { _ <- popPair ; return () }
OP_2DUP -> do { xy <- popPair ; pushPair xy ; pushPair xy }
OP_3DUP -> do { xyz <- popTriple ; pushTriple xyz ; pushTriple xyz }
OP_2OVER -> do { xy <- popPair ; zw <- popPair ; pushPair zw ; pushPair xy ; pushPair zw }
OP_2ROT -> do
a <- popPair ; b <- popPair ; c <- popPair
pushPair b ; pushPair a ; pushPair c
OP_2SWAP -> do { xy <- popPair ; zw <- popPair ; pushPair xy ; pushPair zw }
OP_CAT -> do { b <- popData ; a <- popData ; pushData (B.append a b) }
OP_SIZE -> do { s <- popData ; pushData s ; pushInteger (dataLen s) }
OP_SUBSTR -> do
siz <- popInteger
bgn <- popInteger
str <- popData
let n = dataLen str
when (n < bgn+siz) $ invalid "OP_SUBSTR: string not long enough"
pushData (B.take (fromIntegral siz) $ B.drop (fromIntegral bgn) str)
OP_LEFT -> do
siz <- popInteger
str <- popData
let n = dataLen str
when (n < siz) $ invalid "OP_SUBSTR: string not long enough"
pushData (B.take (fromIntegral siz) str)
OP_RIGHT -> do
siz <- popInteger
str <- popData
let n = dataLen str
when (n < siz) $ invalid "OP_SUBSTR: string not long enough"
pushData (B.drop (fromIntegral (nsiz)) str)
OP_INVERT -> do { x <- popWords ; pushWords (map complement x) }
OP_AND -> do { y <- popWords ; x <- popWords ; pushWords (extendedZipWith (.&.) x y) }
OP_OR -> do { y <- popWords ; x <- popWords ; pushWords (extendedZipWith (.|.) x y) }
OP_XOR -> do { y <- popWords ; x <- popWords ; pushWords (extendedZipWith xor x y) }
OP_EQUAL -> do { y <- popData ; x <- popData ; pushBool (x==y) }
OP_EQUALVERIFY -> scriptStep' OP_EQUAL >> scriptStep' OP_VERIFY
OP_1ADD -> do { x <- popArith ; pushArith (x+1) }
OP_1SUB -> do { x <- popArith ; pushArith (x1) }
OP_2MUL -> do { x <- popArith ; pushArith (x+x) }
OP_2DIV -> do { x <- popArith ; pushArith (div x 2) }
OP_NEGATE -> do { x <- popArith ; pushArith (negate x) }
OP_ABS -> do { x <- popArith ; pushArith (abs x) }
OP_NOT -> do { x <- popArith ; pushBool (x==0) }
OP_0NOTEQUAL -> do { x <- popArith ; pushBool (x/=0) }
OP_ADD -> do { y <- popArith ; x <- popArith ; pushArith (x+y) }
OP_SUB -> do { y <- popArith ; x <- popArith ; pushArith (xy) }
OP_MUL -> do { y <- popArith ; x <- popArith ; pushArith (x*y) }
OP_DIV -> do { y <- popArith ; x <- popArith ; when (y==0) (invalid "OP_DIV: division by zero") ; pushArith (div x y) }
OP_MOD -> do { y <- popArith ; x <- popArith ; when (y==0) (invalid "OP_MOD: division by zero") ; pushArith (mod x y) }
OP_LSHIFT -> do
k <- fromIntegral <$> popArith
n <- popArith
pushArith (shiftL n (mod k 32))
OP_RSHIFT -> do
k <- fromIntegral <$> popArith
n <- popArith
pushArith (shiftR n (mod k 32))
OP_BOOLAND -> do { y <- popArith ; x <- popArith ; pushBool (x/=0 && y/=0) }
OP_BOOLOR -> do { y <- popArith ; x <- popArith ; pushBool (x/=0 || y/=0) }
OP_NUMEQUAL -> do { y <- popArith ; x <- popArith ; pushBool (x==y) }
OP_NUMNOTEQUAL -> do { y <- popArith ; x <- popArith ; pushBool (x/=y) }
OP_NUMEQUALVERIFY -> scriptStep' OP_NUMEQUAL >> scriptStep' OP_VERIFY
OP_LESSTHAN -> do { y <- popArith ; x <- popArith ; pushBool (x<y) }
OP_GREATERTHAN -> do { y <- popArith ; x <- popArith ; pushBool (x>y) }
OP_LESSTHANOREQUAL -> do { y <- popArith ; x <- popArith ; pushBool (x<=y) }
OP_GREATERTHANOREQUAL -> do { y <- popArith ; x <- popArith ; pushBool (x>=y) }
OP_MIN -> do { y <- popArith ; x <- popArith ; pushArith (min x y) }
OP_MAX -> do { y <- popArith ; x <- popArith ; pushArith (max x y) }
OP_WITHIN -> do { b <- popArith ; a <- popArith ; x <- popArith ; pushBool (x>=a && x<b) }
OP_RIPEMD160 -> do { x <- popData ; pushData (toByteString $ ripemd160 x) }
OP_SHA1 -> do { x <- popData ; pushData (toByteString $ sha1 x) }
OP_SHA256 -> do { x <- popData ; pushData (toByteString $ sha256 x) }
OP_HASH160 -> do { x <- popData ; pushData (toByteString $ doHash160 x) }
OP_HASH256 -> do { x <- popData ; pushData (toByteString $ doHash256 x) }
OP_CODESEPARATOR -> return ()
OP_CHECKSIG -> execute_OP_CHECKSIG
OP_CHECKMULTISIG -> execute_OP_CHECKMULTISIG
OP_CHECKSIGVERIFY -> scriptStep' OP_CHECKSIG >> scriptStep' OP_VERIFY
OP_CHECKMULTISIGVERIFY -> scriptStep' OP_CHECKMULTISIG >> scriptStep' OP_VERIFY
OP_RESERVED -> invalid "OP_RESERVED executed"
OP_VER -> invalid "OP_VER executed"
OP_VERIF -> invalid "OP_VERIF executed"
OP_VERNOTIF -> invalid "OP_VERNOTIF executed"
OP_RESERVED1 -> invalid "OP_RESERVED1 executed"
OP_RESERVED2 -> invalid "OP_RESERVED2 executed"
OP_INVALIDOPCODE -> invalid "OP_INVALIDOPCODE executed"
OP_UNKNOWN w -> invalid ("OP_UNKNOWN (decimal " ++ show w ++ ") executed")
_ -> invalid ("unhandled or invalid opcode " ++ show op)
dataLen :: Entry -> Integer
dataLen = fromIntegral . B.length
extendedZipWith :: (Word8 -> Word8 -> Word8) -> [Word8] -> [Word8] -> [Word8]
extendedZipWith f = go where
go (x:xs) (y:ys) = f x y : go xs ys
go [] (y:ys) = f 0 y : go [] ys
go (x:xs) [] = f x 0 : go xs []
go [] [] = []
isFalse :: Entry -> Bool
isFalse bs = (asInteger bs == 0)
isTrue :: Entry -> Bool
isTrue bs = (asInteger bs /= 0)
pushData :: Entry -> ScriptMonad ()
pushData bs = do
St main alt stream <- getState
putState (St (bs:main) alt stream)
popData :: ScriptMonad Entry
popData = do
St main alt stream <- getState
case main of
(x:rest) -> do
putState (St rest alt stream)
return x
[] -> invalid "cannot pop from main stack: it's empty"
pushAltData :: Entry -> ScriptMonad ()
pushAltData bs = do
St main alt stream <- getState
putState (St main (bs:alt) stream)
popAltData :: ScriptMonad Entry
popAltData = do
St main alt stream <- getState
case alt of
(x:rest) -> do
putState (St main rest stream)
return x
[] -> invalid "cannot pop from alt stack: it's empty"
pushArith :: Integer -> ScriptMonad ()
pushArith = pushData . asByteString
popArith :: ScriptMonad Integer
popArith = do
bs <- popData
when (B.length bs > 4) $ invalid "arithmetic operator with argument longer than 4 bytes"
return $ asInteger bs
pushBool :: Bool -> ScriptMonad ()
pushBool b = pushWords $ case b of { True -> [1] ; False -> [] }
popBool :: ScriptMonad Bool
popBool = do
n <- popInteger
return (n/=0)
pushWords :: [Word8] -> ScriptMonad ()
pushWords ws = pushData (B.pack ws)
popWords :: ScriptMonad [Word8]
popWords = B.unpack <$> popData
pushInteger :: Integer -> ScriptMonad ()
pushInteger = pushData . asByteString
popInteger :: ScriptMonad Integer
popInteger = asInteger <$> popData
popPair :: ScriptMonad (Entry,Entry)
popPair = do
x <- popData
y <- popData
return (x,y)
pushPair :: (Entry,Entry) -> ScriptMonad ()
pushPair (x,y) = do
pushData y
pushData x
popTriple :: ScriptMonad (Entry,Entry,Entry)
popTriple = do
x <- popData
y <- popData
z <- popData
return (x,y,z)
pushTriple :: (Entry,Entry,Entry) -> ScriptMonad ()
pushTriple (x,y,z) = do
pushData z
pushData y
pushData x
invalid :: String -> ScriptMonad a
invalid msg = throwE msg
askCfg :: ScriptMonad InterpreterConfig
askCfg = lift (lift ask)
getState :: ScriptMonad InterpreterState
getState = lift get
putState :: InterpreterState -> ScriptMonad ()
putState what = lift (put what)
getMainStack :: ScriptMonad [Entry]
getMainStack = _mainStack <$> getState
putMainStack :: [Entry] -> ScriptMonad ()
putMainStack main = do
St _ alt stream <- getState
putState (St main alt stream)
data IfBranch
= IfBranch
| ElseBranch
deriving (Eq,Show)
data IfType
= If
| NotIf
deriving Show
ifOpcode :: IfType -> Opcode
ifOpcode t = case t of
If -> OP_IF
NotIf -> OP_NOTIF
data IfBlock = IfBlock
{ _ifType :: IfType
, _ifBranch :: [Opcode]
, _elseBranch :: Maybe [Opcode]
}
deriving Show
checkForValidIfBlock :: IfBlock -> Bool
checkForValidIfBlock (IfBlock _ ifbr mbelsebr) =
not $ or
[ elem OP_VERIF ifbr
, elem OP_VERNOTIF ifbr
, elem OP_VERIF elsebr
, elem OP_VERNOTIF elsebr
]
where
elsebr = maybe [] id mbelsebr
reconstructIfBlock :: IfBlock -> [Opcode]
reconstructIfBlock (IfBlock typ ifbranch mbelsebranch) = opcode : ifbranch ++ elsebranch ++ [OP_ENDIF] where
opcode = ifOpcode typ
elsebranch = case mbelsebranch of
Nothing -> []
Just es -> OP_ELSE : es
fetchIfBlock_ :: IfType -> IfBranch -> ScriptMonad ()
fetchIfBlock_ iftype branch = fetchIfBlock iftype branch >> return ()
fetchIfBlock :: IfType -> IfBranch -> ScriptMonad IfBlock
fetchIfBlock topLevelIfType branchWeTook =
do
St main alt (Stream ctx (Zipper yys _)) <- getState
case yys of
[] -> invalid "fetchIfBlock: fatal error, shouldn't happen /1"
(y:ys) -> if (y /= ifOpcode topLevelIfType)
then invalid "fetchIfBlock: fatal error, shouldn't happen /2"
else do
ifblock <- fetch topLevelIfType
let iftype = _ifType ifblock
St _ _ (Stream _ctx (Zipper _ xs)) <- getState
putState $ St main alt $ case branchWeTook of
IfBranch -> Stream (CtxHole ctx (reverse ys) iftype (HoleThen (_elseBranch ifblock)) xs)
(Zipper [] (_ifBranch ifblock))
ElseBranch -> Stream (CtxHole ctx (reverse ys) iftype (HoleElse (_ifBranch ifblock) (isJust $ _elseBranch ifblock)) xs)
(Zipper [] (maybe [] id (_elseBranch ifblock)))
unless (checkForValidIfBlock ifblock) $ invalid "OP_VERIF or OP_VERNOTIF appearing in an if branch"
return ifblock
where
fetch :: IfType -> ScriptMonad IfBlock
fetch iftype = go IfBranch [] [] where
go :: IfBranch -> [Opcode] -> [Opcode] -> ScriptMonad IfBlock
go branch ifops elseops = do
mbop <- fetchOpcodeWithinContext
when (mbop == Nothing) $ invalid "unfinished IF (or NOTIF) block"
let Just op = mbop
case op of
OP_IF -> do
ifblock <- fetch If
let ops = reconstructIfBlock ifblock
continue (reverse ops)
OP_NOTIF -> do
ifblock <- fetch NotIf
let ops = reconstructIfBlock ifblock
continue (reverse ops)
OP_ELSE -> go ElseBranch ifops elseops
OP_ENDIF -> return $ case branch of
IfBranch -> IfBlock iftype (reverse ifops) Nothing
ElseBranch -> IfBlock iftype (reverse ifops) (Just $ reverse elseops)
_ -> case branch of
IfBranch -> go branch (op : ifops) elseops
ElseBranch -> go branch ifops (op : elseops)
where
continue ops = case branch of
IfBranch -> go branch (ops ++ ifops) elseops
ElseBranch -> go branch ifops (ops ++ elseops)
fetchOpcode :: ScriptMonad (Maybe Opcode)
fetchOpcode = do
St main alt stream <- getState
case streamMoveRight stream of
Left stream' -> putState (St main alt stream') >> return Nothing
Right (x,stream') -> putState (St main alt stream') >> return (Just x)
fetchOpcodeWithinContext :: ScriptMonad (Maybe Opcode)
fetchOpcodeWithinContext = do
St main alt stream@(Stream ctx zipper) <- getState
case Zipper.moveRight zipper of
Nothing -> return Nothing
Just (x,zipper') -> putState (St main alt (Stream ctx zipper')) >> return (Just x)
codeSeparatorSubscript :: Stream -> RawScript
codeSeparatorSubscript fullStream = subscript where
Zipper revbefore after = flattenStreamToZipper fullStream
before' = reverse $ takeWhile (/= OP_CODESEPARATOR) revbefore
after' = filter (/= OP_CODESEPARATOR) after
subscript = serializeScript $ Script (before' ++ after') :: RawScript
execute_OP_CHECKSIG :: ScriptMonad ()
execute_OP_CHECKSIG = do
pubKeyStr <- popData
sigStr <- popData
St _ _ fullStream <- getState
Cfg tx inputidx <- askCfg
let subscript = codeSeparatorSubscript fullStream
case decodeSignatureDER' False sigStr of
Nothing -> pushBool False
Just (SignatureExt signature sighash) -> case decodePubKey pubKeyStr of
Nothing -> pushBool False
Just pubKey -> do
let tx' = mapAccumLFst_ (\i old -> (i+1 , if i==inputidx then subscript else RawScript B.empty)) 0 tx
ins' = _txInputs tx'
outs' = _txOutputs tx'
nouts' = length outs'
let (singleIssue,tx'') = case _sigHashType sighash of
SigHashAll -> ( False, tx' )
SigHashAllZero -> ( False, tx' )
SigHashNone -> ( False, setSeqNoToZeroTxExcept inputidx $ tx' { _txOutputs = [] } )
SigHashSingle -> if nouts' > inputidx
then (False, setSeqNoToZeroTxExcept inputidx $ tx' { _txOutputs = (replicate inputidx blankTxOutput) ++ [outs' !! inputidx] } )
else (True , setSeqNoToZeroTxExcept inputidx $ tx' { _txOutputs = (replicate nouts' blankTxOutput) } )
let tx''' = case _anyOneCanPay sighash of
False -> tx''
True -> tx'' { _txInputs = [ ins' !! inputidx ] }
let RawTx rawtx = serializeTx tx'''
hash = if singleIssue
then fromIntegerLE 1
else doHash256 (rawtx `B.append` (fromWord8List [encodeSigHash sighash,0,0,0]))
pushBool $ verifySignatureWithHash pubKey signature hash
execute_OP_CHECKMULTISIG :: ScriptMonad ()
execute_OP_CHECKMULTISIG = do
n <- popInteger
when (n > 20 || n < 1) $ invalid "OP_CHECKMULTISIG: n must be at least 1 and at most 20"
pubKeyStrs <- reverse <$> replicateM (fromIntegral n) popData
m <- popInteger
when (m > n || m < 1) $ invalid "OP_CHECKMULTISIG: m must be at least 1 and at most n"
sigStrs <- reverse <$> replicateM (fromIntegral m) popData
_ <- popData
St _ _ fullStream <- getState
Cfg tx inputidx <- askCfg
let subscript = codeSeparatorSubscript fullStream
let mbSigs = map (decodeSignatureDER' False) sigStrs
mbPubKeys = map decodePubKey pubKeyStrs
case all isJust mbSigs of
False -> invalid $ "OP_CHECKMULTISIG: cannot decode DER signature"
++ "\n pubkeys = " ++ (show $ map RawScript pubKeyStrs)
++ "\n signatures = " ++ (show $ map RawScript sigStrs)
True -> do
let
sigExts = map fromJust mbSigs
sigs = map _extSignature sigExts
hashtypes = map _extSigHash sigExts
let tx' = mapAccumLFst_ (\i old -> (i+1 , if i==inputidx then subscript else RawScript B.empty)) 0 tx
ins' = _txInputs tx'
outs' = _txOutputs tx'
nouts' = length outs'
hashes <- forM hashtypes $ \sighash -> do
let (singleIssue,tx'') = case _sigHashType sighash of
SigHashAll -> ( False, tx' )
SigHashAllZero -> ( False, tx' )
SigHashNone -> ( False, setSeqNoToZeroTxExcept inputidx $ tx' { _txOutputs = [] } )
SigHashSingle -> if nouts' > inputidx
then ( False, setSeqNoToZeroTxExcept inputidx $ tx' { _txOutputs = (replicate inputidx blankTxOutput) ++ [outs' !! inputidx] } )
else ( True , setSeqNoToZeroTxExcept inputidx $ tx' { _txOutputs = (replicate nouts' blankTxOutput) } )
let tx''' = case _anyOneCanPay sighash of
False -> tx''
True -> tx'' { _txInputs = [ ins' !! inputidx ] }
let RawTx rawtx = serializeTx tx'''
hash = if singleIssue
then fromIntegerLE 1
else doHash256 (rawtx `B.append` (fromWord8List [encodeSigHash sighash,0,0,0]))
return hash
b <- worker mbPubKeys (zip hashes sigs)
pushBool b
where
worker :: [Maybe PubKey] -> [(Hash256,Signature)] -> ScriptMonad Bool
worker = go where
go _ [] = return True
go [] _ = return False
go (mbp:ps) (hs@(h,s):hss) = case mbp of
Nothing -> go ps (hs:hss)
Just p -> case verifySignatureWithHash p s h of
True -> go ps hss
False -> go ps (hs:hss)
blankTxOutput :: TxOutput RawScript
blankTxOutput = TxOutput (1) (RawScript B.empty)
setSeqNoToZeroTxExcept :: Int -> Tx a b -> Tx a b
setSeqNoToZeroTxExcept idx tx = tx { _txInputs = setSeqNoToZeroListExcept idx (_txInputs tx) }
setSeqNoToZeroListExcept :: Int -> [TxInput a] -> [TxInput a]
setSeqNoToZeroListExcept idx = mapAccumL_ (\i txin -> (i+1, if i==idx then txin else txin { _txInSeqNo = 0 })) 0
mapAccumL_ :: (acc -> x -> (acc,y)) -> acc -> [x] -> [y]
mapAccumL_ f acc = snd . mapAccumL f acc