ethereum-analyzer-deps 0.0.1 → 1.2.0
raw patch · 16 files changed
+958/−780 lines, 16 filesdep −nibblestringsetup-changed
Dependencies removed: nibblestring
Files
- Setup.hs +3/−3
- ethereum-analyzer-deps.cabal +3/−4
- src/Blockchain/Colors.hs +34/−12
- src/Blockchain/Data/Code.hs +10/−8
- src/Blockchain/Data/RLP.hs +87/−76
- src/Blockchain/Data/Util.hs +9/−9
- src/Blockchain/ExtWord.hs +92/−67
- src/Blockchain/Format.hs +4/−5
- src/Blockchain/Output.hs +2/−4
- src/Blockchain/Util.hs +68/−44
- src/Blockchain/VM/Code.hs +28/−19
- src/Blockchain/VM/Opcodes.hs +276/−151
- src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/BigWord.hs +233/−238
- src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/Curve.hs +8/−11
- src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/NumberTheory.hs +10/−11
- src/Legacy/Haskoin/V0102/Network/Haskoin/Util.hs +91/−118
Setup.hs view
@@ -1,8 +1,8 @@--module Main (main) where+module Main+ ( main+ ) where import Distribution.Simple main :: IO () main = defaultMain-
ethereum-analyzer-deps.cabal view
@@ -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
src/Blockchain/Colors.hs view
@@ -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"-
src/Blockchain/Data/Code.hs view
@@ -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
src/Blockchain/Data/RLP.hs view
@@ -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)
src/Blockchain/Data/Util.hs view
@@ -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)]
src/Blockchain/ExtWord.hs view
@@ -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"
src/Blockchain/Format.hs view
@@ -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-
src/Blockchain/Output.hs view
@@ -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"-
src/Blockchain/Util.hs view
@@ -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
src/Blockchain/VM/Code.hs view
@@ -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 $ "<PrecompiledCode:" ++ show x ++">"-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 $ "<PrecompiledCode:" ++ show x ++ ">"+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
src/Blockchain/VM/Opcodes.hs view
@@ -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)
src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/BigWord.hs view
@@ -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
src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/Curve.hs view
@@ -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
src/Legacy/Haskoin/V0102/Network/Haskoin/Crypto/NumberTheory.hs view
@@ -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
src/Legacy/Haskoin/V0102/Network/Haskoin/Util.hs view
@@ -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