{-# LANGUAGE OverloadedStrings #-}
module Network.Haskoin.Script.Standard
( ScriptInput(..)
, SimpleInput(..)
, RedeemScript
, p2shAddr
, p2wshAddr
, outputAddress
, inputAddress
, encodeInput
, encodeInputBS
, decodeInput
, decodeInputBS
, addressToOutput
, addressToScript
, addressToScriptBS
, scriptToAddress
, scriptToAddressBS
, sortMulSig
, scriptOpToInt
, isSpendPK
, isSpendPKHash
, isSpendMulSig
, isScriptHashInput
) where
import Control.Applicative ((<|>))
import Control.DeepSeq (NFData, rnf)
import Control.Monad (guard, (<=<))
import Data.ByteString (ByteString)
import Data.Function (on)
import Data.List (sortBy)
import Data.Serialize (decode, encode)
import Network.Haskoin.Address
import Network.Haskoin.Constants
import Network.Haskoin.Crypto.Hash
import Network.Haskoin.Keys.Common
import Network.Haskoin.Script.Common
import Network.Haskoin.Script.SigHash
import Network.Haskoin.Util
data SimpleInput
= SpendPK { getInputSig :: !TxSignature }
| SpendPKHash { getInputSig :: !TxSignature
, getInputKey :: !PubKeyI
}
| SpendMulSig { getInputMulSigKeys :: ![TxSignature] }
deriving (Eq, Show)
instance NFData SimpleInput where
rnf (SpendPK i) = rnf i
rnf (SpendPKHash i k) = rnf i `seq` rnf k
rnf (SpendMulSig k) = rnf k
isSpendPK :: ScriptInput -> Bool
isSpendPK (RegularInput (SpendPK _)) = True
isSpendPK _ = False
isSpendPKHash :: ScriptInput -> Bool
isSpendPKHash (RegularInput (SpendPKHash _ _)) = True
isSpendPKHash _ = False
isSpendMulSig :: ScriptInput -> Bool
isSpendMulSig (RegularInput (SpendMulSig _)) = True
isSpendMulSig _ = False
isScriptHashInput :: ScriptInput -> Bool
isScriptHashInput (ScriptHashInput _ _) = True
isScriptHashInput _ = False
type RedeemScript = ScriptOutput
data ScriptInput
= RegularInput { getRegularInput :: SimpleInput }
| ScriptHashInput { getScriptHashInput :: SimpleInput
, getScriptHashRedeem :: RedeemScript
}
deriving (Eq, Show)
instance NFData ScriptInput where
rnf (RegularInput i) = rnf i
rnf (ScriptHashInput i o) = rnf i `seq` rnf o
p2shAddr :: Network -> ScriptOutput -> Address
p2shAddr net out = ScriptAddress (addressHash (encodeOutputBS out)) net
p2wshAddr :: Network -> ScriptOutput -> Maybe Address
p2wshAddr net out = do
guard (getSegWit net)
return $ WitnessScriptAddress (sha256 (encodeOutputBS out)) net
addressToOutput :: Address -> Maybe ScriptOutput
addressToOutput (PubKeyAddress h _) = Just (PayPKHash h)
addressToOutput (ScriptAddress h _) = Just (PayScriptHash h)
addressToOutput (WitnessPubKeyAddress h n)
| getSegWit n = Just (PayWitnessPKHash h)
| otherwise = Nothing
addressToOutput (WitnessScriptAddress h n)
| getSegWit n = Just (PayWitnessScriptHash h)
| otherwise = Nothing
addressToScript :: Address -> Maybe Script
addressToScript a = encodeOutput <$> addressToOutput a
addressToScriptBS :: Address -> Maybe ByteString
addressToScriptBS a = encode <$> addressToScript a
scriptToAddress :: Network -> Script -> Maybe Address
scriptToAddress net = eitherToMaybe . (outputAddress net <=< decodeOutput)
scriptToAddressBS :: Network -> ByteString -> Maybe Address
scriptToAddressBS net = eitherToMaybe . (outputAddress net <=< decodeOutputBS)
outputAddress :: Network -> ScriptOutput -> Either String Address
outputAddress net s =
case s of
PayPKHash h -> return $ PubKeyAddress h net
PayScriptHash h -> return $ ScriptAddress h net
PayPK k -> return $ pubKeyAddr net k
PayWitnessPKHash h
| getSegWit net -> return $ WitnessPubKeyAddress h net
PayWitnessScriptHash h
| getSegWit net -> return $ WitnessScriptAddress h net
_ -> Left "outputAddress: bad output script type"
inputAddress :: Network -> ScriptInput -> Either String Address
inputAddress net s = case s of
RegularInput (SpendPKHash _ key) -> return $ pubKeyAddr net key
ScriptHashInput _ rdm -> return $ p2shAddr net rdm
_ -> Left "inputAddress: bad input script type"
decodeSimpleInput :: Network -> Script -> Either String SimpleInput
decodeSimpleInput net (Script ops) =
maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops
where
matchPK [op] = SpendPK <$> f op
matchPK _ = Nothing
matchPKHash [op, OP_PUSHDATA pub _] =
SpendPKHash <$> f op <*> eitherToMaybe (decode pub)
matchPKHash _ = Nothing
matchMulSig (x:xs) = do
guard $ x == OP_0
SpendMulSig <$> mapM f xs
matchMulSig _ = Nothing
f OP_0 = return TxSignatureEmpty
f (OP_PUSHDATA "" OPCODE) = f OP_0
f (OP_PUSHDATA bs _) = eitherToMaybe $ decodeTxSig net bs
f _ = Nothing
errMsg = "decodeInput: Could not decode script input"
decodeInput :: Network -> Script -> Either String ScriptInput
decodeInput net s@(Script ops) =
maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash
where
matchSimpleInput =
RegularInput <$> eitherToMaybe (decodeSimpleInput net s)
matchPayScriptHash =
case splitAt (length (scriptOps s) - 1) ops of
(is, [OP_PUSHDATA bs _]) -> do
rdm <- eitherToMaybe $ decodeOutputBS bs
inp <- eitherToMaybe $ decodeSimpleInput net $ Script is
return $ ScriptHashInput inp rdm
_ -> Nothing
errMsg = "decodeInput: Could not decode script input"
decodeInputBS :: Network -> ByteString -> Either String ScriptInput
decodeInputBS net = decodeInput net <=< decode
encodeInput :: ScriptInput -> Script
encodeInput s = case s of
RegularInput ri -> encodeSimpleInput ri
ScriptHashInput i o -> Script $
scriptOps (encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o]
encodeInputBS :: ScriptInput -> ByteString
encodeInputBS = encode . encodeInput
encodeSimpleInput :: SimpleInput -> Script
encodeSimpleInput s =
Script $
case s of
SpendPK ts -> [f ts]
SpendPKHash ts p -> [f ts, opPushData $ encode p]
SpendMulSig xs -> OP_0 : map f xs
where
f TxSignatureEmpty = OP_0
f ts = opPushData $ encodeTxSig ts
sortMulSig :: ScriptOutput -> ScriptOutput
sortMulSig out = case out of
PayMulSig keys r -> PayMulSig (sortBy (compare `on` encode) keys) r
_ -> error "Can only call orderMulSig on PayMulSig scripts"