-- | Bitcoin script interpreter

{-# LANGUAGE PatternGuards, ScopedTypeVariables, PackageImports #-}
module Bitcoin.Script.Run
  ( 
  -- * types
    Entry , InterpreterConfig(..) , InterpreterState(..) , ScriptMonad 
  -- * high level functions
  , checkTransaction 
  -- * medium level functions
  , isDisabledOpcode 
  , initialState
  , executeScript , runScriptPre, runScriptFinal
  , scriptStep , scriptStep' 
  , isFalse, isTrue
  -- * internal types
  , Stream(..) , Context(..) , Hole(..) 
  , IfBranch(..) , IfType(..) , IfBlock(..)
  -- * some internal functions
  , streamMoveRight
  , fetchOpcode , fetchOpcodeWithinContext
  , fetchIfBlock
  , reconstructIfBlock
  -- * script monad
  , invalid
  , getState
  , putState
  -- * push\/pop
  , pushData , popData
  , pushAltData , popAltData
  , pushInteger , popInteger
  , pushBool , popBool
  -- * parsing (should be elsewhere)
  , 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

  -- splice
  OP_CAT       -> True
  OP_SUBSTR    -> True
  OP_LEFT      -> True
  OP_RIGHT     -> True

  -- bitwise logic
  OP_INVERT    -> True
  OP_AND       -> True
  OP_OR        -> True
  OP_XOR       -> True

  -- arithmetic
  OP_2MUL      -> True
  OP_2DIV      -> True
  OP_MUL       -> True
  OP_DIV       -> True
  OP_MOD       -> True
  OP_LSHIFT    -> True
  OP_RSHIFT    -> True

  _ -> False

--------------------------------------------------------------------------------

-- | An opcode stream consist of a zipper of opcodes, and a "Context" which
-- describes (possibly recursively) what is on the left and right side of 
-- this zipper. This is used for executing (possibly nested) OP_IF blocks. 
--
-- This may be overly complicated :)
--
data Stream = Stream 
  { _streamContext :: Context
  , _streamZipper  :: Zipper Opcode
  }
  deriving Show

-- | A context of opcodes and (nested) if blocks
data Context 
  = CtxEmpty                                         -- ^ we are the full opcode stream
  | CtxHole Context [Opcode] IfType Hole [Opcode]    -- ^ a hole has an outer context, opcodes on the left and right, and an if block in the middle
  deriving Show

data Hole 
  = HoleThen  { _elsePart :: Maybe [Opcode] }    -- ^ we are in the \"then\" branch
  | HoleElse  { _thenPart   :: [Opcode] 
              , _elseExists :: Bool }            -- ^ we are in the \"else\" branch (which may not physically exists - this is important when reconstructing)
  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]
      -- note: if `exists' is False then `list' must be empty

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)
        -- note: if `exists' is False then `xs' and `ys' must be empty

-- | Even where there is nothing on the right, we can change the stream itself during the discovery of this fact!
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
        -- note: if `exists' is False then `zipperToList zipper' must be empty

--------------------------------------------------------------------------------
-- * Script interpreter

-- | Stack entry
type Entry = B.ByteString

-- | Two stacks, an opcode stream (the latter necessary for the somewhat convoluted IF parsing, and also for OP_CHECKSIG)
data InterpreterState = St 
  { _mainStack    :: [Entry]                -- ^ the main stack
  , _altStack     :: [Entry]                -- ^ the alt stack
  , _opcodeStream :: Stream                 -- ^ the opcode stream
  }
  deriving Show

-- | Empty stacks, empty script
initialState :: InterpreterState
initialState = St [] [] (Stream CtxEmpty (Zipper [] []))

data InterpreterConfig = Cfg
  { _newTx      :: !(Tx RawScript RawScript)  -- ^ the /new/ tx we are running (containing the scriptSigs which are combined with the previous tx's pubKeyScripts)
  , _curTxInIdx :: !Int                       -- ^ the index of the current transaction input (within the /new/ tx) we are checking
  }
  deriving Show

-- | Interpreter monad
type ScriptMonad a = ExceptT String (StateT InterpreterState (ReaderT InterpreterConfig Identity)) a

--------------------------------------------------------------------------------

-- | Given a transaction together with its inputs, we check if it is valid or not.
-- This is done by combining the input scripts of this transaction with the output
-- scripts of the previous transactions, and running the resulting scripts
--
-- If any of the scripts fails, the cause of failure is returned; if the scripts runs correctly,
-- the result is returned (which should be 'True' for valid transactions)
--
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)
                -- NOTE: only the main stack is shared between sig and pk scripts, the alt stack is not!
                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

