Permalink
Browse files

various improvements

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

0 comments on commit e52a19a

Please sign in to comment.