module Bitcoin.Script.Serialize where
import Data.Int
import Data.Word
import Control.Monad
import Control.Applicative
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Bitcoin.Script.Base
instance Binary Opcode where
get = getOpcode
put = putOpcode
getOpcode :: Get Opcode
getOpcode = getWord8 >>= \op -> case op of
0 -> return (OP_SMALLNUM 0)
_ | op>=1 && op<=75 -> OP_PUSHDATA op <$> getByteString (fromIntegral op)
76 -> getWord8 >>= \l -> OP_PUSHDATA op <$> getByteString (fromIntegral l)
77 -> getWord16le >>= \l -> OP_PUSHDATA op <$> getByteString (fromIntegral l)
78 -> getWord32le >>= \l -> OP_PUSHDATA op <$> getByteString (fromIntegral l)
79 -> return (OP_1NEGATE)
81 -> return (OP_SMALLNUM 1)
_ | op>=82 && op<=96 -> return (OP_SMALLNUM (fromIntegral op80))
97 -> return (OP_NOP op)
99 -> return OP_IF
100 -> return OP_NOTIF
103 -> return OP_ELSE
104 -> return OP_ENDIF
105 -> return OP_VERIFY
106 -> return OP_RETURN
107 -> return OP_TOALTSTACK
108 -> return OP_FROMALTSTACK
115 -> return OP_IFDUP
116 -> return OP_DEPTH
117 -> return OP_DROP
118 -> return OP_DUP
119 -> return OP_NIP
120 -> return OP_OVER
121 -> return OP_PICK
122 -> return OP_ROLL
123 -> return OP_ROT
124 -> return OP_SWAP
125 -> return OP_TUCK
109 -> return OP_2DROP
110 -> return OP_2DUP
111 -> return OP_3DUP
112 -> return OP_2OVER
113 -> return OP_2ROT
114 -> return OP_2SWAP
126 -> return OP_CAT
127 -> return OP_SUBSTR
128 -> return OP_LEFT
129 -> return OP_RIGHT
130 -> return OP_SIZE
131 -> return OP_INVERT
132 -> return OP_AND
133 -> return OP_OR
134 -> return OP_XOR
135 -> return OP_EQUAL
136 -> return OP_EQUALVERIFY
139 -> return OP_1ADD
140 -> return OP_1SUB
141 -> return OP_2MUL
142 -> return OP_2DIV
143 -> return OP_NEGATE
144 -> return OP_ABS
145 -> return OP_NOT
146 -> return OP_0NOTEQUAL
147 -> return OP_ADD
148 -> return OP_SUB
149 -> return OP_MUL
150 -> return OP_DIV
151 -> return OP_MOD
152 -> return OP_LSHIFT
153 -> return OP_RSHIFT
154 -> return OP_BOOLAND
155 -> return OP_BOOLOR
156 -> return OP_NUMEQUAL
157 -> return OP_NUMEQUALVERIFY
158 -> return OP_NUMNOTEQUAL
159 -> return OP_LESSTHAN
160 -> return OP_GREATERTHAN
161 -> return OP_LESSTHANOREQUAL
162 -> return OP_GREATERTHANOREQUAL
163 -> return OP_MIN
164 -> return OP_MAX
165 -> return OP_WITHIN
166 -> return OP_RIPEMD160
167 -> return OP_SHA1
168 -> return OP_SHA256
169 -> return OP_HASH160
170 -> return OP_HASH256
171 -> return OP_CODESEPARATOR
172 -> return OP_CHECKSIG
173 -> return OP_CHECKSIGVERIFY
174 -> return OP_CHECKMULTISIG
175 -> return OP_CHECKMULTISIGVERIFY
80 -> return OP_RESERVED
98 -> return OP_VER
101 -> return OP_VERIF
102 -> return OP_VERNOTIF
137 -> return OP_RESERVED1
138 -> return OP_RESERVED2
_ | op>=167 && op<=185 -> return (OP_NOP op)
255 -> return OP_INVALIDOPCODE
_ -> return (OP_UNKNOWN op)
putOpcode :: Opcode -> Put
putOpcode op = case op of
OP_SMALLNUM n -> case n of
0 -> putWord8 0
_ | n>=1 && n<=16 -> putWord8 (80 + fromIntegral n)
_ -> fail ("putOpcode: OP_SMALLNUM can handle integers between 0 and 16")
OP_1NEGATE -> putWord8 79
OP_PUSHDATA w8 bs -> if (is_valid_pushdata w8 bs)
then let l = B.length bs in case w8 of
0 -> putWord8 w8
76 -> putWord8 w8 >> putWord8 (fromIntegral l) >> putByteString bs
77 -> putWord8 w8 >> putWord16le (fromIntegral l) >> putByteString bs
78 -> putWord8 w8 >> putWord32le (fromIntegral l) >> putByteString bs
_ -> putWord8 w8 >> putByteString bs
else fail "putOpcode: invalid OP_PUSHDATA"
OP_NOP w8 -> if is_nop w8 then putWord8 w8 else fail "putOpcode/OP_NOP: invalid NOP opcode"
OP_IF -> putWord8 99
OP_NOTIF -> putWord8 100
OP_ELSE -> putWord8 103
OP_ENDIF -> putWord8 104
OP_VERIFY -> putWord8 105
OP_RETURN -> putWord8 106
OP_TOALTSTACK -> putWord8 107
OP_FROMALTSTACK -> putWord8 108
OP_IFDUP -> putWord8 115
OP_DEPTH -> putWord8 116
OP_DROP -> putWord8 117
OP_DUP -> putWord8 118
OP_NIP -> putWord8 119
OP_OVER -> putWord8 120
OP_PICK -> putWord8 121
OP_ROLL -> putWord8 122
OP_ROT -> putWord8 123
OP_SWAP -> putWord8 124
OP_TUCK -> putWord8 125
OP_2DROP -> putWord8 109
OP_2DUP -> putWord8 110
OP_3DUP -> putWord8 111
OP_2OVER -> putWord8 112
OP_2ROT -> putWord8 113
OP_2SWAP -> putWord8 114
OP_CAT -> putWord8 126
OP_SUBSTR -> putWord8 127
OP_LEFT -> putWord8 128
OP_RIGHT -> putWord8 129
OP_SIZE -> putWord8 130
OP_INVERT -> putWord8 131
OP_AND -> putWord8 132
OP_OR -> putWord8 133
OP_XOR -> putWord8 134
OP_EQUAL -> putWord8 135
OP_EQUALVERIFY -> putWord8 136
OP_1ADD -> putWord8 139
OP_1SUB -> putWord8 140
OP_2MUL -> putWord8 141
OP_2DIV -> putWord8 142
OP_NEGATE -> putWord8 143
OP_ABS -> putWord8 144
OP_NOT -> putWord8 145
OP_0NOTEQUAL -> putWord8 146
OP_ADD -> putWord8 147
OP_SUB -> putWord8 148
OP_MUL -> putWord8 149
OP_DIV -> putWord8 150
OP_MOD -> putWord8 151
OP_LSHIFT -> putWord8 152
OP_RSHIFT -> putWord8 153
OP_BOOLAND -> putWord8 154
OP_BOOLOR -> putWord8 155
OP_NUMEQUAL -> putWord8 156
OP_NUMEQUALVERIFY -> putWord8 157
OP_NUMNOTEQUAL -> putWord8 158
OP_LESSTHAN -> putWord8 159
OP_GREATERTHAN -> putWord8 160
OP_LESSTHANOREQUAL -> putWord8 161
OP_GREATERTHANOREQUAL -> putWord8 162
OP_MIN -> putWord8 163
OP_MAX -> putWord8 164
OP_WITHIN -> putWord8 165
OP_RIPEMD160 -> putWord8 166
OP_SHA1 -> putWord8 167
OP_SHA256 -> putWord8 168
OP_HASH160 -> putWord8 169
OP_HASH256 -> putWord8 170
OP_CODESEPARATOR -> putWord8 171
OP_CHECKSIG -> putWord8 172
OP_CHECKSIGVERIFY -> putWord8 173
OP_CHECKMULTISIG -> putWord8 174
OP_CHECKMULTISIGVERIFY -> putWord8 175
OP_RESERVED -> putWord8 80
OP_VER -> putWord8 98
OP_VERIF -> putWord8 101
OP_VERNOTIF -> putWord8 102
OP_RESERVED1 -> putWord8 137
OP_RESERVED2 -> putWord8 138
OP_INVALIDOPCODE -> putWord8 255
OP_UNKNOWN w8 -> putWord8 w8
_ -> fail ("putOpcode: unhandled or invalid opcode " ++ show op)
instance Binary Script where
get = Script <$> getMany
put (Script ops) = putMany ops
getMany :: Binary a => Get [a]
getMany = do
b <- isEmpty
if b
then return []
else do
x <- get
xs <- getMany
return (x:xs)
putMany :: Binary a => [a] -> Put
putMany xs = mapM_ put xs
parseScript :: RawScript -> Maybe Script
parseScript (RawScript bs) = case decodeOrFail (L.fromChunks [bs]) of
Left _ -> Nothing
Right (remaining, consumedbytes, x) -> if L.null remaining
then Just x
else Nothing
serializeScript :: Script -> RawScript
serializeScript script = RawScript $ B.concat $ L.toChunks $ encode script