diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,8 +1,8 @@ - -module Main (main) where +module Main + ( main + ) where import Distribution.Simple main :: IO () main = defaultMain - diff --git a/ethereum-analyzer-deps.cabal b/ethereum-analyzer-deps.cabal --- a/ethereum-analyzer-deps.cabal +++ b/ethereum-analyzer-deps.cabal @@ -1,5 +1,5 @@ name: ethereum-analyzer-deps -version: 0.0.1 +version: 1.2.0 cabal-version: >=1.10 build-type: Simple author: Jamshid @@ -15,7 +15,7 @@ type: git location: https://github.com/zchn/ethereum-analyzer branch: master - tag: v0.0.1 + tag: v1.2.0 library default-language: Haskell98 @@ -31,7 +31,6 @@ , fast-logger , global-lock , monad-logger - , nibblestring , split , text exposed-modules: Blockchain.Data.Code @@ -48,7 +47,7 @@ , Legacy.Haskoin.V0102.Network.Haskoin.Crypto.Curve , Legacy.Haskoin.V0102.Network.Haskoin.Crypto.NumberTheory , Legacy.Haskoin.V0102.Network.Haskoin.Util - ghc-options: -Wall -O2 + ghc-options: -Wall buildable: True hs-source-dirs: src diff --git a/src/Blockchain/Colors.hs b/src/Blockchain/Colors.hs --- a/src/Blockchain/Colors.hs +++ b/src/Blockchain/Colors.hs @@ -1,33 +1,55 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults #-} - -module Blockchain.Colors ( - red, green, yellow, blue, - magenta, cyan, white2, white, black, - bright, dim, underline, blink, Blockchain.Colors.reverse, hidden, - setTitle -) where +{-# OPTIONS_GHC + -fno-warn-missing-signatures -fno-warn-type-defaults #-} +module Blockchain.Colors + ( red + , green + , yellow + , blue + , magenta + , cyan + , white2 + , white + , black + , bright + , dim + , underline + , blink + , Blockchain.Colors.reverse + , hidden + , setTitle + ) where bright string = "\ESC[1m" ++ string ++ "\ESC[0m" + dim string = "\ESC[2m" ++ string ++ "\ESC[0m" + underline string = "\ESC[4m" ++ string ++ "\ESC[0m" + blink string = "\ESC[5m" ++ string ++ "\ESC[0m" + reverse string = "\ESC[7m" ++ string ++ "\ESC[0m" -hidden string = "\ESC[8m" ++ string ++ "\ESC[0m" +hidden string = "\ESC[8m" ++ string ++ "\ESC[0m" black string = "\ESC[30m" ++ string ++ "\ESC[0m" + red string = "\ESC[31m" ++ string ++ "\ESC[0m" + green string = "\ESC[32m" ++ string ++ "\ESC[0m" + yellow string = "\ESC[33m" ++ string ++ "\ESC[0m" + blue string = "\ESC[34m" ++ string ++ "\ESC[0m" + magenta string = "\ESC[35m" ++ string ++ "\ESC[0m" --AKA purple + cyan string = "\ESC[36m" ++ string ++ "\ESC[0m" --AKA aqua + white string = "\ESC[37m" ++ string ++ "\ESC[0m" -white2 string = "\ESC[38m" ++ string ++ "\ESC[0m" +white2 string = "\ESC[38m" ++ string ++ "\ESC[0m" -setTitle::String->IO() +setTitle :: String -> IO () setTitle value = do putStr $ "\ESC]0;" ++ value ++ "\007" - diff --git a/src/Blockchain/Data/Code.hs b/src/Blockchain/Data/Code.hs --- a/src/Blockchain/Data/Code.hs +++ b/src/Blockchain/Data/Code.hs @@ -7,14 +7,16 @@ import Blockchain.Data.RLP -data Code = - Code{codeBytes::B.ByteString} - | PrecompiledCode Int deriving (Show, Eq, Read, Ord, Generic) +data Code + = Code { codeBytes :: B.ByteString} + | PrecompiledCode Int + deriving (Show, Eq, Read, Ord, Generic) instance RLPSerializable Code where - rlpEncode (Code bytes) = rlpEncode bytes - rlpEncode (PrecompiledCode _) = error "Error in call to rlpEncode for Code: Precompiled contracts can not be serialized." - rlpDecode = Code . rlpDecode - --- instance Format Code where + rlpEncode (Code bytes) = rlpEncode bytes + rlpEncode (PrecompiledCode _) = + error + "Error in call to rlpEncode for Code: Precompiled contracts can not be serialized." + rlpDecode = Code . rlpDecode + -- instance Format Code where -- format Code {codeBytes=c} = B.unpack c diff --git a/src/Blockchain/Data/RLP.hs b/src/Blockchain/Data/RLP.hs --- a/src/Blockchain/Data/RLP.hs +++ b/src/Blockchain/Data/RLP.hs @@ -4,14 +4,13 @@ -- -- The 'RLPObject' is an intermediate data container, whose serialization rules are well defined. By creating code that converts from a -- given type to an 'RLPObject', full serialization will be specified. The 'RLPSerializable' class provides functions to do this conversion. - -module Blockchain.Data.RLP ( - RLPObject(..), - formatRLPObject, - RLPSerializable(..), - rlpSplit, - rlpSerialize, - rlpDeserialize +module Blockchain.Data.RLP + ( RLPObject(..) + , formatRLPObject + , RLPSerializable(..) + , rlpSplit + , rlpSerialize + , rlpDeserialize ) where import Data.Bits @@ -30,13 +29,16 @@ -- End users will not need to directly create objects of this type (an 'RLPObject' can be created using 'rlpEncode'), -- however the designer of a new type will need to create conversion code by making their type an instance -- of the RLPSerializable class. -data RLPObject = RLPScalar Word8 | RLPString B.ByteString | RLPArray [RLPObject] deriving (Show, Eq, Ord) +data RLPObject + = RLPScalar Word8 + | RLPString B.ByteString + | RLPArray [RLPObject] + deriving (Show, Eq, Ord) -- | Converts objects to and from 'RLPObject's. -class RLPSerializable a where - rlpDecode::RLPObject->a - rlpEncode::a->RLPObject - +class RLPSerializable a where + rlpDecode :: RLPObject -> a + rlpEncode :: a -> RLPObject instance Pretty RLPObject where pretty (RLPArray objects) = @@ -44,100 +46,107 @@ pretty (RLPScalar n) = text $ "0x" ++ showHex n "" pretty (RLPString s) = text $ "0x" ++ BC.unpack (B16.encode s) -formatRLPObject::RLPObject->String +formatRLPObject :: RLPObject -> String formatRLPObject = show . pretty -splitAtWithError::Int->B.ByteString->(B.ByteString, B.ByteString) -splitAtWithError i s | i > B.length s = error "splitAtWithError called with n > length arr" +splitAtWithError :: Int -> B.ByteString -> (B.ByteString, B.ByteString) +splitAtWithError i s + | i > B.length s = error "splitAtWithError called with n > length arr" splitAtWithError i s = B.splitAt i s -getLength::Int->B.ByteString->(Integer, B.ByteString) +getLength :: Int -> B.ByteString -> (Integer, B.ByteString) getLength sizeOfLength bytes = (bytes2Integer $ B.unpack $ B.take sizeOfLength bytes, B.drop sizeOfLength bytes) -rlpSplit::B.ByteString->(RLPObject, B.ByteString) +rlpSplit :: B.ByteString -> (RLPObject, B.ByteString) rlpSplit input = case B.head input of - x | x >= 192 && x <= 192+55 -> - let (arrayData, nextRest) = - splitAtWithError (fromIntegral x - 192) $ B.tail input - in (RLPArray $ getRLPObjects arrayData, nextRest) - - x | x >= 0xF8 && x <= 0xFF -> - let - (arrLength, restAfterLen) = getLength (fromIntegral x - 0xF7) $ B.tail input - (arrayData, nextRest) = splitAtWithError (fromIntegral arrLength) restAfterLen - in (RLPArray $ getRLPObjects arrayData, nextRest) - - x | x >= 128 && x <= 128+55 -> - let - (strList, nextRest) = splitAtWithError (fromIntegral $ x - 128) $ B.tail input - in - (RLPString strList, nextRest) - - x | x >= 0xB8 && x <= 0xBF -> - let - (strLength, restAfterLen) = getLength (fromIntegral x - 0xB7) $ B.tail input - (strList, nextRest) = splitAtWithError (fromIntegral strLength) restAfterLen - in - (RLPString strList, nextRest) - - x | x < 128 -> (RLPScalar x, B.tail input) - + x + | x >= 192 && x <= 192 + 55 -> + let (arrayData, nextRest) = + splitAtWithError (fromIntegral x - 192) $ B.tail input + in (RLPArray $ getRLPObjects arrayData, nextRest) + x + | x >= 0xF8 && x <= 0xFF -> + let (arrLength, restAfterLen) = + getLength (fromIntegral x - 0xF7) $ B.tail input + (arrayData, nextRest) = splitAtWithError (fromIntegral arrLength) restAfterLen + in (RLPArray $ getRLPObjects arrayData, nextRest) + x + | x >= 128 && x <= 128 + 55 -> + let (strList, nextRest) = + splitAtWithError (fromIntegral $ x - 128) $ B.tail input + in (RLPString strList, nextRest) + x + | x >= 0xB8 && x <= 0xBF -> + let (strLength, restAfterLen) = + getLength (fromIntegral x - 0xB7) $ B.tail input + (strList, nextRest) = splitAtWithError (fromIntegral strLength) restAfterLen + in (RLPString strList, nextRest) + x + | x < 128 -> (RLPScalar x, B.tail input) x -> error ("Missing case in rlpSplit: " ++ show x) - -getRLPObjects::ByteString->[RLPObject] -getRLPObjects x | B.null x = [] -getRLPObjects theData = obj:getRLPObjects rest +getRLPObjects :: ByteString -> [RLPObject] +getRLPObjects x + | B.null x = [] +getRLPObjects theData = obj : getRLPObjects rest where (obj, rest) = rlpSplit theData -int2Bytes::Int->[Word8] -int2Bytes val | val < 0x100 = map (fromIntegral . (val `shiftR`)) [0] -int2Bytes val | val < 0x10000 = map (fromIntegral . (val `shiftR`)) [8, 0] -int2Bytes val | val < 0x1000000 = map (fromIntegral . (val `shiftR`)) [16, 8, 0] -int2Bytes val | val < 0x100000000 = map (fromIntegral . (val `shiftR`)) [24, 16..0] -int2Bytes val | val < 0x10000000000 = map (fromIntegral . (val `shiftR`)) [32, 24..0] +int2Bytes :: Int -> [Word8] +int2Bytes val + | val < 0x100 = map (fromIntegral . (val `shiftR`)) [0] +int2Bytes val + | val < 0x10000 = map (fromIntegral . (val `shiftR`)) [8, 0] +int2Bytes val + | val < 0x1000000 = map (fromIntegral . (val `shiftR`)) [16, 8, 0] +int2Bytes val + | val < 0x100000000 = map (fromIntegral . (val `shiftR`)) [24,16 .. 0] +int2Bytes val + | val < 0x10000000000 = map (fromIntegral . (val `shiftR`)) [32,24 .. 0] int2Bytes _ = error "int2Bytes not defined for val >= 0x10000000000." -rlp2Bytes::RLPObject->[Word8] +rlp2Bytes :: RLPObject -> [Word8] rlp2Bytes (RLPScalar val) = [fromIntegral val] -rlp2Bytes (RLPString s) | B.length s <= 55 = 0x80 + fromIntegral (B.length s):B.unpack s +rlp2Bytes (RLPString s) + | B.length s <= 55 = 0x80 + fromIntegral (B.length s) : B.unpack s rlp2Bytes (RLPString s) = [0xB7 + fromIntegral (length lengthAsBytes)] ++ lengthAsBytes ++ B.unpack s where lengthAsBytes = int2Bytes $ B.length s rlp2Bytes (RLPArray innerObjects) = if length innerBytes <= 55 - then 0xC0 + fromIntegral (length innerBytes):innerBytes - else let lenBytes = int2Bytes $ length innerBytes - in [0xF7 + fromIntegral (length lenBytes)] ++ lenBytes ++ innerBytes + then 0xC0 + fromIntegral (length innerBytes) : innerBytes + else let lenBytes = int2Bytes $ length innerBytes + in [0xF7 + fromIntegral (length lenBytes)] ++ lenBytes ++ innerBytes where innerBytes = concat $ rlp2Bytes <$> innerObjects --TODO- Probably should just use Data.Binary's 'Binary' class for this - -- | Converts bytes to 'RLPObject's. -- -- Full deserialization of an object can be obtained using @rlpDecode . rlpDeserialize@. -rlpDeserialize::B.ByteString->RLPObject -rlpDeserialize s = +rlpDeserialize :: B.ByteString -> RLPObject +rlpDeserialize s = case rlpSplit s of - (o, x) | B.null x -> o - _ -> error ("parse error converting ByteString to an RLP Object: " ++ show (B.unpack s)) - + (o, x) + | B.null x -> o + _ -> + error + ("parse error converting ByteString to an RLP Object: " ++ + show (B.unpack s)) -- | Converts 'RLPObject's to bytes. -- -- Full serialization of an object can be obtained using @rlpSerialize . rlpEncode@. -rlpSerialize::RLPObject->B.ByteString +rlpSerialize :: RLPObject -> B.ByteString rlpSerialize o = B.pack $ rlp2Bytes o - instance RLPSerializable Integer where rlpEncode 0 = RLPString B.empty - rlpEncode x | x < 128 = RLPScalar $ fromIntegral x + rlpEncode x + | x < 128 = RLPScalar $ fromIntegral x rlpEncode x = RLPString $ B.pack $ integer2Bytes x rlpDecode (RLPScalar x) = fromIntegral x rlpDecode (RLPString s) = byteString2Integer s @@ -145,15 +154,17 @@ instance RLPSerializable String where rlpEncode s = rlpEncode $ BC.pack s - rlpDecode (RLPString s) = BC.unpack s rlpDecode (RLPScalar n) = [w2c $ fromIntegral n] - rlpDecode (RLPArray x) = error $ "Malformed RLP in call to rlpDecode for String: RLPObject is an array: " ++ show (pretty x) + rlpDecode (RLPArray x) = + error $ + "Malformed RLP in call to rlpDecode for String: RLPObject is an array: " ++ + show (pretty x) instance RLPSerializable B.ByteString where - rlpEncode x | B.length x == 1 && B.head x < 128 = RLPScalar $ B.head x - rlpEncode s = RLPString s - - rlpDecode (RLPScalar x) = B.singleton x - rlpDecode (RLPString s) = s - rlpDecode x = error ("rlpDecode for ByteString not defined for: " ++ show x) + rlpEncode x + | B.length x == 1 && B.head x < 128 = RLPScalar $ B.head x + rlpEncode s = RLPString s + rlpDecode (RLPScalar x) = B.singleton x + rlpDecode (RLPString s) = s + rlpDecode x = error ("rlpDecode for ByteString not defined for: " ++ show x) diff --git a/src/Blockchain/Data/Util.hs b/src/Blockchain/Data/Util.hs --- a/src/Blockchain/Data/Util.hs +++ b/src/Blockchain/Data/Util.hs @@ -1,8 +1,7 @@ - -module Blockchain.Data.Util ( - byteString2Integer, - bytes2Integer, - integer2Bytes +module Blockchain.Data.Util + ( byteString2Integer + , bytes2Integer + , integer2Bytes ) where import Data.Bits @@ -12,13 +11,14 @@ --I hate this, it is an ugly way to create an Integer from its component bytes. --There should be an easier way.... --See http://stackoverflow.com/questions/25854311/efficient-packing-bytes-into-integers -byteString2Integer::B.ByteString->Integer +byteString2Integer :: B.ByteString -> Integer byteString2Integer x = bytes2Integer $ B.unpack x -bytes2Integer::[Word8]->Integer +bytes2Integer :: [Word8] -> Integer bytes2Integer [] = 0 -bytes2Integer (byte:rest) = fromIntegral byte `shift` (8 * length rest) + bytes2Integer rest +bytes2Integer (byte:rest) = + fromIntegral byte `shift` (8 * length rest) + bytes2Integer rest -integer2Bytes::Integer->[Word8] +integer2Bytes :: Integer -> [Word8] integer2Bytes 0 = [] integer2Bytes x = integer2Bytes (x `shiftR` 8) ++ [fromInteger (x .&. 255)] diff --git a/src/Blockchain/ExtWord.hs b/src/Blockchain/ExtWord.hs --- a/src/Blockchain/ExtWord.hs +++ b/src/Blockchain/ExtWord.hs @@ -1,98 +1,123 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Blockchain.ExtWord ( - Word128, - Word160, - Word256, - Word512, - word64ToBytes, - bytesToWord64, - word128ToBytes, - bytesToWord128, - word160ToBytes, - bytesToWord160, - word256ToBytes, - bytesToWord256 +module Blockchain.ExtWord + ( Word128 + , Word160 + , Word256 + , Word512 + , word64ToBytes + , bytesToWord64 + , word128ToBytes + , bytesToWord128 + , word160ToBytes + , bytesToWord160 + , word256ToBytes + , bytesToWord256 ) where import Data.Binary import Data.Bits import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Legacy.Haskoin.V0102.Network.Haskoin.Crypto.BigWord (Word128, Word160, Word256, Word512) +import Legacy.Haskoin.V0102.Network.Haskoin.Crypto.BigWord + (Word128, Word160, Word256, Word512) import Data.Ix import Blockchain.Data.RLP - instance Ix Word256 where - range (x, y) | x == y = [x] - range (x, y) = x:range (x+1, y) - index (x, y) z | z < x || z > y = error $ "Ix{Word256}.index: Index (" ++ show z ++ ") out of range ((" ++ show x ++ "," ++ show y ++ "))" - index (x, _) z = fromIntegral $ z - x - inRange (x, y) z | z >= x && z <= y = True - inRange _ _ = False + range (x, y) + | x == y = [x] + range (x, y) = x : range (x + 1, y) + index (x, y) z + | z < x || z > y = + error $ + "Ix{Word256}.index: Index (" ++ + show z ++ ") out of range ((" ++ show x ++ "," ++ show y ++ "))" + index (x, _) z = fromIntegral $ z - x + inRange (x, y) z + | z >= x && z <= y = True + inRange _ _ = False instance RLPSerializable Word512 where - rlpEncode val = RLPString $ BL.toStrict $ encode val - - rlpDecode (RLPString s) | B.length s == 64 = decode $ BL.fromStrict s - rlpDecode x = error ("Missing case in rlp2Word512: " ++ show x) + rlpEncode val = RLPString $ BL.toStrict $ encode val + rlpDecode (RLPString s) + | B.length s == 64 = decode $ BL.fromStrict s + rlpDecode x = error ("Missing case in rlp2Word512: " ++ show x) -word64ToBytes::Word64->[Word8] -word64ToBytes word = map (fromIntegral . (word `shiftR`)) [64-8, 64-16..0] +word64ToBytes :: Word64 -> [Word8] +word64ToBytes word = map (fromIntegral . (word `shiftR`)) [64 - 8,64 - 16 .. 0] -bytesToWord64::[Word8]->Word64 -bytesToWord64 bytes | length bytes == 8 = - sum $ map (\(shiftBits, byte) -> fromIntegral byte `shiftL` shiftBits) $ zip [64-8,64-16..0] bytes -bytesToWord64 _ = error "bytesToWord64 was called with the wrong number of bytes" +bytesToWord64 :: [Word8] -> Word64 +bytesToWord64 bytes + | length bytes == 8 = + sum $ + map (\(shiftBits, byte) -> fromIntegral byte `shiftL` shiftBits) $ + zip [64 - 8,64 - 16 .. 0] bytes +bytesToWord64 _ = + error "bytesToWord64 was called with the wrong number of bytes" -word128ToBytes::Word128->[Word8] -word128ToBytes word = map (fromIntegral . (word `shiftR`)) [128-8, 128-16..0] +word128ToBytes :: Word128 -> [Word8] +word128ToBytes word = + map (fromIntegral . (word `shiftR`)) [128 - 8,128 - 16 .. 0] -bytesToWord128::[Word8]->Word128 -bytesToWord128 bytes | length bytes == 16 = - sum $ map (\(shiftBits, byte) -> fromIntegral byte `shiftL` shiftBits) $ zip [128-8,128-16..0] bytes -bytesToWord128 _ = error "bytesToWord128 was called with the wrong number of bytes" +bytesToWord128 :: [Word8] -> Word128 +bytesToWord128 bytes + | length bytes == 16 = + sum $ + map (\(shiftBits, byte) -> fromIntegral byte `shiftL` shiftBits) $ + zip [128 - 8,128 - 16 .. 0] bytes +bytesToWord128 _ = + error "bytesToWord128 was called with the wrong number of bytes" -word160ToBytes::Word160->[Word8] -word160ToBytes word = map (fromIntegral . (word `shiftR`)) [160-8, 160-16..0] +word160ToBytes :: Word160 -> [Word8] +word160ToBytes word = + map (fromIntegral . (word `shiftR`)) [160 - 8,160 - 16 .. 0] -bytesToWord160::[Word8]->Word160 -bytesToWord160 bytes | length bytes == 20 = - sum $ map (\(shiftBits, byte) -> fromIntegral byte `shiftL` shiftBits) $ zip [160-8,160-16..0] bytes -bytesToWord160 _ = error "bytesToWord128 was called with the wrong number of bytes" +bytesToWord160 :: [Word8] -> Word160 +bytesToWord160 bytes + | length bytes == 20 = + sum $ + map (\(shiftBits, byte) -> fromIntegral byte `shiftL` shiftBits) $ + zip [160 - 8,160 - 16 .. 0] bytes +bytesToWord160 _ = + error "bytesToWord128 was called with the wrong number of bytes" -word256ToBytes::Word256->[Word8] -word256ToBytes word = map (fromIntegral . (word `shiftR`)) [256-8, 256-16..0] +word256ToBytes :: Word256 -> [Word8] +word256ToBytes word = + map (fromIntegral . (word `shiftR`)) [256 - 8,256 - 16 .. 0] instance RLPSerializable Word128 where - rlpEncode val = RLPString $ BL.toStrict $ encode val - - rlpDecode (RLPString s) | B.null s = 0 - rlpDecode (RLPString s) | B.length s <= 16 = decode $ BL.fromStrict s - rlpDecode x = error ("Missing case in rlp2Word128: " ++ show x) - + rlpEncode val = RLPString $ BL.toStrict $ encode val + rlpDecode (RLPString s) + | B.null s = 0 + rlpDecode (RLPString s) + | B.length s <= 16 = decode $ BL.fromStrict s + rlpDecode x = error ("Missing case in rlp2Word128: " ++ show x) instance RLPSerializable Word32 where - rlpEncode val = RLPString $ BL.toStrict $ encode val - - rlpDecode (RLPString s) | B.null s = 0 - rlpDecode (RLPString s) | B.length s <= 4 = decode $ BL.fromStrict s - rlpDecode x = error ("Missing case in rlp2Word32: " ++ show x) + rlpEncode val = RLPString $ BL.toStrict $ encode val + rlpDecode (RLPString s) + | B.null s = 0 + rlpDecode (RLPString s) + | B.length s <= 4 = decode $ BL.fromStrict s + rlpDecode x = error ("Missing case in rlp2Word32: " ++ show x) instance RLPSerializable Word16 where - rlpEncode val = RLPString $ BL.toStrict $ encode val - - rlpDecode (RLPString s) | B.null s = 0 - rlpDecode (RLPString s) | B.length s <= 2 = decode $ BL.fromStrict s - rlpDecode x = error ("Missing case in rlp2Word16: " ++ show x) - - + rlpEncode val = RLPString $ BL.toStrict $ encode val + rlpDecode (RLPString s) + | B.null s = 0 + rlpDecode (RLPString s) + | B.length s <= 2 = decode $ BL.fromStrict s + rlpDecode x = error ("Missing case in rlp2Word16: " ++ show x) -bytesToWord256::[Word8]->Word256 -bytesToWord256 bytes | length bytes == 32 = - sum $ map (\(shiftBits, byte) -> fromIntegral byte `shiftL` shiftBits) $ zip [256-8,256-16..0] bytes -bytesToWord256 _ = error "bytesToWord256 was called with the wrong number of bytes" +bytesToWord256 :: [Word8] -> Word256 +bytesToWord256 bytes + | length bytes == 32 = + sum $ + map (\(shiftBits, byte) -> fromIntegral byte `shiftL` shiftBits) $ + zip [256 - 8,256 - 16 .. 0] bytes +bytesToWord256 _ = + error "bytesToWord256 was called with the wrong number of bytes" diff --git a/src/Blockchain/Format.hs b/src/Blockchain/Format.hs --- a/src/Blockchain/Format.hs +++ b/src/Blockchain/Format.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -module Blockchain.Format ( - Format(..) +module Blockchain.Format + ( Format(..) ) where import qualified Data.ByteString as B @@ -10,12 +10,11 @@ import Blockchain.ExtWord -class Format a where - format::a->String +class Format a where + format :: a -> String instance Format B.ByteString where format x = BC.unpack (B16.encode x) instance Format Word256 where format x = BC.unpack $ B16.encode $ B.pack $ word256ToBytes x - diff --git a/src/Blockchain/Output.hs b/src/Blockchain/Output.hs --- a/src/Blockchain/Output.hs +++ b/src/Blockchain/Output.hs @@ -1,4 +1,3 @@ - module Blockchain.Output where import Control.Monad.Logger @@ -6,13 +5,12 @@ import System.GlobalLock import System.Log.FastLogger -printLogMsg::Loc->LogSource->LogLevel->LogStr->IO () +printLogMsg :: Loc -> LogSource -> LogLevel -> LogStr -> IO () --printLogMsg loc logSource level msg = do printLogMsg _ _ _ msg = do lock $ putStrLn $ BC.unpack $ fromLogStr msg -printToFile::FilePath->Loc->LogSource->LogLevel->LogStr->IO () +printToFile :: FilePath -> Loc -> LogSource -> LogLevel -> LogStr -> IO () --printLogMsg loc logSource level msg = do printToFile path _ _ _ msg = do lock $ appendFile path $ BC.unpack (fromLogStr msg) ++ "\n" - diff --git a/src/Blockchain/Util.hs b/src/Blockchain/Util.hs --- a/src/Blockchain/Util.hs +++ b/src/Blockchain/Util.hs @@ -1,9 +1,7 @@ - module Blockchain.Util where import Data.Bits import qualified Data.ByteString as B -import qualified Data.NibbleString as N import Data.ByteString.Internal import Data.Char import Data.List @@ -12,77 +10,103 @@ import Blockchain.ExtWord -showHex4::Word256->String +showHex4 :: Word256 -> String showHex4 i = replicate (4 - length rawOutput) '0' ++ rawOutput - where rawOutput = showHex i "" + where + rawOutput = showHex i "" -showHexU::Integer->[Char] +showHexU :: Integer -> [Char] showHexU = map toUpper . flip showHex "" -nibbleString2ByteString::N.NibbleString->B.ByteString -nibbleString2ByteString (N.EvenNibbleString s) = s -nibbleString2ByteString (N.OddNibbleString c s) = c `B.cons` s - -byteString2NibbleString::B.ByteString->N.NibbleString -byteString2NibbleString = N.EvenNibbleString - --I hate this, it is an ugly way to create an Integer from its component bytes. --There should be an easier way.... --See http://stackoverflow.com/questions/25854311/efficient-packing-bytes-into-integers -byteString2Integer::B.ByteString->Integer +byteString2Integer :: B.ByteString -> Integer byteString2Integer x = bytes2Integer $ B.unpack x -bytes2Integer::[Word8]->Integer +bytes2Integer :: [Word8] -> Integer bytes2Integer [] = 0 -bytes2Integer (byte:rest) = fromIntegral byte `shift` (8 * length rest) + bytes2Integer rest +bytes2Integer (byte:rest) = + fromIntegral byte `shift` (8 * length rest) + bytes2Integer rest -integer2Bytes::Integer->[Word8] +integer2Bytes :: Integer -> [Word8] integer2Bytes 0 = [] integer2Bytes x = integer2Bytes (x `shiftR` 8) ++ [fromInteger (x .&. 255)] --integer2Bytes1 is integer2Bytes, but with the extra condition that the output be of length 1 or more. -integer2Bytes1::Integer->[Word8] +integer2Bytes1 :: Integer -> [Word8] integer2Bytes1 0 = [0] integer2Bytes1 x = integer2Bytes x -padZeros::Int->String->String +padZeros :: Int -> String -> String padZeros n s = replicate (n - length s) '0' ++ s -tab::String->String +tab :: String -> String tab [] = [] -tab ('\n':rest) = '\n':' ':' ':' ':' ':tab rest -tab (c:rest) = c:tab rest +tab ('\n':rest) = '\n' : ' ' : ' ' : ' ' : ' ' : tab rest +tab (c:rest) = c : tab rest -showWord8::Word8->Char -showWord8 c | c >= 32 && c < 127 = w2c c +showWord8 :: Word8 -> Char +showWord8 c + | c >= 32 && c < 127 = w2c c showWord8 _ = '?' -showMem::Int->[Word8]->String -showMem _ x | length x > 1000 = " mem size greater than 1000 bytes" -showMem _ [] = "" -showMem p (v1:v2:v3:v4:v5:v6:v7:v8:rest) = - padZeros 4 (showHex p "") ++ " " - ++ [showWord8 v1] ++ [showWord8 v2] ++ [showWord8 v3] ++ [showWord8 v4] - ++ [showWord8 v5] ++ [showWord8 v6] ++ [showWord8 v7] ++ [showWord8 v8] ++ " " - ++ padZeros 2 (showHex v1 "") ++ " " ++ padZeros 2 (showHex v2 "") ++ " " ++ padZeros 2 (showHex v3 "") ++ " " ++ padZeros 2 (showHex v4 "") ++ " " - ++ padZeros 2 (showHex v5 "") ++ " " ++ padZeros 2 (showHex v6 "") ++ " " ++ padZeros 2 (showHex v7 "") ++ " " ++ padZeros 2 (showHex v8 "") ++ "\n" - ++ showMem (p+8) rest -showMem p x = padZeros 4 (showHex p "") ++ " " ++ (showWord8 <$> x) ++ " " ++ intercalate " " (padZeros 2 <$> flip showHex "" <$> x) - +showMem :: Int -> [Word8] -> String +showMem _ x + | length x > 1000 = " mem size greater than 1000 bytes" +showMem _ [] = "" +showMem p (v1:v2:v3:v4:v5:v6:v7:v8:rest) = + padZeros 4 (showHex p "") ++ + " " ++ + [showWord8 v1] ++ + [showWord8 v2] ++ + [showWord8 v3] ++ + [showWord8 v4] ++ + [showWord8 v5] ++ + [showWord8 v6] ++ + [showWord8 v7] ++ + [showWord8 v8] ++ + " " ++ + padZeros 2 (showHex v1 "") ++ + " " ++ + padZeros 2 (showHex v2 "") ++ + " " ++ + padZeros 2 (showHex v3 "") ++ + " " ++ + padZeros 2 (showHex v4 "") ++ + " " ++ + padZeros 2 (showHex v5 "") ++ + " " ++ + padZeros 2 (showHex v6 "") ++ + " " ++ + padZeros 2 (showHex v7 "") ++ + " " ++ padZeros 2 (showHex v8 "") ++ "\n" ++ showMem (p + 8) rest +showMem p x = + padZeros 4 (showHex p "") ++ + " " ++ + (showWord8 <$> x) ++ + " " ++ intercalate " " (padZeros 2 <$> flip showHex "" <$> x) -safeTake::Word256->B.ByteString->B.ByteString -safeTake i _ | i > 0x7fffffffffffffff = error "error in call to safeTake: string too long" -safeTake i s | i > fromIntegral (B.length s) = s `B.append` B.replicate (fromIntegral i - B.length s) 0 +safeTake :: Word256 -> B.ByteString -> B.ByteString +safeTake i _ + | i > 0x7fffffffffffffff = error "error in call to safeTake: string too long" +safeTake i s + | i > fromIntegral (B.length s) = + s `B.append` B.replicate (fromIntegral i - B.length s) 0 safeTake i s = B.take (fromIntegral i) s -safeDrop::Word256->B.ByteString->B.ByteString -safeDrop i s | i > fromIntegral (B.length s) = B.empty -safeDrop i _ | i > 0x7fffffffffffffff = error "error in call to safeDrop: string too long" +safeDrop :: Word256 -> B.ByteString -> B.ByteString +safeDrop i s + | i > fromIntegral (B.length s) = B.empty +safeDrop i _ + | i > 0x7fffffffffffffff = error "error in call to safeDrop: string too long" safeDrop i s = B.drop (fromIntegral i) s - -isContiguous::(Eq a, Num a)=>[a]->Bool +isContiguous + :: (Eq a, Num a) + => [a] -> Bool isContiguous [] = True isContiguous [_] = True -isContiguous (x:y:rest) | y == x + 1 = isContiguous $ y:rest +isContiguous (x:y:rest) + | y == x + 1 = isContiguous $ y : rest isContiguous _ = False diff --git a/src/Blockchain/VM/Code.hs b/src/Blockchain/VM/Code.hs --- a/src/Blockchain/VM/Code.hs +++ b/src/Blockchain/VM/Code.hs @@ -1,6 +1,7 @@ module Blockchain.VM.Code where import qualified Data.ByteString as B + -- import Legacy.Haskoin.V0102.Network.Haskoin.Internals import Numeric import Text.PrettyPrint.ANSI.Leijen @@ -12,41 +13,49 @@ import Blockchain.Util import Blockchain.VM.Opcodes - -getOperationAt::Code->Word256->(Operation, Word256) +getOperationAt :: Code -> Word256 -> (Operation, Word256) getOperationAt (Code bytes) p = getOperationAt' bytes p -getOperationAt (PrecompiledCode _) _ = error "getOperationAt called for precompilded code" +getOperationAt (PrecompiledCode _) _ = + error "getOperationAt called for precompilded code" -getOperationAt'::B.ByteString->Word256->(Operation, Word256) +getOperationAt' :: B.ByteString -> Word256 -> (Operation, Word256) getOperationAt' rom p = opCode2Op $ safeDrop p rom -showCode::Word256->Code->String -showCode _ (Code bytes) | B.null bytes = "" -showCode _ (PrecompiledCode x) = CL.blue $ "" -showCode lineNumber c@(Code rom) = showHex lineNumber "" ++ " " ++ format (B.pack $ op2OpCode op) ++ " " ++ show (pretty op) ++ "\n" ++ showCode (lineNumber + nextP) (Code (safeDrop nextP rom)) - where - (op, nextP) = getOperationAt c 0 +showCode :: Word256 -> Code -> String +showCode _ (Code bytes) + | B.null bytes = "" +showCode _ (PrecompiledCode x) = CL.blue $ "" +showCode lineNumber c@(Code rom) = + showHex lineNumber "" ++ + " " ++ + format (B.pack $ op2OpCode op) ++ + " " ++ + show (pretty op) ++ + "\n" ++ showCode (lineNumber + nextP) (Code (safeDrop nextP rom)) + where + (op, nextP) = getOperationAt c 0 -formatCode::Code->String +formatCode :: Code -> String formatCode = showCode 0 -getValidJUMPDESTs::Code->[Word256] +getValidJUMPDESTs :: Code -> [Word256] getValidJUMPDESTs (Code bytes) = map fst $ filter ((== JUMPDEST) . snd) $ getOps bytes 0 where - getOps::B.ByteString->Word256->[(Word256, Operation)] - getOps bytes' p | p > fromIntegral (B.length bytes') = [] - getOps code p = (p, op):getOps code (p+len) + getOps :: B.ByteString -> Word256 -> [(Word256, Operation)] + getOps bytes' p + | p > fromIntegral (B.length bytes') = [] + getOps code p = (p, op) : getOps code (p + len) where (op, len) = getOperationAt' code p -getValidJUMPDESTs (PrecompiledCode _) = error "getValidJUMPDESTs called on precompiled code" - +getValidJUMPDESTs (PrecompiledCode _) = + error "getValidJUMPDESTs called on precompiled code" -codeLength::Code->Int +codeLength :: Code -> Int codeLength (Code bytes) = B.length bytes codeLength (PrecompiledCode _) = error "codeLength called on precompiled code" -compile::[Operation]->Code +compile :: [Operation] -> Code compile x = Code bytes where bytes = B.pack $ op2OpCode =<< x diff --git a/src/Blockchain/VM/Opcodes.hs b/src/Blockchain/VM/Opcodes.hs --- a/src/Blockchain/VM/Opcodes.hs +++ b/src/Blockchain/VM/Opcodes.hs @@ -12,163 +12,287 @@ import Blockchain.Util --import Debug.Trace - -data Operation = - STOP | ADD | MUL | SUB | DIV | SDIV | MOD | SMOD | ADDMOD | MULMOD | EXP | SIGNEXTEND | NEG | LT | GT | SLT | SGT | EQ | ISZERO | NOT | AND | OR | XOR | BYTE | SHA3 | - ADDRESS | BALANCE | ORIGIN | CALLER | CALLVALUE | CALLDATALOAD | CALLDATASIZE | CALLDATACOPY | CODESIZE | CODECOPY | GASPRICE | EXTCODESIZE | EXTCODECOPY | - BLOCKHASH | COINBASE | TIMESTAMP | NUMBER | DIFFICULTY | GASLIMIT | POP | MLOAD | MSTORE | MSTORE8 | SLOAD | SSTORE | - JUMP | JUMPI | PC | MSIZE | GAS | JUMPDEST | - PUSH [Word8] | - DUP1 | DUP2 | DUP3 | DUP4 | - DUP5 | DUP6 | DUP7 | DUP8 | - DUP9 | DUP10 | DUP11 | DUP12 | - DUP13 | DUP14 | DUP15 | DUP16 | - SWAP1 | SWAP2 | SWAP3 | SWAP4 | - SWAP5 | SWAP6 | SWAP7 | SWAP8 | - SWAP9 | SWAP10 | SWAP11 | SWAP12 | - SWAP13 | SWAP14 | SWAP15 | SWAP16 | - LOG0 | LOG1 | LOG2 | LOG3 | LOG4 | - CREATE | CALL | CALLCODE | RETURN | DELEGATECALL | INVALID | SUICIDE | +data Operation + = STOP + | ADD + | MUL + | SUB + | DIV + | SDIV + | MOD + | SMOD + | ADDMOD + | MULMOD + | EXP + | SIGNEXTEND + | NEG + | LT + | GT + | SLT + | SGT + | EQ + | ISZERO + | NOT + | AND + | OR + | XOR + | BYTE + | SHA3 + | ADDRESS + | BALANCE + | ORIGIN + | CALLER + | CALLVALUE + | CALLDATALOAD + | CALLDATASIZE + | CALLDATACOPY + | CODESIZE + | CODECOPY + | GASPRICE + | EXTCODESIZE + | EXTCODECOPY + | BLOCKHASH + | COINBASE + | TIMESTAMP + | NUMBER + | DIFFICULTY + | GASLIMIT + | POP + | MLOAD + | MSTORE + | MSTORE8 + | SLOAD + | SSTORE + | JUMP + | JUMPI + | PC + | MSIZE + | GAS + | JUMPDEST + | PUSH [Word8] + | DUP1 + | DUP2 + | DUP3 + | DUP4 + | DUP5 + | DUP6 + | DUP7 + | DUP8 + | DUP9 + | DUP10 + | DUP11 + | DUP12 + | DUP13 + | DUP14 + | DUP15 + | DUP16 + | SWAP1 + | SWAP2 + | SWAP3 + | SWAP4 + | SWAP5 + | SWAP6 + | SWAP7 + | SWAP8 + | SWAP9 + | SWAP10 + | SWAP11 + | SWAP12 + | SWAP13 + | SWAP14 + | SWAP15 + | SWAP16 + | LOG0 + | LOG1 + | LOG2 + | LOG3 + | LOG4 + | CREATE + | CALL + | CALLCODE + | RETURN + | DELEGATECALL + | INVALID + | SUICIDE --Pseudo Opcodes - LABEL String | PUSHLABEL String | - PUSHDIFF String String | DATA B.ByteString | - MalformedOpcode Word8 deriving (Show, Eq, Ord) + | LABEL String + | PUSHLABEL String + | PUSHDIFF String + String + | DATA B.ByteString + | MalformedOpcode Word8 + deriving (Show, Eq, Ord) instance Pretty Operation where pretty x@JUMPDEST = text $ "------" ++ show x pretty x@(PUSH vals) = text $ show x ++ " --" ++ show (bytes2Integer vals) pretty x = text $ show x -data OPData = OPData Word8 Operation Int Int String +data OPData = + OPData Word8 + Operation + Int + Int + String type EthCode = [Operation] -singleOp::Operation->([Word8]->Operation, Int) +singleOp :: Operation -> ([Word8] -> Operation, Int) singleOp o = (const o, 1) -opDatas::[OPData] +opDatas :: [OPData] opDatas = - [ - OPData 0x00 STOP 0 0 "Halts execution.", - OPData 0x01 ADD 2 1 "Addition operation.", - OPData 0x02 MUL 2 1 "Multiplication operation.", - OPData 0x03 SUB 2 1 "Subtraction operation.", - OPData 0x04 DIV 2 1 "Integer division operation.", - OPData 0x05 SDIV 2 1 "Signed integer division operation.", - OPData 0x06 MOD 2 1 "Modulo remainder operation.", - OPData 0x07 SMOD 2 1 "Signed modulo remainder operation.", - OPData 0x08 ADDMOD 2 1 "unsigned modular addition", - OPData 0x09 MULMOD 2 1 "unsigned modular multiplication", - OPData 0x0a EXP 2 1 "Exponential operation.", - OPData 0x0b SIGNEXTEND 2 1 "Extend length of two’s complement signed integer.", - - OPData 0x10 LT 2 1 "Less-than comparision.", - OPData 0x11 GT 2 1 "Greater-than comparision.", - OPData 0x12 SLT 2 1 "Signed less-than comparision.", - OPData 0x13 SGT 2 1 "Signed greater-than comparision.", - OPData 0x14 EQ 2 1 "Equality comparision.", - OPData 0x15 ISZERO 1 1 "Simple not operator.", - OPData 0x16 AND 2 1 "Bitwise AND operation.", - OPData 0x17 OR 2 1 "Bitwise OR operation.", - OPData 0x18 XOR 2 1 "Bitwise XOR operation.", - OPData 0x19 NOT 1 1 "Bitwise not operator.", - OPData 0x1a BYTE 2 1 "Retrieve single byte from word.", - - OPData 0x20 SHA3 2 1 "Compute SHA3-256 hash.", - - OPData 0x30 ADDRESS 0 1 "Get address of currently executing account.", - OPData 0x31 BALANCE 1 1 "Get balance of the given account.", - OPData 0x32 ORIGIN 0 1 "Get execution origination address.", - OPData 0x33 CALLER 0 1 "Get caller address.", - OPData 0x34 CALLVALUE 0 1 "Get deposited value by the instruction/transaction responsible for this execution.", - OPData 0x35 CALLDATALOAD 1 1 "Get input data of current environment.", - OPData 0x36 CALLDATASIZE 0 1 "Get size of input data in current environment.", - OPData 0x37 CALLDATACOPY 3 0 "Copy input data in current environment to memory.", - OPData 0x38 CODESIZE 0 1 "Get size of code running in current environment.", - OPData 0x39 CODECOPY 3 0 "Copy code running in current environment to memory.", - OPData 0x3a GASPRICE 0 1 "Get price of gas in current environment.", - OPData 0x3b EXTCODESIZE 0 1 "Get size of an account's code.", - OPData 0x3c EXTCODECOPY 0 4 "Copy an account’s code to memory", - - OPData 0x40 BLOCKHASH 0 1 "Get hash of most recent complete block.", - OPData 0x41 COINBASE 0 1 "Get the block’s coinbase address.", - OPData 0x42 TIMESTAMP 0 1 "Get the block’s timestamp.", - OPData 0x43 NUMBER 0 1 "Get the block’s number.", - OPData 0x44 DIFFICULTY 0 1 "Get the block’s difficulty.", - OPData 0x45 GASLIMIT 0 1 "Get the block’s gas limit.", - - OPData 0x50 POP 1 0 "Remove item from stack.", - OPData 0x51 MLOAD 1 1 "Load word from memory.", - OPData 0x52 MSTORE 2 0 "Save word to memory.", - OPData 0x53 MSTORE8 2 0 "Save byte to memory.", - OPData 0x54 SLOAD 1 1 "Load word from storage.", - OPData 0x55 SSTORE 2 0 "Save word to storage.", - OPData 0x56 JUMP 1 0 "Alter the program counter.", - OPData 0x57 JUMPI 2 0 "Conditionally alter the program counter.", - OPData 0x58 PC 0 1 "Get the program counter.", - OPData 0x59 MSIZE 0 1 "Get the size of active memory in bytes.", - OPData 0x5a GAS 0 1 "Get the amount of available gas.", - OPData 0x5b JUMPDEST 0 0 "set a potential jump destination", - - OPData 0x80 DUP1 1 2 "Duplicate 1st stack item.", - OPData 0x81 DUP2 2 3 "Duplicate 2nd stack item.", - OPData 0x82 DUP3 3 4 "Duplicate 3rd stack item.", - OPData 0x83 DUP4 4 5 "Duplicate 4th stack item.", - OPData 0x84 DUP5 5 6 "Duplicate 5th stack item.", - OPData 0x85 DUP6 6 7 "Duplicate 6th stack item.", - OPData 0x86 DUP7 7 8 "Duplicate 7th stack item.", - OPData 0x87 DUP8 8 9 "Duplicate 8th stack item.", - OPData 0x88 DUP9 9 10 "Duplicate 9th stack item.", - OPData 0x89 DUP10 10 11 "Duplicate 10th stack item.", - OPData 0x8a DUP11 11 12 "Duplicate 11th stack item.", - OPData 0x8b DUP12 12 13 "Duplicate 12th stack item.", - OPData 0x8c DUP13 13 14 "Duplicate 13th stack item.", - OPData 0x8d DUP14 14 15 "Duplicate 14th stack item.", - OPData 0x8e DUP15 15 16 "Duplicate 15th stack item.", - OPData 0x8f DUP16 16 17 "Duplicate 16th stack item.", - - OPData 0x90 SWAP1 2 2 "Exchange 1st and 2nd stack items.", - OPData 0x91 SWAP2 3 3 "Exchange 1st and 3nd stack items.", - OPData 0x92 SWAP3 4 4 "Exchange 1st and 4nd stack items.", - OPData 0x93 SWAP4 5 5 "Exchange 1st and 5nd stack items.", - OPData 0x94 SWAP5 6 6 "Exchange 1st and 6nd stack items.", - OPData 0x95 SWAP6 7 7 "Exchange 1st and 7nd stack items.", - OPData 0x96 SWAP7 8 8 "Exchange 1st and 8nd stack items.", - OPData 0x97 SWAP8 9 9 "Exchange 1st and 9nd stack items.", - OPData 0x98 SWAP9 10 10 "Exchange 1st and 10nd stack items.", - OPData 0x99 SWAP10 11 11 "Exchange 1st and 11nd stack items.", - OPData 0x9a SWAP11 12 12 "Exchange 1st and 12nd stack items.", - OPData 0x9b SWAP12 13 13 "Exchange 1st and 13nd stack items.", - OPData 0x9c SWAP13 14 14 "Exchange 1st and 14nd stack items.", - OPData 0x9d SWAP14 15 15 "Exchange 1st and 15nd stack items.", - OPData 0x9e SWAP15 16 16 "Exchange 1st and 16nd stack items.", - OPData 0x9f SWAP16 17 17 "Exchange 1st and 17nd stack items.", - - OPData 0xa0 LOG0 2 0 "Append log record with no topics.", - OPData 0xa1 LOG1 3 0 "Append log record with one topic.", - OPData 0xa2 LOG2 4 0 "Append log record with two topics.", - OPData 0xa3 LOG3 5 0 "Append log record with three topics.", - OPData 0xa4 LOG4 6 0 "Append log record with four topics.", - - OPData 0xf0 CREATE 3 1 "Create a new account with associated code.", - OPData 0xf1 CALL 7 1 "Message-call into an account.", - OPData 0xf2 CALLCODE 7 1 "Message-call into this account with alternate account's code.", - OPData 0xf3 RETURN 2 0 "Halt execution returning output data.", - OPData 0xf4 DELEGATECALL 7 1 "Message-call into this account with an alternative account’s code, but persisting the current values for sender and value.", - OPData 0xfe INVALID 0 0 "Designated invalid instruction.", - OPData 0xff SUICIDE 1 0 "Halt execution and register account for later deletion." + [ OPData 0x00 STOP 0 0 "Halts execution." + , OPData 0x01 ADD 2 1 "Addition operation." + , OPData 0x02 MUL 2 1 "Multiplication operation." + , OPData 0x03 SUB 2 1 "Subtraction operation." + , OPData 0x04 DIV 2 1 "Integer division operation." + , OPData 0x05 SDIV 2 1 "Signed integer division operation." + , OPData 0x06 MOD 2 1 "Modulo remainder operation." + , OPData 0x07 SMOD 2 1 "Signed modulo remainder operation." + , OPData 0x08 ADDMOD 2 1 "unsigned modular addition" + , OPData 0x09 MULMOD 2 1 "unsigned modular multiplication" + , OPData 0x0a EXP 2 1 "Exponential operation." + , OPData + 0x0b + SIGNEXTEND + 2 + 1 + "Extend length of two’s complement signed integer." + , OPData 0x10 LT 2 1 "Less-than comparision." + , OPData 0x11 GT 2 1 "Greater-than comparision." + , OPData 0x12 SLT 2 1 "Signed less-than comparision." + , OPData 0x13 SGT 2 1 "Signed greater-than comparision." + , OPData 0x14 EQ 2 1 "Equality comparision." + , OPData 0x15 ISZERO 1 1 "Simple not operator." + , OPData 0x16 AND 2 1 "Bitwise AND operation." + , OPData 0x17 OR 2 1 "Bitwise OR operation." + , OPData 0x18 XOR 2 1 "Bitwise XOR operation." + , OPData 0x19 NOT 1 1 "Bitwise not operator." + , OPData 0x1a BYTE 2 1 "Retrieve single byte from word." + , OPData 0x20 SHA3 2 1 "Compute SHA3-256 hash." + , OPData 0x30 ADDRESS 0 1 "Get address of currently executing account." + , OPData 0x31 BALANCE 1 1 "Get balance of the given account." + , OPData 0x32 ORIGIN 0 1 "Get execution origination address." + , OPData 0x33 CALLER 0 1 "Get caller address." + , OPData + 0x34 + CALLVALUE + 0 + 1 + "Get deposited value by the instruction/transaction responsible for this execution." + , OPData 0x35 CALLDATALOAD 1 1 "Get input data of current environment." + , OPData + 0x36 + CALLDATASIZE + 0 + 1 + "Get size of input data in current environment." + , OPData + 0x37 + CALLDATACOPY + 3 + 0 + "Copy input data in current environment to memory." + , OPData 0x38 CODESIZE 0 1 "Get size of code running in current environment." + , OPData + 0x39 + CODECOPY + 3 + 0 + "Copy code running in current environment to memory." + , OPData 0x3a GASPRICE 0 1 "Get price of gas in current environment." + , OPData 0x3b EXTCODESIZE 0 1 "Get size of an account's code." + , OPData 0x3c EXTCODECOPY 0 4 "Copy an account’s code to memory" + , OPData 0x40 BLOCKHASH 0 1 "Get hash of most recent complete block." + , OPData 0x41 COINBASE 0 1 "Get the block’s coinbase address." + , OPData 0x42 TIMESTAMP 0 1 "Get the block’s timestamp." + , OPData 0x43 NUMBER 0 1 "Get the block’s number." + , OPData 0x44 DIFFICULTY 0 1 "Get the block’s difficulty." + , OPData 0x45 GASLIMIT 0 1 "Get the block’s gas limit." + , OPData 0x50 POP 1 0 "Remove item from stack." + , OPData 0x51 MLOAD 1 1 "Load word from memory." + , OPData 0x52 MSTORE 2 0 "Save word to memory." + , OPData 0x53 MSTORE8 2 0 "Save byte to memory." + , OPData 0x54 SLOAD 1 1 "Load word from storage." + , OPData 0x55 SSTORE 2 0 "Save word to storage." + , OPData 0x56 JUMP 1 0 "Alter the program counter." + , OPData 0x57 JUMPI 2 0 "Conditionally alter the program counter." + , OPData 0x58 PC 0 1 "Get the program counter." + , OPData 0x59 MSIZE 0 1 "Get the size of active memory in bytes." + , OPData 0x5a GAS 0 1 "Get the amount of available gas." + , OPData 0x5b JUMPDEST 0 0 "set a potential jump destination" + , OPData 0x80 DUP1 1 2 "Duplicate 1st stack item." + , OPData 0x81 DUP2 2 3 "Duplicate 2nd stack item." + , OPData 0x82 DUP3 3 4 "Duplicate 3rd stack item." + , OPData 0x83 DUP4 4 5 "Duplicate 4th stack item." + , OPData 0x84 DUP5 5 6 "Duplicate 5th stack item." + , OPData 0x85 DUP6 6 7 "Duplicate 6th stack item." + , OPData 0x86 DUP7 7 8 "Duplicate 7th stack item." + , OPData 0x87 DUP8 8 9 "Duplicate 8th stack item." + , OPData 0x88 DUP9 9 10 "Duplicate 9th stack item." + , OPData 0x89 DUP10 10 11 "Duplicate 10th stack item." + , OPData 0x8a DUP11 11 12 "Duplicate 11th stack item." + , OPData 0x8b DUP12 12 13 "Duplicate 12th stack item." + , OPData 0x8c DUP13 13 14 "Duplicate 13th stack item." + , OPData 0x8d DUP14 14 15 "Duplicate 14th stack item." + , OPData 0x8e DUP15 15 16 "Duplicate 15th stack item." + , OPData 0x8f DUP16 16 17 "Duplicate 16th stack item." + , OPData 0x90 SWAP1 2 2 "Exchange 1st and 2nd stack items." + , OPData 0x91 SWAP2 3 3 "Exchange 1st and 3nd stack items." + , OPData 0x92 SWAP3 4 4 "Exchange 1st and 4nd stack items." + , OPData 0x93 SWAP4 5 5 "Exchange 1st and 5nd stack items." + , OPData 0x94 SWAP5 6 6 "Exchange 1st and 6nd stack items." + , OPData 0x95 SWAP6 7 7 "Exchange 1st and 7nd stack items." + , OPData 0x96 SWAP7 8 8 "Exchange 1st and 8nd stack items." + , OPData 0x97 SWAP8 9 9 "Exchange 1st and 9nd stack items." + , OPData 0x98 SWAP9 10 10 "Exchange 1st and 10nd stack items." + , OPData 0x99 SWAP10 11 11 "Exchange 1st and 11nd stack items." + , OPData 0x9a SWAP11 12 12 "Exchange 1st and 12nd stack items." + , OPData 0x9b SWAP12 13 13 "Exchange 1st and 13nd stack items." + , OPData 0x9c SWAP13 14 14 "Exchange 1st and 14nd stack items." + , OPData 0x9d SWAP14 15 15 "Exchange 1st and 15nd stack items." + , OPData 0x9e SWAP15 16 16 "Exchange 1st and 16nd stack items." + , OPData 0x9f SWAP16 17 17 "Exchange 1st and 17nd stack items." + , OPData 0xa0 LOG0 2 0 "Append log record with no topics." + , OPData 0xa1 LOG1 3 0 "Append log record with one topic." + , OPData 0xa2 LOG2 4 0 "Append log record with two topics." + , OPData 0xa3 LOG3 5 0 "Append log record with three topics." + , OPData 0xa4 LOG4 6 0 "Append log record with four topics." + , OPData 0xf0 CREATE 3 1 "Create a new account with associated code." + , OPData 0xf1 CALL 7 1 "Message-call into an account." + , OPData + 0xf2 + CALLCODE + 7 + 1 + "Message-call into this account with alternate account's code." + , OPData 0xf3 RETURN 2 0 "Halt execution returning output data." + , OPData + 0xf4 + DELEGATECALL + 7 + 1 + "Message-call into this account with an alternative account’s code, but persisting the current values for sender and value." + , OPData 0xfe INVALID 0 0 "Designated invalid instruction." + , OPData + 0xff + SUICIDE + 1 + 0 + "Halt execution and register account for later deletion." ] - -op2CodeMap::M.Map Operation Word8 -op2CodeMap=M.fromList $ (\(OPData code op _ _ _) -> (op, code)) <$> opDatas +op2CodeMap :: M.Map Operation Word8 +op2CodeMap = M.fromList $ (\(OPData code op _ _ _) -> (op, code)) <$> opDatas -code2OpMap::M.Map Word8 Operation -code2OpMap=M.fromList $ (\(OPData opcode op _ _ _) -> (opcode, op)) <$> opDatas +code2OpMap :: M.Map Word8 Operation +code2OpMap = M.fromList $ (\(OPData opcode op _ _ _) -> (opcode, op)) <$> opDatas -op2OpCode::Operation->[Word8] -op2OpCode (PUSH theList) | length theList <= 32 && not (null theList) = - 0x5F + fromIntegral (length theList):theList +op2OpCode :: Operation -> [Word8] +op2OpCode (PUSH theList) + | length theList <= 32 && not (null theList) = + 0x5F + fromIntegral (length theList) : theList op2OpCode (PUSH []) = error "PUSH needs at least one word" op2OpCode (PUSH x) = error $ "PUSH can only take up to 32 words: " ++ show x op2OpCode (DATA bytes) = B.unpack bytes @@ -178,18 +302,19 @@ Just x -> [x] Nothing -> error $ "op is missing in op2CodeMap: " ++ show op -opLen::Operation->Int +opLen :: Operation -> Int opLen (PUSH x) = 1 + length x opLen _ = 1 -opCode2Op::B.ByteString->(Operation, Word256) -opCode2Op rom | B.null rom = (STOP, 1) --according to the yellowpaper, should return STOP if outside of the code bytestring +opCode2Op :: B.ByteString -> (Operation, Word256) +opCode2Op rom + | B.null rom = (STOP, 1) --according to the yellowpaper, should return STOP if outside of the code bytestring opCode2Op rom = - let opcode = B.head rom in --head OK, null weeded out above - if opcode >= 0x60 && opcode <= 0x7f - then (PUSH $ B.unpack $ safeTake (fromIntegral $ opcode-0x5F) $ B.tail rom, fromIntegral $ opcode - 0x5E) - else --- let op = fromMaybe (error $ "code is missing in code2OpMap: 0x" ++ showHex (B.head rom) "") - let op = fromMaybe (MalformedOpcode opcode) - $ M.lookup opcode code2OpMap in - (op, 1) + let opcode = B.head rom --head OK, null weeded out above + in if opcode >= 0x60 && opcode <= 0x7f + then ( PUSH $ + B.unpack $ safeTake (fromIntegral $ opcode - 0x5F) $ B.tail rom + , fromIntegral $ opcode - 0x5E) + -- let op = fromMaybe (error $ "code is missing in code2OpMap: 0x" ++ showHex (B.head rom) "") + else let op = fromMaybe (MalformedOpcode opcode) $ M.lookup opcode code2OpMap + in (op, 1) diff --git a/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/BigWord.hs b/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/BigWord.hs --- a/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/BigWord.hs +++ b/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/BigWord.hs @@ -1,65 +1,42 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE EmptyDataDecls #-} + module Legacy.Haskoin.V0102.Network.Haskoin.Crypto.BigWord -( --- Useful type aliases - TxHash + ( TxHash , BlockHash , Word512 -, Word256 -, Word160 -, Word128 -, FieldP -, FieldN + , Word256 + , Word160 + , Word128 + , FieldP + , FieldN + , BigWord(..) + , BigWordMod(..) + , inverseP + , inverseN + , quadraticResidue + , isIntegerValidKey + , encodeTxHashLE + , decodeTxHashLE + , encodeBlockHashLE + , decodeBlockHashLE + ) where +-- Useful type aliases -- Data types -, BigWord(..) -, BigWordMod(..) - -- Functions -, inverseP -, inverseN -, quadraticResidue -, isIntegerValidKey -, encodeTxHashLE -, decodeTxHashLE -, encodeBlockHashLE -, decodeBlockHashLE -) where - import Data.Bits - ( Bits - , (.&.), (.|.), xor - , complement - , shift, shiftL, shiftR - , bit, testBit, bitSize - , popCount, isSigned - ) + (Bits, (.&.), (.|.), xor, complement, shift, shiftL, shiftR, bit, + testBit, bitSize, popCount, isSigned) import Data.Binary (Binary, get, put) import Data.Binary.Get - ( getWord64be - , getWord32be - , getWord8 - , getByteString - , Get - ) + (getWord64be, getWord32be, getWord8, getByteString, Get) import Data.Binary.Put - ( putWord64be - , putWord32be - , putWord8 - , putByteString - ) + (putWord64be, putWord32be, putWord8, putByteString) import Data.Aeson - ( Value (String) - , FromJSON - , ToJSON - , parseJSON - , toJSON - , withText - ) + (Value(String), FromJSON, ToJSON, parseJSON, toJSON, withText) import Control.DeepSeq (NFData, rnf) import Control.Monad (unless, guard) -import Control.Applicative ((<$>)) import Data.Ratio (numerator, denominator) import qualified Data.ByteString as BS (head, length, reverse) import qualified Data.Text as T (pack, unpack) @@ -69,40 +46,55 @@ import Legacy.Haskoin.V0102.Network.Haskoin.Util -- | Type representing a transaction hash. -type TxHash = BigWord Mod256Tx +type TxHash = BigWord Mod256Tx + -- | Type representing a block hash. type BlockHash = BigWord Mod256Block + -- | Data type representing a 512 bit unsigned integer. -- It is implemented as an Integer modulo 2^512. type Word512 = BigWord Mod512 + -- | Data type representing a 256 bit unsigned integer. -- It is implemented as an Integer modulo 2^256. type Word256 = BigWord Mod256 + -- | Data type representing a 160 bit unsigned integer. -- It is implemented as an Integer modulo 2^160. type Word160 = BigWord Mod160 + -- | Data type representing a 128 bit unsigned integer. -- It is implemented as an Integer modulo 2^128. type Word128 = BigWord Mod128 + -- | Data type representing an Integer modulo coordinate field order P. -type FieldP = BigWord ModP +type FieldP = BigWord ModP + -- | Data type representing an Integer modulo curve order N. -type FieldN = BigWord ModN +type FieldN = BigWord ModN data Mod512 + data Mod256 + data Mod256Tx + data Mod256Block + data Mod160 + data Mod128 + data ModP + data ModN -newtype BigWord n = BigWord { getBigWordInteger :: Integer } - deriving (Eq, Ord, Read, Show) +newtype BigWord n = BigWord + { getBigWordInteger :: Integer + } deriving (Eq, Ord, Read, Show) instance NFData (BigWord n) where - rnf (BigWord n) = rnf n + rnf (BigWord n) = rnf n inverseP :: FieldP -> FieldP inverseP (BigWord i) = fromInteger $ mulInverse i curveP @@ -110,248 +102,251 @@ inverseN :: FieldN -> FieldN inverseN (BigWord i) = fromInteger $ mulInverse i curveN -class BigWordMod a where - rFromInteger :: Integer -> BigWord a - rBitSize :: BigWord a -> Int +class BigWordMod a where + rFromInteger :: Integer -> BigWord a + rBitSize :: BigWord a -> Int instance BigWordMod Mod512 where - rFromInteger i = BigWord $ i `mod` 2 ^ (512 :: Int) - rBitSize _ = 512 + rFromInteger i = BigWord $ i `mod` 2 ^ (512 :: Int) + rBitSize _ = 512 instance BigWordMod Mod256 where - rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int) - rBitSize _ = 256 + rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int) + rBitSize _ = 256 instance BigWordMod Mod256Tx where - rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int) - rBitSize _ = 256 + rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int) + rBitSize _ = 256 instance BigWordMod Mod256Block where - rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int) - rBitSize _ = 256 + rFromInteger i = BigWord $ i `mod` 2 ^ (256 :: Int) + rBitSize _ = 256 instance BigWordMod Mod160 where - rFromInteger i = BigWord $ i `mod` 2 ^ (160 :: Int) - rBitSize _ = 160 + rFromInteger i = BigWord $ i `mod` 2 ^ (160 :: Int) + rBitSize _ = 160 instance BigWordMod Mod128 where - rFromInteger i = BigWord $ i `mod` 2 ^ (128 :: Int) - rBitSize _ = 128 + rFromInteger i = BigWord $ i `mod` 2 ^ (128 :: Int) + rBitSize _ = 128 instance BigWordMod ModP where - rFromInteger i = BigWord $ i `mod` curveP - rBitSize _ = 256 + rFromInteger i = BigWord $ i `mod` curveP + rBitSize _ = 256 instance BigWordMod ModN where - rFromInteger i = BigWord $ i `mod` curveN - rBitSize _ = 256 + rFromInteger i = BigWord $ i `mod` curveN + rBitSize _ = 256 -instance BigWordMod n => Num (BigWord n) where - fromInteger = rFromInteger - (BigWord i1) + (BigWord i2) = fromInteger $ i1 + i2 - (BigWord i1) * (BigWord i2) = fromInteger $ i1 * i2 - negate (BigWord i) = fromInteger $ negate i - abs r = r - signum (BigWord i) = fromInteger $ signum i +instance BigWordMod n => + Num (BigWord n) where + fromInteger = rFromInteger + (BigWord i1) + (BigWord i2) = fromInteger $ i1 + i2 + (BigWord i1) * (BigWord i2) = fromInteger $ i1 * i2 + negate (BigWord i) = fromInteger $ negate i + abs r = r + signum (BigWord i) = fromInteger $ signum i -instance BigWordMod n => Bits (BigWord n) where - (BigWord i1) .&. (BigWord i2) = fromInteger $ i1 .&. i2 - (BigWord i1) .|. (BigWord i2) = fromInteger $ i1 .|. i2 - (BigWord i1) `xor` (BigWord i2) = fromInteger $ i1 `xor` i2 - complement (BigWord i) = fromInteger $ complement i - shift (BigWord i) j = fromInteger $ shift i j - bitSize = rBitSize - testBit (BigWord i) = testBit i - bit n = fromInteger $ bit n - popCount (BigWord i) = popCount i - isSigned _ = False +instance BigWordMod n => + Bits (BigWord n) where + (BigWord i1) .&. (BigWord i2) = fromInteger $ i1 .&. i2 + (BigWord i1) .|. (BigWord i2) = fromInteger $ i1 .|. i2 + (BigWord i1) `xor` (BigWord i2) = fromInteger $ i1 `xor` i2 + complement (BigWord i) = fromInteger $ complement i + shift (BigWord i) j = fromInteger $ shift i j + bitSize = rBitSize + testBit (BigWord i) = testBit i + bit n = fromInteger $ bit n + popCount (BigWord i) = popCount i + isSigned _ = False -instance BigWordMod n => Bounded (BigWord n) where - minBound = fromInteger 0 - maxBound = fromInteger (-1) +instance BigWordMod n => + Bounded (BigWord n) where + minBound = fromInteger 0 + maxBound = fromInteger (-1) -instance BigWordMod n => Real (BigWord n) where - toRational (BigWord i) = toRational i +instance BigWordMod n => + Real (BigWord n) where + toRational (BigWord i) = toRational i -instance BigWordMod n => Enum (BigWord n) where - succ r@(BigWord i) - | r == maxBound = error "BigWord: tried to take succ of maxBound" - | otherwise = fromInteger $ succ i - pred r@(BigWord i) - | r == minBound = error "BigWord: tried to take pred of minBound" - | otherwise = fromInteger $ pred i - toEnum i - | toInteger i >= toInteger (minFrom r) && - toInteger i <= toInteger (maxFrom r) = r - | otherwise = error "BigWord: toEnum is outside of bounds" - where - r = fromInteger $ toEnum i - minFrom :: BigWordMod a => BigWord a -> BigWord a - minFrom _ = minBound - maxFrom :: BigWordMod a => BigWord a -> BigWord a - maxFrom _ = maxBound - fromEnum (BigWord i) = fromEnum i +instance BigWordMod n => + Enum (BigWord n) where + succ r@(BigWord i) + | r == maxBound = error "BigWord: tried to take succ of maxBound" + | otherwise = fromInteger $ succ i + pred r@(BigWord i) + | r == minBound = error "BigWord: tried to take pred of minBound" + | otherwise = fromInteger $ pred i + toEnum i + | toInteger i >= toInteger (minFrom r) && + toInteger i <= toInteger (maxFrom r) = r + | otherwise = error "BigWord: toEnum is outside of bounds" + where + r = fromInteger $ toEnum i + minFrom + :: BigWordMod a + => BigWord a -> BigWord a + minFrom _ = minBound + maxFrom + :: BigWordMod a + => BigWord a -> BigWord a + maxFrom _ = maxBound + fromEnum (BigWord i) = fromEnum i -instance BigWordMod n => Integral (BigWord n) where - (BigWord i1) `quot` (BigWord i2) = fromInteger $ i1 `quot` i2 - (BigWord i1) `rem` (BigWord i2) = fromInteger $ i1 `rem` i2 - (BigWord i1) `div` (BigWord i2) = fromInteger $ i1 `div` i2 - (BigWord i1) `mod` (BigWord i2) = fromInteger $ i1 `mod` i2 - (BigWord i1) `quotRem` (BigWord i2) = (fromInteger a, fromInteger b) - where - (a,b) = i1 `quotRem` i2 - (BigWord i1) `divMod` (BigWord i2) = (fromInteger a, fromInteger b) - where - (a,b) = i1 `divMod` i2 - toInteger (BigWord i) = i +instance BigWordMod n => + Integral (BigWord n) where + (BigWord i1) `quot` (BigWord i2) = fromInteger $ i1 `quot` i2 + (BigWord i1) `rem` (BigWord i2) = fromInteger $ i1 `rem` i2 + (BigWord i1) `div` (BigWord i2) = fromInteger $ i1 `div` i2 + (BigWord i1) `mod` (BigWord i2) = fromInteger $ i1 `mod` i2 + (BigWord i1) `quotRem` (BigWord i2) = (fromInteger a, fromInteger b) + where + (a, b) = i1 `quotRem` i2 + (BigWord i1) `divMod` (BigWord i2) = (fromInteger a, fromInteger b) + where + (a, b) = i1 `divMod` i2 + toInteger (BigWord i) = i {- Fractional is only defined for prime orders -} - instance Fractional (BigWord ModP) where - recip = inverseP - fromRational r = fromInteger (numerator r) / fromInteger (denominator r) + recip = inverseP + fromRational r = fromInteger (numerator r) / fromInteger (denominator r) instance Fractional (BigWord ModN) where - recip = inverseN - fromRational r = fromInteger (numerator r) / fromInteger (denominator r) + recip = inverseN + fromRational r = fromInteger (numerator r) / fromInteger (denominator r) {- Binary instances for serialization / deserialization -} - instance Binary (BigWord Mod512) where - get = do - a <- fromIntegral <$> (get :: Get Word256) - b <- fromIntegral <$> (get :: Get Word256) - return $ (a `shiftL` 256) + b - - put (BigWord i) = do - put $ (fromIntegral (i `shiftR` 256) :: Word256) - put $ (fromIntegral i :: Word256) + get = do + a <- fromIntegral <$> (get :: Get Word256) + b <- fromIntegral <$> (get :: Get Word256) + return $ (a `shiftL` 256) + b + put (BigWord i) = do + put $ (fromIntegral (i `shiftR` 256) :: Word256) + put $ (fromIntegral i :: Word256) instance Binary (BigWord Mod256) where - get = do - a <- fromIntegral <$> getWord64be - b <- fromIntegral <$> getWord64be - c <- fromIntegral <$> getWord64be - d <- fromIntegral <$> getWord64be - return $ (a `shiftL` 192) + (b `shiftL` 128) + (c `shiftL` 64) + d - - put (BigWord i) = do - putWord64be $ fromIntegral (i `shiftR` 192) - putWord64be $ fromIntegral (i `shiftR` 128) - putWord64be $ fromIntegral (i `shiftR` 64) - putWord64be $ fromIntegral i + get = do + a <- fromIntegral <$> getWord64be + b <- fromIntegral <$> getWord64be + c <- fromIntegral <$> getWord64be + d <- fromIntegral <$> getWord64be + return $ (a `shiftL` 192) + (b `shiftL` 128) + (c `shiftL` 64) + d + put (BigWord i) = do + putWord64be $ fromIntegral (i `shiftR` 192) + putWord64be $ fromIntegral (i `shiftR` 128) + putWord64be $ fromIntegral (i `shiftR` 64) + putWord64be $ fromIntegral i instance Binary (BigWord Mod256Tx) where - get = do - a <- fromIntegral <$> getWord64be - b <- fromIntegral <$> getWord64be - c <- fromIntegral <$> getWord64be - d <- fromIntegral <$> getWord64be - return $ (a `shiftL` 192) + (b `shiftL` 128) + (c `shiftL` 64) + d - - put (BigWord i) = do - putWord64be $ fromIntegral (i `shiftR` 192) - putWord64be $ fromIntegral (i `shiftR` 128) - putWord64be $ fromIntegral (i `shiftR` 64) - putWord64be $ fromIntegral i + get = do + a <- fromIntegral <$> getWord64be + b <- fromIntegral <$> getWord64be + c <- fromIntegral <$> getWord64be + d <- fromIntegral <$> getWord64be + return $ (a `shiftL` 192) + (b `shiftL` 128) + (c `shiftL` 64) + d + put (BigWord i) = do + putWord64be $ fromIntegral (i `shiftR` 192) + putWord64be $ fromIntegral (i `shiftR` 128) + putWord64be $ fromIntegral (i `shiftR` 64) + putWord64be $ fromIntegral i instance Binary (BigWord Mod256Block) where - get = do - a <- fromIntegral <$> getWord64be - b <- fromIntegral <$> getWord64be - c <- fromIntegral <$> getWord64be - d <- fromIntegral <$> getWord64be - return $ (a `shiftL` 192) + (b `shiftL` 128) + (c `shiftL` 64) + d - - put (BigWord i) = do - putWord64be $ fromIntegral (i `shiftR` 192) - putWord64be $ fromIntegral (i `shiftR` 128) - putWord64be $ fromIntegral (i `shiftR` 64) - putWord64be $ fromIntegral i + get = do + a <- fromIntegral <$> getWord64be + b <- fromIntegral <$> getWord64be + c <- fromIntegral <$> getWord64be + d <- fromIntegral <$> getWord64be + return $ (a `shiftL` 192) + (b `shiftL` 128) + (c `shiftL` 64) + d + put (BigWord i) = do + putWord64be $ fromIntegral (i `shiftR` 192) + putWord64be $ fromIntegral (i `shiftR` 128) + putWord64be $ fromIntegral (i `shiftR` 64) + putWord64be $ fromIntegral i instance Binary (BigWord Mod160) where - get = do - a <- fromIntegral <$> getWord32be - b <- fromIntegral <$> getWord64be - c <- fromIntegral <$> getWord64be - return $ (a `shiftL` 128) + (b `shiftL` 64) + c - - put (BigWord i) = do - putWord32be $ fromIntegral (i `shiftR` 128) - putWord64be $ fromIntegral (i `shiftR` 64) - putWord64be $ fromIntegral i + get = do + a <- fromIntegral <$> getWord32be + b <- fromIntegral <$> getWord64be + c <- fromIntegral <$> getWord64be + return $ (a `shiftL` 128) + (b `shiftL` 64) + c + put (BigWord i) = do + putWord32be $ fromIntegral (i `shiftR` 128) + putWord64be $ fromIntegral (i `shiftR` 64) + putWord64be $ fromIntegral i instance Binary (BigWord Mod128) where - get = do - a <- fromIntegral <$> getWord64be - b <- fromIntegral <$> getWord64be - return $ (a `shiftL` 64) + b - - put (BigWord i) = do - putWord64be $ fromIntegral (i `shiftR` 64) - putWord64be $ fromIntegral i + get = do + a <- fromIntegral <$> getWord64be + b <- fromIntegral <$> getWord64be + return $ (a `shiftL` 64) + b + put (BigWord i) = do + putWord64be $ fromIntegral (i `shiftR` 64) + putWord64be $ fromIntegral i -- DER encoding of a FieldN element as Integer -- http://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf instance Binary (BigWord ModN) where - get = do - t <- getWord8 - unless (t == 0x02) (fail $ - "Bad DER identifier byte " ++ (show t) ++ ". Expecting 0x02" ) - l <- getWord8 - i <- bsToInteger <$> getByteString (fromIntegral l) - unless (isIntegerValidKey i) $ fail $ - "Invalid fieldN element: " ++ (show i) - return $ fromInteger i - - put (BigWord 0) = error "0 is an invalid FieldN element to serialize" - put (BigWord i) = do - putWord8 0x02 -- Integer type - let b = integerToBS i - l = fromIntegral $ BS.length b - if BS.head b >= 0x80 - then do - putWord8 (l + 1) - putWord8 0x00 - else do - putWord8 l - putByteString b - -instance Binary (BigWord ModP) where - - -- Section 2.3.6 http://www.secg.org/download/aid-780/sec1-v2.pdf - get = do - (BigWord i) <- get :: Get Word256 - unless (i < curveP) (fail $ "Get: Integer not in FieldP: " ++ (show i)) - return $ fromInteger i + get = do + t <- getWord8 + unless + (t == 0x02) + (fail $ "Bad DER identifier byte " ++ (show t) ++ ". Expecting 0x02") + l <- getWord8 + i <- bsToInteger <$> getByteString (fromIntegral l) + unless (isIntegerValidKey i) $ fail $ "Invalid fieldN element: " ++ (show i) + return $ fromInteger i + put (BigWord 0) = error "0 is an invalid FieldN element to serialize" + put (BigWord i) = do + putWord8 0x02 -- Integer type + let b = integerToBS i + l = fromIntegral $ BS.length b + if BS.head b >= 0x80 + then do + putWord8 (l + 1) + putWord8 0x00 + else do + putWord8 l + putByteString b - -- Section 2.3.7 http://www.secg.org/download/aid-780/sec1-v2.pdf - put r = put (fromIntegral r :: Word256) +instance Binary (BigWord ModP) + -- Section 2.3.6 http://www.secg.org/download/aid-780/sec1-v2.pdf + where + get = do + (BigWord i) <- get :: Get Word256 + unless (i < curveP) (fail $ "Get: Integer not in FieldP: " ++ (show i)) + return $ fromInteger i + -- Section 2.3.7 http://www.secg.org/download/aid-780/sec1-v2.pdf + put r = put (fromIntegral r :: Word256) instance ToJSON (BigWord Mod256Tx) where - toJSON = String . T.pack . encodeTxHashLE + toJSON = String . T.pack . encodeTxHashLE instance FromJSON (BigWord Mod256Tx) where - parseJSON = withText "TxHash not a string: " $ \a -> do - let s = T.unpack a - maybe (fail $ "Not a TxHash: " ++ s) return $ decodeTxHashLE s + parseJSON = + withText "TxHash not a string: " $ + \a -> do + let s = T.unpack a + maybe (fail $ "Not a TxHash: " ++ s) return $ decodeTxHashLE s instance ToJSON (BigWord Mod256) where - toJSON = String . T.pack . bsToHex . encode' + toJSON = String . T.pack . bsToHex . encode' instance FromJSON (BigWord Mod256) where - parseJSON = withText "Word256 not a string: " $ \a -> do - let s = T.unpack a - maybe (fail $ "Not a Word256: " ++ s) return $ - hexToBS s >>= decodeToMaybe + parseJSON = + withText "Word256 not a string: " $ + \a -> do + let s = T.unpack a + maybe (fail $ "Not a Word256: " ++ s) return $ hexToBS s >>= decodeToMaybe -- curveP = 3 (mod 4), thus Lagrange solutions apply -- http://en.wikipedia.org/wiki/Quadratic_residue quadraticResidue :: FieldP -> [FieldP] -quadraticResidue x = guard (y^(2 :: Int) == x) >> [y, (-y)] +quadraticResidue x = guard (y ^ (2 :: Int) == x) >> [y, (-y)] where q = (curveP + 1) `div` 4 - y = x^q + y = x ^ q isIntegerValidKey :: Integer -> Bool isIntegerValidKey i = i > 0 && i < curveN @@ -360,7 +355,7 @@ -- displaying transaction ids. Internally, these ids are handled as big endian -- but are transformed to little endian when displaying them. encodeTxHashLE :: TxHash -> String -encodeTxHashLE = bsToHex . BS.reverse . encode' +encodeTxHashLE = bsToHex . BS.reverse . encode' -- | Decodes a little endian 'TxHash' in HEX format. decodeTxHashLE :: String -> Maybe TxHash @@ -370,7 +365,7 @@ -- for displaying Block hash ids. Internally, these ids are handled as big -- endian but are transformed to little endian when displaying them. encodeBlockHashLE :: BlockHash -> String -encodeBlockHashLE = bsToHex . BS.reverse . encode' +encodeBlockHashLE = bsToHex . BS.reverse . encode' -- | Decodes a little endian 'BlockHash' in HEX format. decodeBlockHashLE :: String -> Maybe BlockHash diff --git a/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/Curve.hs b/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/Curve.hs --- a/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/Curve.hs +++ b/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/Curve.hs @@ -1,18 +1,15 @@ module Legacy.Haskoin.V0102.Network.Haskoin.Crypto.Curve -( - pairG -, curveP -, curveN -, integerB -, integerA -) where + ( pairG + , curveP + , curveN + , integerB + , integerA + ) where -- SECP256k1 curve parameters - pairG :: (Integer, Integer) -pairG = ( 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798 - , 0X483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8 - ) +pairG = + (0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798, 0X483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8) curveP :: Integer curveP = 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f diff --git a/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/NumberTheory.hs b/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/NumberTheory.hs --- a/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/NumberTheory.hs +++ b/src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/NumberTheory.hs @@ -1,23 +1,22 @@ module Legacy.Haskoin.V0102.Network.Haskoin.Crypto.NumberTheory -( - extendedModGCD -, mulInverse -) where + ( extendedModGCD + , mulInverse + ) where -- Extended euclidean algorithm -- Calculates the multiplicative inverse modulo p extendedModGCD :: Integer -> Integer -> Integer -> (Integer, Integer) extendedModGCD a b p - | b == 0 = (1,0) - | otherwise = (t, (s - q*t) `mod` p) + | b == 0 = (1, 0) + | otherwise = (t, (s - q * t) `mod` p) where - (q,r) = quotRem a b - (s,t) = extendedModGCD b r p + (q, r) = quotRem a b + (s, t) = extendedModGCD b r p -- Find multiplicative inverse of a : a*s = 1 (mod p) mulInverse :: Integer -> Integer -> Integer mulInverse a p - | a*s `mod` p == 1 = s - | otherwise = error "No multiplicative inverse (mod p) for a" + | a * s `mod` p == 1 = s + | otherwise = error "No multiplicative inverse (mod p) for a" where - (s,_) = extendedModGCD a p p + (s, _) = extendedModGCD a p p diff --git a/src/Legacy/Haskoin/V0102/Network/Haskoin/Util.hs b/src/Legacy/Haskoin/V0102/Network/Haskoin/Util.hs --- a/src/Legacy/Haskoin/V0102/Network/Haskoin/Util.hs +++ b/src/Legacy/Haskoin/V0102/Network/Haskoin/Util.hs @@ -3,30 +3,29 @@ Network.Haskoin modules. -} module Legacy.Haskoin.V0102.Network.Haskoin.Util -( --- -- * ByteString helpers - toStrictBS + ( toStrictBS , toLazyBS , stringToBS , bsToString -, bsToInteger -, integerToBS + , bsToInteger + , integerToBS , bsToHex , hexToBS + , encode' + , decode' + , runPut' + , runGet' + , decodeOrFail' + , runGetOrFail' + , fromDecode + , fromRunGet + , decodeToEither + , decodeToMaybe + , isolate + ) where +-- -- * ByteString helpers -- * Data.Binary helpers -, encode' -, decode' -, runPut' -, runGet' -, decodeOrFail' -, runGetOrFail' -, fromDecode -, fromRunGet -, decodeToEither -, decodeToMaybe -, isolate - -- -- * Maybe and Either monad helpers -- , isLeft -- , isRight @@ -36,64 +35,35 @@ -- , maybeToEither -- -- , liftEither -- -- , liftMaybe - -- -- * Various helpers -- , updateIndex -- , matchTemplate - -- -- Triples -- , fst3 -- , snd3 -- , lst3 - -) where - import Numeric (readHex) -import Control.Applicative ((<$>)) import Control.Monad (guard) --- -- import Control.Monad.Trans.Either (EitherT, hoistEither) +-- -- import Control.Monad.Trans.Either (EitherT, hoistEither) import Data.Word (Word8) import Data.Bits ((.|.), shiftL, shiftR) import Data.List (unfoldr) import Data.List.Split (chunksOf) import Data.Binary.Put (Put, runPut) -import Data.Binary - ( Binary - , encode - , decode - , decodeOrFail - ) +import Data.Binary (Binary, encode, decode, decodeOrFail) import Data.Binary.Get - ( Get - , runGetOrFail - , getByteString - , ByteOffset - , runGet - ) + (Get, runGetOrFail, getByteString, ByteOffset, runGet) import qualified Data.ByteString.Lazy as BL - ( ByteString - , toChunks - , fromChunks - ) + (ByteString, toChunks, fromChunks) import qualified Data.ByteString as BS - ( ByteString - , concat - , pack, unpack - , null - ) + (ByteString, concat, pack, unpack, null) import qualified Data.ByteString.Builder as BSB - ( toLazyByteString - , byteStringHex - ) -import qualified Data.ByteString.Char8 as C - ( pack - , unpack - ) + (toLazyByteString, byteStringHex) +import qualified Data.ByteString.Char8 as C (pack, unpack) -- ByteString helpers - -- | Transforms a lazy bytestring into a strict bytestring toStrictBS :: BL.ByteString -> BS.ByteString toStrictBS = BS.concat . BL.toChunks @@ -120,8 +90,8 @@ integerToBS :: Integer -> BS.ByteString integerToBS 0 = BS.pack [0] integerToBS i - | i > 0 = BS.pack $ reverse $ unfoldr f i - | otherwise = error "integerToBS not defined for negative values" + | i > 0 = BS.pack $ reverse $ unfoldr f i + | otherwise = error "integerToBS not defined for negative values" where f 0 = Nothing f x = Just $ (fromInteger x :: Word8, x `shiftR` 8) @@ -136,25 +106,30 @@ hexToBS xs = BS.pack <$> mapM hexWord (chunksOf 2 xs) where hexWord x = do - guard $ length x == 2 - let hs = readHex x - guard $ not $ null hs - let [(w, s)] = hs - guard $ null s - return w + guard $ length x == 2 + let hs = readHex x + guard $ not $ null hs + let [(w, s)] = hs + guard $ null s + return w -- Data.Binary helpers - -- | Strict version of @Data.Binary.encode@ -encode' :: Binary a => a -> BS.ByteString +encode' + :: Binary a + => a -> BS.ByteString encode' = toStrictBS . encode -- | Strict version of @Data.Binary.decode@ -decode' :: Binary a => BS.ByteString -> a +decode' + :: Binary a + => BS.ByteString -> a decode' = decode . toLazyBS -- | Strict version of @Data.Binary.runGet@ -runGet' :: Binary a => Get a -> BS.ByteString -> a +runGet' + :: Binary a + => Get a -> BS.ByteString -> a runGet' m = (runGet m) . toLazyBS -- | Strict version of @Data.Binary.runPut@ @@ -162,114 +137,116 @@ runPut' = toStrictBS . runPut -- | Strict version of @Data.Binary.decodeOrFail@ -decodeOrFail' :: - Binary a => - BS.ByteString -> - Either (BS.ByteString, ByteOffset, String) (BS.ByteString, ByteOffset, a) -decodeOrFail' bs = case decodeOrFail $ toLazyBS bs of - Left (lbs,o,err) -> Left (toStrictBS lbs,o,err) - Right (lbs,o,res) -> Right (toStrictBS lbs,o,res) +decodeOrFail' + :: Binary a + => BS.ByteString + -> Either (BS.ByteString, ByteOffset, String) (BS.ByteString, ByteOffset, a) +decodeOrFail' bs = + case decodeOrFail $ toLazyBS bs of + Left (lbs, o, err) -> Left (toStrictBS lbs, o, err) + Right (lbs, o, res) -> Right (toStrictBS lbs, o, res) -- | Strict version of @Data.Binary.runGetOrFail@ -runGetOrFail' :: - Binary a => Get a -> BS.ByteString -> - Either (BS.ByteString, ByteOffset, String) (BS.ByteString, ByteOffset, a) -runGetOrFail' m bs = case runGetOrFail m $ toLazyBS bs of - Left (lbs,o,err) -> Left (toStrictBS lbs,o,err) - Right (lbs,o,res) -> Right (toStrictBS lbs,o,res) +runGetOrFail' + :: Binary a + => Get a + -> BS.ByteString + -> Either (BS.ByteString, ByteOffset, String) (BS.ByteString, ByteOffset, a) +runGetOrFail' m bs = + case runGetOrFail m $ toLazyBS bs of + Left (lbs, o, err) -> Left (toStrictBS lbs, o, err) + Right (lbs, o, res) -> Right (toStrictBS lbs, o, res) -- | Try to decode a Data.Binary value. If decoding succeeds, apply the function -- to the result. Otherwise, return the default value. -fromDecode :: Binary a - => BS.ByteString -- ^ The bytestring to decode - -> b -- ^ Default value to return when decoding fails - -> (a -> b) -- ^ Function to apply when decoding succeeds - -> b -- ^ Final result +fromDecode + :: Binary a + => BS.ByteString -- ^ The bytestring to decode + -> b -- ^ Default value to return when decoding fails + -> (a -> b) -- ^ Function to apply when decoding succeeds + -> b -- ^ Final result fromDecode bs def f = either (const def) (f . lst) $ decodeOrFail' bs where - lst (_,_,c) = c + lst (_, _, c) = c -- | Try to run a Data.Binary.Get monad. If decoding succeeds, apply a function -- to the result. Otherwise, return the default value. -fromRunGet :: Binary a - => Get a -- ^ The Get monad to run - -> BS.ByteString -- ^ The bytestring to decode - -> b -- ^ Default value to return when decoding fails - -> (a -> b) -- ^ Function to apply when decoding succeeds - -> b -- ^ Final result +fromRunGet + :: Binary a + => Get a -- ^ The Get monad to run + -> BS.ByteString -- ^ The bytestring to decode + -> b -- ^ Default value to return when decoding fails + -> (a -> b) -- ^ Function to apply when decoding succeeds + -> b -- ^ Final result fromRunGet m bs def f = either (const def) (f . lst) $ runGetOrFail' m bs where - lst (_,_,c) = c + lst (_, _, c) = c -- | Decode a Data.Binary value into the Either monad. A Right value is returned -- with the result upon success. Otherwise a Left value with the error message -- is returned. -decodeToEither :: Binary a => BS.ByteString -> Either String a -decodeToEither bs = case decodeOrFail' bs of - Left (_,_,err) -> Left err - Right (_,_,res) -> Right res +decodeToEither + :: Binary a + => BS.ByteString -> Either String a +decodeToEither bs = + case decodeOrFail' bs of + Left (_, _, err) -> Left err + Right (_, _, res) -> Right res -- | Decode a Data.Binary value into the Maybe monad. A Just value is returned -- with the result upon success. Otherwise, Nothing is returned. -decodeToMaybe :: Binary a => BS.ByteString -> Maybe a +decodeToMaybe + :: Binary a + => BS.ByteString -> Maybe a decodeToMaybe bs = fromDecode bs Nothing Just -- | Isolate a Data.Binary.Get monad for the next @Int@ bytes. Only the next -- @Int@ bytes of the input bytestring will be available for the Get monad to -- consume. This function will fail if the Get monad fails or some of the input -- is not consumed. -isolate :: Binary a => Int -> Get a -> Get a +isolate + :: Binary a + => Int -> Get a -> Get a isolate i g = do - bs <- getByteString i - case runGetOrFail' g bs of - Left (_, _, err) -> fail err - Right (unconsumed, _, res) - | BS.null unconsumed -> return res - | otherwise -> fail "Isolate: unconsumed input" - + bs <- getByteString i + case runGetOrFail' g bs of + Left (_, _, err) -> fail err + Right (unconsumed, _, res) + | BS.null unconsumed -> return res + | otherwise -> fail "Isolate: unconsumed input" -- -- Maybe and Eithre monad helpers - -- -- | Returns True if the Either value is Right -- isRight :: Either a b -> Bool -- isRight (Right _) = True -- isRight _ = False - -- -- | Returns True if the Either value is Left -- isLeft :: Either a b -> Bool -- isLeft = not . isRight - -- -- | Extract the Right value from an Either value. Fails if the value is Left -- fromRight :: Either a b -> b -- fromRight (Right b) = b -- fromRight _ = error "Either.fromRight: Left" - -- -- | Extract the Left value from an Either value. Fails if the value is Right -- fromLeft :: Either a b -> a -- fromLeft (Left a) = a -- fromLeft _ = error "Either.fromLeft: Right" - -- -- | Transforms an Either value into a Maybe value. Right is mapped to Just -- -- and Left is mapped to Nothing. The value inside Left is lost. -- eitherToMaybe :: Either a b -> Maybe b -- eitherToMaybe (Right b) = Just b -- eitherToMaybe _ = Nothing - -- -- | Transforms a Maybe value into an Either value. Just is mapped to Right and -- -- Nothing is mapped to Left. You also pass in an error value in case Left is -- -- returned. -- maybeToEither :: b -> Maybe a -> Either b a -- maybeToEither err m = maybe (Left err) Right m - -- -- -- | Lift a Either computation into the EitherT monad -- -- liftEither :: Monad m => Either b a -> EitherT b m a -- -- liftEither = hoistEither - -- -- -- | Lift a Maybe computation into the EitherT monad -- -- liftMaybe :: Monad m => b -> Maybe a -> EitherT b m a -- -- liftMaybe err = liftEither . (maybeToEither err) - -- -- Various helpers - -- -- | Applies a function to only one element of a list defined by it's index. -- -- If the index is out of the bounds of the list, the original list is returned. -- updateIndex :: Int -- ^ The index of the element to change @@ -281,7 +258,6 @@ -- | otherwise = l ++ (f h : r) -- where -- (l,h:r) = splitAt i xs - -- -- | Use the list [b] as a template and try to match the elements of [a] -- -- against it. For each element of [b] return the (first) matching element of -- -- [a], or Nothing. Output list has same size as [b] and contains results in @@ -295,15 +271,12 @@ -- matchTemplate as (b:bs) f = case break (flip f b) as of -- (l,(r:rs)) -> (Just r) : matchTemplate (l ++ rs) bs f -- _ -> Nothing : matchTemplate as bs f - -- -- | Returns the first value of a triple. -- fst3 :: (a,b,c) -> a -- fst3 (a,_,_) = a - -- -- | Returns the second value of a triple. -- snd3 :: (a,b,c) -> b -- snd3 (_,b,_) = b - -- -- | Returns the last value of a triple. -- lst3 :: (a,b,c) -> c -- lst3 (_,_,c) = c