Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

various improvements

parser understands PASTE opcode
I/O from stdin/stdout possible
changed the types of the machine
  • Loading branch information...
commit e52a19a3a13bb144a61a665d436b4adc6351dee3 1 parent 44fa9e8
Alexander Bernauer authored
3  bitcoin-script-engine.cabal
@@ -17,7 +17,8 @@ library
17 17 hs-source-dirs: src
18 18 build-depends:
19 19 bytestring >= 0.9.1.10,
20   - parsec >= 3.1.1
  20 + parsec >= 3.1.1,
  21 + binary >= 0.5.0.2
21 22 exposed-modules:
22 23 Language.Bitcoin.Types
23 24 Language.Bitcoin.Simulator
78 src/Language/Bitcoin/Main.hs
... ... @@ -1,47 +1,57 @@
1 1 module Language.Bitcoin.Main where
2 2
3   -import qualified Data.ByteString.Char8 as B
4 3 import Language.Bitcoin.Options
5   -import Language.Bitcoin.Types (ResultCode(Error), Result(Result))
6 4 import Language.Bitcoin.Simulator (run_simulator)
7   -import Language.Bitcoin.Assembler (run_assembler, run_disassembler)
  5 +--import Language.Bitcoin.Assembler (run_assembler, run_disassembler)
8 6 import Language.Bitcoin.Parser (run_parser)
9 7 import System.Environment (getArgs, getProgName)
10 8 import System.Exit (exitWith, ExitCode(ExitFailure))
11   -import System.IO (stderr, hPutStrLn)
  9 +import System.IO (stderr, hPutStrLn, hGetContents, hPutStr, hFlush, Handle, stdin, stdout, openFile, IOMode(ReadMode, WriteMode))
12 10
13 11 main :: IO ()
14 12 main = do
15   - prg <- getProgName
16   - args <- getArgs
17   - opts <- exitOnError $ options prg args
18   - input <- B.readFile $ optInput opts
19   - output <- exitOnError $ runAction opts input
20   - if (optOutput opts /= optOutput defaultOptions)
21   - then B.writeFile (optOutput opts) output
22   - else putStrLn $ B.unpack output
23   -
24   -runAction :: Options -> B.ByteString -> Either String B.ByteString
25   -runAction opts input
26   - | optAssembler opts = Right $ assembler input
27   - | optDisassembler opts = Right $ disassembler input
28   - | optSimulator opts = simulator opts input
29   - | otherwise = error "internal error"
30   -
31   -assembler :: B.ByteString -> B.ByteString
32   -assembler = run_assembler
33   -
34   -disassembler :: B.ByteString -> B.ByteString
35   -disassembler = run_disassembler
36   -
37   -simulator :: Options -> B.ByteString -> Either String B.ByteString
38   -simulator opts code =
39   - case run_parser (optInput opts) code of
40   - Left parseError -> Left $ show parseError
41   - Right script ->
42   - case run_simulator script of
43   - result@(Result (Error _) _) -> Left $ show result
44   - result -> Right $ B.pack (show result)
  13 + prg <- getProgName
  14 + args <- getArgs
  15 + opts <- exitOnError $ options prg args
  16 + runAction opts
  17 +
  18 +runAction :: Options -> IO ()
  19 +runAction opts
  20 + | optAssembler opts = assembler opts
  21 + | optDisassembler opts = disassembler opts
  22 + | optSimulator opts = simulator opts
  23 + | otherwise = error "internal error"
  24 +
  25 +assembler :: Options -> IO ()
  26 +assembler = undefined
  27 +
  28 +disassembler :: Options -> IO ()
  29 +disassembler = undefined
  30 +
  31 +simulator :: Options -> IO ()
  32 +simulator opts = do
  33 + (hIn, name) <- fileIn $ optInput opts
  34 + code <- hGetContents hIn
  35 + result <- exitOnError $ do
  36 + script <- run_parser name code
  37 + result <- run_simulator script
  38 + return $ show result
  39 + hOut <- fileOut $ optOutput opts
  40 + hPutStr hOut result
  41 + hFlush hOut
  42 +
  43 +
  44 +fileIn :: String -> IO (Handle, String)
  45 +fileIn name
  46 + | name == "-" = return (stdin, "<<stdin>>")
  47 + | otherwise = do
  48 + handle <- openFile name ReadMode
  49 + return (handle, name)
  50 +
  51 +fileOut :: String -> IO Handle
  52 +fileOut name
  53 + | name == "-" = return stdout
  54 + | otherwise = openFile name WriteMode
