diff --git a/data/ERC20.json b/data/ERC20.json new file mode 100644 --- /dev/null +++ b/data/ERC20.json @@ -0,0 +1,1 @@ +[{"constant":true,"inputs":[],"name":"name","outputs":[{"name":"","type":"string"}],"payable":false,"type":"function"},{"constant":false,"inputs":[{"name":"_spender","type":"address"},{"name":"_value","type":"uint256"}],"name":"approve","outputs":[{"name":"","type":"bool"}],"payable":false,"type":"function"},{"constant":true,"inputs":[],"name":"totalSupply","outputs":[{"name":"","type":"uint256"}],"payable":false,"type":"function"},{"constant":false,"inputs":[{"name":"_from","type":"address"},{"name":"_to","type":"address"},{"name":"_value","type":"uint256"}],"name":"transferFrom","outputs":[{"name":"","type":"bool"}],"payable":false,"type":"function"},{"constant":true,"inputs":[],"name":"decimals","outputs":[{"name":"","type":"uint8"}],"payable":false,"type":"function"},{"constant":false,"inputs":[],"name":"kill","outputs":[],"payable":false,"type":"function"},{"constant":false,"inputs":[{"name":"_owner","type":"address"}],"name":"delegate","outputs":[],"payable":false,"type":"function"},{"constant":true,"inputs":[{"name":"_owner","type":"address"}],"name":"balanceOf","outputs":[{"name":"","type":"uint256"}],"payable":false,"type":"function"},{"constant":true,"inputs":[],"name":"owner","outputs":[{"name":"","type":"address"}],"payable":false,"type":"function"},{"constant":true,"inputs":[],"name":"symbol","outputs":[{"name":"","type":"string"}],"payable":false,"type":"function"},{"constant":false,"inputs":[{"name":"_to","type":"address"},{"name":"_value","type":"uint256"}],"name":"transfer","outputs":[{"name":"","type":"bool"}],"payable":false,"type":"function"},{"constant":true,"inputs":[{"name":"_owner","type":"address"},{"name":"_spender","type":"address"}],"name":"allowance","outputs":[{"name":"","type":"uint256"}],"payable":false,"type":"function"},{"constant":false,"inputs":[{"name":"_spender","type":"address"}],"name":"unapprove","outputs":[],"payable":false,"type":"function"},{"inputs":[{"name":"_name","type":"string"},{"name":"_symbol","type":"string"},{"name":"_decimals","type":"uint8"},{"name":"_count","type":"uint256"}],"type":"constructor"},{"anonymous":false,"inputs":[{"indexed":true,"name":"_from","type":"address"},{"indexed":true,"name":"_to","type":"address"},{"indexed":false,"name":"_value","type":"uint256"}],"name":"Transfer","type":"event"},{"anonymous":false,"inputs":[{"indexed":true,"name":"_owner","type":"address"},{"indexed":true,"name":"_spender","type":"address"},{"indexed":false,"name":"_value","type":"uint256"}],"name":"Approval","type":"event"}] diff --git a/data/sample.json b/data/sample.json deleted file mode 100644 --- a/data/sample.json +++ /dev/null @@ -1,1 +0,0 @@ -[{"constant":false,"inputs":[],"name":"runA1","outputs":[],"payable":false,"type":"function"},{"constant":false,"inputs":[{"name":"_s","type":"string"},{"name":"_x","type":"uint256"}],"name":"runA2","outputs":[],"payable":false,"type":"function"},{"anonymous":false,"inputs":[{"indexed":true,"name":"client","type":"address"},{"indexed":true,"name":"s","type":"uint256"}],"name":"Action1","type":"event"},{"anonymous":false,"inputs":[{"indexed":false,"name":"str","type":"string"},{"indexed":true,"name":"i","type":"uint256"}],"name":"Action2","type":"event"}] diff --git a/data/sample.sol b/data/sample.sol deleted file mode 100644 --- a/data/sample.sol +++ /dev/null @@ -1,13 +0,0 @@ -pragma solidity ^0.4.2; - -contract TestContract { - event Action1(address indexed client, uint indexed s); - event Action2(string str, uint indexed i); - - function runA1() { - Action1(msg.sender, 10); - } - function runA2(string _s, uint _x) { - Action2(_s, _x); - } -} diff --git a/src/Network/Ethereum/Web3.hs b/src/Network/Ethereum/Web3.hs --- a/src/Network/Ethereum/Web3.hs +++ b/src/Network/Ethereum/Web3.hs @@ -28,8 +28,7 @@ , Event(..) , Method(..) , nopay - -- ** ABI encoding & data types - , ABIEncoding(..) + -- ** Ethereum data types , BytesN(..) , BytesD(..) , Address @@ -37,9 +36,10 @@ , module Network.Ethereum.Unit ) where +import Network.Ethereum.Web3.Encoding.Bytes +import Network.Ethereum.Web3.Encoding.Tuple import Network.Ethereum.Web3.Contract import Network.Ethereum.Web3.Encoding import Network.Ethereum.Web3.Address import Network.Ethereum.Web3.Types -import Network.Ethereum.Web3.Bytes import Network.Ethereum.Unit diff --git a/src/Network/Ethereum/Web3/Bytes.hs b/src/Network/Ethereum/Web3/Bytes.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Bytes.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} --- | --- Module : Network.Ethereum.Web3.Bytes --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : noportable --- --- The type bytes support. --- -module Network.Ethereum.Web3.Bytes ( - BytesN(..) - , BytesD(..) - ) where - -import qualified Data.ByteString.Base16 as BS16 (decode, encode) -import qualified Data.Attoparsec.Text as P -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Encoding as T -import qualified Data.Text as T -import qualified Data.ByteArray as BA -import Network.Ethereum.Web3.EncodingUtils -import Network.Ethereum.Web3.Encoding -import GHC.TypeLits (KnownNat, Nat, natVal) -import Data.ByteArray (Bytes) -import Data.Monoid ((<>)) - -import Debug.Trace - --- | Fixed length byte array -newtype BytesN (n :: Nat) = BytesN { unBytesN :: Bytes } - deriving (Eq, Ord) - -update :: BytesN a -> Bytes -> BytesN a -update _ a = BytesN a - -instance KnownNat n => ABIEncoding (BytesN n) where - toDataBuilder (BytesN bytes) = bytesBuilder bytes - fromDataParser = do - let result = undefined :: KnownNat n => BytesN n - len = fromIntegral (natVal result) - bytesString <- T.take (len * 2) <$> P.take 64 - return (update result (bytesDecode bytesString)) - -instance KnownNat n => Show (BytesN n) where - show = show . BS16.encode . BA.convert . unBytesN - -bytesBuilder :: Bytes -> B.Builder -bytesBuilder = alignL . B.fromText . T.decodeUtf8 - . BS16.encode . BA.convert - -bytesDecode :: T.Text -> Bytes -bytesDecode = BA.convert . fst . BS16.decode . T.encodeUtf8 - --- | Dynamic length byte array -newtype BytesD = BytesD { unBytesD :: Bytes } - deriving (Eq, Ord) - -instance ABIEncoding BytesD where - toDataBuilder (BytesD bytes) = int256HexBuilder (BA.length bytes) - <> bytesBuilder bytes - fromDataParser = do - len <- int256HexParser - if (len :: Integer) > fromIntegral (maxBound :: Int) - then fail "Bytes length over bound!" - else (BytesD . bytesDecode) <$> P.take (fromIntegral len * 2) - -instance Show BytesD where - show = show . BS16.encode . BA.convert . unBytesD diff --git a/src/Network/Ethereum/Web3/Contract.hs b/src/Network/Ethereum/Web3/Contract.hs --- a/src/Network/Ethereum/Web3/Contract.hs +++ b/src/Network/Ethereum/Web3/Contract.hs @@ -102,7 +102,8 @@ call :: ABIEncoding b => Address -> CallMode -> a -> Web3 b call = _call -_sendTransaction :: (Method a, Unit b) => Address -> b -> a -> Web3 TxHash +_sendTransaction :: (Method a, Unit b) + => Address -> b -> a -> Web3 TxHash _sendTransaction to value dat = do primeAddress <- head <$> eth_accounts eth_sendTransaction (txdata primeAddress $ Just $ toData dat) @@ -112,11 +113,14 @@ -- TODO: Correct dynamic type parsing _call :: (Method a, ABIEncoding b) => Address -> CallMode -> a -> Web3 b -_call to mode dat = do res <- eth_call txdata mode - case fromData (T.drop 2 res) of - Nothing -> fail "Unable to parse result" - Just x -> return x - where txdata = Call Nothing to Nothing Nothing Nothing (Just (toData dat)) +_call to mode dat = do + res <- eth_call txdata mode + case fromData (T.drop 2 res) of + Nothing -> fail $ + "Unable to parse result on `" ++ T.unpack res ++ "`" + Just x -> return x + where + txdata = Call Nothing to Nothing Nothing Nothing (Just (toData dat)) -- | Zero value is used to send transaction without money nopay :: Wei diff --git a/src/Network/Ethereum/Web3/Encoding.hs b/src/Network/Ethereum/Web3/Encoding.hs --- a/src/Network/Ethereum/Web3/Encoding.hs +++ b/src/Network/Ethereum/Web3/Encoding.hs @@ -17,8 +17,8 @@ import qualified Data.Attoparsec.Text as P import qualified Data.Text.Lazy as LT import qualified Data.Text as T +import Network.Ethereum.Web3.Encoding.Internal import Network.Ethereum.Web3.Address (Address) -import Network.Ethereum.Web3.EncodingUtils import Data.Monoid ((<>)) import Data.Text (Text) diff --git a/src/Network/Ethereum/Web3/Encoding/Bytes.hs b/src/Network/Ethereum/Web3/Encoding/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/Web3/Encoding/Bytes.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +-- | +-- Module : Network.Ethereum.Web3.Encoding.Bytes +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- The type bytes support. +-- +module Network.Ethereum.Web3.Encoding.Bytes ( + BytesN(..) + , BytesD(..) + ) where + +import qualified Data.ByteString.Base16 as BS16 (decode, encode) +import qualified Data.Attoparsec.Text as P +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Encoding as T +import qualified Data.Text as T +import qualified Data.ByteArray as BA +import Network.Ethereum.Web3.Encoding.Internal +import Network.Ethereum.Web3.Encoding +import GHC.TypeLits (KnownNat, Nat, natVal) +import Data.ByteArray (Bytes) +import Data.Monoid ((<>)) + +import Debug.Trace + +-- | Fixed length byte array +newtype BytesN (n :: Nat) = BytesN { unBytesN :: Bytes } + deriving (Eq, Ord) + +update :: BytesN a -> Bytes -> BytesN a +update _ a = BytesN a + +instance KnownNat n => EncodingType (BytesN n) where + typeName = const "bytes[N]" + isDynamic = const False + +instance KnownNat n => ABIEncoding (BytesN n) where + toDataBuilder (BytesN bytes) = bytesBuilder bytes + fromDataParser = do + let result = undefined :: KnownNat n => BytesN n + len = fromIntegral (natVal result) + bytesString <- T.take (len * 2) <$> P.take 64 + return (update result (bytesDecode bytesString)) + +instance KnownNat n => Show (BytesN n) where + show = show . BS16.encode . BA.convert . unBytesN + +bytesBuilder :: Bytes -> B.Builder +bytesBuilder = alignL . B.fromText . T.decodeUtf8 + . BS16.encode . BA.convert + +bytesDecode :: T.Text -> Bytes +bytesDecode = BA.convert . fst . BS16.decode . T.encodeUtf8 + +-- | Dynamic length byte array +newtype BytesD = BytesD { unBytesD :: Bytes } + deriving (Eq, Ord) + +instance EncodingType BytesD where + typeName = const "bytes[]" + isDynamic = const True + +instance ABIEncoding BytesD where + toDataBuilder (BytesD bytes) = int256HexBuilder (BA.length bytes) + <> bytesBuilder bytes + fromDataParser = do + len <- int256HexParser + if (len :: Integer) > fromIntegral (maxBound :: Int) + then fail "Bytes length over bound!" + else (BytesD . bytesDecode) <$> P.take (fromIntegral len * 2) + +instance Show BytesD where + show = show . BS16.encode . BA.convert . unBytesD diff --git a/src/Network/Ethereum/Web3/Encoding/Internal.hs b/src/Network/Ethereum/Web3/Encoding/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/Web3/Encoding/Internal.hs @@ -0,0 +1,99 @@ +-- | +-- Module : Network.Ethereum.Web3.Encoding.Internal +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- ABI encoding internal function and types. +-- +module Network.Ethereum.Web3.Encoding.Internal where + +import Data.Text.Lazy.Builder (Builder, toLazyText, fromText, fromLazyText) +import qualified Data.ByteString.Base16 as BS16 (decode, encode) +import qualified Data.Attoparsec.Text as P +import qualified Data.Text.Lazy as LT +import qualified Data.Text as T +import qualified Data.Text.Read as R +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Network.Ethereum.Web3.Address (Address) +import Data.Attoparsec.Text.Lazy (Parser) +import Data.Text.Lazy.Builder.Int as B +import Language.Haskell.TH +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Bits (Bits) + +class EncodingType a where + typeName :: a -> String + isDynamic :: a -> Bool + +instance EncodingType Bool where + typeName = const "bool" + isDynamic = const False + +instance EncodingType Integer where + typeName = const "int" + isDynamic = const False + +instance EncodingType Int where + typeName = const "int" + isDynamic = const False + +instance EncodingType Word where + typeName = const "uint" + isDynamic = const False + +instance EncodingType Text where + typeName = const "string" + isDynamic = const True + +instance EncodingType Address where + typeName = const "address" + isDynamic = const False + +instance EncodingType a => EncodingType [a] where + typeName = const "[]" + isDynamic = const True + +-- | Make 256bit alignment; lazy (left, right) +align :: Builder -> (Builder, Builder) +align v = (v <> zeros, zeros <> v) + where zerosLen | LT.length s `mod` 64 == 0 = 0 + | otherwise = 64 - (LT.length s `mod` 64) + zeros = fromLazyText (LT.replicate zerosLen "0") + s = toLazyText v + +-- | Left/Right specialized alignment +alignL, alignR :: Builder -> Builder +{-# INLINE alignL #-} +alignL = fst . align +{-# INLINE alignR #-} +alignR = snd . align + +int256HexBuilder :: Integral a => a -> Builder +int256HexBuilder x | x < 0 = int256HexBuilder (2^256 + fromIntegral x) + | otherwise = alignR (B.hexadecimal x) + +int256HexParser :: (Bits a, Integral a) => Parser a +int256HexParser = do + hex <- P.take 64 + case R.hexadecimal hex of + Right (v, "") -> return v + _ -> fail ("Broken hexadecimal: `" ++ T.unpack hex ++ "`") + +textBuilder :: Text -> Builder +textBuilder s = int256HexBuilder (T.length hex `div` 2) + <> alignL (fromText hex) + where textToHex = decodeUtf8 . BS16.encode . encodeUtf8 + hex = textToHex s + +textParser :: Parser Text +textParser = do + len <- int256HexParser + let zeroBytes = 32 - (len `mod` 32) + str <- P.take (len * 2) <* P.take (zeroBytes * 2) + return (hexToText str) + where hexToText = decodeUtf8 . fst . BS16.decode . encodeUtf8 diff --git a/src/Network/Ethereum/Web3/Encoding/Tuple.hs b/src/Network/Ethereum/Web3/Encoding/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/Web3/Encoding/Tuple.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Network.Ethereum.Web3.Encoding.Tuple +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- ABIEncoding tuple instances. +-- +module Network.Ethereum.Web3.Encoding.Tuple (Singleton(..)) where + +import Network.Ethereum.Web3.Encoding.Internal +import Network.Ethereum.Web3.Encoding.TupleTH +import Network.Ethereum.Web3.Encoding + +-- | Singleton parameter instance +newtype Singleton a = Singleton { unSingleton :: a } + +instance (EncodingType a, ABIEncoding a) => ABIEncoding (Singleton a) where + toDataBuilder = _serialize (1, []) . unSingleton + fromDataParser = Singleton <$> (withParser sParser >>= dParser) + where withParser f = f undefined + +-- | Tuple instances from 2 to 15 params +$(mkTupleInst 2) +$(mkTupleInst 3) +$(mkTupleInst 4) +$(mkTupleInst 5) +$(mkTupleInst 6) +$(mkTupleInst 7) +$(mkTupleInst 8) +$(mkTupleInst 9) +$(mkTupleInst 10) +$(mkTupleInst 11) +$(mkTupleInst 12) +$(mkTupleInst 13) +$(mkTupleInst 14) +$(mkTupleInst 15) diff --git a/src/Network/Ethereum/Web3/Encoding/TupleTH.hs b/src/Network/Ethereum/Web3/Encoding/TupleTH.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/Web3/Encoding/TupleTH.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +-- | +-- Module : Network.Ethereum.Web3.Encoding.TupleTH +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Tuple ABI encoding instance TH generator. +-- +module Network.Ethereum.Web3.Encoding.TupleTH ( + mkTupleInst + , ABIData(..) + , sParser + , dParser + ) where + +import Data.Text.Lazy.Builder (toLazyText, Builder) +import Network.Ethereum.Web3.Encoding.Internal +import qualified Data.Attoparsec.Text as P +import qualified Data.Text.Lazy as LT +import Network.Ethereum.Web3.Encoding +import Data.Attoparsec.Text (Parser) +import Language.Haskell.TH + +-- | Argument offset calculator +offset :: Int + -- ^ Count of arguments + -> [Builder] + -- ^ Previous dynamic arguments + -> Int + -- ^ Offset +offset totalArgs args = headerOffset + dataOffset + where + headerOffset = totalArgs * 32 + dataOffset = builderLen (mconcat args) + builderLen = fromIntegral . (`div` 2) . LT.length . toLazyText + +-- | ABI data multiparam internal serializer +class ABIData a where + _serialize :: (Int, [(Builder, Builder)]) -> a + -- ^ Serialize with accumulator: + -- pair of argument count and list of pair header and + -- data part (for dynamic arguments) + +instance (EncodingType b, ABIEncoding b, ABIData a) => ABIData (b -> a) where + _serialize (n, l) x + | isDynamic x = _serialize (n, (toDataBuilder dynOffset, toDataBuilder x) : l) + | otherwise = _serialize (n, (toDataBuilder x , mempty) : l) + where dynOffset = offset n (fmap snd l) + +instance ABIData Builder where + _serialize = uncurry mappend . mconcat . reverse . snd + +-- | Static argument parser +sParser :: (EncodingType a, ABIEncoding a) => a -> Parser a +sParser x | isDynamic x = P.take 64 >> return undefined + | otherwise = fromDataParser + +-- | Dynamic argument parser +dParser :: (EncodingType a, ABIEncoding a) => a -> Parser a +dParser x | isDynamic x = fromDataParser + | otherwise = return x + +-- | Generator for tupleP{N} function signature +mkTuplePType :: Int -> DecQ +mkTuplePType n = do + vars <- sequence (replicate n $ newName "t") + let varsT = fmap varT vars + contextT = fmap (appT [t|ABIEncoding|]) varsT + ++ fmap (appT [t|EncodingType|]) varsT + varsTupleT = foldl appT (tupleT n) varsT + sigD (mkName $ "tupleP" ++ show n) + (forallT [] (cxt contextT) [t|Parser $(varsTupleT)|]) + +-- | Generator for tupleP{N} function +mkTupleP :: Int -> DecQ +mkTupleP n = do + vars <- sequence (replicate n $ newName "t") + funD (mkName $ "tupleP" ++ show n) $ pure $ + clause [] + (normalB [|$(varE withPN) $(varE staticPN) >>= $(varE dynamicPN)|]) + (decs vars) + where + withPN = mkName "withParser" + staticPN = mkName "staticParser" + dynamicPN = mkName "dynamicParser" + fun = mkName "f" + decs vars = [ withPFun, staticPFun vars, dynamicPFun vars ] + + withPFun = funD withPN $ pure $ + clause [varP fun] + (normalB [|$(varE fun) $(tupE (replicate n [|undefined|]))|]) [] + + staticPFun vars = funD staticPN $ pure $ + clause [tupP $ fmap varP vars] + (normalB (mkAppSeq (eTupleE n : fmap (\x -> [|sParser $(varE x)|]) vars))) [] + + dynamicPFun vars = funD dynamicPN $ pure $ + clause [tupP $ fmap varP vars] + (normalB (mkAppSeq (eTupleE n : fmap (\x -> [|dParser $(varE x)|]) vars))) [] + +mkAppSeq :: [ExpQ] -> ExpQ +mkAppSeq = infixApps . dollarFirst . sparse + where sparse [x] = [x] + sparse (x : xs) = x : [|(<*>)|] : sparse xs + dollarFirst (x : _ : xs) = x : [|(<$>)|] : xs + infixApps (x : xs) = go x xs + go acc [] = acc + go acc (f : x : xs) = go (infixApp acc f x) xs + +eTupleE :: Int -> ExpQ +eTupleE 2 = [|(,)|] +eTupleE 3 = [|(,,)|] +eTupleE 4 = [|(,,,)|] +eTupleE 5 = [|(,,,,)|] +eTupleE 6 = [|(,,,,,)|] +eTupleE 7 = [|(,,,,,,)|] +eTupleE 8 = [|(,,,,,,,)|] +eTupleE 9 = [|(,,,,,,,,)|] +eTupleE 10 = [|(,,,,,,,,,)|] +eTupleE 11 = [|(,,,,,,,,,,)|] +eTupleE 12 = [|(,,,,,,,,,,,)|] +eTupleE 13 = [|(,,,,,,,,,,,,)|] +eTupleE 14 = [|(,,,,,,,,,,,,,)|] +eTupleE 15 = [|(,,,,,,,,,,,,,,)|] +eTupleE _ = error "Unsupported empty tuple" + +mkEncodingInst :: Int -> DecQ +mkEncodingInst n = do + vars <- sequence (replicate n $ newName "t") + let varsT = fmap varT vars + contextT = fmap (appT [t|ABIEncoding|]) varsT + ++ fmap (appT [t|EncodingType|]) varsT + varsTupleT = foldl appT (tupleT n) varsT + instanceD (cxt contextT) (appT [t|ABIEncoding|] varsTupleT) + [ funD (mkName "toDataBuilder") [ + clause [tupP (fmap varP vars)] + (normalB (appsE ([|_serialize (n, [])|] : fmap varE vars))) [] ] + , funD (mkName "fromDataParser") [ + clause [] (normalB $ varE $ mkName $ "tupleP" ++ show n) [] ] + ] + +-- | Make a ABIEncoding tuple instance with given count of arguments +mkTupleInst :: Int -> Q [Dec] +mkTupleInst n = sequence $ + [ mkTuplePType n + , mkTupleP n + , mkEncodingInst n ] diff --git a/src/Network/Ethereum/Web3/EncodingUtils.hs b/src/Network/Ethereum/Web3/EncodingUtils.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/EncodingUtils.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | --- Module : Network.Ethereum.Web3.EncodingUtils --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : portable --- --- ABI encoding functions. --- -module Network.Ethereum.Web3.EncodingUtils where - -import Data.Text.Lazy.Builder (Builder, toLazyText, fromText, fromLazyText) -import qualified Data.ByteString.Base16 as BS16 (decode, encode) -import qualified Data.Attoparsec.Text as P -import qualified Data.Text.Lazy as LT -import qualified Data.Text as T -import qualified Data.Text.Read as R -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Data.Attoparsec.Text.Lazy (Parser) -import Data.Text.Lazy.Builder.Int as B -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Bits (Bits) - --- | Make 256bit aligment; lazy (left, right) -align :: Builder -> (Builder, Builder) -align v = (v <> zeros, zeros <> v) - where zerosLen | LT.length s `mod` 64 == 0 = 0 - | otherwise = 64 - (LT.length s `mod` 64) - zeros = fromLazyText (LT.replicate zerosLen "0") - s = toLazyText v - -alignL, alignR :: Builder -> Builder -{-# INLINE alignL #-} -alignL = fst . align -{-# INLINE alignR #-} -alignR = snd . align - -int256HexBuilder :: Integral a => a -> Builder -int256HexBuilder x | x < 0 = int256HexBuilder (2^256 + fromIntegral x) - | otherwise = alignR (B.hexadecimal x) - -int256HexParser :: (Bits a, Integral a) => Parser a -int256HexParser = do - hex <- P.take 64 - case R.hexadecimal hex of - Right (v, "") -> return v - _ -> fail ("Broken hexadecimal: `" ++ T.unpack hex ++ "`") - -textBuilder :: Text -> Builder -textBuilder s = int256HexBuilder (T.length hex `div` 2) - <> alignL (fromText hex) - where textToHex = decodeUtf8 . BS16.encode . encodeUtf8 - hex = textToHex s - -textParser :: Parser Text -textParser = do - len <- int256HexParser - let zeroBytes = 32 - (len `mod` 32) - str <- P.take (len * 2) <* P.take (zeroBytes * 2) - return (hexToText str) - where hexToText = decodeUtf8 . fst . BS16.decode . encodeUtf8 diff --git a/src/Network/Ethereum/Web3/TH.hs b/src/Network/Ethereum/Web3/TH.hs --- a/src/Network/Ethereum/Web3/TH.hs +++ b/src/Network/Ethereum/Web3/TH.hs @@ -24,26 +24,41 @@ -- where wait = threadDelay 1000000 >> wait -- @ -- -module Network.Ethereum.Web3.TH (abi, abiFrom) where +module Network.Ethereum.Web3.TH ( + -- ** Quasiquoter's + abi + , abiFrom + -- ** Used by TH data types + , Bytes + , Text + , Singleton(..) + , ABIEncoding(..) + ) where import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy as LT import qualified Data.Attoparsec.Text as P import qualified Data.Text as T + import Network.Ethereum.Web3.Address (Address) +import Network.Ethereum.Web3.Encoding.Tuple +import Network.Ethereum.Web3.Encoding import Network.Ethereum.Web3.Internal import Network.Ethereum.Web3.Contract import Network.Ethereum.Web3.JsonAbi import Network.Ethereum.Web3.Types +import Network.Ethereum.Unit + import Data.Text (Text, isPrefixOf) import Data.List (groupBy, sortBy) import Data.Monoid (mconcat, (<>)) +import Data.ByteArray (Bytes) +import Data.Aeson + import Language.Haskell.TH.Quote import Language.Haskell.TH.Lib import Language.Haskell.TH -import Control.Arrow -import Data.Aeson -- | Read contract ABI from file abiFrom :: QuasiQuoter @@ -108,58 +123,48 @@ isDynType x | T.any (== '[') x = True | otherwise = False --- | ABI encoding generator -abiEncodingParse :: [(Text, Name)] -> [StmtQ] -abiEncodingParse vars = fmap parseSta vars - ++ fmap (parseVar . snd) dynVars - where dynVars = filter (isDynType . fst) vars - parseSta (t, v) | isDynType t = noBindS [|P.take 64|] - | otherwise = parseVar v - parseVar v = bindS (varP v) [|fromDataParser|] - eventEncodigD :: Name -> [EventArg] -> [DecQ] -eventEncodigD eventName args = [ funD' (mkName "toDataBuilder") [] toDataB - , funD' (mkName "fromDataParser") [] fromDataP ] - where toDataB = [|error "Event to data conversion isn't available!"|] - indexed = map (eveArgType &&& eveArgIndexed) args - genVar (a, b) = do v <- newName "t" - return (b, (a, v)) - parseArg (_, v) = bindS (varP v) [|fromDataParser|] - fromDataP = do - vars <- mapM genVar indexed - let indexedVars = [v | (ix, v) <- vars, ix] - unindexedVars = [v | (ix, v) <- vars, not ix] - freeVars = [varE v | (_, (_, v)) <- vars] - doE $ fmap parseArg indexedVars - ++ abiEncodingParse unindexedVars - ++ [noBindS [|return $(appsE (conE eventName : freeVars))|]] +eventEncodigD eventName args = + [ funD' (mkName "toDataBuilder") [] + [|error "Event to data conversion isn't available!"|] + , funD' (mkName "fromDataParser") [] fromDataP ] + where + indexed = map eveArgIndexed args + newVars = sequence $ replicate (length args) (newName "t") -genABIHeader :: [(Text, Name)] -> [ExpQ] -genABIHeader vars = fmap go offsetVars - where offsetVars :: [((Text, Name), Int)] - offsetVars = zip vars (fmap ((32 *) . (length vars +)) [0..]) - go ((typ, v), o) | isDynType typ = [|toDataBuilder (o :: Int)|] - | otherwise = [|toDataBuilder $(varE v)|] + parseArg v = bindS (varP v) [|fromDataParser|] -genABIData :: [(Text, Name)] -> [ExpQ] -genABIData = fmap (\(_, v) -> [|toDataBuilder $(varE v)|]) + parseData [] = [] + parseData [v] = pure $ bindS (varP v) [|unSingleton <$> fromDataParser|] + parseData vars = pure $ bindS (tupP (varP <$> vars)) [|fromDataParser|] -funEncodigD :: Name -> [FunctionArg] -> String -> [DecQ] -funEncodigD funName args ident = + fromDataP = do + vars <- zip indexed <$> newVars + let ixVars = [v | (isIndexed, v) <- vars, isIndexed] + noIxVars = [v | (isIndexed, v) <- vars, not isIndexed] + expVars = [varE v | (_, v) <- vars] + doE $ fmap parseArg ixVars + ++ parseData noIxVars + ++ [noBindS [|return $(appsE (conE eventName : expVars))|]] + +funEncodigD :: Name -> Int -> String -> [DecQ] +funEncodigD funName paramLen ident = [ funDtoDataB - , funD' (mkName "fromDataParser") [] fromDataP ] - where fromDataP = [|error "Function from data conversion isn't available!"|] - funDtoDataB = do - vars <- sequence $ replicate (length args) (newName "t") + , funD' (mkName "fromDataParser") [] + [|error "Function from data conversion isn't available!"|] ] + where + newVars = sequence $ replicate paramLen (newName "t") + sVar = mkName "a" + funDtoDataB + | paramLen == 0 = funD' (mkName "toDataBuilder") [conP funName []] [|ident|] + | paramLen == 1 = funD' (mkName "toDataBuilder") + [conP funName [varP sVar]] + [|ident <> toDataBuilder (Singleton $(varE sVar))|] + | otherwise = do + vars <- newVars funD' (mkName "toDataBuilder") - [conP funName $ fmap varP vars] - (toDataB $ zip argTypes vars) - argTypes = fmap funArgType args - toDataB vars = do - let dynamicVars = filter (isDynType . fst) vars - appE [|mconcat|] $ - listE $ [|B.fromText ident|] - : genABIHeader vars ++ genABIData dynamicVars + [conP funName $ fmap varP vars] + [|ident <> toDataBuilder $(tupE $ fmap varE vars)|] eventFilterD :: String -> [DecQ] eventFilterD topic0 = let addr = mkName "a" in @@ -171,32 +176,46 @@ |] ] -{- - - TODO - - -funTypeWrapper :: Name -> [FunctionArg] -> Maybe [FunctionArg] -> DecQ -funTypeWrapper funName args result = sigD funName funType +funWrapper :: Bool + -- ^ Is constant? + -> Name + -- ^ Function name + -> Name + -- ^ Function data name + -> [FunctionArg] + -- ^ Parameters + -> Maybe [FunctionArg] + -- ^ Results + -> Q [Dec] +funWrapper c name dname args result = do + a : b : vars <- sequence $ replicate (length args + 2) (newName "t") + let params = appsE $ (conE dname) : fmap varE vars + + sequence $ case c of + True -> + [ sigD name $ arrowing $ [t|Address|] : inputT ++ [outputT] + , funD' name (varP <$> a : vars) $ + case result of + Just [_] -> [|unSingleton <$> call $(varE a) Latest $(params)|] + _ -> [|call $(varE a) Latest $(params)|] + ] + + False -> + [ sigD name $ [t|Unit $(varT b) => + $(arrowing $ [t|Address|] : varT b : inputT ++ [[t|Web3 TxHash|]]) + |] + , funD' name (varP <$> a : b : vars) $ + [|sendTx $(varE a) $(varE b) $(params)|] ] where - funType = foldl appT [t|Address|] $ arrowing (inputT ++ [outputT]) - arrowing= concat . zipWith (\a b -> [a, b]) (repeat arrowT) + arrowing [x] = x + arrowing (x : xs) = [t|$x -> $(arrowing xs)|] inputT = fmap (typeQ . funArgType) args outputT = case result of Nothing -> [t|Web3 ()|] Just [x] -> [t|Web3 $(typeQ $ funArgType x)|] Just xs -> let outs = fmap (typeQ . funArgType) xs in [t|Web3 $(foldl appT (tupleT (length xs)) outs)|] --} -funWrapper :: Bool -> Name -> Name -> [FunctionArg] -> DecQ -funWrapper c name dname args = do - (a : b : vars) <- sequence $ replicate (length args + 2) (newName "t") - let params = appsE ((conE dname) : fmap varE vars) - case c of - True -> funD' name (fmap varP (a : vars)) $ - [|call $(varE a) Latest $(params)|] - False -> funD' name (fmap varP (a : b : vars)) $ - [|sendTx $(varE a) $(varE b) $(params)|] - -- | Event declarations maker mkEvent :: Declaration -> Q [Dec] mkEvent eve@(DEvent name inputs _) = sequence $ @@ -212,14 +231,13 @@ -- | Method delcarations maker mkFun :: Declaration -> Q [Dec] -mkFun fun@(DFunction name constant inputs outputs) = do - sequence $ +mkFun fun@(DFunction name constant inputs outputs) = (++) + <$> funWrapper constant funName dataName inputs outputs + <*> sequence [ dataD' dataName (normalC dataName bangInput) derivingD - , instanceD' dataName encodingT (funEncodigD dataName inputs mIdent) - , instanceD' dataName methodT [] - -- , funTypeWrapper funName inputs outputs - , funWrapper constant funName dataName inputs - ] + , instanceD' dataName encodingT + (funEncodigD dataName (length inputs) mIdent) + , instanceD' dataName methodT [] ] where mIdent = T.unpack (methodId fun) dataName = mkName (toUpperFirst (T.unpack $ name <> "Data")) funName = mkName (toLowerFirst (T.unpack name)) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,21 +3,24 @@ {-# LANGUAGE DataKinds #-} module Main where -import Network.Ethereum.Web3.Address (fromText) import Network.Ethereum.Web3.TH import Network.Ethereum.Web3 - -import Control.Concurrent (threadDelay) -import Data.ByteArray (Bytes) -import Data.Text (Text) +import Data.Text (unpack) +import Text.Printf -[abiFrom|data/sample.json|] +[abiFrom|data/ERC20.json|] main :: IO () main = do putStrLn "" - putStrLn [abiFrom|data/sample.json|] - -- runWeb3 $ event addr (\(Action2 x y) -> print x >> print y >> return TerminateEvent) - -- threadDelay 100000000 - -- return () - where Right addr = fromText "0x19EE7966474b31225F71Ef8e36A71378a58a20E1" + putStrLn [abiFrom|data/ERC20.json|] +{- + Right s <- runWeb3 $ do + n <- name token + s <- symbol token + d <- decimals token + return $ printf "Token %s with symbol %s and decimals %d" + (unpack n) (unpack s) d + putStrLn s + where token = "0x237D60A8b41aFD2a335305ed458B609D7667D789" +-} diff --git a/web3.cabal b/web3.cabal --- a/web3.cabal +++ b/web3.cabal @@ -1,5 +1,5 @@ name: web3 -version: 0.3.4.0 +version: 0.4.0.0 synopsis: Ethereum API for Haskell description: Web3 is a Haskell client library for Ethereum homepage: https://github.com/airalab/hs-web3#readme @@ -14,8 +14,7 @@ extra-source-files: README.md - data/sample.json - data/sample.sol + data/ERC20.json source-repository head type: git @@ -28,14 +27,16 @@ , Network.Ethereum.Web3.TH , Network.Ethereum.Web3.Api , Network.Ethereum.Web3.Types - , Network.Ethereum.Web3.Bytes , Network.Ethereum.Web3.Address , Network.Ethereum.Web3.JsonAbi , Network.Ethereum.Web3.Encoding , Network.Ethereum.Web3.Contract + , Network.Ethereum.Web3.Encoding.Bytes + , Network.Ethereum.Web3.Encoding.Tuple other-modules: Network.Ethereum.Web3.JsonRpc , Network.Ethereum.Web3.Internal - , Network.Ethereum.Web3.EncodingUtils + , Network.Ethereum.Web3.Encoding.TupleTH + , Network.Ethereum.Web3.Encoding.Internal build-depends: base >4.8 && <4.11 , data-default-class , base16-bytestring