--------------------------------------------------------------------------------
    
-- | Tries to parse all scripts, both input and output. Since the output scripts can fail to parse (see below),
-- this may also fail.
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

-- | Tries to parse all input scripts. This shouldn't fail for a valid transaction.
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

-- | Tries to parse all output scripts. This may fail because invalid output scripts are allowed, just unspendable... :(
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

-- | Parses only a single output script, leaves the rest (reason: tx validation shouldn\'t fail just
-- because there are other invalid scripts in the prev tx unrelated to this one).
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"

-- | Helper function.
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"
 
--------------------------------------------------------------------------------

-- | Runs the scriptSig 
runScriptPre :: InterpreterConfig -> InterpreterState -> Script -> (Either String (), InterpreterState)
runScriptPre cfg st (Script opcodes) = runIdentity $ runReaderT (runStateT (runExceptT (executeScript opcodes)) st) cfg

-- | Runs the scriptPubKey
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)                         -- if the top of the stack is TRUE, we are ok, otherwise we failed.
              []      -> invalid "script finished but the stack is empty"
        _ -> invalid $ "executeScript: shouldn't happen (script finished but there are remaining opcodes)"   -- (++ "\n" ++ show stream)

--------------------------------------------------------------------------------

-- | Executes a list of 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 

-- | Execute a single (except in case of conditionals) opcode 
-- 
-- \"The stacks hold byte vectors. Byte vectors are interpreted as little-endian 
-- variable-length integers with the most significant bit determining the sign
-- of the integer. Thus 0x81 represents -1. 0x80 is another representation of 
-- zero (so called negative 0). Byte vectors are interpreted as Booleans where 
-- False is represented by any representation of zero, and True is represented 
-- by any representation of non-zero.\"
--
-- Returns 'True' if the script finished.
--
scriptStep :: ScriptMonad Bool
scriptStep = fetchOpcode >>= \mbop -> case mbop of
  Nothing -> return True
  Just op -> do
    -- when (isDisabledOpcode op) $ invalid $ show op ++ ": disabled opcode"
    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]    -- "Thus 0x81 represents -1"
  OP_PUSHDATA w8 bs  -> if is_valid_pushdata w8 bs 
                          then pushData bs 
                          else invalid "fatal error: invalid PUSHDATA opcode"

  -- control flow
  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
                   -- unless (checkForValidIfBlock ifblock) $ invalid "OP_VERIF or OP_VERNOTIF appearing in an if branch"                   
                   return ()
  OP_NOTIF    -> do 
                   b <- popBool
                   let branchTaken = if not b then IfBranch else ElseBranch
                   ifblock@(IfBlock _ ifops mbelseops) <- fetchIfBlock NotIf branchTaken
                   -- unless (checkForValidIfBlock ifblock) $ invalid "OP_VERIF or OP_VERNOTIF appearing in an if branch"
                   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"

  -- stack
  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 }  -- Copies the second-to-top stack item to the top.

  -- The item n back in the stack is copied to the top. 
  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)                        
              
  -- The item n back in the stack is moved to the top.
  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 }  -- The item at the top of the stack is copied and inserted before the second-to-top item

  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 }  -- Copies the pair of items two spaces back in the stack to the front.

  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 }

  -- splice
  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 (n-siz)) str)

  -- bitwise logic
  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

  -- arithmetic
  -- Note: Arithmetic inputs are limited to signed 32-bit integers, but may overflow their output. 
  -- If any input value for any of these commands is longer than 4 bytes, the script must abort and fail. 
  -- If any opcode marked as disabled is present in a script - it must also abort and fail.
  OP_1ADD           -> do { x <- popArith ; pushArith (x+1) }
  OP_1SUB           -> do { x <- popArith ; pushArith (x-1) }
  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 (x-y) }
  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) }

  -- Shifts a left b bits, preserving sign
  OP_LSHIFT -> do  
                 -- k <- popArith 
                 -- (sgn,absn) <- (toSignAbs . fromIntegral) <$> popArith
                 -- pushArith $ fromSignAbs (sgn, shiftL absn (fromIntegral k)) 
                 k <- fromIntegral <$> popArith
                 n <- popArith
                 pushArith (shiftL n (mod k 32))

  -- Shifts a right b bits, preserving sign
  OP_RSHIFT -> do  
                 -- k <- popArith
                 -- (sgn,absn) <- (toSignAbs . fromIntegral) <$> popArith 
                 -- pushArith $ fromSignAbs (sgn, shiftR absn (fromIntegral k)) 
                 k <- fromIntegral <$> popArith
                 n <- popArith
                 pushArith (shiftR n (mod k 32))   -- Right shifts perform sign extension on /signed/ number types (here Integer)

  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) }  -- Returns 1 if x is within the specified range (left-inclusive), 0 otherwise

  -- crypto
  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 ()   -- this one has only a meta meaning
  OP_CHECKSIG            -> execute_OP_CHECKSIG       -- invalid "OP_CHECKSIG: not implemented"
  OP_CHECKMULTISIG       -> execute_OP_CHECKMULTISIG  -- invalid "OP_CHECKMULTISIG: not implemented"
  OP_CHECKSIGVERIFY      -> scriptStep' OP_CHECKSIG      >> scriptStep' OP_VERIFY
  OP_CHECKMULTISIGVERIFY -> scriptStep' OP_CHECKMULTISIG >> scriptStep' OP_VERIFY
  
  -- reserved words
  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"

  -- pseudo
  OP_INVALIDOPCODE      -> invalid "OP_INVALIDOPCODE executed"
  OP_UNKNOWN w          -> invalid ("OP_UNKNOWN (decimal " ++ show w ++ ") executed")

  _  -> invalid ("unhandled or invalid opcode " ++ show op)

