Permalink
Browse files

numbers and byte streams

  • Loading branch information...
1 parent f424655 commit 668885630f05908fe69d4d0d95caf4ee0c40c923 Alexander Bernauer committed Oct 23, 2011
@@ -20,10 +20,13 @@ library
parsec >= 3.1.1,
binary >= 0.5.0.2
exposed-modules:
- Language.Bitcoin.Types
- Language.Bitcoin.Simulator
Language.Bitcoin.Assembler
+ Language.Bitcoin.Disassembler
+ Language.Bitcoin.Interpreter
Language.Bitcoin.Parser
+ Language.Bitcoin.Printer
+ Language.Bitcoin.Types
+ Language.Bitcoin.Utils
executable bitcoin-script
hs-source-dirs: src
@@ -40,5 +43,6 @@ executable Test
build-depends:
HUnit >= 1.2.2.1
other-modules:
- Language.Bitcoin.Test.Simulator
+ Language.Bitcoin.Test.Interpreter
Language.Bitcoin.Test.Parser
+ Language.Bitcoin.Test.Utils
@@ -1,7 +1,7 @@
module Language.Bitcoin.Assembler
-- export {{{1
(
- run_assembler, run_disassembler
+ run_assembler
) where
-- imports
@@ -11,9 +11,6 @@ import Language.Bitcoin.Types
run_assembler :: Code -> Binary
run_assembler = undefined
--- run_disassembler :: Binary -> Code {{{1
-run_disassembler :: Binary -> Code
-run_disassembler = undefined
--opcodes :: [(Opcode, Int)]
--opcodes = [
@@ -0,0 +1,12 @@
+module Language.Bitcoin.Disassembler
+-- export {{{1
+(
+ run_disassembler
+) where
+
+-- import {{{1
+import Language.Bitcoin.Types
+
+-- run_disassembler :: Binary -> Code {{{1
+run_disassembler :: Binary -> Code
+run_disassembler = undefined
@@ -0,0 +1,57 @@
+module Language.Bitcoin.Interpreter
+(
+ run_interpreter, run_interpreter'
+) where
+
+import Language.Bitcoin.Types
+import Language.Bitcoin.Utils (b2i, i2b)
+
+run_interpreter :: Program -> Keyring -> Either String Result
+run_interpreter program keyring =
+ case run_interpreter' (Machine program keyring [] []) of
+ result@(Result (Error _) _) -> Left $ show result
+ result -> Right result
+
+run_interpreter' :: Machine -> Result
+run_interpreter' machine@(Machine [] _ stack _) =
+ if checkSuccess stack
+ then Result Success machine
+ else Result (Failure "top stack value is not True") machine
+ where
+ checkSuccess (x:_) =
+ case b2i x of
+ Left _ -> False
+ Right value -> value == 1
+ checkSuccess _ = False
+
+--run_interpreter' (Machine ((PASTE _ data_):rest) stack altStack) =
+-- run_interpreter' (Machine rest (Raw data_ : stack) altStack)
+
+run_interpreter' machine@(Machine (op:rest) keyring stack altStack) =
+ case simpleOp op stack of
+ Left what -> Result (Error what) machine
+ Right (stack') -> run_interpreter' (Machine rest keyring stack' altStack)
+
+
+simpleOp :: Opcode -> Stack -> Either String Stack
+simpleOp OP_FALSE stack = Right $ i2b 0 : stack
+simpleOp OP_TRUE stack = Right $ i2b 1 : stack
+simpleOp OP_0 stack = Right $ i2b 0 : stack
+simpleOp OP_1 stack = Right $ i2b 1 : stack
+simpleOp OP_2 stack = Right $ i2b 2 : stack
+simpleOp OP_3 stack = Right $ i2b 3 : stack
+simpleOp OP_4 stack = Right $ i2b 4 : stack
+simpleOp OP_5 stack = Right $ i2b 5 : stack
+simpleOp OP_6 stack = Right $ i2b 6 : stack
+simpleOp OP_7 stack = Right $ i2b 7 : stack
+simpleOp OP_8 stack = Right $ i2b 8 : stack
+simpleOp OP_9 stack = Right $ i2b 9 : stack
+simpleOp OP_10 stack = Right $ i2b 10 : stack
+simpleOp OP_11 stack = Right $ i2b 11 : stack
+simpleOp OP_12 stack = Right $ i2b 12 : stack
+simpleOp OP_13 stack = Right $ i2b 13 : stack
+simpleOp OP_14 stack = Right $ i2b 14 : stack
+simpleOp OP_15 stack = Right $ i2b 15 : stack
+simpleOp OP_16 stack = Right $ i2b 16 : stack
+simpleOp OP_NOP stack = Right stack
+simpleOp op _ = Left $ "sorry, opcode " ++ show op ++ " is not implemented yet"
@@ -1,7 +1,7 @@
module Language.Bitcoin.Main where
import Language.Bitcoin.Options
-import Language.Bitcoin.Simulator (run_simulator)
+import Language.Bitcoin.Interpreter (run_interpreter)
import Language.Bitcoin.Preprocessor (run_preprocessor)
--import Language.Bitcoin.Assembler (run_assembler, run_disassembler)
import Language.Bitcoin.Parser (run_parser)
@@ -21,7 +21,7 @@ runAction :: Options -> IO ()
runAction opts
| optAssembler opts = assembler opts
| optDisassembler opts = disassembler opts
- | optSimulator opts = simulator opts
+ | optSimulator opts = interpreter opts
| otherwise = error "internal error"
assembler :: Options -> IO ()
@@ -30,14 +30,13 @@ assembler = undefined
disassembler :: Options -> IO ()
disassembler = undefined
-simulator :: Options -> IO ()
-simulator opts = do
+interpreter :: Options -> IO ()
+interpreter opts = do
(hIn, name) <- fileIn $ optInput opts
code <- hGetContents hIn
result <- exitOnError $
run_parser name code
- >>= run_preprocessor
- >>= run_simulator
+ >>= (uncurry run_interpreter) . run_preprocessor
>>= return . show
hOut <- fileOut $ optOutput opts
hPutStr hOut result
@@ -2,14 +2,18 @@ module Language.Bitcoin.Parser
-- export {{{1
(
run_parser
- , run_printer
) where
-- import {{{1
import Language.Bitcoin.Types
-import Numeric (readHex)
-import Text.ParserCombinators.Parsec
+import Language.Bitcoin.Utils (b2i, bsLength)
+import Text.ParserCombinators.Parsec (Parser, parse, spaces, endBy, eof, many, (<|>), (<?>), alphaNum, char, hexDigit, newline, unexpected)
+import Text.Parsec.Prim (parserFail)
import Control.Monad (liftM, when)
+import qualified Data.ByteString.Lazy as B
+import qualified Data.Char as C
+import Data.Word (Word8)
+import Data.Int (Int32)
-- run_parser :: String -> Code -> Either String Script {{{1
run_parser :: String -> Code -> Either String Script
@@ -29,60 +33,84 @@ operation :: Parser Command
operation = do
command <- many (alphaNum <|> char '_' <?> "opcode")
case command of
- "DATA" -> spaces >> liftM DATA hex
- "KEY" -> spaces >> hex >>= (\num -> return $ KEY (fromIntegral num))
- "SIG" -> spaces >> hex >>= (\num -> return $ SIG (fromIntegral num))
- "PUSH" -> push
+ "DATA" -> spaces >> liftM DATA hexString
+ "KEY" -> keyOrSig KEY
+ "SIG" -> keyOrSig SIG
+ "OP_PUSHDATA" -> push
"OP_PUSHDATA1" -> push1
"OP_PUSHDATA2" -> push2
"OP_PUSHDATA4" -> push4
x -> opcode x
+
+keyOrSig :: (Int32 -> Command) -> Parser Command
+keyOrSig createCommand = do
+ number <- spaces >> hexString
+ case b2i number of
+ Left e -> parserFail e
+ Right value -> return $ createCommand value
+
opcode :: String -> Parser Command
opcode x = liftM CmdOpcode $ liftReadS reads x
push :: Parser Command
-push = do
- spaces
- value <- hex
- when (value < 1 || value > 0x75) $
- fail "illegal value for PUSH operation (allowed [0x01,0x75])"
- return $ CmdOpcode $ PUSH value
+push = pushN checkLength checkValue Direct
+ where
+ checkLength len = when (len /= 1) $ parserFail "OP_PUSHDATA expects a one byte size parameter"
+ checkValue value = when (value > 0x75) $ parserFail "OP_PUSHDATA only support up to 0x75 bytes of data"
push1 :: Parser Command
-push1 = pushN 0xff "OP_PUSHDATA1" "exactly one byte" OP_PUSHDATA1
+push1 = pushN checkLength checkValue OneByte
+ where
+ checkLength len = when (len /= 1) $ parserFail "OP_PUSHDATA1 expects a one byte size parameter"
+ checkValue _ = return ()
push2 :: Parser Command
-push2 = pushN 0xffff "OP_PUSHDATA2" "at most two bytes" OP_PUSHDATA2
-
+push2 = pushN checkLength checkValue TwoBytes
+ where
+ checkLength len = when (len /= 2) $ parserFail "OP_PUSHDATA2 expects a two bytes size parameter"
+ checkValue _ = return ()
+
push4 :: Parser Command
-push4 = pushN 0xffffffff "OP_PUSHDATA4" "at most four bytes" OP_PUSHDATA4
+push4 = pushN checkLength checkValue FourBytes
+ where
+ checkLength len = when (len /= 4) $ parserFail "OP_PUSHDATA4 expects a four bytes size parameter"
+ checkValue _ = return ()
-pushN :: Num a => Integer -> String -> String -> (a -> Integer -> Opcode) -> Parser Command
-pushN maxSize opcodeString errorString createOpcode = do
- size <- spaces >> hex
- when (size > maxSize) $
- fail $ "size parameter for " ++ opcodeString ++ " must be " ++ errorString
- value <- spaces >> hex
- when (value > 2 ^ (8*size)) $
- fail $ "data is more than " ++ show size ++ " byte(s)"
- return $ CmdOpcode $ createOpcode (fromIntegral size) value
+pushN :: (Int -> Parser ()) -> (Int32 -> Parser ()) -> PushDataType -> Parser Command
+pushN checkLength checkValue pushType = do
+ sizeString <- spaces >> hexString
+ checkLength $ bsLength sizeString
+ sizeValue <- liftError $ b2i sizeString
+ when (sizeValue == 0) $
+ parserFail "data of zero length is not allowed"
+ checkValue sizeValue
+ dataString <- spaces >> hexString
+ let dataLength = fromIntegral $ bsLength dataString
+ when (dataLength /= sizeValue) $
+ parserFail $ "actual length of data does not match the announced length (" ++ show dataLength ++ " vs. " ++ show sizeValue ++ ")"
+ return $ CmdOpcode $ OP_PUSHDATA pushType dataString
+
+
+hexString :: Parser B.ByteString
+hexString = liftM B.pack $ many hexByte
-hex :: Parser Integer
-hex = many alphaNum >>= liftReadS readHex
+hexByte :: Parser Word8
+hexByte = do
+ upperNibble <- hexDigit
+ lowerNibble <- hexDigit
+ return $ fromIntegral $ (C.digitToInt upperNibble) * 16 + (C.digitToInt lowerNibble)
separator :: Parser Char
separator = newline <|> char ';'
--- utils {{{1
liftReadS :: ReadS a -> String -> Parser a
liftReadS f s =
let readings = f s in
if length readings /= 1 || snd (head readings) /= ""
then unexpected s
else return $ fst $ head readings
--- run_printer :: Script -> Code {{{1
-run_printer :: Script -> Code
-run_printer = undefined
-
+liftError :: Either String a -> Parser a
+liftError (Left e) = parserFail e
+liftError (Right v) = return v
@@ -1,13 +1,52 @@
module Language.Bitcoin.Preprocessor
+-- export {{{1
(
run_preprocessor
) where
+-- import {{{1
+import Data.Int (Int32)
import Language.Bitcoin.Types
+import Language.Bitcoin.Utils (i2b)
+import qualified Data.ByteString.Lazy as B
+import qualified Data.List as List
-run_preprocessor :: Script -> Either String Program
-run_preprocessor script = Right $ foldr process [] script
+-- run_preprocessor :: Script -> (Program, Keyring) {{{1
+run_preprocessor :: Script -> (Program, Keyring)
+run_preprocessor script = foldr process ([], []) script
-process :: Command -> Program -> Program
-process (CmdOpcode op) program = op : program
-process _ _ = error "TODO"
+
+process :: Command -> (Program, Keyring) -> (Program, Keyring)
+process (CmdOpcode op) (program, keyring) = (op : program, keyring)
+process (KEY number) x = processKey keyPublic number x
+process (SIG number) x = processKey keyPrivate number x
+process (DATA data_) (program, keyring) = (push data_ : program, keyring)
+
+
+processKey :: (Keypair -> B.ByteString) -> Int32 -> (Program, Keyring) -> (Program, Keyring)
+processKey getter number (program, keyring) =
+ let (keyring', keypair) = getOrCreate keyring number in
+ (OP_PUSHDATA Direct (getter keypair) : program, keyring')
+
+
+getOrCreate :: Keyring -> Int32 -> (Keyring, Keypair)
+getOrCreate keyring number =
+ let publicKey = i2b $ fromIntegral number in
+ case List.find ((==publicKey) . keyPublic) keyring of
+ Nothing ->
+ let
+ privateKey = i2b $ fromIntegral $ -1 * number
+ keypair = Keypair publicKey privateKey
+ in
+ (keypair : keyring, keypair)
+ Just keypair -> (keyring, keypair)
+
+
+push :: B.ByteString -> Opcode
+push data_ = OP_PUSHDATA (pushType (B.length data_)) data_
+ where
+ pushType size
+ | size <= 75 = Direct
+ | size <= 0xff = OneByte
+ | size <= 0xffff = TwoBytes
+ | otherwise = FourBytes
@@ -0,0 +1,12 @@
+module Language.Bitcoin.Printer
+-- export {{{1
+(
+ run_printer
+) where
+
+-- import {{{1
+import Language.Bitcoin.Types
+
+-- run_printer :: Script -> Code {{{1
+run_printer :: Script -> Code
+run_printer = undefined
Oops, something went wrong.

0 comments on commit 6688856

Please sign in to comment.