module Bitcoin.Protocol.Tx where
import Data.Word
import qualified Data.ByteString as B
import System.Random
import Bitcoin.Protocol.Address
import Bitcoin.Protocol.Amount
import Bitcoin.Protocol.Signature
import Bitcoin.Protocol.Key
import Bitcoin.BlockChain.Tx
import Bitcoin.BlockChain.Parser ( serializeTx )
import Bitcoin.Script.Base
import Bitcoin.Script.Standard
import Bitcoin.Script.Run
import Bitcoin.Script.Serialize
import Bitcoin.Misc.Bifunctor
import Bitcoin.Misc.Tuple
data StdTxInput a = StdTxInput
{ _prevTx :: !(Tx a RawScript)
, _prevOutIndex :: !Int
, _prevOutPrivKey :: !PrivKey
}
data StdTxOutput = StdTxOutput
{ _outAddress :: !Address
, _outAmount :: !Amount
}
signTransaction :: forall a gen. RandomGen gen => Tx (Tx a RawScript, PrivKey) RawScript -> gen -> (Either String (Tx RawScript RawScript) ,gen)
signTransaction newTxExt gen0 = result where
result = case mapAccumLFst worker (Right 0, gen0) newTxExt of
((Left err , gen1) , _ ) -> (Left err, gen1)
((Right _ , gen1) , finalTx) ->
let prevs = map fst $ toListFst newTxExt :: [Tx a RawScript]
finalTxExt = zipWithFst (,) prevs finalTx
in case checkTransaction finalTxExt of
Left err -> (Left err, gen1)
Right b -> if b
then (Right finalTx, gen1)
else (Left "cannot verify the signed transaction", gen1)
undefRawScript :: RawScript
undefRawScript = error "signTransaction/undefRawScript: shouldn't be evaluated"
worker :: (Either String Int, gen) -> (Tx a RawScript, PrivKey) -> ((Either String Int, gen), RawScript)
worker (Left err, gen) _ = ((Left err,gen) , undefRawScript)
worker (Right k , gen) (prevtx,privkey) =
case signSingleInput privkey sigHashAll k prevtx newTxExt gen of
Left err -> ((Left err, gen), undefRawScript)
Right ((sigext,pubkey),gen') -> ((Right (k+1), gen') , sigScript) where
sigScript = createInputScript $ RedeemAddress sigext pubkey
signSingleInput :: forall a b gen. RandomGen gen => PrivKey -> SigHash -> Int -> Tx a RawScript -> Tx b RawScript -> gen -> Either String ((SignatureExt,PubKey),gen)
signSingleInput privkey sighash inpidx prevtx thistx gen = result where
result = case safeLookup inpidx thisinps of
Nothing -> Left "signSingleInput: input index out of range"
Just inp ->
let outidx = _txInPrevOutIdx inp
in case safeLookup (fromIntegral outidx) prevouts of
Nothing -> Left "signSingleOutput: prev output index out of range"
Just prevout ->
let pkscript = _txOutScript prevout
in case getSubscript pkscript of
Left err -> Left err
Right subscript ->
let txcopy = replaceTxIns emptyRawScript (inpidx,subscript) thistx
RawTx raw = serializeTx txcopy
msg = B.append raw (B.pack [encodeSigHash sighash, 0,0,0::Word8])
((signbits,signat),gen') = signRawMessage privkey msg gen
sigext = SignatureExt signat sighash
in Right ((sigext,pubkey),gen')
thisinps = _txInputs thistx :: [TxInput b]
prevouts = _txOutputs prevtx :: [TxOutput RawScript]
pubkey = computePubKey Compressed privkey
safeLookup :: forall x. Int -> [x] -> Maybe x
safeLookup n xs
| n<0 = Nothing
| n==0 = case xs of { (x:_) -> Just x ; [] -> Nothing }
| True = case xs of { (x:_) -> safeLookup (n1) xs ; [] -> Nothing }
getSubscript :: RawScript -> Either String RawScript
getSubscript full = case parseScript full of
Nothing -> Left "signInput/subscript: cannot parse pkScript"
Just pk -> Right $ serializeScript $ Script $ reverse $ takeWhile (/=OP_CODESEPARATOR) $ reverse $ fromScript $ pk
replaceTxIns :: forall a b c. b -> (Int,b) -> Tx a c -> Tx b c
replaceTxIns def (k,spec) tx = mapAccumLFst_ worker 0 tx where
worker j _ = if j==k then (j+1,spec) else (j+1,def)
isPayToAddress :: OutputScript -> Bool
isPayToAddress s = case s of
PayToAddress {} -> True
_ -> False
isPayToPubKey :: OutputScript -> Bool
isPayToPubKey s = case s of
PayToPubKey {} -> True
_ -> False