--------------------------------------------------------------------------------
-- * stack entries

dataLen :: Entry -> Integer
dataLen = fromIntegral . B.length

-- | zero-extended zipWith (the result will as long as the longer input)
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)

--------------------------------------------------------------------------------
-- * stack


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"

----------------------------------------
-- arithmetic stupidity

{-
ok this is the craziest stupid fucking thing i ever seen. Inputs are limited to 32 bit signed 
integers, but then they are treated as a bigint, and output can be more than 32 bit... 
(let me bet here that they were originally implemented using @uint64_t@...)
-}

-- | Note: Arithmetic inputs are limited to signed 32-bit integers, but may overflow their output 
-- (and by overflow they don't mean Int32 overflow, but that the result will not fit into an Int32...)
pushArith :: Integer -> ScriptMonad ()
pushArith = pushData . asByteString

-- | If any input value for any of these commands is longer than 4 bytes, the script must abort and fail. 
-- If any opcode marked as disabled is present in a script - it must also abort and fail.
--
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

--------------------------------------------------------------------------------
-- * lifted monad operations

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)  

--------------------------------------------------------------------------------
-- * if blocks

data IfBranch 
  = IfBranch      -- ^ \"if-then\"
  | ElseBranch    -- ^ \"else\"
  deriving (Eq,Show)

data IfType
  = If          -- ^ OP_IF
  | NotIf       -- ^ OP_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

-- | Checks if OP_VER or OP_VERIF appears in any branch. Returns "True" if the block is valid.
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 () 

-- | We fetch an if block *and* take the given branch (second argument)
--
-- Note: if blocks can be nested...
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

      -- first argument is which branch we are in right now
      -- second and third arguments accumulates the opcodes on the two branches
      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) 

--------------------------------------------------------------------------------
-- * opcode stream manipulation

-- | Fetches an opcode, possibly exiting the current context
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)
           
-- | Fetches an opcode, but does not exit the current context
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)

{-
getOpcodes :: ScriptMonad [Opcode]
getOpcodes = do
  St main alt stream <- getState
  return $ snd $ zipperView stream

putOpcodes :: [Opcode] -> ScriptMonad ()
putOpcodes stream = do
  St main alt _ <- getState
  putState (St main alt stream)
-}

--------------------------------------------------------------------------------
-- * CHECKSIG