45 55
46 56 exitOnError :: Either String a -> IO a
47 57 exitOnError (Left e) = hPutStrLn stderr e >> exitWith (ExitFailure 1)
25 src/Language/Bitcoin/Options.hs
@@ -23,6 +23,16 @@ data Options = Options {
23 23 , optHelp :: Bool
24 24 } deriving Show
25 25
  26 +defaultOptions :: Options
  27 +defaultOptions = Options {
  28 + optInput = "-"
  29 + , optOutput = "-"
  30 + , optSimulator = False
  31 + , optAssembler = False
  32 + , optDisassembler = False
  33 + , optHelp = False
  34 +}
  35 +
26 36 -- options :: String -> [String] -> Either String Options {{{1
27 37 options :: String -> [String] -> Either String Options
28 38 options prg argv =
@@ -50,23 +60,14 @@ usage prg = usageInfo ("Usage: " ++ prg ++ " OPTIONS") available_options
50 60
51 61 available_options :: [OptDescr (Options -> Options)]
52 62 available_options = [
53   - Option ['i'] ["input"] (ReqArg (\x opts -> opts {optInput = x}) "input") "input file"
54   - , Option ['o'] ["output"] (ReqArg (\x opts -> opts {optOutput = x}) "output") "output file"
  63 + Option ['i'] ["input"] (ReqArg (\x opts -> opts {optInput = x}) "input") "input file (default '-')"
  64 + , Option ['o'] ["output"] (ReqArg (\x opts -> opts {optOutput = x}) "output") "output file (default '-')"
55 65 , Option ['s'] ["assembler"] (NoArg (\opts -> opts {optSimulator = True})) "run the simulator"
56 66 , Option ['a'] ["assembler"] (NoArg (\opts -> opts {optAssembler = True})) "run the assembler"
57 67 , Option ['d'] ["disassembler"] (NoArg (\opts -> opts {optDisassembler = True})) "run the disassembler"
58 68 , Option ['h'] ["help"] (NoArg (\opts -> opts {optHelp = True})) "print help and quit"
59 69 ]
60 70
61   -defaultOptions :: Options
62   -defaultOptions = Options {
63   - optInput = ""
64   - , optOutput = ""
65   - , optSimulator = False
66   - , optAssembler = False
67   - , optDisassembler = False
68   - , optHelp = False
69   -}
70 71
71 72 b2n :: Bool -> Int
72 73 b2n True = 1
@@ -74,7 +75,5 @@ b2n False = 0
74 75
75 76 checkOptions :: Options -> Maybe String
76 77 checkOptions opts
77   - | optInput opts == optInput defaultOptions = Just "input file required"
78 78 | b2n (optSimulator opts) + b2n (optAssembler opts) + b2n (optDisassembler opts) /= 1 = Just "please choose exactly one action to run"
79   - | ((optAssembler opts || optDisassembler opts) && (optOutput opts) == (optOutput defaultOptions)) = Just "output required for assembler and dissasembler action"
80 79 | otherwise = Nothing
41 src/Language/Bitcoin/Parser.hs
... ... @@ -1,44 +1,51 @@
1 1 module Language.Bitcoin.Parser
2 2 -- export {{{1
3 3 (
4   - run_parser, run_parser',
5   - run_printer
  4 + run_parser
  5 + , run_printer
6 6 ) where
7 7
8 8 -- import {{{1
9 9 import Language.Bitcoin.Types
  10 +import Numeric (readHex)
10 11 import Text.ParserCombinators.Parsec
11   -import qualified Data.ByteString.Char8 as B
12 12
13   --- run_parser :: Code -> Script {{{1
14   -
15   -run_parser :: String -> Code -> Either ParseError Script
16   -run_parser source code = run_parser' source (B.unpack code)
17   -
18   -run_parser' :: String -> String -> Either ParseError Script
19   -run_parser' source code = parse script source code
  13 +-- run_parser :: String -> Code -> Either String Script {{{1
  14 +run_parser :: String -> Code -> Either String Script
  15 +run_parser source code =
  16 + case parse script source code of
  17 + Left parseError -> Left $ show parseError
  18 + Right x -> Right x
20 19
21 20 script :: Parser Script
22 21 script = spaces >> endBy operation separator
23 22
24 23 operation :: Parser Opcode
25   -operation = opcode -- <|> paste
  24 +operation = opcode <|> paste
26 25
27 26 opcode :: Parser Opcode
28 27 opcode = do
29 28 prefix <- string "OP_"
30 29 suffix <- many alphaNum
31   - let op = prefix ++ suffix
32   - let readings = reads op
33   - if length readings /= 1 || snd (head readings) /= ""
34   - then unexpected op <?> "valid opcode"
35   - else return $ fst $ head readings
  30 + liftReadS reads $ prefix ++ suffix
36 31
37   ---paste = string "PASTE" >> bytes >>= (\bs -> return PASTE DATA (pack bs))
  32 +paste :: Parser Opcode
  33 +paste = do
  34 + _ <- string "PASTE" >> space >> string "0x"
  35 + value <- many alphaNum
  36 + data_ <- (liftReadS readHex value) :: Parser Integer
  37 + return $ PASTE Nothing $ data_
38 38
39 39 separator :: Parser Char
40 40 separator = newline <|> char ';'
41 41
  42 +-- utils {{{1
  43 +liftReadS :: ReadS a -> String -> Parser a
  44 +liftReadS f s =
  45 + let readings = f s in
  46 + if length readings /= 1 || snd (head readings) /= ""
  47 + then unexpected s
  48 + else return $ fst $ head readings
42 49
43 50 -- run_printer :: Script -> Code {{{1
44 51 run_printer :: Script -> Code
55 src/Language/Bitcoin/Simulator.hs
@@ -4,20 +4,21 @@ module Language.Bitcoin.Simulator
4 4 ) where
5 5
6 6 import Language.Bitcoin.Types
7   -import Data.ByteString (unpack)
8 7
9   -
10   -run_simulator :: Script -> Result
11   -run_simulator script = run_simulator' (Machine script [] [])
  8 +run_simulator :: Script -> Either String Result
  9 +run_simulator script =
  10 + case run_simulator' (Machine script [] []) of
  11 + result@(Result (Error _) _) -> Left $ show result
  12 + result -> Right result
12 13
13 14 run_simulator' :: Machine -> Result
14 15 run_simulator' machine@(Machine [] stack _) =
15   - case stack of
16   - ([1]:_) -> Result Success machine
17   - _ -> Result (Failure "top stack value is not True") machine
  16 + if not (null stack) && head stack == 1
  17 + then Result Success machine
  18 + else Result (Failure "top stack value is not True") machine
18 19
19 20 run_simulator' (Machine ((PASTE _ data_):rest) stack altStack) =
20   - run_simulator' (Machine rest (unpack data_ : stack) altStack)
  21 + run_simulator' (Machine rest (data_ : stack) altStack)
21 22
22 23 run_simulator' machine@(Machine (op:rest) stack altStack) =
23 24 case simpleOp op stack of
@@ -26,24 +27,24 @@ run_simulator' machine@(Machine (op:rest) stack altStack) =
26 27
27 28
28 29 simpleOp :: Opcode -> Stack -> Either String Stack
29   -simpleOp OP_FALSE stack = Right $ [0] : stack
30   -simpleOp OP_TRUE stack = Right $ [1] : stack
31   -simpleOp OP_0 stack = Right $ [0] : stack
32   -simpleOp OP_1 stack = Right $ [1] : stack
33   -simpleOp OP_2 stack = Right $ [2] : stack
34   -simpleOp OP_3 stack = Right $ [3] : stack
35   -simpleOp OP_4 stack = Right $ [4] : stack
36   -simpleOp OP_5 stack = Right $ [5] : stack
37   -simpleOp OP_6 stack = Right $ [6] : stack
38   -simpleOp OP_7 stack = Right $ [7] : stack
39   -simpleOp OP_8 stack = Right $ [8] : stack
40   -simpleOp OP_9 stack = Right $ [9] : stack
41   -simpleOp OP_10 stack = Right $ [10] : stack
42   -simpleOp OP_11 stack = Right $ [11] : stack
43   -simpleOp OP_12 stack = Right $ [12] : stack
44   -simpleOp OP_13 stack = Right $ [13] : stack
45   -simpleOp OP_14 stack = Right $ [14] : stack
46   -simpleOp OP_15 stack = Right $ [15] : stack
47   -simpleOp OP_16 stack = Right $ [16] : stack
  30 +simpleOp OP_FALSE stack = Right $ 0 : stack
  31 +simpleOp OP_TRUE stack = Right $ 1 : stack
  32 +simpleOp OP_0 stack = Right $ 0 : stack
  33 +simpleOp OP_1 stack = Right $ 1 : stack
  34 +simpleOp OP_2 stack = Right $ 2 : stack
  35 +simpleOp OP_3 stack = Right $ 3 : stack
  36 +simpleOp OP_4 stack = Right $ 4 : stack
  37 +simpleOp OP_5 stack = Right $ 5 : stack
  38 +simpleOp OP_6 stack = Right $ 6 : stack
  39 +simpleOp OP_7 stack = Right $ 7 : stack
  40 +simpleOp OP_8 stack = Right $ 8 : stack
  41 +simpleOp OP_9 stack = Right $ 9 : stack
  42 +simpleOp OP_10 stack = Right $ 10 : stack
  43 +simpleOp OP_11 stack = Right $ 11 : stack
  44 +simpleOp OP_12 stack = Right $ 12 : stack
  45 +simpleOp OP_13 stack = Right $ 13 : stack
  46 +simpleOp OP_14 stack = Right $ 14 : stack
  47 +simpleOp OP_15 stack = Right $ 15 : stack
  48 +simpleOp OP_16 stack = Right $ 16 : stack
48 49 simpleOp OP_NOP stack = Right stack
49 50 simpleOp op _ = Left $ "sorry, opcode " ++ show op ++ " is not implemented yet"
13 src/Language/Bitcoin/Types.hs
... ... @@ -1,14 +1,13 @@
1 1 module Language.Bitcoin.Types where
2 2 -- import {{{1
3 3 import Data.Word (Word8)
4   -import qualified Data.ByteString.Char8 as B
  4 +import qualified Data.ByteString.Lazy as B
5 5
6 6 -- types {{{1
7 7 type Binary = B.ByteString
8   -type Code = B.ByteString
  8 +type Code = String
9 9
10   -type Item = [Word8]
11   -type Stack = [Item]
  10 +type Stack = [Integer]
12 11 type Script = [Opcode]
13 12
14 13 data Machine = Machine Script Stack Stack deriving Show
@@ -28,7 +27,7 @@ data Result = Result ResultCode Machine deriving Show
28 27 -- data Opcode = {{{1
29 28 data Opcode =
30 29 -- constants {{{2
31   - PASTE Data B.ByteString
  30 + PASTE (Maybe DataOpcode) Integer
32 31 | OP_0 | OP_FALSE
33 32 | OP_1NEGATE
34 33 | OP_1 | OP_TRUE
@@ -150,8 +149,8 @@ data Opcode =
150 149 | OP_NOP10
151 150 deriving (Show, Eq, Read)
152 151
153   --- data Data = {{{1
154   -data Data =
  152 +-- data DataOpcode = {{{1
  153 +data DataOpcode =
155 154 DATA Word8
156 155 | OP_PUSHDATA1 Word8
157 156 | OP_PUSHDATA2 Word8 Word8
11 test/Language/Bitcoin/Test/Parser.hs
@@ -3,9 +3,11 @@ module Language.Bitcoin.Test.Parser
3 3 tests
4 4 ) where
5 5
6   -import Language.Bitcoin.Parser (run_parser')
  6 +import Data.Binary (encode)
  7 +import Language.Bitcoin.Parser (run_parser)
7 8 import Language.Bitcoin.Types
8 9 import Test.HUnit
  10 +import qualified Data.ByteString.Lazy as B
9 11
10 12 tests = TestLabel "Parser" $ TestList $ good ++ bad
11 13
@@ -15,6 +17,7 @@ goodCases = [
15 17 , (" OP_FALSE;", [OP_FALSE])
16 18 , ("OP_FALSE;OP_TRUE;", [OP_FALSE, OP_TRUE])
17 19 , ("OP_FALSE\nOP_TRUE;", [OP_FALSE, OP_TRUE])
  20 + , ("PASTE 0x23;", [PASTE Nothing 0x23])
18 21 ]
19 22
20 23 badCases = [
@@ -25,8 +28,8 @@ good :: [Test]
25 28 good = map runTest goodCases
26 29 where
27 30 runTest (code, expected) = TestCase $
28   - case run_parser' "<<test>>" code of
29   - Left e -> assertString $ show e
  31 + case run_parser "<<test>>" code of
  32 + Left e -> assertString e
30 33 Right script -> expected @=? script
31 34
32 35
@@ -34,6 +37,6 @@ bad :: [Test]
34 37 bad = map runTest badCases
35 38 where
36 39 runTest code = TestCase $
37   - case run_parser' "<<test>>" code of
  40 + case run_parser "<<test>>" code of
38 41 Left _ -> return ()
39 42 Right _ -> assertString "Parser should have failed"
40 test/Language/Bitcoin/Test/Simulator.hs
@@ -11,26 +11,26 @@ tests = TestLabel "Simulator" $ TestList testSimpleOps
11 11
12 12 simpleOps = [
13 13 ([], [], [])
14   - , ([OP_FALSE], [], [[0]])
15   - , ([OP_TRUE], [], [[1]])
16   - , ([OP_0], [], [[0]])
17   - , ([OP_1], [], [[1]])
18   - , ([OP_2], [], [[2]])
19   - , ([OP_3], [], [[3]])
20   - , ([OP_4], [], [[4]])
21   - , ([OP_5], [], [[5]])
22   - , ([OP_6], [], [[6]])
23   - , ([OP_7], [], [[7]])
24   - , ([OP_8], [], [[8]])
25   - , ([OP_9], [], [[9]])
26   - , ([OP_10], [], [[10]])
27   - , ([OP_11], [], [[11]])
28   - , ([OP_12], [], [[12]])
29   - , ([OP_13], [], [[13]])
30   - , ([OP_14], [], [[14]])
31   - , ([OP_15], [], [[15]])
32   - , ([OP_16], [], [[16]])
33   - , ([OP_NOP], [[23]], [[23]])
  14 + , ([OP_FALSE], [], [ 0])
  15 + , ([OP_TRUE], [], [ 1])
  16 + , ([OP_0], [], [ 0])
  17 + , ([OP_1], [], [ 1])
  18 + , ([OP_2], [], [ 2])
  19 + , ([OP_3], [], [ 3])
  20 + , ([OP_4], [], [ 4])
  21 + , ([OP_5], [], [ 5])
  22 + , ([OP_6], [], [ 6])
  23 + , ([OP_7], [], [ 7])
  24 + , ([OP_8], [], [ 8])
  25 + , ([OP_9], [], [ 9])
  26 + , ([OP_10], [], [10])
  27 + , ([OP_11], [], [11])
  28 + , ([OP_12], [], [12])
  29 + , ([OP_13], [], [13])
  30 + , ([OP_14], [], [14])
  31 + , ([OP_15], [], [15])
  32 + , ([OP_16], [], [16])
  33 + , ([OP_NOP], [23], [23])
34 34 ]
35 35
36 36

0 comments on commit e52a19a

Please sign in to comment.
Something went wrong with that request. Please try again.