module Network.Haskoin.Script.Parser
( ScriptOutput(..)
, ScriptInput(..)
, SimpleInput(..)
, RedeemScript
, scriptAddr
, outputAddress
, inputAddress
, encodeInput
, encodeInputBS
, decodeInput
, decodeInputBS
, encodeOutput
, encodeOutputBS
, decodeOutput
, decodeOutputBS
, sortMulSig
, intToScriptOp
, scriptOpToInt
, isPayPK
, isPayPKHash
, isPayMulSig
, isPayScriptHash
, isSpendPK
, isSpendPKHash
, isSpendMulSig
, isScriptHashInput
, isDataCarrier
) where
import Control.Applicative ((<|>))
import Control.DeepSeq (NFData, rnf)
import Control.Monad (guard, liftM2, (<=<))
import Data.Aeson (FromJSON, ToJSON,
Value (String), parseJSON,
toJSON, withText)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (head, singleton)
import Data.Foldable (foldrM)
import Data.List (sortBy)
import Data.Serialize (encode, decode)
import Data.String.Conversions (cs)
import Network.Haskoin.Crypto.Base58
import Network.Haskoin.Crypto.Hash
import Network.Haskoin.Crypto.Keys
import Network.Haskoin.Script.SigHash
import Network.Haskoin.Script.Types
import Network.Haskoin.Util
data ScriptOutput =
PayPK { getOutputPubKey :: !PubKey }
| PayPKHash { getOutputAddress :: !Address }
| PayMulSig { getOutputMulSigKeys :: ![PubKey]
, getOutputMulSigRequired :: !Int
}
| PayScriptHash { getOutputAddress :: !Address }
| DataCarrier { getOutputData :: !ByteString }
deriving (Eq, Show, Read)
instance FromJSON ScriptOutput where
parseJSON = withText "scriptoutput" $ \t -> either fail return $
maybeToEither "scriptoutput not hex" (decodeHex $ cs t) >>=
decodeOutputBS
instance ToJSON ScriptOutput where
toJSON = String . cs . encodeHex . encodeOutputBS
instance NFData ScriptOutput where
rnf (PayPK k) = rnf k
rnf (PayPKHash a) = rnf a
rnf (PayMulSig k r) = rnf k `seq` rnf r
rnf (PayScriptHash a) = rnf a
rnf (DataCarrier a) = rnf a
isPayPK :: ScriptOutput -> Bool
isPayPK (PayPK _) = True
isPayPK _ = False
isPayPKHash :: ScriptOutput -> Bool
isPayPKHash (PayPKHash _) = True
isPayPKHash _ = False
isPayMulSig :: ScriptOutput -> Bool
isPayMulSig (PayMulSig _ _) = True
isPayMulSig _ = False
isPayScriptHash :: ScriptOutput -> Bool
isPayScriptHash (PayScriptHash _) = True
isPayScriptHash _ = False
isDataCarrier :: ScriptOutput -> Bool
isDataCarrier (DataCarrier _) = True
isDataCarrier _ = False
scriptAddr :: ScriptOutput -> Address
scriptAddr = ScriptAddress . hash160 . getHash256 . hash256 . encodeOutputBS
sortMulSig :: ScriptOutput -> ScriptOutput
sortMulSig out = case out of
PayMulSig keys r -> PayMulSig (sortBy f keys) r
_ -> error "Can only call orderMulSig on PayMulSig scripts"
where
f a b = encode a `compare` encode b
encodeOutput :: ScriptOutput -> Script
encodeOutput s = Script $ case s of
(PayPK k) -> [opPushData $ encode k, OP_CHECKSIG]
(PayPKHash a) -> case a of
(PubKeyAddress h) -> [ OP_DUP, OP_HASH160, opPushData $ encode h
, OP_EQUALVERIFY, OP_CHECKSIG
]
(ScriptAddress _) ->
error "encodeOutput: ScriptAddress is invalid in PayPKHash"
(PayMulSig ps r)
| r <= length ps ->
let opM = intToScriptOp r
opN = intToScriptOp $ length ps
keys = map (opPushData . encode) ps
in opM : keys ++ [opN, OP_CHECKMULTISIG]
| otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys"
(PayScriptHash a) -> case a of
(ScriptAddress h) -> [ OP_HASH160
, opPushData $ encode h, OP_EQUAL
]
(PubKeyAddress _) ->
error "encodeOutput: PubKeyAddress is invalid in PayScriptHash"
(DataCarrier d) -> [OP_RETURN, opPushData d]
encodeOutputBS :: ScriptOutput -> ByteString
encodeOutputBS = encode . encodeOutput
decodeOutput :: Script -> Either String ScriptOutput
decodeOutput s = case scriptOps s of
[OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> decode bs
[OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] ->
(PayPKHash . PubKeyAddress) <$> decode bs
[OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] ->
(PayScriptHash . ScriptAddress) <$> decode bs
[OP_RETURN, OP_PUSHDATA bs _] -> Right $ DataCarrier bs
_ -> matchPayMulSig s
decodeOutputBS :: ByteString -> Either String ScriptOutput
decodeOutputBS = decodeOutput <=< decode
matchPayMulSig :: Script -> Either String ScriptOutput
matchPayMulSig (Script ops) = case splitAt (length ops 2) ops of
(m:xs,[n,OP_CHECKMULTISIG]) -> do
(intM,intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n)
if intM <= intN && length xs == intN
then liftM2 PayMulSig (go xs) (return intM)
else Left "matchPayMulSig: Invalid M or N parameters"
_ -> Left "matchPayMulSig: script did not match output template"
where
go (OP_PUSHDATA bs _:xs) = liftM2 (:) (decode bs) (go xs)
go [] = return []
go _ = Left "matchPayMulSig: invalid multisig opcode"
intToScriptOp :: Int -> ScriptOp
intToScriptOp i
| i `elem` [1..16] = either (const err) id op
| otherwise = err
where
op = decode $ BS.singleton $ fromIntegral $ i + 0x50
err = error $ "intToScriptOp: Invalid integer " ++ (show i)
scriptOpToInt :: ScriptOp -> Either String Int
scriptOpToInt s
| res `elem` [1..16] = return res
| otherwise = Left $ "scriptOpToInt: invalid opcode " ++ (show s)
where
res = (fromIntegral $ BS.head $ encode s) 0x50
outputAddress :: ScriptOutput -> Either String Address
outputAddress s = case s of
PayPKHash a -> return a
PayScriptHash a -> return a
PayPK k -> return $ pubKeyAddr k
_ -> Left "outputAddress: bad output script type"
inputAddress :: ScriptInput -> Either String Address
inputAddress s = case s of
RegularInput (SpendPKHash _ key) -> return $ pubKeyAddr key
ScriptHashInput _ rdm -> return $ scriptAddr rdm
_ -> Left "inputAddress: bad input script type"
data SimpleInput
= SpendPK { getInputSig :: !TxSignature }
| SpendPKHash { getInputSig :: !TxSignature
, getInputKey :: !PubKey
}
| SpendMulSig { getInputMulSigKeys :: ![TxSignature] }
deriving (Eq, Show, Read)
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, Read)
instance NFData ScriptInput where
rnf (RegularInput i) = rnf i
rnf (ScriptHashInput i o) = rnf i `seq` rnf o
encodeSimpleInput :: SimpleInput -> Script
encodeSimpleInput s = Script $ case s of
SpendPK ts -> [ opPushData $ encodeSig ts ]
SpendPKHash ts p -> [ opPushData $ encodeSig ts
, opPushData $ encode p
]
SpendMulSig ts -> OP_0 : map (opPushData . encodeSig) ts
decodeSimpleInput :: Script -> Either String SimpleInput
decodeSimpleInput (Script ops) = maybeToEither errMsg $
matchPK ops <|> matchPKHash ops <|> matchMulSig ops
where
matchPK [OP_PUSHDATA bs _] = SpendPK <$> eitherToMaybe (decodeSig bs)
matchPK _ = Nothing
matchPKHash [OP_PUSHDATA sig _, OP_PUSHDATA pub _] =
liftM2 SpendPKHash (eitherToMaybe $ decodeSig sig) (decodeToMaybe pub)
matchPKHash _ = Nothing
matchMulSig (x:xs) = do
guard $ isPushOp x
SpendMulSig <$> foldrM f [] xs
matchMulSig _ = Nothing
f (OP_PUSHDATA bs _) acc =
liftM2 (:) (eitherToMaybe $ decodeSig bs) (Just acc)
f _ _ = Nothing
errMsg = "decodeInput: Could not decode script input"
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
decodeInput :: Script -> Either String ScriptInput
decodeInput s@(Script ops) = maybeToEither errMsg $
matchSimpleInput <|> matchPayScriptHash
where
matchSimpleInput = RegularInput <$> (eitherToMaybe $ decodeSimpleInput s)
matchPayScriptHash = case splitAt (length (scriptOps s) 1) ops of
(is, [OP_PUSHDATA bs _]) -> do
rdm <- eitherToMaybe $ decodeOutputBS bs
inp <- eitherToMaybe $ decodeSimpleInput $ Script is
return $ ScriptHashInput inp rdm
_ -> Nothing
errMsg = "decodeInput: Could not decode script input"
decodeInputBS :: ByteString -> Either String ScriptInput
decodeInputBS = decodeInput <=< decode