{-
Hashtype SIGHASH_ALL (default)
  No special further handling occurs in the default case. 
  Think of this as "sign all of the outputs." Which is already done by the default procedure. 

Procedure for Hashtype SIGHASH_NONE
  1. The output of txCopy is set to a vector of zero size. 
  2. All other inputs aside from the current input in txCopy have their nSequence index set to zero 
  Think of this as "sign none of the outputs -- I don't care where the bitcoins go."
 
Procedure for Hashtype SIGHASH_SINGLE
  1. The output of txCopy is resized to the size of the current input index+1. 
  2. All other txCopy outputs aside from the output that is the same as the current input index are set to a blank script and a value of (long) -1. 
  3. All other txCopy inputs aside from the current input are set to have an nSequence index of zero. 
  Think of this as "sign one of the outputs-- I don't care where the other outputs go". 

  Note: The transaction that uses SIGHASH_SINGLE type of signature should not have more outputs than inputs. 
  However if it does (because of the pre-existing implementation), it shall not be rejected, but instead 
  for every "illegal" input (meaning: an input that has an index bigger than the maximum output index) 
  the node should still verify it, though assuming the hash of 0000000000000000000000000000000000000000000000000000000000000001 
  <https://bitcointalk.org/index.php?topic=260595.0>

Procedure for Hashtype SIGHASH_ANYONECANPAY
  1. The txCopy input vector is resized to a length of one. 
  2. The subScript (lead in by its length as a var-integer encoded!) is set as the first and only member of this vector. 
  Think of this as "Let other people add inputs to this transaction, I don't care where the rest of the bitcoins come from."
-}

--------------------------------------------------------------------------------

codeSeparatorSubscript :: Stream -> RawScript
codeSeparatorSubscript fullStream = subscript where

  Zipper revbefore after = flattenStreamToZipper fullStream

  before' = reverse $ takeWhile (/= OP_CODESEPARATOR) revbefore
  after'  = filter (/= OP_CODESEPARATOR) after

  -- here, in theory, signatures should be deleted from subscript.
  -- however, in practice:
  --   1) signatures do not appear in pubKeyScripts (because self-signing is impossible?)
  --   2) it is theoretically impossible to distinguish a signature from some other data
  -- so we ignore this step

  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  -- invalid "OP_CHECKSIG: cannot decode DER signature"        
    Just (SignatureExt signature sighash) -> case decodePubKey pubKeyStr of

      Nothing -> pushBool False  -- invalid "OP_CHECKSIG: cannnot decode PubKey"     
      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       -- this works this way because of a stupid bug in the reference implementation...
              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     -- this is a bug in the original Satoshi client, which we must faithfully reproduce :(

  -- the first signature seems to have *another* extra byte at the end
  -- EXCEPT when it is missing, or EVEN the normal hashtype byte is missing!
  -- of course, there is precisely *ZERO* information about this on the net
  -- ok, fuck it, let's loose up the signature decoding...

  St _ _ fullStream   <- getState
  Cfg tx inputidx <- askCfg

  let subscript = codeSeparatorSubscript fullStream

  let mbSigs    = map (decodeSignatureDER' False) sigStrs     -- we allow non-standard encodings because they appear in the blockchain :(
      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)
              
    -- unfortunately, the original bitcoin client checks the pubkeys in order, and decodes on-the-fly, which means that
    -- it allows for invalid pubkeys after there is enough to satisfy the transaction :((( all these stupid on-the-fly
    -- validation issues (allowing partially-unparsable transaction in the blockchain) makes my nice code much more ugly :(
    --
    -- see (the output script of) testnet3 transaction 2e131d48f58cbb358cc53967a2fb89a80a6da337cb430fd719f5888af7a48507
{-
    True  -> case all isJust mbPubKeys of

      False -> invalid "OP_CHECKMULTISIG: cannnot decode PubKey"
      True  -> do
-}
    True -> do

        let -- pubKeys = map fromJust mbPubKeys
            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'

        -- there are more signatures -> more hashtypes 
        -- (but no documentation, fuck, who needs documentation for idiosyncratic code...)
        -- ok it seems that you have to recompute the hash for the different signatures because they can contain
        -- different hashtypes... (why isn't this documented anywhere?!)
        -- fuck all this overcomplicated shit
        
        -- this could be optimized since sighash is typically the same for all the signatures, but i don't care
        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       -- this works this way because of a stupid bug in the reference implementation...
                else doHash256 (rawtx `B.append` (fromWord8List [encodeSigHash sighash,0,0,0]))

          return hash

        b <- worker mbPubKeys (zip hashes sigs)
        pushBool b

  where

    -- we have n pubkeys (some of them can be invalid...) and m signatures, n >= m
    worker :: [Maybe PubKey] -> [(Hash256,Signature)] -> ScriptMonad Bool
    worker = go where
      go _      []          = return True    -- there are no more signatures -> all of them matched
      go []     _           = return False   -- there are at least one signature but no more pubkey -> not all of them matched
      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)

--------------------------------------------------------------------------------
-- helpers for CHECKSIG

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

--------------------------------------------------------------------------------