diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,30 @@ +# Changelog +All notable changes to this project will be documented in this file. + +## [0.7.0.0] 2018-04-22 +### Added +- This CHANGELOG.md file for significant changes tracking. +- Descriptive types for all JSON-RPC method parameters and returned values (#15). +- Widely use of basement:Word256 type for encoding. +- Full list of ethereum abi encoding types: + * bool: `Bool` + * int256: `IntN` + * uint256: `UIntN` + * string: `Text` + * bytes: `Bytes` + * bytes32: `BytesN` + * dynamic array: `[]` + * static array: `ListN` + +### Changed +- Rewriten encoding engine for best performance, it now based on cereal:Serialize instead of parsec:Parser. +- Renamed encoding type classes and methods: `ABIEncode` -> `ABIPut`, `ABIDecode` -> `ABIGet`. +- Encoding related modules moved to Network.Ethereum.ABI. +- Primitive abi encoding types are moved to separated modules in Network.Ethereum.ABI.Prim. +- Contract interation related modules moved to Network.Ethereum.Contract. +- Ethereum node communication modules stay in Network.Ethereum.Web3. +- JSON-RPC tiny client is independent now and can be used separately. + +### Removed +- `Event` type class, currently TH create `Data.Default` instance for `Filter e`. +- Custom setup for live testing (it replaced by travis script). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -23,27 +23,28 @@ Any Ethereum node communication wrapped with `Web3` monadic type. - > :t web3_clientVersion - web3_clientVersion :: Provider a => Web3 a Text + > import Network.Ethereum.Web3.Web3 + > :t clientVersion + clientVersion :: Web3 Text To run this computation used `runWeb3'` or `runWeb3` functions. - > runWeb3 web3_clientVersion + > import Network.Ethereum.Web3 + > runWeb3 clientVersion Right "Parity//v1.4.5-beta-a028d04-20161126/x86_64-linux-gnu/rustc1.13.0" Function `runWeb3` use default `Web3` provider at `localhost:8545`. > :t runWeb3 runWeb3 - :: MonadIO m => Web3 DefaultProvider b -> m (Either Web3Error b) + :: MonadIO m => Web3 a -> m (Either Web3Error a) ### TemplateHaskell generator -[Quasiquotation](https://wiki.haskell.org/Quasiquotation) is used to parse -contract ABI or load from JSON file. [TemplateHaskell](https://wiki.haskell.org/Template_Haskell) driven Haskell contract API generator can automatical create instances for `Event` and `Method` -typeclasses and function helpers. +[Quasiquotation](https://wiki.haskell.org/Quasiquotation) is used to parse contract ABI or load from JSON file. [TemplateHaskell](https://wiki.haskell.org/Template_Haskell) driven Haskell contract API generator can automatical create ABI encoding instances and contract method helpers. > :set -XQuasiQuotes + > import Network.Ethereum.Contract.TH > putStr [abiFrom|data/sample.json|] Contract: Events: @@ -53,22 +54,23 @@ 0x03de48b3 runA1() 0x90126c7a runA2(string,uint256) -See example of usage. +Use `-ddump-splices` to see generated code during compilation or in GHCi. See `examples` folder for more use cases. -```haskell -import Data.Text (unpack) -import Text.Printf +### Testing -[abiFrom|data/ERC20.json|] +Testing the `web3` is split up into two suites: `unit` and `live`. +The `unit` suite tests internal library facilities, while the `live` tests that +the library adequately interacts with a Web3 provider. -main :: IO () -main = do - 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" -``` +One may simply run `stack test` to run both suites, or `stack test web3:unit` or `stack test web3:live` +to run the test suites individually. + +The `unit` suite has no external dependencies, while the `live` suite requires Truffle and `jq` +to be available on your machine. + +The `live` suite also requires a Web3 provider with Ethereum capabilities, as well as +an unlocked account with ether to send transactions from. It uses Truffle to deploy testing contracts, +generating ABIs for them in the process, then using said ABIs as part of a TemplateHaskell step in the suite. +It is assumed that the provider is available at `http://localhost:8545`. If that's not the case, you must update `truffle.js` +so that Truffle can deploy the contracts correctly, and pass the `WEB3_PROVIDER=http://host:port` environment variable +when running the tests so that the `web3` library can interact with the chain that's being tested against. diff --git a/data/ERC20.json b/data/ERC20.json deleted file mode 100644 --- a/data/ERC20.json +++ /dev/null @@ -1,1 +0,0 @@ -[{"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/examples/ERC20.hs b/examples/ERC20.hs new file mode 100644 --- /dev/null +++ b/examples/ERC20.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module ERC20 where + +import Network.Ethereum.Contract.TH + +[abiFrom|examples/ERC20.json|] diff --git a/examples/ERC20.json b/examples/ERC20.json new file mode 100644 --- /dev/null +++ b/examples/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/examples/TokenInfo.hs b/examples/TokenInfo.hs new file mode 100644 --- /dev/null +++ b/examples/TokenInfo.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Default (def) +import Data.Text (unpack) +import Text.Printf (printf) + +import Network.Ethereum.Contract.TH +import Network.Ethereum.Web3 hiding (name) + +import ERC20 + +main :: IO () +main = do + result <- runWeb3 $ do + n <- name tokenCall + s <- symbol tokenCall + d <- decimals tokenCall + return $ printf "Token %s with symbol %s and decimals %d" + (unpack n) (unpack s) (fromIntegral d :: Int) + case result of + Left err -> print err + Right info -> putStrLn info + where + token :: Address + token = "0xA2f4FCb0FDe2dD59f7a1873e121bc5623e3164Eb" + + tokenCall :: Call + tokenCall = def { callTo = Just token } diff --git a/src/Data/String/Extra.hs b/src/Data/String/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/String/Extra.hs @@ -0,0 +1,25 @@ +-- | +-- Module : Data.String.Extra +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Extra string manipulation functions. +-- + +module Data.String.Extra where + +import Data.Char (toLower, toUpper) + +-- | Lower first char of string +toLowerFirst :: String -> String +toLowerFirst [] = [] +toLowerFirst (x : xs) = toLower x : xs + +-- | Upper first char of string +toUpperFirst :: String -> String +toUpperFirst [] = [] +toUpperFirst (x : xs) = toUpper x : xs diff --git a/src/Network/Ethereum/ABI/Class.hs b/src/Network/Ethereum/ABI/Class.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Class.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.Ethereum.ABI.Class +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI encoding base type classes. +-- + +module Network.Ethereum.ABI.Class ( + ABIType(..) + , ABIPut(..) + , ABIGet(..) + , GenericABIPut(..) + , GenericABIGet(..) + ) where + +import Data.Proxy (Proxy) +import Data.Serialize (Get, Putter) +import Generics.SOP (Generic, Rep, from, to) + +-- | A class for abi encoding datatype descriptions +class ABIType a where + isDynamic :: Proxy a -> Bool + +-- | A class for encoding datatypes to their abi encoding +-- +-- If your compiler has support for the @DeriveGeneric@ and +-- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@), +-- the 'abiPut' method will have default generic implementations. +-- +-- To use this option, simply add a @deriving 'Generic'@ clause +-- to your datatype and declare a 'ABIPut' instance for it without +-- giving a definition for 'abiPut'. +-- +class ABIType a => ABIPut a where + abiPut :: Putter a + + default abiPut :: (Generic a, Rep a ~ rep, GenericABIPut rep) => Putter a + abiPut = gAbiPut . from + +-- | A class for encoding generically composed datatypes to their abi encoding +class GenericABIPut a where + gAbiPut :: Putter a + +-- | A class for decoding datatypes from their abi encoding +-- +-- If your compiler has support for the @DeriveGeneric@ and +-- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@), +-- the 'abiGet' method will have default generic implementations. +-- +-- To use this option, simply add a @deriving 'Generic'@ clause +-- to your datatype and declare a 'ABIGet' instance for it without +-- giving a definition for 'abiGet'. +-- +class ABIType a => ABIGet a where + abiGet :: Get a + + default abiGet :: (Generic a, Rep a ~ rep, GenericABIGet rep) => Get a + abiGet = to <$> gAbiGet + +-- | A class for decoding generically composed datatypes from their abi encoding +class GenericABIGet a where + gAbiGet :: Get a diff --git a/src/Network/Ethereum/ABI/Codec.hs b/src/Network/Ethereum/ABI/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Codec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.Ethereum.ABI.Codec +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI encoding codec functions. +-- + +module Network.Ethereum.ABI.Codec ( + encode + , decode + , encode' + , decode' + ) where + +import Data.ByteArray (ByteArray, ByteArrayAccess, + convert) +import Data.Serialize (runGet, runPut) +import Generics.SOP (Generic, Rep, from, to) + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + GenericABIGet (..), + GenericABIPut (..)) +import Network.Ethereum.ABI.Generic () + +-- | Encode datatype to Ethereum ABI-encoding +encode :: (ABIPut a, ByteArray ba) + => a + -> ba +{-# INLINE encode #-} +encode = convert . runPut . abiPut + +-- | Generic driven version of 'encode' +encode' :: (Generic a, + Rep a ~ rep, + GenericABIPut rep, + ByteArray ba) + => a + -> ba +{-# INLINE encode' #-} +encode' = convert . runPut . gAbiPut . from + +-- | Decode datatype from Ethereum ABI-encoding +decode :: (ByteArrayAccess ba, ABIGet a) + => ba + -> Either String a +{-# INLINE decode #-} +decode = runGet abiGet . convert + +-- | Generic driven version of 'decode' +decode' :: (Generic a, + Rep a ~ rep, + GenericABIGet rep, + ByteArrayAccess ba) + => ba + -> Either String a +decode' = runGet (to <$> gAbiGet) . convert diff --git a/src/Network/Ethereum/ABI/Event.hs b/src/Network/Ethereum/ABI/Event.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Event.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Network.Ethereum.Web3.Encoding.Event +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- This module is internal, the purpose is to define +-- helper classes and functions to assist in event decoding. +-- The user of this library should have no need to use +-- this directly in application code. +-- + +module Network.Ethereum.ABI.Event( + DecodeEvent(..) + , IndexedEvent(..) + ) where + +import Data.ByteArray (ByteArrayAccess) +import Data.Proxy (Proxy (..)) +import Generics.SOP (Generic, I (..), NP (..), + NS (..), Rep, SOP (..), + from, to) + +import Network.Ethereum.ABI.Class (GenericABIGet) +import Network.Ethereum.ABI.Codec (decode') +import Network.Ethereum.ABI.Event.Internal +import Network.Ethereum.Web3.Types (Change (..)) + +-- | Indexed event args come back in as a list of encoded values. 'ArrayParser' +-- | is used to decode these values so that they can be used to reconstruct the +-- | entire decoded event. +class ArrayParser a where + arrayParser :: ByteArrayAccess ba + => [ba] + -> Either String a + +instance ArrayParser (NP f '[]) where + arrayParser _ = Right Nil + +instance (ArrayParser (NP I as), Generic a, Rep a ~ rep, GenericABIGet rep) + => ArrayParser (NP I (a : as)) where + arrayParser [] = Left "Empty" + arrayParser (a : as) = do + a' <- decode' a + as' <- arrayParser as + return $ I a' :* as' + +instance ArrayParser (NP f as) => ArrayParser (SOP f '[as]) where + arrayParser = fmap (SOP . Z) . arrayParser + +genericArrayParser :: ( Generic a + , Rep a ~ rep + , ArrayParser rep + , ByteArrayAccess ba + ) + => [ba] + -> Either String a +genericArrayParser = fmap to . arrayParser + +-------------------------------------------------------------------------------- +-- Event Parsing +-------------------------------------------------------------------------------- + +data Event i ni = Event i ni + +-- | 'parseChange' decodes both the indexed and non-indexed event components. +parseChange :: ( Generic i + , Rep i ~ irep + , ArrayParser irep + , Generic ni + , Rep ni ~ nirep + , GenericABIGet nirep + ) + => Change + -> Bool + -- ^ is anonymous event + -> Either String (Event i ni) +parseChange change anonymous = + Event <$> genericArrayParser topics <*> decode' data_ + where + topics | anonymous = changeTopics change + | otherwise = tail (changeTopics change) + data_ = changeData change + +class IndexedEvent i ni e | e -> i ni where + isAnonymous :: Proxy e -> Bool + +-- | 'CombineChange' is a class which indicates that given event components of types 'i' +-- | and 'ni', we can construct an event of type 'e'. The functional dependency is valid +-- | becasue of how the template haskell generates the event types. +class CombineChange i ni e | e -> i ni where + combineChange :: i -> ni -> e + +instance ( Generic i + , Rep i ~ irep + , Generic ni + , Rep ni ~ nirep + , Generic e + , Rep e ~ erep + , HListRep irep hli + , HListRep nirep hlni + , MergeIndexedArguments hli hlni + , MergeIndexedArguments' hli hlni ~ hle + , HListRep erep hle + , IndexedEvent i ni e + ) => CombineChange i ni e where + combineChange i ni = + let hli = toHList . from $ i + hlni = toHList . from $ ni + hle = mergeIndexedArguments hli hlni + in to . fromHList $ hle + +class DecodeEvent i ni e | e -> i ni where + decodeEvent :: Change -> Either String e + +instance ( IndexedEvent i ni e + , Generic i + , Rep i ~ SOP I '[hli] + , Generic ni + , Rep ni ~ SOP I '[hlni] + , Generic e + , Rep e ~ SOP I '[hle] + , CombineChange i ni e + , GenericABIGet (SOP I '[hlni]) + , ArrayParser (SOP I '[hli]) + ) => DecodeEvent i ni e where + decodeEvent change = do + let anonymous = isAnonymous (Proxy :: Proxy e) + (Event i ni :: Event i ni) <- parseChange change anonymous + return $ combineChange i ni diff --git a/src/Network/Ethereum/ABI/Event/Internal.hs b/src/Network/Ethereum/ABI/Event/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Event/Internal.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Network.Ethereum.ABI.Event.Internal +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- This module is internal, the purpose is to define helper classes and types +-- to assist in event decoding. The user of this library should have no need to use +-- this directly in application code. +-- + +module Network.Ethereum.ABI.Event.Internal where + +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import Data.Tagged (Tagged (..)) +import Generics.SOP (I (..), NP (..), NS (..), SOP (..)) +import GHC.TypeLits (CmpNat) + +data HList :: [Type] -> Type where + HNil :: HList '[] + (:<) :: a -> HList as -> HList (a : as) + +infixr 0 :< + +-- | Generic representation to HList representation +class HListRep a xs | a -> xs, a -> xs where + toHList :: a -> HList xs + fromHList :: HList xs -> a + +instance HListRep (NP I '[]) '[] where + toHList _ = HNil + fromHList _ = Nil + +instance HListRep (NP I as) as => HListRep (NP I (a:as)) (a:as) where + toHList (I a :* rest) = a :< toHList rest + fromHList (a :< rest) = I a :* fromHList rest + +instance HListRep (NP f as') as => HListRep (SOP f '[as']) as where + toHList (SOP (Z rep)) = toHList rep + toHList _ = error "Impossible branch" + fromHList = SOP . Z . fromHList + +-- | Sort a Tagged HList +class Sort (xs :: [Type]) where + type Sort' xs :: [Type] + sort :: HList xs -> HList (Sort' xs) + +instance Sort '[] where + type Sort' '[] = '[] + sort HNil = HNil + +instance (Sort xs, Insert x (Sort' xs)) => Sort (x : xs) where + type Sort' (x : xs) = Insert' x (Sort' xs) + sort (x :< xs) = insert x (sort xs) + +class Insert (x :: Type) (xs :: [Type]) where + type Insert' x xs :: [Type] + insert :: x -> HList xs -> HList (Insert' x xs) + +instance Insert x '[] where + type Insert' x '[] = '[x] + insert x HNil = x :< HNil + +instance InsertCmp (CmpNat n m) (Tagged n x) (Tagged m y) ys => Insert (Tagged n x) (Tagged m y : ys) where + type Insert' (Tagged n x) (Tagged m y : ys) = InsertCmp' (CmpNat n m) (Tagged n x) (Tagged m y) ys + insert (x :: Tagged n x) ((y :: Tagged m y) :< ys) = insertCmp (Proxy :: Proxy (CmpNat n m)) x y ys + +class InsertCmp (b :: Ordering) (x :: Type) (y :: Type) (ys :: [Type]) where + type InsertCmp' b x y ys :: [Type] + insertCmp :: Proxy (b :: Ordering) -> x -> y -> HList ys -> HList (InsertCmp' b x y ys) + +instance InsertCmp 'LT x y ys where + type InsertCmp' 'LT x y ys = x : (y : ys) + insertCmp _ x y ys = x :< y :< ys + +instance Insert x ys => InsertCmp 'GT x y ys where + type InsertCmp' 'GT x y ys = y : Insert' x ys + insertCmp _ x y ys = y :< insert x ys + +-- | Unwrap all the Tagged items in an HList +class UnTag t where + type UnTag' t :: [Type] + unTag :: HList t -> HList (UnTag' t) + +instance UnTag '[] where + type UnTag' '[] = '[] + unTag a = a + +instance UnTag ts => UnTag (Tagged n a : ts) where + type UnTag' (Tagged n a : ts) = a : UnTag' ts + unTag (Tagged a :< ts) = a :< unTag ts + +class HListMerge (as :: [Type]) (bs :: [Type]) where + type Concat as bs :: [Type] + mergeHList :: HList as -> HList bs -> HList (Concat as bs) + +instance HListMerge '[] bs where + type Concat '[] bs = bs + mergeHList _ bs = bs + +instance HListMerge as bs => HListMerge (a : as) bs where + type Concat (a : as) bs = a : Concat as bs + mergeHList (a :< as) bs = a :< mergeHList as bs + +class HListMergeSort as bs where + type MergeSort' as bs :: [Type] + mergeSortHList :: HList as -> HList bs -> HList (MergeSort' as bs) + +instance (HListMerge as bs, Concat as bs ~ cs, Sort cs, Sort' cs ~ cs') => HListMergeSort as bs where + type MergeSort' as bs = Sort' (Concat as bs) + mergeSortHList as bs = sort $ (mergeHList as bs :: HList cs) + +class MergeIndexedArguments as bs where + type MergeIndexedArguments' as bs :: [Type] + mergeIndexedArguments :: HList as -> HList bs -> HList (MergeIndexedArguments' as bs) + +instance (HListMergeSort as bs, MergeSort' as bs ~ cs, UnTag cs, UnTag cs' ~ ds) => MergeIndexedArguments as bs where + type MergeIndexedArguments' as bs = (UnTag' (MergeSort' as bs)) + mergeIndexedArguments as bs = unTag $ mergeSortHList as bs diff --git a/src/Network/Ethereum/ABI/Generic.hs b/src/Network/Ethereum/ABI/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Generic.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Network.Ethereum.ABI.Generic +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- This module is internal, the purpose is to define helper classes and functions +-- to assist in encoding and decoding Solidity types for function calls and events. +-- The user of this library should have no need to use this directly in application code. +-- + +module Network.Ethereum.ABI.Generic () where + +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int64) +import qualified Data.List as L +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Serialize (Get, Put) +import Data.Serialize.Get (bytesRead, lookAheadE, skip) +import Data.Serialize.Put (runPutLazy) +import Generics.SOP (I (..), NP (..), NS (..), + SOP (..)) + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + ABIType (..), + GenericABIGet (..), + GenericABIPut (..)) +import Network.Ethereum.ABI.Prim.Int (getWord256, putWord256) + +data EncodedValue = + EncodedValue { order :: Int64 + , offset :: Maybe Int64 + , encoding :: Put + } + +instance Eq EncodedValue where + ev1 == ev2 = order ev1 == order ev2 + +instance Ord EncodedValue where + compare ev1 ev2 = order ev1 `compare` order ev2 + +combineEncodedValues :: [EncodedValue] -> Put +combineEncodedValues encodings = + let sortedEs = adjust headsOffset $ L.sort encodings + encodings' = addTailOffsets headsOffset [] sortedEs + in let heads = foldl (\acc EncodedValue{..} -> case offset of + Nothing -> acc <> encoding + Just o -> acc <> putWord256 (fromIntegral o) + ) mempty encodings' + tails = foldl (\acc EncodedValue{..} -> case offset of + Nothing -> acc + Just _ -> acc <> encoding + ) mempty encodings' + in heads <> tails + where + adjust :: Int64 -> [EncodedValue] -> [EncodedValue] + adjust n = map (\ev -> ev {offset = (+) n <$> offset ev}) + addTailOffsets :: Int64 -> [EncodedValue] -> [EncodedValue] -> [EncodedValue] + addTailOffsets init' acc es = case es of + [] -> reverse acc + (e : tail') -> case offset e of + Nothing -> addTailOffsets init' (e : acc) tail' + Just _ -> addTailOffsets init' (e : acc) (adjust (LBS.length . runPutLazy . encoding $ e) tail') + headsOffset :: Int64 + headsOffset = foldl (\acc e -> case offset e of + Nothing -> acc + (LBS.length . runPutLazy . encoding $ e) + Just _ -> acc + 32 + ) 0 encodings + +class ABIData a where + _serialize :: [EncodedValue] -> a -> [EncodedValue] + +instance ABIData (NP f '[]) where + _serialize encoded _ = encoded + +instance (ABIType b, ABIPut b, ABIData (NP I as)) => ABIData (NP I (b :as)) where + _serialize encoded (I b :* a) = + if isDynamic (Proxy :: Proxy b) + then _serialize (dynEncoding : encoded) a + else _serialize (staticEncoding : encoded) a + where + staticEncoding = EncodedValue { encoding = abiPut b + , offset = Nothing + , order = 1 + (fromInteger . toInteger . L.length $ encoded) + } + dynEncoding = EncodedValue { encoding = abiPut b + , offset = Just 0 + , order = 1 + (fromInteger . toInteger . L.length $ encoded) + } + +instance ABIData (NP f as) => GenericABIPut (SOP f '[as]) where + gAbiPut (SOP (Z a)) = combineEncodedValues $ _serialize [] a + gAbiPut _ = error "Impossible branch" + +instance GenericABIGet (NP f '[]) where + gAbiGet = return Nil + +instance (ABIGet a, GenericABIGet (NP I as)) => GenericABIGet (NP I (a : as)) where + gAbiGet = (:*) <$> (I <$> factorParser) <*> gAbiGet + +instance GenericABIGet (NP f as) => GenericABIGet (SOP f '[as]) where + gAbiGet = SOP . Z <$> gAbiGet + +factorParser :: forall a . ABIGet a => Get a +factorParser + | not $ isDynamic (Proxy :: Proxy a) = abiGet + | otherwise = do + dataOffset <- fromIntegral <$> getWord256 + currentOffset <- bytesRead + Left x <- lookAheadE $ do + skip (dataOffset - currentOffset) + Left <$> abiGet + return x diff --git a/src/Network/Ethereum/ABI/Json.hs b/src/Network/Ethereum/ABI/Json.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Json.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Network.Ethereum.ABI.Json +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- JSON encoded contract ABI parsers. +-- + +module Network.Ethereum.ABI.Json ( + ContractABI(..) + , Declaration(..) + , FunctionArg(..) + , EventArg(..) + , signature + , methodId + , eventId + , SolidityType(..) + , parseSolidityType + ) where + +import Control.Monad (void) +import Crypto.Hash (Digest, Keccak_256, hash) +import Data.Aeson (FromJSON (parseJSON), Options (constructorTagModifier, fieldLabelModifier, sumEncoding), + SumEncoding (TaggedObject), + ToJSON (toJSON), defaultOptions) +import Data.Aeson.TH (deriveJSON) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T (dropEnd, pack, take, unlines, unpack) +import Data.Text.Encoding (encodeUtf8) +import Text.Parsec (ParseError, char, choice, digit, eof, + lookAhead, many1, manyTill, optionMaybe, + parse, string, try, (<|>)) +import Text.Parsec.Text (Parser) + +import Data.String.Extra (toLowerFirst) + +-- | Method argument +data FunctionArg = FunctionArg + { funArgName :: Text + -- ^ Argument name + , funArgType :: Text + -- ^ Argument type + } deriving (Show, Eq, Ord) + +$(deriveJSON + (defaultOptions {fieldLabelModifier = toLowerFirst . drop 6}) + ''FunctionArg) + +-- | Event argument +data EventArg = EventArg + { eveArgName :: Text + -- ^ Argument name + , eveArgType :: Text + -- ^ Argument type + , eveArgIndexed :: Bool + -- ^ Argument is indexed (e.g. placed on topics of event) + } deriving (Show, Eq, Ord) + +$(deriveJSON + (defaultOptions {fieldLabelModifier = toLowerFirst . drop 6}) + ''EventArg) + +-- | Elementrary contract interface item +data Declaration + = DConstructor { conInputs :: [FunctionArg] } + -- ^ Contract constructor + | DFunction { funName :: Text + , funConstant :: Bool + , funInputs :: [FunctionArg] + , funOutputs :: Maybe [FunctionArg] } + -- ^ Method + | DEvent { eveName :: Text + , eveInputs :: [EventArg] + , eveAnonymous :: Bool } + -- ^ Event + | DFallback { falPayable :: Bool } + -- ^ Fallback function + deriving (Show, Eq, Ord) + +$(deriveJSON (defaultOptions { + sumEncoding = TaggedObject "type" "contents" + , constructorTagModifier = toLowerFirst . drop 1 + , fieldLabelModifier = toLowerFirst . drop 3 }) + ''Declaration) + +-- | Contract ABI is a list of method / event declarations +newtype ContractABI = ContractABI { unABI :: [Declaration] } + deriving (Eq, Ord) + +instance FromJSON ContractABI where + parseJSON = fmap ContractABI . parseJSON + +instance ToJSON ContractABI where + toJSON = toJSON . unABI + +instance Show ContractABI where + show (ContractABI c) = T.unpack $ T.unlines $ + [ "Contract:" ] + ++ foldMap showConstructor c ++ + [ "\tEvents:" ] + ++ foldMap showEvent c ++ + [ "\tMethods:" ] + ++ foldMap showMethod c + +showConstructor :: Declaration -> [Text] +showConstructor x = case x of + DConstructor{} -> ["\tConstructor " <> signature x] + _ -> [] + +showEvent :: Declaration -> [Text] +showEvent x = case x of + DEvent{} -> ["\t\t" <> signature x] + _ -> [] + +showMethod :: Declaration -> [Text] +showMethod x = case x of + DFunction{} -> + ["\t\t" <> methodId x <> " " <> signature x] + _ -> [] + +-- | Take a signature by given decl, e.g. foo(uint,string) +signature :: Declaration -> Text + +signature (DConstructor inputs) = "(" <> args inputs <> ")" + where + args :: [FunctionArg] -> Text + args = T.dropEnd 1 . foldMap (<> ",") . fmap funArgType + +signature (DFallback _) = "()" + +signature (DFunction name _ inputs _) = name <> "(" <> args inputs <> ")" + where + args :: [FunctionArg] -> Text + args = T.dropEnd 1 . foldMap (<> ",") . fmap funArgType + +signature (DEvent name inputs _) = name <> "(" <> args inputs <> ")" + where + args :: [EventArg] -> Text + args = T.dropEnd 1 . foldMap (<> ",") . fmap eveArgType + +-- | Localy compute Keccak-256 hash of given text +sha3 :: Text -> Text +{-# INLINE sha3 #-} +sha3 x = T.pack (show digest) + where digest :: Digest Keccak_256 + digest = hash (encodeUtf8 x) + +-- | Generate method selector by given method 'Delcaration' +methodId :: Declaration -> Text +{-# INLINE methodId #-} +methodId = ("0x" <>) . T.take 8 . sha3 . signature + +-- | Generate event `topic0` hash by givent event 'Delcaration' +eventId :: Declaration -> Text +{-# INLINE eventId #-} +eventId = ("0x" <>) . sha3 . signature + +-- | Solidity types and parsers +data SolidityType = + SolidityBool + | SolidityAddress + | SolidityUint Int + | SolidityInt Int + | SolidityString + | SolidityBytesN Int + | SolidityBytes + | SolidityVector [Int] SolidityType + | SolidityArray SolidityType + deriving (Eq, Show) + +numberParser :: Parser Int +numberParser = read <$> many1 digit + +parseUint :: Parser SolidityType +parseUint = do + _ <- string "uint" + n <- numberParser + pure $ SolidityUint n + +parseInt :: Parser SolidityType +parseInt = do + _ <- string "int" + n <- numberParser + pure $ SolidityInt n + +parseBool :: Parser SolidityType +parseBool = string "bool" >> pure SolidityBool + +parseString :: Parser SolidityType +parseString = string "string" >> pure SolidityString + +parseBytes :: Parser SolidityType +parseBytes = do + _ <- string "bytes" + mn <- optionMaybe numberParser + pure $ maybe SolidityBytes SolidityBytesN mn + +parseAddress :: Parser SolidityType +parseAddress = string "address" >> pure SolidityAddress + +solidityBasicTypeParser :: Parser SolidityType +solidityBasicTypeParser = + choice [ try parseUint + , try parseInt + , try parseAddress + , try parseBool + , try parseString + , parseBytes + ] + +parseVector :: Parser SolidityType +parseVector = do + s <- solidityBasicTypeParser + ns <- many1Till lengthParser ((lookAhead $ void (string "[]")) <|> eof) + pure $ SolidityVector ns s + where + many1Till :: Parser Int -> Parser () -> Parser [Int] + many1Till p end = do + a <- p + as <- manyTill p end + return (a : as) + + lengthParser = do + _ <- char '[' + n <- numberParser + _ <- char ']' + pure n + +parseArray :: Parser SolidityType +parseArray = do + s <- (try $ parseVector <* string "[]") <|> (solidityBasicTypeParser <* string "[]") + pure $ SolidityArray s + + +solidityTypeParser :: Parser SolidityType +solidityTypeParser = + choice [ try parseArray + , try parseVector + , solidityBasicTypeParser + ] + +parseSolidityType :: Text -> Either ParseError SolidityType +parseSolidityType = parse solidityTypeParser "Solidity" diff --git a/src/Network/Ethereum/ABI/Prim/Address.hs b/src/Network/Ethereum/ABI/Prim/Address.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/Address.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Ethereum.ABI.Prim.Address +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI address type. +-- + +module Network.Ethereum.ABI.Prim.Address ( + Address + ) where + +import Control.Monad ((<=<)) +import Data.Aeson (FromJSON (..), ToJSON (..), + Value (String)) +import Data.ByteArray (Bytes, zero) +import Data.ByteArray.Encoding (Base (Base16), convertFromBase, + convertToBase) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 (drop, pack, take, unpack) +import Data.Monoid ((<>)) +import Data.String (IsString (..)) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Generics.SOP (Generic) +import qualified GHC.Generics as GHC (Generic) + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + ABIType (..)) +import Network.Ethereum.ABI.Codec (decode, encode) +import Network.Ethereum.ABI.Prim.Int (UIntN) + +-- | Ethereum account address +newtype Address = Address { unAddress :: UIntN 160 } + deriving (Eq, Ord, GHC.Generic) + +instance Generic Address + +-- TODO: Address . drop 12 . sha3 +{- +fromPublic :: ByteArrayAccess bin => bin -> Maybe Address +fromPublic = undefined +-} + +fromHexString :: ByteString -> Either String Address +fromHexString = decode . align <=< convertFromBase Base16 . trim0x + where trim0x s | C8.take 2 s == "0x" = C8.drop 2 s + | otherwise = s + align = (zero 12 <>) :: Bytes -> Bytes + +toHexString :: Address -> ByteString +toHexString = ("0x" <>) . convertToBase Base16 . C8.drop 12 . encode + +instance Show Address where + show = C8.unpack . toHexString + +instance IsString Address where + fromString = either error id . fromHexString . C8.pack + +instance ABIType Address where + isDynamic _ = False + +instance ABIGet Address where + abiGet = Address <$> abiGet + +instance ABIPut Address where + abiPut = abiPut . unAddress + +instance FromJSON Address where + parseJSON (String a) = either fail return $ fromHexString (encodeUtf8 a) + parseJSON _ = fail "Address should be a string" + +instance ToJSON Address where + toJSON = String . decodeUtf8 . toHexString diff --git a/src/Network/Ethereum/ABI/Prim/Bool.hs b/src/Network/Ethereum/ABI/Prim/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/Bool.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Network.Ethereum.ABI.Prim.Bool +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI boolean type. +-- + +module Network.Ethereum.ABI.Prim.Bool () where + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + ABIType (..)) +import Network.Ethereum.ABI.Prim.Int (getWord256, putWord256) + +instance ABIType Bool where + isDynamic _ = False + +instance ABIGet Bool where + abiGet = toEnum . fromIntegral <$> getWord256 + +instance ABIPut Bool where + abiPut = putWord256 . fromIntegral . fromEnum diff --git a/src/Network/Ethereum/ABI/Prim/Bytes.hs b/src/Network/Ethereum/ABI/Prim/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/Bytes.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Network.Ethereum.ABI.Prim.Bytes +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI bytes and bytesN types. +-- + +module Network.Ethereum.ABI.Prim.Bytes ( + Bytes + , BytesN + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..), + Value (String)) +import Data.ByteArray (Bytes, convert, length, zero) +import Data.ByteArray.Encoding (Base (Base16), convertFromBase, + convertToBase) +import Data.ByteArray.Sized (SizedByteArray, + unsafeFromByteArrayAccess) +import qualified Data.ByteArray.Sized as S (take) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Serialize (Get, Putter, getBytes, + putByteString) +import Data.String (IsString (..)) +import qualified Data.Text as T (append, drop, take) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import GHC.TypeLits +import Prelude hiding (length) + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + ABIType (..)) +import Network.Ethereum.ABI.Prim.Int (getWord256, putWord256) + +instance ABIType ByteString where + isDynamic _ = True + +instance ABIGet ByteString where + abiGet = abiGetByteString + +instance ABIPut ByteString where + abiPut = abiPutByteString + +instance ABIType Bytes where + isDynamic _ = True + +instance ABIGet Bytes where + abiGet = convert <$> abiGetByteString + +instance ABIPut Bytes where + abiPut = abiPutByteString . convert + +instance IsString Bytes where + fromString ('0' : 'x' : hex) = either error id $ convertFromBase Base16 (C8.pack hex) + fromString str = convert (C8.pack str) + +instance FromJSON Bytes where + parseJSON (String hex) + | T.take 2 hex == "0x" = + either fail pure $ convertFromBase Base16 $ encodeUtf8 $ T.drop 2 hex + | otherwise = fail "Hex string should have '0x' prefix" + parseJSON _ = fail "Bytes should be encoded as hex string" + +instance ToJSON Bytes where + toJSON = toJSON . T.append "0x" . decodeUtf8 . convertToBase Base16 + +type BytesN n = SizedByteArray n Bytes + +instance (n <= 32) => ABIType (BytesN n) where + isDynamic _ = False + +instance (KnownNat n, n <= 32) => ABIGet (BytesN n) where + abiGet = do + ba <- unsafeFromByteArrayAccess <$> getBytes 32 + return $ S.take (ba :: BytesN 32) + +instance (KnownNat n, n <= 32) => ABIPut (BytesN n) where + abiPut ba = putByteString $ convert ba <> zero (32 - len) + where len = fromIntegral $ natVal (Proxy :: Proxy n) + +instance (KnownNat n, n <= 32) => IsString (BytesN n) where + fromString = unsafeFromByteArrayAccess . (fromString :: String -> Bytes) + +abiGetByteString :: Get ByteString +abiGetByteString = do + len <- fromIntegral <$> getWord256 + ba <- getBytes len + _ <- getBytes $ 32 - len `mod` 32 + return ba + +abiPutByteString :: Putter ByteString +abiPutByteString bs = do + putWord256 $ fromIntegral len + putByteString $ bs <> zero (32 - len `mod` 32) + where len = length bs diff --git a/src/Network/Ethereum/ABI/Prim/Int.hs b/src/Network/Ethereum/ABI/Prim/Int.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/Int.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Network.Ethereum.Encoding.Prim.Int +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI intN and uintN types. +-- + +module Network.Ethereum.ABI.Prim.Int ( + IntN + , UIntN + , getWord256 + , putWord256 + ) where + +import qualified Basement.Numerical.Number as Basement (toInteger) +import Basement.Types.Word256 (Word256 (Word256)) +import qualified Basement.Types.Word256 as Basement (quot, rem) +import Data.Bits (Bits (testBit)) +import Data.Proxy (Proxy (..)) +import Data.Serialize (Get, Putter, Serialize (get, put)) +import GHC.Generics (Generic) +import GHC.TypeLits + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + ABIType (..)) + +instance Real Word256 where + toRational = toRational . toInteger + +instance Integral Word256 where + toInteger = Basement.toInteger + quotRem a b = (Basement.quot a b, Basement.rem a b) + +newtype UIntN (n :: Nat) = UIntN { unUIntN :: Word256 } + deriving (Eq, Ord, Enum, Num, Bits, Generic) + +instance (KnownNat n, n <= 256) => Show (UIntN n) where + show = show . unUIntN + +instance (KnownNat n, n <= 256) => Bounded (UIntN n) where + minBound = 0 + maxBound = 2 ^ (natVal (Proxy :: Proxy n)) - 1 + +instance (KnownNat n, n <= 256) => Real (UIntN n) where + toRational = toRational . toInteger + +instance (KnownNat n, n <= 256) => Integral (UIntN n) where + toInteger = toInteger . unUIntN + quotRem (UIntN a) (UIntN b) = (UIntN $ quot a b, UIntN $ rem a b) + +instance (n <= 256) => ABIType (UIntN n) where + isDynamic _ = False + +instance (n <= 256) => ABIGet (UIntN n) where + abiGet = UIntN <$> getWord256 + +instance (n <= 256) => ABIPut (UIntN n) where + abiPut = putWord256 . unUIntN + +-- TODO: Signed data type +newtype IntN (n :: Nat) = IntN { unIntN :: Word256 } + deriving (Eq, Ord, Enum, Bits, Generic) + +instance (KnownNat n, n <= 256) => Show (IntN n) where + show = show . toInteger + +instance (KnownNat n, n <= 256) => Bounded (IntN n) where + minBound = negate $ 2 ^ (natVal (Proxy :: Proxy (n :: Nat)) - 1) + maxBound = 2 ^ (natVal (Proxy :: Proxy (n :: Nat)) - 1) - 1 + +instance (KnownNat n, n <= 256) => Num (IntN n) where + a + b = fromInteger (toInteger a + toInteger b) + a - b = fromInteger (toInteger a - toInteger b) + a * b = fromInteger (toInteger a * toInteger b) + abs = fromInteger . abs . toInteger + negate = fromInteger . negate . toInteger + signum = fromInteger . signum . toInteger + fromInteger x + | x >= 0 = IntN (fromInteger x) + | otherwise = IntN (fromInteger $ 2 ^ 256 + x) + +instance (KnownNat n, n <= 256) => Real (IntN n) where + toRational = toRational . toInteger + +instance (KnownNat n, n <= 256) => Integral (IntN n) where + quotRem (IntN a) (IntN b) = (IntN $ quot a b, IntN $ rem a b) + toInteger x + | testBit x 255 = toInteger (unIntN x) - 2 ^ 256 + | otherwise = toInteger $ unIntN x + +instance (n <= 256) => ABIType (IntN n) where + isDynamic _ = False + +instance (n <= 256) => ABIGet (IntN n) where + abiGet = IntN <$> getWord256 + +instance (n <= 256) => ABIPut (IntN n) where + abiPut = putWord256 . unIntN + +putWord256 :: Putter Word256 +putWord256 (Word256 a3 a2 a1 a0) = + put a3 >> put a2 >> put a1 >> put a0 + +getWord256 :: Get Word256 +getWord256 = Word256 <$> get <*> get <*> get <*> get diff --git a/src/Network/Ethereum/ABI/Prim/List.hs b/src/Network/Ethereum/ABI/Prim/List.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/List.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Network.Ethereum.ABI.Prim.List +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI dynamic and static size vectors based on linked lists. +-- + +module Network.Ethereum.ABI.Prim.List ( + ListN + ) where + +import Basement.Nat (NatWithinBound) +import Basement.Sized.List (ListN, toListN_, unListN) +import qualified Basement.Sized.List as SL (mapM_, replicateM) +import Control.Monad (replicateM) +import GHC.Exts (IsList (..)) +import GHC.TypeLits (KnownNat) + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + ABIType (..)) +import Network.Ethereum.ABI.Prim.Int (getWord256, putWord256) + +instance ABIType [a] where + isDynamic _ = True + +instance ABIPut a => ABIPut [a] where + abiPut l = do putWord256 $ fromIntegral (length l) + foldMap abiPut l + +instance ABIGet a => ABIGet [a] where + abiGet = do len <- fromIntegral <$> getWord256 + replicateM len abiGet + +instance ABIType (ListN n a) where + isDynamic _ = False + +instance ABIPut a => ABIPut (ListN n a) where + abiPut = SL.mapM_ abiPut + +instance (NatWithinBound Int n, KnownNat n, ABIGet a) => ABIGet (ListN n a) where + abiGet = SL.replicateM abiGet + +instance (NatWithinBound Int n, KnownNat n) => IsList (ListN n a) where + type Item (ListN n a) = a + fromList = toListN_ + toList = unListN diff --git a/src/Network/Ethereum/ABI/Prim/String.hs b/src/Network/Ethereum/ABI/Prim/String.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/String.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Network.Ethereum.ABI.Prim.String +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI UTF8-encoded string type. +-- + +module Network.Ethereum.ABI.Prim.String () where + +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + ABIType (..)) +import Network.Ethereum.ABI.Prim.Bytes () + +instance ABIType Text where + isDynamic _ = True + +instance ABIPut Text where + abiPut = abiPut . encodeUtf8 + +instance ABIGet Text where + abiGet = decodeUtf8 <$> abiGet diff --git a/src/Network/Ethereum/ABI/Prim/Tagged.hs b/src/Network/Ethereum/ABI/Prim/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/Tagged.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Network.Ethereum.ABI.Prim.Tagged +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Ethereum ABI UTF8-encoded tagged types. +-- + +module Network.Ethereum.ABI.Prim.Tagged ( + Tagged + ) where + +import Data.Proxy (Proxy (..)) +import Data.Tagged (Tagged (..)) +import Generics.SOP (Generic) + +import Network.Ethereum.ABI.Class (ABIGet (..), ABIPut (..), + ABIType (..)) + +instance ABIType a => ABIType (Tagged t a) where + isDynamic _ = isDynamic (Proxy :: Proxy a) + +instance ABIPut a => ABIPut (Tagged t a) where + abiPut (Tagged a) = abiPut a + +instance ABIGet a => ABIGet (Tagged t a) where + abiGet = Tagged <$> abiGet + +instance Generic a => Generic (Tagged t a) diff --git a/src/Network/Ethereum/ABI/Prim/Tuple.hs b/src/Network/Ethereum/ABI/Prim/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/Tuple.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Network.Ethereum.ABI.Prim.Tuple +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Tuple type abi encoding instances. +-- + +module Network.Ethereum.ABI.Prim.Tuple ( + Singleton(..) + ) where + +import Data.Proxy (Proxy (..)) +import Generics.SOP (Generic) +import qualified GHC.Generics as GHC (Generic) + +import Network.Ethereum.ABI.Class (ABIGet, ABIPut, + ABIType (..)) +import Network.Ethereum.ABI.Generic () +import Network.Ethereum.ABI.Prim.Tuple.TH (tupleDecs) + +-- | The type for one-tuples +newtype Singleton a = Singleton { unSingleton :: a } + deriving GHC.Generic + +deriving instance Eq a => Eq (Singleton a) +deriving instance Show a => Show (Singleton a) +instance Generic (Singleton a) + +instance ABIType a => ABIType (Singleton a) where + isDynamic _ = isDynamic (Proxy :: Proxy a) + +instance ABIGet a => ABIGet (Singleton a) +instance ABIPut a => ABIPut (Singleton a) + +$(fmap concat $ sequence $ map tupleDecs [2..20]) diff --git a/src/Network/Ethereum/ABI/Prim/Tuple/TH.hs b/src/Network/Ethereum/ABI/Prim/Tuple/TH.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/ABI/Prim/Tuple/TH.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Network.Ethereum.ABI.Prim.Tuple.TH +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- This module is for internal usage only. +-- It contains tuple abi encoding template haskell generator. +-- + +module Network.Ethereum.ABI.Prim.Tuple.TH (tupleDecs) where + + +import Control.Monad (replicateM) +import Language.Haskell.TH (DecsQ, Type (VarT), appT, clause, + conT, cxt, funD, instanceD, + newName, normalB, tupleT) + +import Network.Ethereum.ABI.Class (ABIGet, ABIPut, ABIType (..)) + +tupleDecs :: Int -> DecsQ +tupleDecs n = do + vars <- replicateM n $ newName "a" + let types = fmap (pure . VarT) vars + sequence $ + [ instanceD (cxt $ map (appT $ conT ''ABIType) types) (appT (conT ''ABIType) (foldl appT (tupleT n) types)) + [funD 'isDynamic [clause [] (normalB [|const False|]) []]] + , instanceD (cxt $ map (appT $ conT ''ABIGet) types) (appT (conT ''ABIGet) (foldl appT (tupleT n) types)) [] + , instanceD (cxt $ map (appT $ conT ''ABIPut) types) (appT (conT ''ABIPut) (foldl appT (tupleT n) types)) [] ] diff --git a/src/Network/Ethereum/Contract/Event.hs b/src/Network/Ethereum/Contract/Event.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/Contract/Event.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Network.Ethereum.Contract.Event +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Ethereum contract event support. +-- + +module Network.Ethereum.Contract.Event ( + EventAction(..) + , event + , event' + , eventMany' + ) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forM, void, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Either (rights) +import Data.Machine (MachineT, asParts, autoM, + await, construct, final, + mapping, repeatedly, runT, + unfoldPlan, (~>)) +import Data.Machine.Plan (PlanT, stop, yield) +import Data.Maybe (listToMaybe) + +import Control.Concurrent.Async (Async) +import Network.Ethereum.ABI.Event (DecodeEvent (..)) +import qualified Network.Ethereum.Web3.Eth as Eth +import Network.Ethereum.Web3.Provider (Web3, forkWeb3) +import Network.Ethereum.Web3.Types (BlockNumber (..), Change (..), + DefaultBlock (..), Filter (..), + FilterId) + +-- | Event callback control response +data EventAction = ContinueEvent + -- ^ Continue to listen events + | TerminateEvent + -- ^ Terminate event listener + deriving (Show, Eq) + +-- | Run 'event\'' one block at a time. +event :: DecodeEvent i ni e + => Filter e + -> (e -> ReaderT Change Web3 EventAction) + -> Web3 (Async ()) +event fltr = forkWeb3 . event' fltr + +-- | Same as 'event', but does not immediately spawn a new thread. +event' :: DecodeEvent i ni e + => Filter e + -> (e -> ReaderT Change Web3 EventAction) + -> Web3 () +event' fltr = eventMany' fltr 0 + +-- | 'eventMany\'' take s a filter, a window size, and a handler. +-- +-- It runs the handler over the results of 'eventLogs' results using +-- 'reduceEventStream'. If no 'TerminateEvent' action is thrown and +-- the toBlock is not yet reached, it then transitions to polling. +-- +eventMany' :: DecodeEvent i ni e + => Filter e + -> Integer + -> (e -> ReaderT Change Web3 EventAction) + -> Web3 () +eventMany' fltr window handler = do + start <- mkBlockNumber $ filterFromBlock fltr + let initState = FilterStreamState { fssCurrentBlock = start + , fssInitialFilter = fltr + , fssWindowSize = window + } + mLastProcessedFilterState <- reduceEventStream (playLogs initState) handler + case mLastProcessedFilterState of + Nothing -> startPolling fltr {filterFromBlock = BlockWithNumber start} + Just (act, lastBlock) -> do + end <- mkBlockNumber . filterToBlock $ fltr + when (act /= TerminateEvent && lastBlock < end) $ + let pollingFromBlock = lastBlock + 1 + in startPolling fltr {filterFromBlock = BlockWithNumber pollingFromBlock} + where + startPolling fltr' = do + filterId <- Eth.newFilter fltr' + let pollTo = filterToBlock fltr' + void $ reduceEventStream (pollFilter filterId pollTo) handler + +-- | Effectively a mapM_ over the machine using the given handler. +reduceEventStream :: Monad m + => MachineT m k [FilterChange a] + -> (a -> ReaderT Change m EventAction) + -> m (Maybe (EventAction, BlockNumber)) +reduceEventStream filterChanges handler = fmap listToMaybe . runT $ + filterChanges + ~> autoM (processChanges handler) + ~> asParts + ~> runWhile (\(act, _) -> act /= TerminateEvent) + ~> final + where + runWhile p = repeatedly $ do + v <- await + if p v + then yield v + else yield v >> stop + processChanges :: Monad m + => (a -> ReaderT Change m EventAction) + -> [FilterChange a] + -> m [(EventAction, BlockNumber)] + processChanges handler' changes = + forM changes $ \FilterChange{..} -> do + act <- flip runReaderT filterChangeRawChange $ + handler' filterChangeEvent + return (act, changeBlockNumber filterChangeRawChange) + +data FilterChange a = FilterChange { filterChangeRawChange :: Change + , filterChangeEvent :: a + } + +-- | 'playLogs' streams the 'filterStream' and calls eth_getLogs on these 'Filter' objects. +playLogs :: DecodeEvent i ni e + => FilterStreamState e + -> MachineT Web3 k [FilterChange e] +playLogs s = filterStream s + ~> autoM Eth.getLogs + ~> mapping mkFilterChanges + +-- | Polls a filter from the given filterId until the target toBlock is reached. +pollFilter :: forall i ni e k . DecodeEvent i ni e + => FilterId + -> DefaultBlock + -> MachineT Web3 k [FilterChange e] +pollFilter i = construct . pollPlan i + where + pollPlan :: FilterId -> DefaultBlock -> PlanT k [FilterChange e] Web3 () + pollPlan fid end = do + bn <- lift $ Eth.blockNumber + if BlockWithNumber bn > end + then do + _ <- lift $ Eth.uninstallFilter fid + stop + else do + liftIO $ threadDelay 1000000 + changes <- lift $ Eth.getFilterChanges fid + yield $ mkFilterChanges changes + pollPlan fid end + +mkFilterChanges :: DecodeEvent i ni e + => [Change] + -> [FilterChange e] +mkFilterChanges = rights + . fmap (\c@Change{..} -> FilterChange c <$> decodeEvent c) + +data FilterStreamState e = + FilterStreamState { fssCurrentBlock :: BlockNumber + , fssInitialFilter :: Filter e + , fssWindowSize :: Integer + } + + +-- | 'filterStream' is a machine which represents taking an initial filter +-- over a range of blocks b1, ... bn (where bn is possibly `Latest` or `Pending`, +-- but b1 is an actual `BlockNumber`), and making a stream of filter objects +-- which cover this filter in intervals of size `windowSize`. The machine +-- halts whenever the `fromBlock` of a spanning filter either (1) excedes then +-- initial filter's `toBlock` or (2) is greater than the chain head's `BlockNumber`. +filterStream :: FilterStreamState e + -> MachineT Web3 k (Filter e) +filterStream initialPlan = unfoldPlan initialPlan filterPlan + where + filterPlan :: FilterStreamState e -> PlanT k (Filter e) Web3 (FilterStreamState e) + filterPlan initialState@FilterStreamState{..} = do + end <- lift . mkBlockNumber $ filterToBlock fssInitialFilter + if fssCurrentBlock > end + then stop + else do + let to' = newTo end fssCurrentBlock fssWindowSize + filter' = fssInitialFilter { filterFromBlock = BlockWithNumber fssCurrentBlock + , filterToBlock = BlockWithNumber to' + } + yield filter' + filterPlan $ initialState { fssCurrentBlock = succBn to' } + succBn :: BlockNumber -> BlockNumber + succBn (BlockNumber bn) = BlockNumber $ bn + 1 + newTo :: BlockNumber -> BlockNumber -> Integer -> BlockNumber + newTo upper (BlockNumber current) window = min upper . BlockNumber $ current + window + +-- | Coerce a 'DefaultBlock' into a numerical block number. +mkBlockNumber :: DefaultBlock -> Web3 BlockNumber +mkBlockNumber bm = case bm of + BlockWithNumber bn -> return bn + Earliest -> return 0 + _ -> Eth.blockNumber diff --git a/src/Network/Ethereum/Contract/Method.hs b/src/Network/Ethereum/Contract/Method.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/Contract/Method.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Network.Ethereum.Contract.Method +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Ethereum contract method support. +-- + +module Network.Ethereum.Contract.Method ( + Method(..) + , call + , sendTx + ) where + +import Control.Monad.Catch (throwM) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) + +import Network.Ethereum.ABI.Class (ABIGet, ABIPut, ABIType (..)) +import Network.Ethereum.ABI.Codec (decode, encode) +import Network.Ethereum.ABI.Prim.Bytes (Bytes) +import qualified Network.Ethereum.Web3.Eth as Eth +import Network.Ethereum.Web3.Provider (Web3, Web3Error (ParserFail)) +import Network.Ethereum.Web3.Types (Call (callData), DefaultBlock, + TxHash) + +class ABIPut a => Method a where + selector :: Proxy a -> Bytes + +instance ABIType () where + isDynamic _ = False + +instance ABIPut () + +-- | Send transaction without method selection +instance Method () where + selector = mempty + +-- | 'sendTx' is used to submit a state changing transaction. +sendTx :: Method a + => Call + -- ^ Call configuration + -> a + -- ^ method data + -> Web3 TxHash +sendTx call' (dat :: a) = + let sel = selector (Proxy :: Proxy a) + in Eth.sendTransaction (call' { callData = Just $ sel <> encode dat }) + +-- | 'call' is used to call contract methods that have no state changing effects. +call :: (Method a, ABIGet b) + => Call + -- ^ Call configuration + -> DefaultBlock + -- ^ State mode for constant call (latest or pending) + -> a + -- ^ Method data + -> Web3 b + -- ^ 'Web3' wrapped result +call call' mode (dat :: a) = do + let sel = selector (Proxy :: Proxy a) + res <- Eth.call (call' { callData = Just $ sel <> encode dat }) mode + case decode res of + Left e -> throwM $ ParserFail $ "Unable to parse response: " ++ e + Right x -> return x diff --git a/src/Network/Ethereum/Contract/TH.hs b/src/Network/Ethereum/Contract/TH.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum/Contract/TH.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Network.Ethereum.Contract.TH +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Contract abstraction is a high level interface of web3 library. +-- +-- The Application Binary Interface is the standard way to interact +-- with contracts in the Ethereum ecosystem. It can be described by +-- specially JSON file, like @ERC20.json@. This module use TemplateHaskell +-- for generation described in ABI contract methods and events. Helper +-- functions and instances inserted in haskell module and can be used in +-- another modules or in place. +-- +-- @ +-- import Network.Ethereum.Contract.TH +-- +-- [abiFrom|examples/ERC20.json|] +-- +-- main = do +-- runWeb3 $ event' def $ +-- \(Transfer _ to val) -> liftIO $ do print to +-- print val +-- @ +-- +-- Full code example available in examples folder. +-- + +module Network.Ethereum.Contract.TH (abi, abiFrom) where + +import Control.Monad (replicateM, (<=<)) +import Data.Aeson (eitherDecode) +import Data.Default (Default (..)) +import Data.List (groupBy, sortBy, uncons) +import Data.Monoid ((<>)) +import Data.Tagged (Tagged) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Generics.SOP (Generic) +import qualified GHC.Generics as GHC (Generic) +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Data.String.Extra (toLowerFirst, toUpperFirst) +import Network.Ethereum.ABI.Class (ABIGet, ABIPut, + ABIType (..)) +import Network.Ethereum.ABI.Event (IndexedEvent (..)) +import Network.Ethereum.ABI.Json (ContractABI (..), + Declaration (..), + EventArg (..), + FunctionArg (..), + SolidityType (..), eventId, + methodId, parseSolidityType) +import Network.Ethereum.ABI.Prim.Address (Address) +import Network.Ethereum.ABI.Prim.Bytes (Bytes, BytesN) +import Network.Ethereum.ABI.Prim.Int (IntN, UIntN) +import Network.Ethereum.ABI.Prim.List (ListN) +import Network.Ethereum.ABI.Prim.String () +import Network.Ethereum.ABI.Prim.Tagged () +import Network.Ethereum.ABI.Prim.Tuple (Singleton (..)) +import Network.Ethereum.Contract.Method (Method (..), call, sendTx) +import Network.Ethereum.Web3.Provider (Web3) +import Network.Ethereum.Web3.Types (Call, DefaultBlock (..), + Filter (..), TxHash) + +-- | Read contract ABI from file +abiFrom :: QuasiQuoter +abiFrom = quoteFile abi + +-- | QQ reader for contract ABI +abi :: QuasiQuoter +abi = QuasiQuoter + { quoteDec = quoteAbiDec + , quoteExp = quoteAbiExp + , quotePat = undefined + , quoteType = undefined + } + +-- | Instance declaration with empty context +instanceD' :: Name -> TypeQ -> [DecQ] -> DecQ +instanceD' name insType = + instanceD (cxt []) (appT insType (conT name)) + +-- | Simple data type declaration with one constructor +dataD' :: Name -> ConQ -> [Name] -> DecQ +dataD' name rec derive = +#if MIN_VERSION_template_haskell(2,12,0) + dataD (cxt []) name [] Nothing [rec] [derivClause Nothing (conT <$> derive)] +#else + dataD (cxt []) name [] Nothing [rec] $ cxt (conT <$> derive) +#endif + +-- | Simple function declaration +funD' :: Name -> [PatQ] -> ExpQ -> DecQ +funD' name p f = funD name [clause p (normalB f) []] + +-- | ABI and Haskell types association +toHSType :: SolidityType -> TypeQ +toHSType s = case s of + SolidityBool -> conT ''Bool + SolidityAddress -> conT ''Address + SolidityUint n -> appT (conT ''UIntN) (numLit n) + SolidityInt n -> appT (conT ''IntN) (numLit n) + SolidityString -> conT ''Text + SolidityBytesN n -> appT (conT ''BytesN) (numLit n) + SolidityBytes -> conT ''Bytes + SolidityVector ns a -> expandVector ns a + SolidityArray a -> appT listT $ toHSType a + where + numLit n = litT (numTyLit $ toInteger n) + expandVector :: [Int] -> SolidityType -> TypeQ + expandVector ns a = case uncons ns of + Just (n, rest) -> + if length rest == 0 + then (conT ''ListN) `appT` numLit n `appT` toHSType a + else (conT ''ListN) `appT` numLit n `appT` expandVector rest a + _ -> error $ "Impossible Nothing branch in `expandVector`: " ++ show ns ++ " " ++ show a + +typeQ :: Text -> TypeQ +typeQ t = case parseSolidityType t of + Left e -> error $ "Unable to parse solidity type: " ++ show e + Right ty -> toHSType ty + +-- | Function argument to TH type +funBangType :: FunctionArg -> BangTypeQ +funBangType (FunctionArg _ typ) = + bangType (bang sourceNoUnpack sourceStrict) (typeQ typ) + +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 : _ : vars <- replicateM (length args + 2) (newName "t") + let params = appsE $ conE dname : fmap varE vars + + sequence $ if c + then + [ sigD name $ [t|$(arrowing $ [t|Call|] : inputT ++ [outputT])|] + , funD' name (varP <$> a : vars) $ + case result of + Just [_] -> [|unSingleton <$> call $(varE a) Latest $(params)|] + _ -> [|call $(varE a) Latest $(params)|] + ] + + else + [ sigD name $ [t|$(arrowing $ [t|Call|] : inputT ++ [[t|Web3 TxHash|]])|] + , funD' name (varP <$> a : vars) $ + [|sendTx $(varE a) $(params)|] ] + where + arrowing [] = error "Impossible branch call" + 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)|] + +mkDecl :: Declaration -> Q [Dec] + +mkDecl ev@(DEvent name inputs anonymous) = sequence + [ dataD' indexedName (normalC indexedName (map (toBang <=< tag) indexedArgs)) derivingD + , instanceD' indexedName (conT ''Generic) [] + , instanceD' indexedName (conT ''ABIType) [funD' 'isDynamic [] [|const False|]] + , instanceD' indexedName (conT ''ABIGet) [] + , dataD' nonIndexedName (normalC nonIndexedName (map (toBang <=< tag) nonIndexedArgs)) derivingD + , instanceD' nonIndexedName (conT ''Generic) [] + , instanceD' nonIndexedName (conT ''ABIType) [funD' 'isDynamic [] [|const False|]] + , instanceD' nonIndexedName (conT ''ABIGet) [] + , dataD' allName (recC allName (map (\(n, a) -> ((\(b,t) -> return (n,b,t)) <=< toBang <=< typeQ $ a)) allArgs)) derivingD + , instanceD' allName (conT ''Generic) [] + , instanceD (cxt []) + (pure $ ConT ''IndexedEvent `AppT` ConT indexedName `AppT` ConT nonIndexedName `AppT` ConT allName) + [funD' 'isAnonymous [] [|const anonymous|]] + , instanceD (cxt []) + (pure $ ConT ''Default `AppT` (ConT ''Filter `AppT` ConT allName)) + [funD' 'def [] [|Filter Nothing (Just topics) Latest Latest|] ] + ] + where + topics = [Just (T.unpack $ eventId ev)] <> replicate (length indexedArgs) Nothing + toBang ty = bangType (bang sourceNoUnpack sourceStrict) (return ty) + tag (n, ty) = AppT (AppT (ConT ''Tagged) (LitT $ NumTyLit n)) <$> typeQ ty + labeledArgs = zip [1..] inputs + indexedArgs = map (\(n, ea) -> (n, eveArgType ea)) . filter (eveArgIndexed . snd) $ labeledArgs + indexedName = mkName $ toUpperFirst (T.unpack name) <> "Indexed" + nonIndexedArgs = map (\(n, ea) -> (n, eveArgType ea)) . filter (not . eveArgIndexed . snd) $ labeledArgs + nonIndexedName = mkName $ toUpperFirst (T.unpack name) <> "NonIndexed" + allArgs = makeArgs name $ map (\i -> (eveArgName i, eveArgType i)) inputs + allName = mkName $ toUpperFirst (T.unpack name) + derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic] + +-- | Method delcarations maker +mkDecl fun@(DFunction name constant inputs outputs) = (++) + <$> funWrapper constant fnName dataName inputs outputs + <*> sequence + [ dataD' dataName (normalC dataName bangInput) derivingD + , instanceD' dataName (conT ''Generic) [] + , instanceD' dataName (conT ''ABIType) + [funD' 'isDynamic [] [|const False|]] + , instanceD' dataName (conT ''ABIPut) [] + , instanceD' dataName (conT ''ABIGet) [] + , instanceD' dataName (conT ''Method) + [funD' 'selector [] [|const mIdent|]] + ] + where mIdent = T.unpack (methodId $ fun {funName = T.replace "'" "" name}) + dataName = mkName (toUpperFirst (T.unpack $ name <> "Data")) + fnName = mkName (toLowerFirst (T.unpack name)) + bangInput = fmap funBangType inputs + derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic] + +mkDecl _ = return [] + +-- | this function gives appropriate names for the accessors in the following way +-- | argName -> evArgName +-- | arg_name -> evArg_name +-- | _argName -> evArgName +-- | "" -> evi , for example Transfer(address, address uint256) ~> Transfer {transfer1 :: address, transfer2 :: address, transfer3 :: Integer} +makeArgs :: Text -> [(Text, Text)] -> [(Name, Text)] +makeArgs prefix ns = go 1 ns + where + prefixStr = toLowerFirst . T.unpack $ prefix + go :: Int -> [(Text, Text)] -> [(Name, Text)] + go _ [] = [] + go i ((h, ty) : tail') = if T.null h + then (mkName $ prefixStr ++ show i, ty) : go (i + 1) tail' + else (mkName . (++ "_") . (++) prefixStr . toUpperFirst . T.unpack $ h, ty) : go (i + 1) tail' + +escape :: [Declaration] -> [Declaration] +escape = concat . escapeNames . groupBy fnEq . sortBy fnCompare + where fnEq (DFunction n1 _ _ _) (DFunction n2 _ _ _) = n1 == n2 + fnEq _ _ = False + fnCompare (DFunction n1 _ _ _) (DFunction n2 _ _ _) = compare n1 n2 + fnCompare _ _ = GT + +escapeNames :: [[Declaration]] -> [[Declaration]] +escapeNames = fmap go + where go [] = [] + go (x : xs) = x : zipWith appendToName xs hats + hats = [T.replicate n "'" | n <- [1..]] + appendToName dfn addition = dfn { funName = funName dfn <> addition } + +-- | ABI to declarations converter +quoteAbiDec :: String -> Q [Dec] +quoteAbiDec abi_string = + case eitherDecode abi_lbs of + Left e -> fail $ "Error: " ++ show e + Right (ContractABI a) -> concat <$> mapM mkDecl (escape a) + where abi_lbs = LT.encodeUtf8 (LT.pack abi_string) + +-- | ABI information string +quoteAbiExp :: String -> ExpQ +quoteAbiExp abi_string = stringE $ + case eitherDecode abi_lbs of + Left e -> "Error: " ++ show e + Right a -> show (a :: ContractABI) + where abi_lbs = LT.encodeUtf8 (LT.pack abi_string) diff --git a/src/Network/Ethereum/Unit.hs b/src/Network/Ethereum/Unit.hs --- a/src/Network/Ethereum/Unit.hs +++ b/src/Network/Ethereum/Unit.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} + -- | -- Module : Network.Ethereum.Unit --- Copyright : Alexander Krupenkin 2016 +-- Copyright : Alexander Krupenkin 2016-2018 -- License : BSD3 -- -- Maintainer : mail@akru.me @@ -43,8 +46,10 @@ -- Actual type: Szabo -- @ -- + module Network.Ethereum.Unit ( Unit(..) + , UnitSpec(..) , Wei , Babbage , Lovelace @@ -55,7 +60,7 @@ , KEther ) where -import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) import Data.Text.Lazy (Text, unpack) import GHC.Generics (Generic) import GHC.Read @@ -76,26 +81,23 @@ -- | Unit specification class UnitSpec a where - divider :: RealFrac b => Value a -> b - name :: Value a -> Text + divider :: RealFrac b => proxy a -> b + name :: proxy a -> Text -- | Value abstraction -data Value a = MkValue { unValue :: Integer } +newtype Value a = MkValue { unValue :: Integer } deriving (Eq, Ord, Generic) -mkValue :: (UnitSpec a, RealFrac b) => b -> Value a -mkValue = modify res . round . (divider res *) - where res = undefined :: UnitSpec a => Value a - modify :: Value a -> Integer -> Value a - modify _ = MkValue +mkValue :: forall a b . (UnitSpec a, RealFrac b) => b -> Value a +mkValue = MkValue . round . (* divider (Proxy :: Proxy a)) instance UnitSpec a => Unit (Value a) where fromWei = MkValue toWei = unValue instance UnitSpec a => UnitSpec (Value a) where - divider = divider . (undefined :: Value (Value a) -> Value a) - name = name . (undefined :: Value (Value a) -> Value a) + divider = const $ divider (Proxy :: Proxy a) + name = const $ name (Proxy :: Proxy a) instance UnitSpec a => Num (Value a) where a + b = MkValue (unValue a + unValue b) 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 @@ -1,11 +1,11 @@ -- | -- Module : Network.Ethereum.Web3 --- Copyright : Alexander Krupenkin 2016 +-- Copyright : Alexander Krupenkin 2016-2018 -- License : BSD3 -- -- Maintainer : mail@akru.me -- Stability : experimental --- Portability : unknown +-- Portability : unportable -- -- An Ethereum node offers a RPC interface. This interface gives Ðapp’s -- access to the Ethereum blockchain and functionality that the node provides, @@ -16,34 +16,44 @@ -- -- Web3 Haskell library currently use JSON-RPC over HTTP to access node functionality. -- + module Network.Ethereum.Web3 ( - -- ** Web3 monad and service provider + + -- ** Monad as base of any Ethereum node communication Web3 - , Provider(..) - , DefaultProvider - , Web3Error(..) - , forkWeb3 - , runWeb3' , runWeb3 - -- ** Contract actions + + -- ** Basic transaction sending + , sendTx + , Call(..) + + -- ** Basic event listening , EventAction(..) - , Event(..) - , Method(..) - , NoMethod(..) - , nopay - -- ** Ethereum data types - , BytesN(..) - , BytesD(..) + , event + , event' + + -- ** Primitive data types , Address - -- ** Ethereum unit conversion utils + , Bytes + , BytesN + , IntN + , UIntN + , ListN + + -- ** Metric unit system , module Network.Ethereum.Unit + ) where +import Network.Ethereum.ABI.Prim.Address (Address) +import Network.Ethereum.ABI.Prim.Bool () +import Network.Ethereum.ABI.Prim.Bytes (Bytes, BytesN) +import Network.Ethereum.ABI.Prim.Int (IntN, UIntN) +import Network.Ethereum.ABI.Prim.List (ListN) +import Network.Ethereum.ABI.Prim.String () +import Network.Ethereum.Contract.Event (EventAction (..), event, + event') +import Network.Ethereum.Contract.Method (sendTx) import Network.Ethereum.Unit -import Network.Ethereum.Web3.Address -import Network.Ethereum.Web3.Contract -import Network.Ethereum.Web3.Encoding -import Network.Ethereum.Web3.Encoding.Bytes -import Network.Ethereum.Web3.Encoding.Tuple -import Network.Ethereum.Web3.Provider -import Network.Ethereum.Web3.Types +import Network.Ethereum.Web3.Provider (Web3, runWeb3) +import Network.Ethereum.Web3.Types (Call (..)) diff --git a/src/Network/Ethereum/Web3/Address.hs b/src/Network/Ethereum/Web3/Address.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Address.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} --- | --- Module : Network.Ethereum.Web3.Address --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : unknown --- --- Ethereum address type, render and parser. --- -module Network.Ethereum.Web3.Address ( - Address - , fromText - , toText - , zero - ) where - -import Control.Monad ((<=<)) -import Data.Aeson (FromJSON (..), ToJSON (..), - Value (..)) -import qualified Data.Char as C -import Data.Monoid ((<>)) -import Data.String (IsString (..)) -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (toLazyText) -import Data.Text.Lazy.Builder.Int as B (hexadecimal) -import Data.Text.Read as R (hexadecimal) - -import GHC.Generics (Generic) - --- | Ethereum account address -newtype Address = Address { unAddress :: Integer } - deriving (Eq, Ord, Generic) - -instance Show Address where - show = unpack . toText - -instance IsString Address where - fromString a = case fromText (pack a) of - Right address -> address - Left e -> error e - -instance FromJSON Address where - parseJSON (String a) = either fail return (fromText a) - parseJSON _ = fail "Address should be a string" - -instance ToJSON Address where - toJSON = toJSON . ("0x" <>) . toText - --- | Parse 'Address' from text string -fromText :: Text -> Either String Address -fromText = fmap (Address . fst) . R.hexadecimal <=< check - where check t | T.take 2 t == "0x" = check (T.drop 2 t) - | otherwise = do if T.length t == 40 then pure () else lengthError - if T.all C.isHexDigit t then pure () else invalidCharError - pure t - lengthError = Left "Invalid Address: text length not equal to 20" - invalidCharError = Left "Invalid Address: contains non-hex character" - --- | Render 'Address' to text string -toText :: Address -> Text -toText = wFix . toStrict . toLazyText . B.hexadecimal . unAddress - where wFix x | T.length x < 40 = T.replicate (40 - T.length x) "0" <> x - | otherwise = x - --- | Null address -zero :: Address -zero = Address 0 diff --git a/src/Network/Ethereum/Web3/Contract.hs b/src/Network/Ethereum/Web3/Contract.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Contract.hs +++ /dev/null @@ -1,165 +0,0 @@ --- | --- Module : Network.Ethereum.Web3.Contract --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : portable --- --- Ethereum contract generalized interface, e.g. 'event' function --- catch all event depend by given callback function type. --- --- @ --- runWeb3 $ do --- event "0x..." $ \(MyEvent a b c) -> --- liftIO $ print (a + b * c)) --- @ --- --- In other case 'call' function used for constant calls (without --- transaction creation and change state), and 'sendTx' function --- like a 'call' but return no contract method return but created --- transaction hash. --- --- @ --- runweb3 $ do --- x <- call "0x.." Latest MySelector --- tx <- sendTx "0x.." nopay $ MySelector2 (x + 2) --- @ --- -module Network.Ethereum.Web3.Contract ( - EventAction(..) - , Method(..) - , Event(..) - , NoMethod(..) - , nopay - ) where - -import Control.Concurrent (ThreadId, threadDelay) -import Control.Exception (throwIO) -import Control.Monad (forM, when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Reader (ReaderT (..)) -import Data.Maybe (listToMaybe, mapMaybe) -import Data.Monoid ((<>)) -import qualified Data.Text as T -import Data.Text.Lazy (toStrict) -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.Builder.Int as B - -import Network.Ethereum.Unit -import Network.Ethereum.Web3.Address -import Network.Ethereum.Web3.Encoding -import qualified Network.Ethereum.Web3.Eth as Eth -import Network.Ethereum.Web3.Provider -import Network.Ethereum.Web3.Types - --- | Event callback control response -data EventAction = ContinueEvent - -- ^ Continue to listen events - | TerminateEvent - -- ^ Terminate event listener - deriving (Show, Eq) - --- | Contract event listener -class ABIEncoding a => Event a where - -- | Event filter structure used by low-level subscription methods - eventFilter :: a -> Address -> Filter - - -- | Start an event listener for given contract 'Address' and callback - event :: Provider p - => Address - -- ^ Contract address - -> (a -> ReaderT Change (Web3 p) EventAction) - -- ^ 'Event' handler - -> Web3 p ThreadId - -- ^ 'Web3' wrapped event handler spawn ident - event = _event - -_event :: (Provider p, Event a) - => Address - -> (a -> ReaderT Change (Web3 p) EventAction) - -> Web3 p ThreadId -_event a f = do - fid <- let ftyp = snd $ let x = undefined :: Event a => a - in (f x, x) - in Eth.newFilter (eventFilter ftyp a) - - forkWeb3 $ - let loop = do liftIO (threadDelay 1000000) - changes <- Eth.getFilterChanges fid - acts <- forM (mapMaybe pairChange changes) $ \(changeEvent, changeWithMeta) -> - runReaderT (f changeEvent) changeWithMeta - when (TerminateEvent `notElem` acts) loop - in do loop - Eth.uninstallFilter fid - return () - where - prepareTopics = fmap (T.drop 2) . drop 1 - pairChange changeWithMeta = do - changeEvent <- fromData $ - T.append (T.concat (prepareTopics $ changeTopics changeWithMeta)) - (T.drop 2 $ changeData changeWithMeta) - return (changeEvent, changeWithMeta) - --- | Contract method caller -class ABIEncoding a => Method a where - -- | Send a transaction for given contract 'Address', value and input data - sendTx :: (Provider p, Unit b) - => Address - -- ^ Contract address - -> b - -- ^ Payment value (set 'nopay' to empty value) - -> a - -- ^ Method data - -> Web3 p TxHash - -- ^ 'Web3' wrapped result - sendTx = _sendTransaction - - -- | Constant call given contract 'Address' in mode and given input data - call :: (Provider p, ABIEncoding b) - => Address - -- ^ Contract address - -> DefaultBlock - -- ^ State mode for constant call (latest or pending) - -> a - -- ^ Method data - -> Web3 p b - -- ^ 'Web3' wrapped result - call = _call - -_sendTransaction :: (Provider p, Method a, Unit b) - => Address -> b -> a -> Web3 p TxHash -_sendTransaction to value dat = do - primeAddress <- listToMaybe <$> Eth.accounts - Eth.sendTransaction (txdata primeAddress $ Just $ toData dat) - where txdata from = Call from to (Just defaultGas) Nothing (Just $ toWeiText value) - toWeiText = ("0x" <>) . toStrict . B.toLazyText . B.hexadecimal . toWei - defaultGas = "0x2DC2DC" - -_call :: (Provider p, Method a, ABIEncoding b) - => Address -> DefaultBlock -> a -> Web3 p b -_call to mode dat = do - primeAddress <- listToMaybe <$> Eth.accounts - res <- Eth.call (txdata primeAddress) mode - case fromData (T.drop 2 res) of - Nothing -> liftIO $ throwIO $ ParserFail $ - "Unable to parse result on `" ++ T.unpack res - ++ "` from `" ++ show to ++ "`" - Just x -> return x - where - txdata from = Call from to Nothing Nothing Nothing (Just (toData dat)) - --- | Zero value is used to send transaction without money -nopay :: Wei -{-# INLINE nopay #-} -nopay = 0 - --- | Dummy method for sending transaction without method call -data NoMethod = NoMethod - -instance ABIEncoding NoMethod where - fromDataParser = return NoMethod - toDataBuilder = const "" - -instance Method NoMethod diff --git a/src/Network/Ethereum/Web3/Encoding.hs b/src/Network/Ethereum/Web3/Encoding.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Encoding.hs +++ /dev/null @@ -1,71 +0,0 @@ --- | --- Module : Network.Ethereum.Web3.Encoding --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : portable --- --- Web3 ABI encoding data support. --- -module Network.Ethereum.Web3.Encoding (ABIEncoding(..)) where - -import qualified Data.Attoparsec.Text as P -import Data.Attoparsec.Text.Lazy (Parser, maybeResult, - parse) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy.Builder (Builder, fromLazyText, - fromText, toLazyText) -import Network.Ethereum.Web3.Address (Address) -import qualified Network.Ethereum.Web3.Address as A -import Network.Ethereum.Web3.Encoding.Internal - --- | Contract ABI data codec -class ABIEncoding a where - toDataBuilder :: a -> Builder - fromDataParser :: Parser a - - -- | Encode value into abi-encoding represenation - toData :: a -> Text - {-# INLINE toData #-} - toData = LT.toStrict . toLazyText . toDataBuilder - - -- | Parse encoded value - fromData :: Text -> Maybe a - {-# INLINE fromData #-} - fromData = maybeResult . parse fromDataParser . LT.fromStrict - -instance ABIEncoding Bool where - toDataBuilder = int256HexBuilder . fromEnum - fromDataParser = fmap toEnum int256HexParser - -instance ABIEncoding Integer where - toDataBuilder = int256HexBuilder - fromDataParser = int256HexParser - -instance ABIEncoding Int where - toDataBuilder = int256HexBuilder - fromDataParser = int256HexParser - -instance ABIEncoding Word where - toDataBuilder = int256HexBuilder - fromDataParser = int256HexParser - -instance ABIEncoding Text where - toDataBuilder = textBuilder - fromDataParser = textParser - -instance ABIEncoding Address where - toDataBuilder = alignR . fromText . A.toText - fromDataParser = either error id . A.fromText - <$> (P.take 24 *> P.take 40) - -instance ABIEncoding a => ABIEncoding [a] where - toDataBuilder x = int256HexBuilder (length x) - <> foldMap toDataBuilder x - fromDataParser = do len <- int256HexParser - take len <$> P.many1 fromDataParser diff --git a/src/Network/Ethereum/Web3/Encoding/Bytes.hs b/src/Network/Ethereum/Web3/Encoding/Bytes.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Encoding/Bytes.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | --- 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.Attoparsec.Text as P -import Data.ByteArray (Bytes) -import qualified Data.ByteArray as BA -import qualified Data.ByteString.Base16 as BS16 (decode, - encode) -import Data.Monoid (Monoid (..), (<>)) -import Data.Proxy -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy.Builder as B -import GHC.TypeLits (KnownNat, Nat, natVal) -import Network.Ethereum.Web3.Encoding -import Network.Ethereum.Web3.Encoding.Internal - -import Debug.Trace - --- | Fixed length byte array -newtype BytesN (n :: Nat) = BytesN { unBytesN :: Bytes } - deriving (Eq, Ord) - -update :: BytesN a -> Bytes -> BytesN a -{-# INLINE update #-} -update _ = BytesN - -instance KnownNat n => EncodingType (BytesN n) where - typeName = const $ "bytes" <> (show . natVal $ (Proxy :: Proxy 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 -{-# INLINE bytesBuilder #-} -bytesBuilder = alignL . B.fromText . T.decodeUtf8 - . BS16.encode . BA.convert - -bytesDecode :: T.Text -> Bytes -{-# INLINE bytesDecode #-} -bytesDecode = BA.convert . fst . BS16.decode . T.encodeUtf8 - --- | Dynamic length byte array -newtype BytesD = BytesD { unBytesD :: Bytes } - deriving (Eq, Ord) - -instance Monoid BytesD where - mempty = BytesD mempty - mappend (BytesD a) (BytesD b) = BytesD (mappend a b) - -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 deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Encoding/Internal.hs +++ /dev/null @@ -1,101 +0,0 @@ --- | --- 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 qualified Data.Attoparsec.Text as P -import Data.Attoparsec.Text.Lazy (Parser) -import Data.Bits (Bits) -import qualified Data.ByteString.Base16 as BS16 (decode, encode) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy.Builder (Builder, fromLazyText, fromText, - toLazyText) -import Data.Text.Lazy.Builder.Int as B -import qualified Data.Text.Read as R -import Language.Haskell.TH -import Network.Ethereum.Web3.Address (Address) - -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 deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Encoding/Tuple.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# 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 -import Network.Ethereum.Web3.Encoding.Internal -import Network.Ethereum.Web3.Encoding.TupleTH - --- | 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 deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Encoding/TupleTH.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- 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 Control.Monad (replicateM) -import Data.Attoparsec.Text (Parser) -import qualified Data.Attoparsec.Text as P -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy.Builder (Builder, toLazyText) -import Language.Haskell.TH -import Network.Ethereum.Web3.Encoding -import Network.Ethereum.Web3.Encoding.Internal - --- | 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 - varsT <- fmap varT <$> replicateM n (newName "t") - let contextT = concat - [[[t|ABIEncoding $x|], [t|EncodingType $x|]] | x <- 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 <- replicateM 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 tuple size" - -mkEncodingInst :: Int -> DecQ -mkEncodingInst n = do - vars <- replicateM n (newName "t") - let varsT = fmap varT vars - contextT = concat - [[[t|ABIEncoding $x|], [t|EncodingType $x|]] | x <- 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/Eth.hs b/src/Network/Ethereum/Web3/Eth.hs --- a/src/Network/Ethereum/Web3/Eth.hs +++ b/src/Network/Ethereum/Web3/Eth.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Network.Ethereum.Web3.Eth -- Copyright : Alexander Krupenkin 2016 @@ -9,216 +11,218 @@ -- -- Ethereum node JSON-RPC API methods with `eth_` prefix. -- + module Network.Ethereum.Web3.Eth where -import Data.Text (Text) -import Network.Ethereum.Web3.Address -import Network.Ethereum.Web3.JsonRpc -import Network.Ethereum.Web3.Provider +import Network.Ethereum.ABI.Prim.Address (Address) +import Network.Ethereum.ABI.Prim.Bytes (Bytes) +import Network.Ethereum.Web3.Provider (Web3) import Network.Ethereum.Web3.Types +import Network.JsonRpc.TinyClient (remote) -- | Returns the current ethereum protocol version. -protocolVersion :: Provider a => Web3 a Text +protocolVersion :: Web3 Int {-# INLINE protocolVersion #-} protocolVersion = remote "eth_protocolVersion" --- TODO The return type of this function requires a new type to be created -- | Returns an object with data about the sync status or false. --- syncing :: Proviver a => Web3 a Text +syncing :: Web3 SyncingState +{-# INLINE syncing #-} +syncing = remote "eth_syncing" -- | Returns the client coinbase address. -coinbase :: Provider a => Web3 a Address +coinbase :: Web3 Address {-# INLINE coinbase #-} coinbase = remote "eth_coinbase" -- | Returns true if client is actively mining new blocks. -mining :: Provider a => Web3 a Bool +mining :: Web3 Bool {-# INLINE mining #-} mining = remote "eth_mining" -- | Returns the number of hashes per second that the node is mining with. -hashrate :: Provider a => Web3 a Text +hashrate :: Web3 Quantity {-# INLINE hashrate #-} hashrate = remote "eth_hashrate" -- | Returns the value from a storage position at a given address. -getStorageAt :: Provider a => Address -> Text -> DefaultBlock -> Web3 a Text +getStorageAt :: Address -> Quantity -> DefaultBlock -> Web3 Bytes {-# INLINE getStorageAt #-} getStorageAt = remote "eth_getStorageAt" -- | Returns the number of transactions sent from an address. -getTransactionCount :: Provider a => Address -> DefaultBlock -> Web3 a Text +getTransactionCount :: Address -> DefaultBlock -> Web3 Quantity {-# INLINE getTransactionCount #-} getTransactionCount = remote "eth_getTransactionCount" -- | Returns the number of transactions in a block from a block matching the given block hash. -getBlockTransactionCountByHash :: Provider a => Text -> Web3 a Text +getBlockTransactionCountByHash :: Bytes -> Web3 Quantity {-# INLINE getBlockTransactionCountByHash #-} getBlockTransactionCountByHash = remote "eth_getBlockTransactionCountByHash" -- | Returns the number of transactions in a block matching the -- given block number. -getBlockTransactionCountByNumber :: Provider a => Text -> Web3 a Text +getBlockTransactionCountByNumber :: Quantity -> Web3 Quantity {-# INLINE getBlockTransactionCountByNumber #-} getBlockTransactionCountByNumber = remote "eth_getBlockTransactionCountByNumber" -- | Returns the number of uncles in a block from a block matching the given -- block hash. -getUncleCountByBlockHash :: Provider a => Text -> Web3 a Text +getUncleCountByBlockHash :: Bytes -> Web3 Quantity {-# INLINE getUncleCountByBlockHash #-} getUncleCountByBlockHash = remote "eth_getUncleCountByBlockHash" -- | Returns the number of uncles in a block from a block matching the given -- block number. -getUncleCountByBlockNumber :: Provider a => Text -> Web3 a Text +getUncleCountByBlockNumber :: Quantity -> Web3 Quantity {-# INLINE getUncleCountByBlockNumber #-} getUncleCountByBlockNumber = remote "eth_getUncleCountByBlockNumber" -- | Returns code at a given address. -getCode :: Provider a => Address -> DefaultBlock -> Web3 a Text +getCode :: Address -> DefaultBlock -> Web3 Bytes {-# INLINE getCode #-} getCode = remote "eth_getCode" -- | Returns an Ethereum specific signature with: -- sign(keccak256("\x19Ethereum Signed Message:\n" + len(message) + message))). -sign :: Provider a => Address -> Text -> Web3 a Text +sign :: Address -> Bytes -> Web3 Bytes {-# INLINE sign #-} sign = remote "eth_sign" -- | Creates new message call transaction or a contract creation, -- if the data field contains code. -sendTransaction :: Provider a => Call -> Web3 a Text +sendTransaction :: Call -> Web3 Bytes {-# INLINE sendTransaction #-} sendTransaction = remote "eth_sendTransaction" -- | Creates new message call transaction or a contract creation for signed -- transactions. -sendRawTransaction :: Provider a => Text -> Web3 a Text +sendRawTransaction :: Bytes -> Web3 Bytes {-# INLINE sendRawTransaction #-} sendRawTransaction = remote "eth_sendRawTransaction" -- | Returns the balance of the account of given address. -getBalance :: Provider a => Address -> DefaultBlock -> Web3 a Text +getBalance :: Address -> DefaultBlock -> Web3 Quantity {-# INLINE getBalance #-} getBalance = remote "eth_getBalance" -- | Creates a filter object, based on filter options, to notify when the -- state changes (logs). To check if the state has changed, call -- 'getFilterChanges'. -newFilter :: Provider a => Filter -> Web3 a FilterId +newFilter :: Filter e -> Web3 FilterId {-# INLINE newFilter #-} newFilter = remote "eth_newFilter" -- | Polling method for a filter, which returns an array of logs which -- occurred since last poll. -getFilterChanges :: Provider a => FilterId -> Web3 a [Change] +getFilterChanges :: FilterId -> Web3 [Change] {-# INLINE getFilterChanges #-} getFilterChanges = remote "eth_getFilterChanges" -- | Uninstalls a filter with given id. -- Should always be called when watch is no longer needed. -uninstallFilter :: Provider a => FilterId -> Web3 a Bool +uninstallFilter :: FilterId -> Web3 Bool {-# INLINE uninstallFilter #-} uninstallFilter = remote "eth_uninstallFilter" -- | Returns an array of all logs matching a given filter object. -getLogs :: Provider a => Filter -> Web3 a [Change] +getLogs :: Filter e -> Web3 [Change] {-# INLINE getLogs #-} getLogs = remote "eth_getLogs" -- | Executes a new message call immediately without creating a -- transaction on the block chain. -call :: Provider a => Call -> DefaultBlock -> Web3 a Text +call :: Call -> DefaultBlock -> Web3 Bytes {-# INLINE call #-} call = remote "eth_call" -- | Makes a call or transaction, which won't be added to the blockchain and -- returns the used gas, which can be used for estimating the used gas. -estimateGas :: Provider a => Call -> Web3 a Text +estimateGas :: Call -> Web3 Quantity {-# INLINE estimateGas #-} estimateGas = remote "eth_estimateGas" -- | Returns information about a block by hash. -getBlockByHash :: Provider a => Text -> Web3 a Block +getBlockByHash :: Bytes -> Web3 Block {-# INLINE getBlockByHash #-} getBlockByHash = flip (remote "eth_getBlockByHash") True -- | Returns information about a block by block number. -getBlockByNumber :: Provider a => Text -> Web3 a Block +getBlockByNumber :: Quantity -> Web3 Block {-# INLINE getBlockByNumber #-} getBlockByNumber = flip (remote "eth_getBlockByNumber") True -- | Returns the information about a transaction requested by transaction hash. -getTransactionByHash :: Provider a => Text -> Web3 a (Maybe Transaction) +getTransactionByHash :: Bytes -> Web3 (Maybe Transaction) {-# INLINE getTransactionByHash #-} getTransactionByHash = remote "eth_getTransactionByHash" -- | Returns information about a transaction by block hash and transaction index position. -getTransactionByBlockHashAndIndex :: Provider a => Text -> Text -> Web3 a (Maybe Transaction) +getTransactionByBlockHashAndIndex :: Bytes -> Quantity -> Web3 (Maybe Transaction) {-# INLINE getTransactionByBlockHashAndIndex #-} getTransactionByBlockHashAndIndex = remote "eth_getTransactionByBlockHashAndIndex" -- | Returns information about a transaction by block number and transaction -- index position. -getTransactionByBlockNumberAndIndex :: Provider a => DefaultBlock -> Text -> Web3 a (Maybe Transaction) +getTransactionByBlockNumberAndIndex :: DefaultBlock -> Quantity -> Web3 (Maybe Transaction) {-# INLINE getTransactionByBlockNumberAndIndex #-} getTransactionByBlockNumberAndIndex = remote "eth_getTransactionByBlockNumberAndIndex" -- | Returns the receipt of a transaction by transaction hash. -- TODO must create new type, TxReceipt --- getTransactionReceipt :: Provider a => Text -> Web3 a TxReceipt +-- getTransactionReceipt :: Text -> Web3 TxReceipt -- getTransactionReceipt = remote "getTransactionReceipt" -- | Returns a list of addresses owned by client. -accounts :: Provider a => Web3 a [Address] +accounts :: Web3 [Address] {-# INLINE accounts #-} accounts = remote "eth_accounts" -newBlockFilter :: Provider a => Web3 a Text +newBlockFilter :: Web3 Bytes {-# INLINE newBlockFilter #-} newBlockFilter = remote "eth_newBlockFilter" -- | Polling method for a block filter, which returns an array of block hashes -- occurred since last poll. -getBlockFilterChanges :: Provider a => Text -> Web3 a [Text] +getBlockFilterChanges :: Quantity -> Web3 [Bytes] {-# INLINE getBlockFilterChanges #-} -getBlockFilterChanges = remote "eth_getBlockFilterChanges" +getBlockFilterChanges = remote "eth_getFilterChanges" -- | Returns the number of most recent block. -blockNumber :: Provider a => Web3 a Text +blockNumber :: Web3 BlockNumber {-# INLINE blockNumber #-} blockNumber = remote "eth_blockNumber" -- | Returns the current price per gas in wei. -gasPrice :: Provider a => Web3 a Text +gasPrice :: Web3 Quantity {-# INLINE gasPrice #-} gasPrice = remote "eth_gasPrice" -- | Returns information about a uncle of a block by hash and uncle index -- position. -getUncleByBlockHashAndIndex :: Provider a => Text -> Text -> Web3 a Block +getUncleByBlockHashAndIndex :: Bytes -> Quantity -> Web3 Block {-# INLINE getUncleByBlockHashAndIndex #-} getUncleByBlockHashAndIndex = remote "eth_getUncleByBlockHashAndIndex" -- | Returns information about a uncle of a block by number and uncle index -- position. -getUncleByBlockNumberAndIndex :: Provider a => DefaultBlock -> Text -> Web3 a Block +getUncleByBlockNumberAndIndex :: DefaultBlock -> Quantity -> Web3 Block {-# INLINE getUncleByBlockNumberAndIndex #-} getUncleByBlockNumberAndIndex = remote "eth_getUncleByBlockNumberAndIndex" -- | Creates a filter in the node, to notify when new pending transactions arrive. To check if the state has changed, call getFilterChanges. Returns a FilterId. -newPendingTransactionFilter :: Provider a => Web3 a Text +newPendingTransactionFilter :: Web3 Quantity {-# INLINE newPendingTransactionFilter #-} newPendingTransactionFilter = remote "eth_newPendingTransactionFilter" -- | Returns an array of all logs matching filter with given id. -getFilterLogs :: Provider a => Text -> Web3 a [Change] +getFilterLogs :: Quantity -> Web3 [Change] {-# INLINE getFilterLogs #-} getFilterLogs = remote "eth_getFilterLogs" -- | Returns the hash of the current block, the seedHash, and the boundary -- condition to be met ("target"). -getWork :: Provider a => Web3 a [Text] +getWork :: Web3 [Bytes] {-# INLINE getWork #-} getWork = remote "eth_getWork" @@ -227,7 +231,7 @@ -- 1. DATA, 8 Bytes - The nonce found (64 bits) -- 2. DATA, 32 Bytes - The header's pow-hash (256 bits) -- 3. DATA, 32 Bytes - The mix digest (256 bits) -submitWork :: Provider a => Text -> Text -> Text -> Web3 a Bool +submitWork :: Bytes -> Bytes -> Bytes -> Web3 Bool {-# INLINE submitWork #-} submitWork = remote "eth_submitWork" @@ -235,6 +239,6 @@ -- Parameters: -- 1. Hashrate, a hexadecimal string representation (32 bytes) of the hash rate -- 2. ID, String - A random hexadecimal(32 bytes) ID identifying the client -submitHashrate :: Provider a => Text -> Text -> Web3 a Bool +submitHashrate :: Bytes -> Bytes -> Web3 Bool {-# INLINE submitHashrate #-} submitHashrate = remote "eth_submitHashrate" diff --git a/src/Network/Ethereum/Web3/Internal.hs b/src/Network/Ethereum/Web3/Internal.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/Internal.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | --- Module : Network.Ethereum.Web3.Internal --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : portable --- --- Common used internal functions. --- -module Network.Ethereum.Web3.Internal where - -import Data.Char (toLower, toUpper) - --- | Lower first char of string -toLowerFirst :: String -> String -toLowerFirst [] = [] -toLowerFirst (x : xs) = toLower x : xs - --- | Upper first char of string -toUpperFirst :: String -> String -toUpperFirst [] = [] -toUpperFirst (x : xs) = toUpper x : xs diff --git a/src/Network/Ethereum/Web3/JsonAbi.hs b/src/Network/Ethereum/Web3/JsonAbi.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/JsonAbi.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Module : Network.Ethereum.Web3.JsonAbi --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : portable --- --- Ethereum smart contract JSON ABI types. --- -module Network.Ethereum.Web3.JsonAbi ( - ContractABI(..) - , Declaration(..) - , FunctionArg(..) - , EventArg(..) - , signature - , methodId - , eventId - ) where - -import Crypto.Hash (Digest, Keccak_256, hash) -import Data.Aeson -import Data.Aeson.TH -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.Ethereum.Web3.Internal - --- | Method argument -data FunctionArg = FunctionArg - { funArgName :: Text - -- ^ Argument name - , funArgType :: Text - -- ^ Argument type - } deriving (Show, Eq, Ord) - -$(deriveJSON - (defaultOptions {fieldLabelModifier = toLowerFirst . drop 6}) - ''FunctionArg) - --- | Event argument -data EventArg = EventArg - { eveArgName :: Text - -- ^ Argument name - , eveArgType :: Text - -- ^ Argument type - , eveArgIndexed :: Bool - -- ^ Argument is indexed (e.g. placed on topics of event) - } deriving (Show, Eq, Ord) - -$(deriveJSON - (defaultOptions {fieldLabelModifier = toLowerFirst . drop 6}) - ''EventArg) - --- | Elementrary contract interface item -data Declaration - = DConstructor { conInputs :: [FunctionArg] } - -- ^ Contract constructor - | DFunction { funName :: Text - , funConstant :: Bool - , funInputs :: [FunctionArg] - , funOutputs :: Maybe [FunctionArg] } - -- ^ Method - | DEvent { eveName :: Text - , eveInputs :: [EventArg] - , eveAnonymous :: Bool } - -- ^ Event - | DFallback { falPayable :: Bool } - -- ^ Fallback function - deriving (Show, Eq, Ord) - -$(deriveJSON (defaultOptions { - sumEncoding = defaultTaggedObject { tagFieldName = "type" } - , constructorTagModifier = toLowerFirst . drop 1 - , fieldLabelModifier = toLowerFirst . drop 3 }) - ''Declaration) - --- | Contract ABI is a list of method / event declarations -newtype ContractABI = ContractABI { unABI :: [Declaration] } - deriving (Eq, Ord) - -instance Show ContractABI where - show (ContractABI c) = T.unpack $ T.unlines $ - [ "Contract:" ] - ++ foldMap showConstructor c ++ - [ "\tEvents:" ] - ++ foldMap showEvent c ++ - [ "\tMethods:" ] - ++ foldMap showMethod c - -instance FromJSON ContractABI where - parseJSON = fmap ContractABI . parseJSON - -instance ToJSON ContractABI where - toJSON (ContractABI x) = toJSON x - -showConstructor :: Declaration -> [Text] -showConstructor x = case x of - DConstructor{} -> ["\tConstructor " <> signature x] - _ -> [] - -showEvent :: Declaration -> [Text] -showEvent x = case x of - DEvent{} -> ["\t\t" <> signature x] - _ -> [] - -showMethod :: Declaration -> [Text] -showMethod x = case x of - DFunction{} -> - ["\t\t" <> methodId x <> " " <> signature x] - _ -> [] - --- | Take a signature by given decl, e.g. foo(uint,string) -signature :: Declaration -> Text - -signature (DConstructor inputs) = "(" <> args inputs <> ")" - where args = T.dropEnd 1 . foldMap (<> ",") . fmap funArgType - -signature (DFallback _) = "()" - -signature (DFunction name _ inputs _) = name <> "(" <> args inputs <> ")" - where args = T.dropEnd 1 . foldMap (<> ",") . fmap funArgType - -signature (DEvent name inputs _) = name <> "(" <> args inputs <> ")" - where args = T.dropEnd 1 . foldMap (<> ",") . fmap eveArgType - --- | Localy compute Keccak-256 hash of given text -sha3 :: Text -> Text -{-# INLINE sha3 #-} -sha3 x = T.pack (show digest) - where digest :: Digest Keccak_256 - digest = hash (T.encodeUtf8 x) - --- | Generate method selector by given method 'Delcaration' -methodId :: Declaration -> Text -{-# INLINE methodId #-} -methodId = ("0x" <>) . T.take 8 . sha3 . signature - --- | Generate event `topic0` hash by givent event 'Delcaration' -eventId :: Declaration -> Text -{-# INLINE eventId #-} -eventId = ("0x" <>) . sha3 . signature diff --git a/src/Network/Ethereum/Web3/JsonRpc.hs b/src/Network/Ethereum/Web3/JsonRpc.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/JsonRpc.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} --- | --- Module : Network.JsonRpc --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : portable --- --- Little JSON-RPC 2.0 client. --- Functions for implementing the client side of JSON-RPC 2.0. --- See . --- -module Network.Ethereum.Web3.JsonRpc ( - remote - , MethodName - , ServerUri - ) where - -import Network.Ethereum.Web3.Provider -import Network.Ethereum.Web3.Types - -import Control.Applicative ((<|>)) -import Control.Exception (throwIO) -import Control.Monad ((>=>)) -import Data.Aeson -import Data.ByteString.Lazy (ByteString) -import Data.Text (Text) -import Data.Vector (fromList) -import Network.HTTP.Client (RequestBody (RequestBodyLBS), - httpLbs, method, newManager, - parseRequest, requestBody, - requestHeaders, responseBody) -import Network.HTTP.Client.TLS (tlsManagerSettings) - --- | Name of called method. -type MethodName = Text - --- | JSON-RPC server URI -type ServerUri = String - --- | Remote call of JSON-RPC method. --- Arguments of function are stored into @params@ request array. -remote :: Remote a => MethodName -> a -remote n = remote_ (\uri -> call uri . Array . fromList) - where - call uri = connection uri . encode . Request n 1 - connection uri body = do - manager <- newManager tlsManagerSettings - request <- parseRequest uri - let request' = request - { requestBody = RequestBodyLBS body - , requestHeaders = [("Content-Type", "application/json")] - , method = "POST" } - responseBody <$> httpLbs request' manager - -decodeResponse :: FromJSON a => ByteString -> IO a -decodeResponse = tryParse . eitherDecode - >=> tryJsonRpc . rsResult - >=> tryParse . eitherDecode . encode - where tryJsonRpc :: Either RpcError a -> IO a - tryJsonRpc = either (throwIO . JsonRpcFail) return - tryParse :: Either String a -> IO a - tryParse = either (throwIO . ParserFail) return - -class Remote a where - remote_ :: (ServerUri -> [Value] -> IO ByteString) -> a - -instance (ToJSON a, Remote b) => Remote (a -> b) where - remote_ f x = remote_ (\u xs -> f u (toJSON x : xs)) - -instance (Provider p, FromJSON a) => Remote (Web3 p a) where - remote_ f = (\u -> Web3 (decodeResponse =<< f u [])) =<< rpcUri - --- | JSON-RPC request. -data Request = Request { rqMethod :: !Text - , rqId :: !Int - , rqParams :: !Value } - -instance ToJSON Request where - toJSON rq = object [ "jsonrpc" .= String "2.0" - , "method" .= rqMethod rq - , "params" .= rqParams rq - , "id" .= rqId rq ] - --- | JSON-RPC response. -data Response = Response - { rsResult :: !(Either RpcError Value) - } deriving (Show) - -instance FromJSON Response where - parseJSON = withObject "JSON-RPC response object" $ - \v -> Response <$> - (Right <$> v .: "result" <|> Left <$> v .: "error") diff --git a/src/Network/Ethereum/Web3/Net.hs b/src/Network/Ethereum/Web3/Net.hs --- a/src/Network/Ethereum/Web3/Net.hs +++ b/src/Network/Ethereum/Web3/Net.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Network.Ethereum.Web3.Net -- Copyright : Alexander Krupenkin 2016 @@ -9,24 +11,24 @@ -- -- Ethereum node JSON-RPC API methods with `net_` prefix. -- + module Network.Ethereum.Web3.Net where -import Data.Text (Text) -import Network.Ethereum.Web3.JsonRpc -import Network.Ethereum.Web3.Provider -import Network.Ethereum.Web3.Types +import Network.Ethereum.Web3.Provider (Web3) +import Network.Ethereum.Web3.Types (Quantity) +import Network.JsonRpc.TinyClient (remote) -- | Returns the current network id. -version :: Provider a => Web3 a Text +version :: Web3 Int {-# INLINE version #-} version = remote "net_version" -- | Returns true if client is actively listening for network connections. -listening :: Provider a => Web3 a Bool +listening :: Web3 Bool {-# INLINE listening #-} listening = remote "net_listening" -- | Returns number of peers currently connected to the client. -peerCount :: Provider a => Web3 a Text +peerCount :: Web3 Quantity {-# INLINE peerCount #-} peerCount = remote "net_peerCount" diff --git a/src/Network/Ethereum/Web3/Provider.hs b/src/Network/Ethereum/Web3/Provider.hs --- a/src/Network/Ethereum/Web3/Provider.hs +++ b/src/Network/Ethereum/Web3/Provider.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + -- | -- Module : Network.Ethereum.Web3.Provider -- Copyright : Alexander Krupenkin 2016 @@ -9,35 +14,70 @@ -- -- Web3 service provider. -- + module Network.Ethereum.Web3.Provider where -import Control.Concurrent (ThreadId, forkIO) -import Control.Exception (try) -import Control.Monad.IO.Class (MonadIO (..)) -import Network.Ethereum.Web3.Types +import Control.Concurrent.Async (Async, async) +import Control.Exception (Exception, try) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.Trans.Reader (ReaderT, mapReaderT, runReaderT) +import Data.Aeson (FromJSON) +import Data.Default (Default (..)) +import GHC.Generics (Generic) +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) --- | Ethereum node service provider -class Provider a where - -- | JSON-RPC provider URI, default: localhost:8545 - rpcUri :: Web3 a String +import Network.JsonRpc.TinyClient (Remote, ServerUri) --- | Default 'Web3' service provider -data DefaultProvider +-- | Any communication with Ethereum node wrapped with 'Web3' monad +newtype Web3 a = Web3 { unWeb3 :: ReaderT (ServerUri, Manager) IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow) -instance Provider DefaultProvider where - rpcUri = return "http://localhost:8545" +instance MonadReader (ServerUri, Manager) Web3 where + ask = Web3 ask + local f = Web3 . local f . unWeb3 +instance FromJSON a => Remote Web3 (Web3 a) + +-- | Some peace of error response +data Web3Error + = JsonRpcFail !String + -- ^ JSON-RPC communication error + | ParserFail !String + -- ^ Error in parser state + | UserFail !String + -- ^ Common head for user errors + deriving (Show, Eq, Generic) + +instance Exception Web3Error + +--TODO: Change to `HttpProvider ServerUri | IpcProvider FilePath` to support IPC +-- | Web3 Provider +data Provider = HttpProvider ServerUri + deriving (Show, Eq, Generic) + +instance Default Provider where + def = HttpProvider "http://localhost:8545" + +-- | 'Web3' monad runner, using the supplied Manager +runWeb3With :: MonadIO m => Manager -> Provider -> Web3 a -> m (Either Web3Error a) +runWeb3With manager (HttpProvider uri) f = + liftIO . try . flip runReaderT (uri, manager) . unWeb3 $ f + -- | 'Web3' monad runner -runWeb3' :: MonadIO m => Web3 a b -> m (Either Web3Error b) -{-# INLINE runWeb3' #-} -runWeb3' = liftIO . try . unWeb3 +runWeb3' :: MonadIO m => Provider -> Web3 a -> m (Either Web3Error a) +runWeb3' provider f = do + manager <- liftIO $ newManager tlsManagerSettings + runWeb3With manager provider f -- | 'Web3' runner for default provider -runWeb3 :: MonadIO m => Web3 DefaultProvider b -> m (Either Web3Error b) +runWeb3 :: MonadIO m => Web3 a -> m (Either Web3Error a) {-# INLINE runWeb3 #-} -runWeb3 = runWeb3' +runWeb3 = runWeb3' def -- | Fork 'Web3' with the same 'Provider' -forkWeb3 :: Web3 a () -> Web3 a ThreadId +forkWeb3 :: Web3 a -> Web3 (Async a) {-# INLINE forkWeb3 #-} -forkWeb3 = Web3 . forkIO . unWeb3 +forkWeb3 = Web3 . mapReaderT async . unWeb3 diff --git a/src/Network/Ethereum/Web3/TH.hs b/src/Network/Ethereum/Web3/TH.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3/TH.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- Module : Network.Ethereum.Web3.TH --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : unportable --- --- TemplateHaskell based Ethereum contract ABI --- methods & event generator for Haskell native API. --- --- @ --- [abiFrom|data/sample.json|] --- --- main = do --- runWeb3 $ event "0x..." $ --- \(Action2 n x) -> liftIO $ do print n --- print x --- wait --- where wait = threadDelay 1000000 >> wait --- @ --- -module Network.Ethereum.Web3.TH ( - -- ** Quasiquoter's - abi - , abiFrom - -- ** Used by TH data types - , Bytes - , Text - , Singleton(..) - , ABIEncoding(..) - ) where - -import qualified Data.Attoparsec.Text as P -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.Encoding as LT - -import Network.Ethereum.Unit -import Network.Ethereum.Web3.Address (Address) -import Network.Ethereum.Web3.Contract -import Network.Ethereum.Web3.Encoding -import Network.Ethereum.Web3.Encoding.Tuple -import Network.Ethereum.Web3.Internal -import Network.Ethereum.Web3.JsonAbi -import Network.Ethereum.Web3.Provider -import Network.Ethereum.Web3.Types - -import Control.Monad (replicateM) - -import Data.Aeson -import Data.ByteArray (Bytes) -import Data.List (groupBy, sortBy) -import Data.Monoid (mconcat, (<>)) -import Data.Text (Text, isPrefixOf) - -import GHC.Generics - -import Language.Haskell.TH -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Quote - --- | Read contract ABI from file -abiFrom :: QuasiQuoter -abiFrom = quoteFile abi - --- | QQ reader for contract ABI -abi :: QuasiQuoter -abi = QuasiQuoter - { quoteDec = quoteAbiDec - , quoteExp = quoteAbiExp - , quotePat = undefined - , quoteType = undefined - } - --- | Instance declaration with empty context -instanceD' :: Name -> TypeQ -> [DecQ] -> DecQ -instanceD' name insType = - instanceD (cxt []) (appT insType (conT name)) - --- | Simple data type declaration with one constructor -dataD' :: Name -> ConQ -> [Name] -> DecQ -dataD' name rec derive = -#if MIN_VERSION_template_haskell(2,12,0) - dataD (cxt []) name [] Nothing [rec] [derivClause Nothing (conT <$> derive)] -#else - dataD (cxt []) name [] Nothing [rec] $ cxt (conT <$> derive) -#endif - --- | Simple function declaration -funD' :: Name -> [PatQ] -> ExpQ -> DecQ -funD' name p f = funD name [clause p (normalB f) []] - --- | ABI and Haskell types association -typeQ :: Text -> TypeQ -typeQ typ | T.any (== '[') typ = appT listT (go (T.takeWhile (/= '[') typ)) - | otherwise = go typ - where go x | "string" == x = conT (mkName "Text") - | "address" == x = conT (mkName "Address") - | "bytes" == x = conT (mkName "BytesD") - | "bool" == x = conT (mkName "Bool") - | "bytes" `isPrefixOf` x = appT (conT (mkName "BytesN")) - (numLit (T.drop 5 x)) - | "int" `isPrefixOf` x = conT (mkName "Integer") - | "uint" `isPrefixOf` x = conT (mkName "Integer") - | otherwise = fail ("Unknown type: " ++ T.unpack x) - numLit n = litT (numTyLit (read (T.unpack n))) - --- | Event argument to TH type -eventBangType :: EventArg -> BangTypeQ -eventBangType (EventArg _ typ _) = - bangType (bang sourceNoUnpack sourceStrict) (typeQ typ) - --- | Function argument to TH type -funBangType :: FunctionArg -> BangTypeQ -funBangType (FunctionArg _ typ) = - bangType (bang sourceNoUnpack sourceStrict) (typeQ typ) - --- | Solidity dynamic type predicate -isDynType :: Text -> Bool -isDynType "bytes" = True -isDynType "string" = True -isDynType x | T.any (== '[') x = True - | otherwise = False - -eventEncodigD :: Name -> [EventArg] -> [DecQ] -eventEncodigD eventName args = - [ funD' (mkName "toDataBuilder") [] - [|error "Event to data conversion isn't available!"|] - , funD' (mkName "fromDataParser") [] fromDataP ] - where - indexed = map eveArgIndexed args - newVars = replicateM (length args) (newName "t") - - parseArg v = bindS (varP v) [|fromDataParser|] - - parseData [] = [] - parseData [v] = pure $ bindS (varP v) [|unSingleton <$> fromDataParser|] - parseData vars = pure $ bindS (tupP (varP <$> vars)) [|fromDataParser|] - - 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") [] - [|error "Function from data conversion isn't available!"|] ] - where - newVars = replicateM 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] - [|ident <> toDataBuilder $(tupE $ fmap varE vars)|] - -eventFilterD :: String -> Int -> [DecQ] -eventFilterD topic0 n = - let addr = mkName "a" - indexedArgs = replicate n Nothing :: [Maybe String] - in [ funD' (mkName "eventFilter") [wildP, varP addr] - [|Filter (Just $(varE addr)) - (Just $ [Just topic0] <> indexedArgs) - Nothing - Nothing - |] - ] - -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 <- replicateM (length args + 2) (newName "t") - let params = appsE $ conE dname : fmap varE vars - - sequence $ if c - then - [ sigD name $ [t|Provider $p => - $(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)|] - ] - - else - [ sigD name $ [t|(Provider $p, Unit $(varT b)) => - $(arrowing $ [t|Address|] : varT b : inputT ++ [[t|Web3 $p TxHash|]]) - |] - , funD' name (varP <$> a : b : vars) $ - [|sendTx $(varE a) $(varE b) $(params)|] ] - where - p = varT (mkName "p") - arrowing [x] = x - arrowing (x : xs) = [t|$x -> $(arrowing xs)|] - inputT = fmap (typeQ . funArgType) args - outputT = case result of - Nothing -> [t|Web3 $p ()|] - Just [x] -> [t|Web3 $p $(typeQ $ funArgType x)|] - Just xs -> let outs = fmap (typeQ . funArgType) xs - in [t|Web3 $p $(foldl appT (tupleT (length xs)) outs)|] - --- | Event declarations maker -mkEvent :: Declaration -> Q [Dec] -mkEvent eve@(DEvent name inputs _) = sequence - [ dataD' eventName eventFields derivingD - , instanceD' eventName encodingT (eventEncodigD eventName inputs) - , instanceD' eventName eventT (eventFilterD (T.unpack $ eventId eve) indexedFieldsCount) - ] - where eventName = mkName (toUpperFirst (T.unpack name)) - derivingD = [mkName "Show", mkName "Eq", mkName "Ord", ''Generic] - eventFields = normalC eventName (eventBangType <$> inputs) - encodingT = conT (mkName "ABIEncoding") - eventT = conT (mkName "Event") - indexedFieldsCount = length . filter eveArgIndexed $ inputs - --- | Method delcarations maker -mkFun :: Declaration -> Q [Dec] -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 (length inputs) mIdent) - , instanceD' dataName methodT [] ] - where mIdent = T.unpack (methodId $ fun{funName = T.replace "'" "" name}) - dataName = mkName (toUpperFirst (T.unpack $ name <> "Data")) - funName = mkName (toLowerFirst (T.unpack name)) - bangInput = fmap funBangType inputs - derivingD = [mkName "Show", mkName "Eq", mkName "Ord", ''Generic] - encodingT = conT (mkName "ABIEncoding") - methodT = conT (mkName "Method") - -escape :: [Declaration] -> [Declaration] -escape = concat . escapeNames . groupBy fnEq . sortBy fnCompare - where fnEq (DFunction n1 _ _ _) (DFunction n2 _ _ _) = n1 == n2 - fnEq _ _ = False - fnCompare (DFunction n1 _ _ _) (DFunction n2 _ _ _) = compare n1 n2 - fnCompare _ _ = GT - -escapeNames :: [[Declaration]] -> [[Declaration]] -escapeNames = fmap go - where go (x : xs) = x : zipWith appendToName xs hats - hats = [T.replicate n "'" | n <- [1..]] - appendToName dfn addition = dfn { funName = funName dfn <> addition } - --- | Declaration parser -mkDecl :: Declaration -> Q [Dec] -mkDecl x@DFunction{} = mkFun x -mkDecl x@DEvent{} = mkEvent x -mkDecl _ = return [] - --- | ABI to declarations converter -quoteAbiDec :: String -> Q [Dec] -quoteAbiDec abi_string = - case decode abi_lbs of - Just (ContractABI abi) -> concat <$> mapM mkDecl (escape abi) - _ -> fail "Unable to parse ABI!" - where abi_lbs = LT.encodeUtf8 (LT.pack abi_string) - --- | ABI information string -quoteAbiExp :: String -> ExpQ -quoteAbiExp abi_string = stringE $ - case eitherDecode abi_lbs of - Left e -> "Error: " ++ show e - Right abi -> show (abi :: ContractABI) - where abi_lbs = LT.encodeUtf8 (LT.pack abi_string) diff --git a/src/Network/Ethereum/Web3/Types.hs b/src/Network/Ethereum/Web3/Types.hs --- a/src/Network/Ethereum/Web3/Types.hs +++ b/src/Network/Ethereum/Web3/Types.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} + -- | -- Module : Network.Ethereum.Web3.Types -- Copyright : Alexander Krupenkin 2016 @@ -11,61 +13,104 @@ -- Stability : experimental -- Portability : portable -- --- Commonly used types and instances. +-- Ethereum generic JSON-RPC types. -- + module Network.Ethereum.Web3.Types where -import Control.Exception (Exception) -import Control.Monad.IO.Class (MonadIO) import Data.Aeson import Data.Aeson.TH -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.Builder.Int as B -import qualified Data.Text.Read as R -import Data.Typeable (Typeable) -import GHC.Generics -import Network.Ethereum.Web3.Address (Address) -import Network.Ethereum.Web3.Internal (toLowerFirst) +import Data.Default +import Data.Monoid ((<>)) +import Data.Ord (Down (..)) +import Data.String (IsString (..)) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy.Builder.Int as B +import qualified Data.Text.Read as R +import GHC.Generics (Generic) --- | Any communication with Ethereum node wrapped with 'Web3' monad -newtype Web3 a b = Web3 { unWeb3 :: IO b } - deriving (Functor, Applicative, Monad, MonadIO) +import Data.String.Extra (toLowerFirst) +import Network.Ethereum.ABI.Prim.Address (Address) +import Network.Ethereum.ABI.Prim.Bytes (Bytes) +import Network.Ethereum.Unit --- | Some peace of error response -data Web3Error - = JsonRpcFail !RpcError - -- ^ JSON-RPC communication error - | ParserFail !String - -- ^ Error in parser state - | UserFail !String - -- ^ Common head for user errors - deriving (Typeable, Show, Eq, Generic) +-- | Should be viewed as type to representing QUANTITY in Web3 JSON RPC docs +-- +-- When encoding QUANTITIES (integers, numbers): encode as hex, prefix with "0x", +-- the most compact representation (slight exception: zero should be represented as "0x0"). +-- Examples: +-- +-- 0x41 (65 in decimal) +-- 0x400 (1024 in decimal) +-- WRONG: 0x (should always have at least one digit - zero is "0x0") +-- WRONG: 0x0400 (no leading zeroes allowed) +-- WRONG: ff (must be prefixed 0x) +newtype Quantity = Quantity { unQuantity :: Integer } + deriving (Show, Read, Num, Real, Enum, Eq, Ord, Generic) -instance Exception Web3Error +instance IsString Quantity where + fromString ('0' : 'x' : hex) = + case R.hexadecimal (T.pack hex) of + Right (x, "") -> Quantity x + _ -> error "Unable to parse Quantity!" + fromString str = + case R.decimal (T.pack str) of + Right (x, "") -> Quantity x + _ -> error "Unable to parse Quantity!" --- | JSON-RPC error message -data RpcError = RpcError - { errCode :: !Int - , errMessage :: !Text - , errData :: !(Maybe Value) - } deriving (Show, Eq, Generic) +instance ToJSON Quantity where + toJSON (Quantity x) = + let hexValue = B.toLazyText (B.hexadecimal x) + in toJSON ("0x" <> hexValue) -$(deriveJSON (defaultOptions - { fieldLabelModifier = toLowerFirst . drop 3 }) ''RpcError) +instance FromJSON Quantity where + parseJSON (String v) = + case R.hexadecimal v of + Right (x, "") -> return (Quantity x) + _ -> fail "Unable to parse Quantity" + parseJSON _ = fail "Quantity may only be parsed from a JSON String" --- | Low-level event filter data structure -data Filter = Filter - { filterAddress :: !(Maybe Address) - , filterTopics :: !(Maybe [Maybe Text]) - , filterFromBlock :: !(Maybe Text) - , filterToBlock :: !(Maybe Text) - } deriving (Show, Generic) +instance Fractional Quantity where + (/) a b = Quantity $ div (unQuantity a) (unQuantity b) + fromRational = Quantity . floor -$(deriveJSON (defaultOptions - { fieldLabelModifier = toLowerFirst . drop 6 }) ''Filter) +instance Unit Quantity where + fromWei = Quantity + toWei = unQuantity +instance UnitSpec Quantity where + divider = const 1 + name = const "quantity" + +newtype BlockNumber = BlockNumber Integer deriving (Eq, Show, Generic, Ord, Read, Num) + +instance FromJSON BlockNumber where + parseJSON (String v) = + case R.hexadecimal v of + Right (x, "") -> return (BlockNumber x) + _ -> fail "Unable to parse BlockNumber!" + parseJSON _ = fail "The string is required!" + +instance ToJSON BlockNumber where + toJSON (BlockNumber x) = + let hexValue = B.toLazyText (B.hexadecimal x) + in toJSON ("0x" <> hexValue) + + +data SyncActive = SyncActive { syncStartingBlock :: BlockNumber + , syncCurrentBlock :: BlockNumber + , syncHighestBlock :: BlockNumber + } deriving (Eq, Generic, Show) +$(deriveJSON (defaultOptions { fieldLabelModifier = toLowerFirst . drop 4 }) ''SyncActive) + +data SyncingState = Syncing SyncActive | NotSyncing deriving (Eq, Generic, Show) + +instance FromJSON SyncingState where + parseJSON (Bool _) = pure NotSyncing + parseJSON v = Syncing <$> parseJSON v + + -- | Event filter identifier newtype FilterId = FilterId Integer deriving (Show, Eq, Ord, Generic) @@ -85,14 +130,14 @@ -- | Changes pulled by low-level call 'eth_getFilterChanges', 'eth_getLogs', -- and 'eth_getFilterLogs' data Change = Change - { changeLogIndex :: !Text - , changeTransactionIndex :: !Text - , changeTransactionHash :: !Text - , changeBlockHash :: !Text - , changeBlockNumber :: !Text + { changeLogIndex :: !Quantity + , changeTransactionIndex :: !Quantity + , changeTransactionHash :: !Bytes + , changeBlockHash :: !Bytes + , changeBlockNumber :: !BlockNumber , changeAddress :: !Address - , changeData :: !Text - , changeTopics :: ![Text] + , changeData :: !Bytes + , changeTopics :: ![Bytes] } deriving (Show, Generic) $(deriveJSON (defaultOptions @@ -101,52 +146,80 @@ -- | The contract call params data Call = Call { callFrom :: !(Maybe Address) - , callTo :: !Address - , callGas :: !(Maybe Text) - , callGasPrice:: !(Maybe Text) - , callValue :: !(Maybe Text) - , callData :: !(Maybe Text) + , callTo :: !(Maybe Address) + , callGas :: !(Maybe Quantity) + , callGasPrice :: !(Maybe Quantity) + , callValue :: !(Maybe Quantity) -- expressed in wei + , callData :: !(Maybe Bytes) } deriving (Show, Generic) $(deriveJSON (defaultOptions { fieldLabelModifier = toLowerFirst . drop 4 , omitNothingFields = True }) ''Call) +instance Default Call where + def = Call Nothing Nothing (Just 3000000) Nothing (Just 0) Nothing + + -- | The contract call mode describe used state: latest or pending -data DefaultBlock = BlockNumberHex Text | Earliest | Latest | Pending +data DefaultBlock = BlockWithNumber BlockNumber | Earliest | Latest | Pending deriving (Show, Eq) instance ToJSON DefaultBlock where - toJSON (BlockNumberHex hex) = toJSON hex + toJSON (BlockWithNumber bn) = toJSON bn toJSON parameter = toJSON . toLowerFirst . show $ parameter --- TODO: Wrap --- | Transaction hash text string -type TxHash = Text +-- | Low-level event filter data structure +data Filter e = Filter + { filterAddress :: !(Maybe Address) + , filterTopics :: !(Maybe [Maybe Bytes]) + , filterFromBlock :: !DefaultBlock + , filterToBlock :: !DefaultBlock + } deriving (Show, Generic) + +instance ToJSON (Filter e) where + toJSON f = object [ "address" .= filterAddress f + , "topics" .= filterTopics f + , "fromBlock" .= filterFromBlock f + , "toBlock" .= filterToBlock f + ] + +instance Ord DefaultBlock where + compare Pending Pending = EQ + compare Latest Latest = EQ + compare Earliest Earliest = EQ + compare (BlockWithNumber a) (BlockWithNumber b) = compare a b + compare _ Pending = LT + compare Pending Latest = GT + compare _ Latest = LT + compare Earliest _ = LT + compare a b = compare (Down b) (Down a) + + -- | Transaction information data Transaction = Transaction - { txHash :: !TxHash + { txHash :: !Bytes -- ^ DATA, 32 Bytes - hash of the transaction. - , txNonce :: !Text + , txNonce :: !Quantity -- ^ QUANTITY - the number of transactions made by the sender prior to this one. - , txBlockHash :: !Text + , txBlockHash :: !Bytes -- ^ DATA, 32 Bytes - hash of the block where this transaction was in. null when its pending. - , txBlockNumber :: !Text + , txBlockNumber :: !BlockNumber -- ^ QUANTITY - block number where this transaction was in. null when its pending. - , txTransactionIndex :: !Text + , txTransactionIndex :: !Quantity -- ^ QUANTITY - integer of the transactions index position in the block. null when its pending. , txFrom :: !Address -- ^ DATA, 20 Bytes - address of the sender. , txTo :: !(Maybe Address) -- ^ DATA, 20 Bytes - address of the receiver. null when its a contract creation transaction. - , txValue :: !Text + , txValue :: !Quantity -- ^ QUANTITY - value transferred in Wei. - , txGasPrice :: !Text + , txGasPrice :: !Quantity -- ^ QUANTITY - gas price provided by the sender in Wei. - , txGas :: !Text + , txGas :: !Quantity -- ^ QUANTITY - gas provided by the sender. - , txInput :: !Text + , txInput :: !Bytes -- ^ DATA - the data send along with the transaction. } deriving (Show, Generic) @@ -155,45 +228,47 @@ -- | Block information data Block = Block - { blockNumber :: !Text + { blockNumber :: !BlockNumber -- ^ QUANTITY - the block number. null when its pending block. - , blockHash :: !Text + , blockHash :: !Bytes -- ^ DATA, 32 Bytes - hash of the block. null when its pending block. - , blockParentHash :: !Text + , blockParentHash :: !Bytes -- ^ DATA, 32 Bytes - hash of the parent block. - , blockNonce :: !(Maybe Text) + , blockNonce :: !(Maybe Bytes) -- ^ DATA, 8 Bytes - hash of the generated proof-of-work. null when its pending block. - , blockSha3Uncles :: !Text + , blockSha3Uncles :: !Bytes -- ^ DATA, 32 Bytes - SHA3 of the uncles data in the block. - , blockLogsBloom :: !Text + , blockLogsBloom :: !Bytes -- ^ DATA, 256 Bytes - the bloom filter for the logs of the block. null when its pending block. - , blockTransactionsRoot :: !Text + , blockTransactionsRoot :: !Bytes -- ^ DATA, 32 Bytes - the root of the transaction trie of the block. - , blockStateRoot :: !Text + , blockStateRoot :: !Bytes -- ^ DATA, 32 Bytes - the root of the final state trie of the block. - , blockReceiptRoot :: !(Maybe Text) + , blockReceiptRoot :: !(Maybe Bytes) -- ^ DATA, 32 Bytes - the root of the receipts trie of the block. , blockMiner :: !Address -- ^ DATA, 20 Bytes - the address of the beneficiary to whom the mining rewards were given. - , blockDifficulty :: !Text + , blockDifficulty :: !Quantity -- ^ QUANTITY - integer of the difficulty for this block. - , blockTotalDifficulty :: !Text + , blockTotalDifficulty :: !Quantity -- ^ QUANTITY - integer of the total difficulty of the chain until this block. - , blockExtraData :: !Text + , blockExtraData :: !Bytes -- ^ DATA - the "extra data" field of this block. - , blockSize :: !Text + , blockSize :: !Quantity -- ^ QUANTITY - integer the size of this block in bytes. - , blockGasLimit :: !Text + , blockGasLimit :: !Quantity -- ^ QUANTITY - the maximum gas allowed in this block. - , blockGasUsed :: !Text + , blockGasUsed :: !Quantity -- ^ QUANTITY - the total used gas by all transactions in this block. - , blockTimestamp :: !Text + , blockTimestamp :: !Quantity -- ^ QUANTITY - the unix timestamp for when the block was collated. , blockTransactions :: ![Transaction] -- ^ Array of transaction objects. - , blockUncles :: ![Text] + , blockUncles :: ![Bytes] -- ^ Array - Array of uncle hashes. } deriving (Show, Generic) $(deriveJSON (defaultOptions { fieldLabelModifier = toLowerFirst . drop 5 }) ''Block) + +type TxHash = Bytes diff --git a/src/Network/Ethereum/Web3/Web3.hs b/src/Network/Ethereum/Web3/Web3.hs --- a/src/Network/Ethereum/Web3/Web3.hs +++ b/src/Network/Ethereum/Web3/Web3.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Network.Ethereum.Web3.Web3 -- Copyright : Alexander Krupenkin 2016 @@ -9,19 +11,20 @@ -- -- Ethereum node JSON-RPC API methods with `web3_` prefix. -- + module Network.Ethereum.Web3.Web3 where -import Data.Text (Text) -import Network.Ethereum.Web3.JsonRpc -import Network.Ethereum.Web3.Provider -import Network.Ethereum.Web3.Types +import Data.Text (Text) +import Network.Ethereum.ABI.Prim.Bytes (Bytes) +import Network.Ethereum.Web3.Provider (Web3) +import Network.JsonRpc.TinyClient (remote) -- | Returns current node version string. -clientVersion :: Provider a => Web3 a Text +clientVersion :: Web3 Text {-# INLINE clientVersion #-} clientVersion = remote "web3_clientVersion" -- | Returns Keccak-256 (not the standardized SHA3-256) of the given data. -sha3 :: Provider a => Text -> Web3 a Text +sha3 :: Bytes -> Web3 Bytes {-# INLINE sha3 #-} sha3 = remote "web3_sha3" diff --git a/src/Network/JsonRpc/TinyClient.hs b/src/Network/JsonRpc/TinyClient.hs new file mode 100644 --- /dev/null +++ b/src/Network/JsonRpc/TinyClient.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Network.JsonRpc.TinyClient +-- Copyright : Alexander Krupenkin 2016-2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Tiny JSON-RPC 2.0 client. +-- Functions for implementing the client side of JSON-RPC 2.0. +-- See . +-- + +module Network.JsonRpc.TinyClient ( + JsonRpcException(..) + , RpcError(..) + , MethodName + , ServerUri + , Remote + , remote + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (Exception) +import Control.Monad ((<=<)) +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader, ask) +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text, unpack) +import Network.HTTP.Client (Manager, RequestBody (RequestBodyLBS), + httpLbs, method, parseRequest, + requestBody, requestHeaders, + responseBody) + +-- | Name of called method. +type MethodName = Text + +-- | JSON-RPC server URI +type ServerUri = String + +-- | JSON-RPC minimal client config +type Config = (ServerUri, Manager) + +-- | JSON-RPC request. +data Request = Request { rqMethod :: !Text + , rqId :: !Int + , rqParams :: !Value } + +instance ToJSON Request where + toJSON rq = object [ "jsonrpc" .= String "2.0" + , "method" .= rqMethod rq + , "params" .= rqParams rq + , "id" .= rqId rq ] + +-- | JSON-RPC response. +data Response = Response + { rsResult :: !(Either RpcError Value) + } deriving (Eq, Show) + +instance FromJSON Response where + parseJSON = + withObject "JSON-RPC response object" $ + \v -> Response <$> + (Right <$> v .: "result" <|> Left <$> v .: "error") + +-- | JSON-RPC error message +data RpcError = RpcError + { errCode :: !Int + , errMessage :: !Text + , errData :: !(Maybe Value) + } deriving Eq + +instance Show RpcError where + show (RpcError code msg dat) = + "JSON-RPC error " ++ show code ++ ": " ++ unpack msg + ++ ". Data: " ++ show dat + +instance FromJSON RpcError where + parseJSON = withObject "JSON-RPC error object" $ + \v -> RpcError <$> v .: "code" + <*> v .: "message" + <*> v .:? "data" + +-- | Typeclass for JSON-RPC monad base. +-- +-- If you have monad with 'MonadIO', 'MonadThrow' and 'MonadReader' instances, +-- it can be used as base for JSON-RPC calls. +-- +-- Example: +-- +-- @ +-- newtype MyMonad a = ... +-- +-- instance Remote MyMonad (Mymonad a) +-- +-- foo :: Int -> Bool -> Mymonad Text +-- foo = remote "foo" +-- @ +-- +class (MonadIO m, MonadThrow m, MonadReader Config m) => Remote m a | a -> m where + remote_ :: ([Value] -> m ByteString) -> a + + default remote_ :: (FromJSON b, m b ~ a) => ([Value] -> m ByteString) -> a + remote_ f = decodeResponse =<< f [] + +instance (ToJSON a, Remote m b) => Remote m (a -> b) where + remote_ f x = remote_ (\xs -> f (toJSON x : xs)) + +-- | Remote call of JSON-RPC method. +-- +-- Arguments of function are stored into @params@ request array. +-- +-- Example: +-- +-- @ +-- myMethod :: Int -> Bool -> m String +-- myMethod = remote "myMethod" +-- @ +-- +remote :: Remote m a => MethodName -> a +{-# INLINE remote #-} +remote = remote_ . call + +call :: (MonadIO m, + MonadThrow m, + MonadReader Config m) + => MethodName + -> [Value] + -> m ByteString +call n = connection . encode . Request n 1 . toJSON + where + connection body = do + (uri, manager) <- ask + request <- parseRequest uri + let request' = request + { requestBody = RequestBodyLBS body + , requestHeaders = [("Content-Type", "application/json")] + , method = "POST" } + responseBody <$> liftIO (httpLbs request' manager) + +data JsonRpcException + = ParsingException String + | CallException RpcError + deriving (Eq, Show) + +instance Exception JsonRpcException + +decodeResponse :: (MonadThrow m, FromJSON a) + => ByteString + -> m a +decodeResponse = (tryParse . eitherDecode . encode) + <=< tryResult . rsResult + <=< tryParse . eitherDecode + where + tryParse = either (throwM . ParsingException) return + tryResult = either (throwM . CallException) return diff --git a/test-support/contracts/Migrations.sol b/test-support/contracts/Migrations.sol new file mode 100644 --- /dev/null +++ b/test-support/contracts/Migrations.sol @@ -0,0 +1,23 @@ +pragma solidity ^0.4.4; + +contract Migrations { + address public owner; + uint public last_completed_migration; + + modifier restricted() { + if (msg.sender == owner) _; + } + + function Migrations() { + owner = msg.sender; + } + + function setCompleted(uint completed) restricted { + last_completed_migration = completed; + } + + function upgrade(address new_address) restricted { + Migrations upgraded = Migrations(new_address); + upgraded.setCompleted(last_completed_migration); + } +} diff --git a/test-support/contracts/SimpleStorage.sol b/test-support/contracts/SimpleStorage.sol new file mode 100644 --- /dev/null +++ b/test-support/contracts/SimpleStorage.sol @@ -0,0 +1,12 @@ +pragma solidity ^0.4.15; + +contract SimpleStorage { + uint public count; + + event CountSet(uint _count); + + function setCount(uint _count) { + count = _count; + CountSet(_count); + } +} diff --git a/test-support/convertAbi.sh b/test-support/convertAbi.sh new file mode 100644 --- /dev/null +++ b/test-support/convertAbi.sh @@ -0,0 +1,9 @@ +#!/bin/sh +set -xe +cd build/contracts/ +mkdir -p abis + +for file in *.json; do + jq '.abi' < "$file" > "abis/$file" +done + diff --git a/test-support/inject-contract-addresses.sh b/test-support/inject-contract-addresses.sh new file mode 100644 --- /dev/null +++ b/test-support/inject-contract-addresses.sh @@ -0,0 +1,26 @@ +#!/bin/bash + +set -ex + +EXPORT_STORE=${EXPORT_STORE:-/tmp/detected-vars} +SEARCH_DIRECTORY=${SEARCH_DIRECTORY:-build/contracts} + +function detect_contract_addresses() { + for file in $(find $SEARCH_DIRECTORY -maxdepth 1 -type f -name '*.json'); do + maybe_address=`jq -r .networks[].address $file | grep -v null | head -n 1` + if [ -z "${maybe_address}" ]; then + echo no addresses detected for $file >&2 + else + contract_name=`echo $file | sed -e 's@'$SEARCH_DIRECTORY'/@@g' -e 's/.json//g'` + echo found address "${maybe_address}" for "${contract_name}" >&2 + contract_var=`echo $contract_name | tr '[:lower:]' '[:upper:]'`_CONTRACT_ADDRESS + echo the var for "${contract_name}" is "${contract_var}" >&2 + echo "export ${contract_var}=`echo ${maybe_address} | sed s/0x//`" + fi + done +} + +detect_contract_addresses 2>/dev/null >$EXPORT_STORE + +source $EXPORT_STORE +$@ diff --git a/test-support/migrations/1_initial_migration.js b/test-support/migrations/1_initial_migration.js new file mode 100644 --- /dev/null +++ b/test-support/migrations/1_initial_migration.js @@ -0,0 +1,5 @@ +var Migrations = artifacts.require("./Migrations.sol"); + +module.exports = function(deployer) { + deployer.deploy(Migrations); +}; diff --git a/test-support/migrations/2_deploy_contracts.js b/test-support/migrations/2_deploy_contracts.js new file mode 100644 --- /dev/null +++ b/test-support/migrations/2_deploy_contracts.js @@ -0,0 +1,7 @@ +var SimpleStorage = artifacts.require("./SimpleStorage.sol"); +var ComplexStorage = artifacts.require("./ComplexStorage.sol"); + +module.exports = function(deployer) { + deployer.deploy(SimpleStorage); + deployer.deploy(ComplexStorage); +}; diff --git a/test-support/truffle.js b/test-support/truffle.js new file mode 100644 --- /dev/null +++ b/test-support/truffle.js @@ -0,0 +1,9 @@ +module.exports = { + networks: { + development: { + host: "localhost", + port: 8545, + network_id: "*" // Match any network id + } + } +}; diff --git a/test/Network/Ethereum/Web3/Test/ComplexStorageSpec.hs b/test/Network/Ethereum/Web3/Test/ComplexStorageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Web3/Test/ComplexStorageSpec.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Network.Ethereum.Web3.Test.ComplexStorage +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- ComplexStorage is a Solidity contract which has global variables of +-- several different types. The point of this test is to test the encoding +-- of a complicated Solidity tuple, consisting of dynamically and statically +-- sized components. +-- + +module Network.Ethereum.Web3.Test.ComplexStorageSpec where + +import Control.Concurrent.Async (wait) +import Control.Concurrent.MVar +import Control.Monad.IO.Class (liftIO) +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import Data.Default +import Data.Either (isRight) +import Data.Maybe +import Data.String (fromString) +import Network.Ethereum.Contract.TH +import Network.Ethereum.Web3 hiding (convert) +import qualified Network.Ethereum.Web3.Eth as Eth +import Network.Ethereum.Web3.Test.Utils +import Network.Ethereum.Web3.Types (Call (..), Filter (..)) +import System.Environment (getEnv) +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec + +[abiFrom|test-support/build/contracts/abis/ComplexStorage.json|] + +spec :: Spec +spec = describe "Complex Storage" $ do + it "should inject contract addresses" injectExportedEnvironmentVariables + withPrimaryEthereumAccount `before` complexStorageSpec + +complexStorageSpec :: SpecWith Address +complexStorageSpec = do + describe "can interact with a ComplexStorage contract" $ do + -- todo: these should ideally be arbitrary! + let sUint = 1 + sInt = -1 + sBool = True + sInt224 = 221 + sBools = [True, False] + sInts = [1, 1, -3] + sString = "hello" + sBytes16 = "\x12\x34\x56\x78\x12\x34\x56\x78\x12\x34\x56\x78\x12\x34\x56\x78" + sByte2sElem = "\x12\x34" + sByte2sVec = [sByte2sElem, sByte2sElem, sByte2sElem, sByte2sElem] + sByte2s = [sByte2sVec, sByte2sVec] + + it "can set the values of a ComplexStorage and validate them with an event" $ \primaryAccount -> do + contractAddress <- Prelude.fmap fromString . liftIO $ getEnv "COMPLEXSTORAGE_CONTRACT_ADDRESS" + let theCall = callFromTo primaryAccount contractAddress + fltr = (def :: Filter ValsSet) { filterAddress = Just contractAddress } + -- kick off listening for the ValsSet event + vals <- newEmptyMVar + fiber <- runWeb3Configured' $ + event fltr $ \vs -> do + liftIO $ putMVar vals vs + pure TerminateEvent + -- kick off tx + ret <- runWeb3Configured $ setValues theCall + sUint + sInt + sBool + sInt224 + sBools + sInts + sString + sBytes16 + sByte2s + -- wait for its ValsSet event + wait fiber + (ValsSet vsA vsB vsC vsD vsE vsF vsG vsH vsI) <- takeMVar vals + vsA `shouldBe` sUint + vsB `shouldBe` sInt + vsC `shouldBe` sBool + vsD `shouldBe` sInt224 + vsE `shouldBe` sBools + vsF `shouldBe` sInts + vsG `shouldBe` sString + vsH `shouldBe` sBytes16 + vsI `shouldBe` sByte2s + + it "can verify that it set the values correctly" $ \primaryAccount -> do + contractAddress <- Prelude.fmap fromString . liftIO $ getEnv "COMPLEXSTORAGE_CONTRACT_ADDRESS" + let theCall = callFromTo primaryAccount contractAddress + runGetterCall f = runWeb3Configured (f theCall) + -- there really has to be a better way to do this + uintVal' <- runGetterCall uintVal + intVal' <- runGetterCall intVal + boolVal' <- runGetterCall boolVal + int224Val' <- runGetterCall int224Val + boolsVal <- runGetterCall $ \c -> boolVectorVal c 0 + intsVal <- runGetterCall $ \c -> intListVal c 0 + stringVal' <- runGetterCall stringVal + bytes16Val' <- runGetterCall bytes16Val + bytes2s <- runGetterCall $ \c -> bytes2VectorListVal c 0 0 + uintVal' `shouldBe` sUint + intVal' `shouldBe` sInt + boolVal' `shouldBe` sBool + int224Val' `shouldBe` sInt224 + boolsVal `shouldBe` True + intsVal `shouldBe` sInts Prelude.!! 0 + stringVal' `shouldBe` sString + bytes16Val' `shouldBe` sBytes16 + bytes2s `shouldBe` sByte2sElem + + it "can decode a complicated value correctly" $ \primaryAccount -> do + contractAddress <- Prelude.fmap fromString . liftIO $ getEnv "COMPLEXSTORAGE_CONTRACT_ADDRESS" + let theCall = callFromTo primaryAccount contractAddress + runGetterCall f = runWeb3Configured (f theCall) + allVals <- runGetterCall getVals + allVals `shouldBe` (sUint, sInt, sBool, sInt224, sBools, sInts, sString, sBytes16, sByte2s) diff --git a/test/Network/Ethereum/Web3/Test/SimpleStorageSpec.hs b/test/Network/Ethereum/Web3/Test/SimpleStorageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Web3/Test/SimpleStorageSpec.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Network.Ethereum.Web3.Test.SimpleStorage +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- SimpleStorage is a Solidity contract which stores a uint256. +-- The point of this test is to test function calls to update and +-- read the value, as well as an event monitor. + +module Network.Ethereum.Web3.Test.SimpleStorageSpec where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (wait) +import Control.Concurrent.MVar +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ask) +import Data.ByteString (ByteString) +import Data.Default +import Data.Either (isRight) +import Data.Foldable (forM_) +import Data.List (sort) +import Data.Maybe +import Data.Monoid +import Data.String (fromString) +import qualified Data.Text as T +import Data.Traversable (for) +import GHC.TypeLits + +import Network.Ethereum.Contract.TH +import Network.Ethereum.Web3 hiding (convert) +import qualified Network.Ethereum.Web3.Eth as Eth +import Network.Ethereum.Web3.Provider (forkWeb3) +import Network.Ethereum.Web3.Types + +import Numeric (showHex) +import System.Environment (getEnv) +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec + +import Network.Ethereum.Web3.Test.Utils + +[abiFrom|test-support/build/contracts/abis/SimpleStorage.json|] + +unCountSet :: CountSet -> UIntN 256 +unCountSet (CountSet n) = n + +contractAddress :: Address +contractAddress = fromString . unsafePerformIO $ getEnv "SIMPLESTORAGE_CONTRACT_ADDRESS" + +spec :: Spec +spec = describe "Simple Storage" $ do + it "should inject contract addresses" injectExportedEnvironmentVariables + withPrimaryEthereumAccount `before` interactions + withPrimaryEthereumAccount `before` events + +interactions :: SpecWith Address +interactions = describe "can interact with a SimpleStorage contract" $ do + -- todo: this should ideally be arbitrary! + let theValue = 12345 + it "can set the value of a SimpleStorage contract" $ \primaryAccount -> do + let theCall = callFromTo primaryAccount contractAddress + ret <- runWeb3Configured $ setCount theCall theValue + True `shouldBe` True -- we need to get this far + + it "can read the value back" $ \primaryAccount -> do + let theCall = callFromTo primaryAccount contractAddress + now <- runWeb3Configured Eth.blockNumber + let later = now + 3 + awaitBlock later + v <- runWeb3Configured (count theCall) + v `shouldBe` theValue + +events :: SpecWith Address +events = describe "can interact with a SimpleStorage contract across block intervals" $ do + it "can stream events starting and ending in the future, unbounded" $ \primaryAccount -> do + var <- newMVar [] + let theCall = callFromTo primaryAccount contractAddress + theSets = [1, 2, 3] + print "Setting up the filter..." + fiber <- runWeb3Configured' $ do + let fltr = (def :: Filter CountSet) { filterAddress = Just contractAddress } + forkWeb3 $ processUntil' var fltr ((3 ==) . length) + print "Setting the values..." + setValues theCall theSets + wait fiber + print "Filter caught 3 values..." + vals <- takeMVar var + sort (unCountSet <$> vals) `shouldBe` sort theSets + + it "can stream events starting and ending in the future, bounded" $ \primaryAccount -> do + runWeb3Configured Eth.blockNumber >>= \bn -> awaitBlock (bn + 1) + var <- newMVar [] + let theCall = callFromTo primaryAccount contractAddress + theSets = [13, 14, 15] + start <- runWeb3Configured Eth.blockNumber + let later = BlockWithNumber (start + 3) + latest = BlockWithNumber (start + 8) + fltr = (def :: Filter CountSet) { filterAddress = Just contractAddress + , filterFromBlock = later + , filterToBlock = latest } + print "Setting up the filter..." + fiber <- runWeb3Configured' $ + forkWeb3 $ processUntil' var fltr ((3 ==) . length) + awaitBlock (start + 3) + print "Setting the values..." + setValues theCall theSets + wait fiber + print "Filter caught 3 values..." + vals <- takeMVar var + sort (unCountSet <$> vals) `shouldBe` sort theSets + + it "can stream events starting in the past and ending in the future" $ \primaryAccount -> do + runWeb3Configured Eth.blockNumber >>= \bn -> awaitBlock (bn + 1) + var <- newMVar [] + blockNumberVar <- newEmptyMVar + let theCall = callFromTo primaryAccount contractAddress + theSets1 = [7, 8, 9] + theSets2 = [10, 11, 12] + start <- runWeb3Configured Eth.blockNumber + let fltr = (def :: Filter CountSet) { filterAddress = Just contractAddress } + fiber <- runWeb3Configured' $ do + forkWeb3 $ processUntil var fltr ((3 ==) . length) (liftIO . putMVar blockNumberVar . changeBlockNumber) + print "Running first transactions as past transactions..." + setValues theCall theSets1 + wait fiber + print "All past transactions succeeded... " + end <- takeMVar blockNumberVar + awaitBlock $ end + 1 -- make past transactions definitively in past + var' <- newMVar [] + fiber <- runWeb3Configured' $ do + let fltr = (def :: Filter CountSet) { filterAddress = Just contractAddress + , filterFromBlock = BlockWithNumber start} + forkWeb3 $ processUntil' var' fltr ((6 ==) . length) + print "Setting more values" + setValues theCall theSets2 + wait fiber + print "All new values have ben set" + vals <- takeMVar var' + sort (unCountSet <$> vals) `shouldBe` sort (theSets1 <> theSets2) + + it "can stream events starting and ending in the past, bounded" $ \primaryAccount -> do + runWeb3Configured Eth.blockNumber >>= \bn -> awaitBlock (bn + 1) + var <- newMVar [] + let theCall = callFromTo primaryAccount contractAddress + theSets = [4, 5, 6] + start <- runWeb3Configured Eth.blockNumber + blockNumberVar <- newEmptyMVar + let fltr = (def :: Filter CountSet) { filterAddress = Just contractAddress } + print "Setting up filter for past transactions..." + fiber <- runWeb3Configured' $ do + forkWeb3 $ processUntil var fltr ((3 ==) . length) (liftIO . putMVar blockNumberVar . changeBlockNumber) + print "Setting values" + setValues theCall theSets + wait fiber + print "All values have been set" + end <- takeMVar blockNumberVar + var' <- newMVar [] + let fltr' = fltr { filterFromBlock = BlockWithNumber start + , filterToBlock = BlockWithNumber end + } + awaitBlock $ end + 1 -- make it definitively in the past + runWeb3Configured $ processUntil' var' fltr' ((3 ==) . length) + vals <- takeMVar var' + sort (unCountSet <$> vals) `shouldBe` sort theSets + +processUntil :: MVar [CountSet] + -> Filter CountSet + -> ([CountSet] -> Bool) -- TODO: make it work for any event + -> (Change -> Web3 ()) + -> Web3 () +processUntil var filter predicate action = do + event' filter $ \(ev :: CountSet) -> do + newV <- liftIO $ modifyMVar var $ \v -> return (ev:v, ev:v) + if predicate newV + then do + change <- ask + lift $ action change + return TerminateEvent + else return ContinueEvent + +processUntil' :: MVar [CountSet] + -> Filter CountSet + -> ([CountSet] -> Bool) + -> Web3 () +processUntil' var filter predicate = processUntil var filter predicate (const $ return ()) + +setValues :: Call -> [UIntN 256] -> IO () +setValues theCall theSets = forM_ theSets $ \v -> do + runWeb3Configured (setCount theCall v) + threadDelay 1000000 diff --git a/test/Network/Ethereum/Web3/Test/Utils.hs b/test/Network/Ethereum/Web3/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Web3/Test/Utils.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE LambdaCase #-} +module Network.Ethereum.Web3.Test.Utils + ( injectExportedEnvironmentVariables + , runWeb3Configured + , runWeb3Configured' + , withAccounts + , withPrimaryEthereumAccount + , callFromTo + , sleepSeconds + , microtime + , awaitBlock + ) where + +import Control.Concurrent (MVar, threadDelay, + tryTakeMVar) +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.Either (isRight) +import Data.List.Split (splitOn) +import Data.Maybe (fromMaybe) +import Data.Ratio (numerator) +import Data.String (IsString, fromString) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Traversable (for) + +import Network.Ethereum.ABI.Prim.Address (Address) +import Network.Ethereum.Web3.Eth (accounts, blockNumber) +import Network.Ethereum.Web3.Provider (Provider (..), Web3, + Web3Error, runWeb3') +import Network.Ethereum.Web3.Types (BlockNumber, Call (..)) +import System.Environment (lookupEnv, setEnv) +import Test.Hspec.Expectations (shouldSatisfy) + +rpcUri :: IO String +rpcUri = liftIO (fromMaybe "http://localhost:8545" <$> lookupEnv "WEB3_PROVIDER") + +exportStore :: String +exportStore = "./test-support/.detected-contract-addresses" + +loadExportedEnvironmentVariables :: IO [(String, String)] +loadExportedEnvironmentVariables = do + exportables <- lines <$> readFile exportStore + detecteds <- for exportables $ \line -> case words line of + ["export", e] -> case splitOn "=" e of + [x] -> detectedEnv x "" + [k, v] -> detectedEnv k v + _ -> warnMalformation $ "oddly structured export statement " ++ line + _ -> warnMalformation $ "no export in line " ++ line + return $ concat detecteds + + where warnMalformation m = do + putStrLn $ m ++ ". are you sure you're using the right inject-contract-addresses.sh?" + pure [] + detectedEnv k v = do + -- putStrLn $ "detected " ++ k ++ "=" ++ v + pure [(k, v)] + +injectExportedEnvironmentVariables :: IO () +injectExportedEnvironmentVariables = do + detectedEnvs <- loadExportedEnvironmentVariables + sequence_ (uncurry setEnv <$> detectedEnvs) + +runWeb3Configured :: Show a => Web3 a -> IO a +runWeb3Configured f = do + provider <- HttpProvider <$> rpcUri + v <- runWeb3' provider f + v `shouldSatisfy` isRight + let Right a = v in return a + +runWeb3Configured' :: Web3 a -> IO a +runWeb3Configured' f = do + provider <- HttpProvider <$> rpcUri + Right v <- runWeb3' provider f + return v + +withAccounts :: ([Address] -> IO a) -> IO a +withAccounts f = runWeb3Configured accounts >>= f + +withPrimaryEthereumAccount :: IO Address +withPrimaryEthereumAccount = withAccounts (pure . head) + +callFromTo :: Address -> Address -> Call +callFromTo from to = + def { callFrom = Just from + , callTo = Just to + , callGasPrice = Just 4000000000 + } + +sleepSeconds :: Int -> IO () +sleepSeconds = threadDelay . (* 1000000) + +microtime :: IO Integer +microtime = numerator . toRational . (* 1000000) <$> getPOSIXTime + +awaitBlock :: BlockNumber -> IO () +awaitBlock bn = do + bn' <- runWeb3Configured blockNumber + putStrLn $ "awaiting block " ++ show bn ++ ", currently " ++ show bn' + if bn' >= bn + then return () + else threadDelay 1000000 >> awaitBlock bn diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,27 +1,1 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module Main where - -import Data.Text (unpack) -import Network.Ethereum.Web3 -import Network.Ethereum.Web3.TH -import Text.Printf - -[abiFrom|data/ERC20.json|] - -main :: IO () -main = do - putStrLn "" - 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" --} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/unit/Network/Ethereum/Web3/Test/EncodingSpec.hs b/unit/Network/Ethereum/Web3/Test/EncodingSpec.hs new file mode 100644 --- /dev/null +++ b/unit/Network/Ethereum/Web3/Test/EncodingSpec.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Network.Ethereum.Web3.Test.EncodingSpec where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import Generics.SOP (Generic, Rep) +import Test.Hspec + +import Network.Ethereum.ABI.Class (ABIGet, ABIPut, + GenericABIGet, GenericABIPut) +import Network.Ethereum.ABI.Codec (decode, decode', encode, + encode') +import Network.Ethereum.ABI.Prim.Bool () +import Network.Ethereum.ABI.Prim.Bytes (Bytes, BytesN) +import Network.Ethereum.ABI.Prim.Int (IntN, UIntN) +import Network.Ethereum.ABI.Prim.List (ListN) +import Network.Ethereum.ABI.Prim.String () +import Network.Ethereum.ABI.Prim.Tuple (Singleton (..)) + +spec :: Spec +spec = do + intNTest + bytesTest + bytesNTest + vectorTest + dynamicArraysTest + tuplesTest + +intNTest :: Spec +intNTest = + describe "uint tests" $ do + + it "can encode int16" $ + let decoded = (-1) :: IntN 16 + encoded = "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + in roundTrip decoded encoded + + it "can encode larger uint256" $ + let decoded = (2 ^ 255) - 1 :: UIntN 256 + encoded = "0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + in roundTrip decoded encoded + +bytesTest :: Spec +bytesTest = do + describe "bytes tests" $ do + + it "can encode short bytes" $ do + let decoded :: Bytes + decoded = "0xc3a40000c3a4" + encoded = "0x0000000000000000000000000000000000000000000000000000000000000006" + <> "0xc3a40000c3a40000000000000000000000000000000000000000000000000000" + in roundTrip decoded encoded + + it "can encode long bytes" $ do + let decoded :: Bytes + decoded = "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1" + encoded = "0x000000000000000000000000000000000000000000000000000000000000009f" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff100" + in roundTrip decoded encoded + +bytesNTest :: Spec +bytesNTest = + describe "sized bytes tests" $ do + + it "can encode Bytes1" $ do + let decoded = "0xcf" :: BytesN 1 + encoded = "0xcf00000000000000000000000000000000000000000000000000000000000000" + roundTrip decoded encoded + + it "can encode Bytes12" $ do + let decoded = "0x6761766f66796f726b000000" :: BytesN 12 + encoded = "0x6761766f66796f726b0000000000000000000000000000000000000000000000" + roundTrip decoded encoded + +vectorTest :: Spec +vectorTest = + describe "statically sized array tests" $ do + + it "can encode statically sized vectors of addresses" $ do + let decoded = [False, True] :: ListN 2 Bool + encoded = "0x0000000000000000000000000000000000000000000000000000000000000000" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + in roundTrip decoded encoded + + it "can encode statically sized vectors of statically sized bytes"$ do + let elem1 = "0xcf" + elem2 = "0x68" + elem3 = "0x4d" + elem4 = "0xfb" + decoded = [elem1, elem2, elem3, elem4] :: ListN 4 (BytesN 1) + encoded = "0xcf00000000000000000000000000000000000000000000000000000000000000" + <> "0x6800000000000000000000000000000000000000000000000000000000000000" + <> "0x4d00000000000000000000000000000000000000000000000000000000000000" + <> "0xfb00000000000000000000000000000000000000000000000000000000000000" + in roundTrip decoded encoded + +dynamicArraysTest :: Spec +dynamicArraysTest = do + describe "dynamically sized array tests" $ do + + it "can encode dynamically sized lists of bools" $ do + let decoded = [True, True, False] :: [Bool] + encoded = "0x0000000000000000000000000000000000000000000000000000000000000003" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x0000000000000000000000000000000000000000000000000000000000000000" + in roundTrip decoded encoded + +tuplesTest :: Spec +tuplesTest = + describe "tuples test" $ do + + it "can encode 2-tuples with both static args" $ do + let decoded = (True, False) + encoded = "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x0000000000000000000000000000000000000000000000000000000000000000" + in roundTripGeneric decoded encoded + + it "can encode 1-tuples with dynamic arg" $ do + let decoded = Singleton ([True, False] :: [Bool]) + encoded = "0x0000000000000000000000000000000000000000000000000000000000000020" + <> "0x0000000000000000000000000000000000000000000000000000000000000002" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x0000000000000000000000000000000000000000000000000000000000000000" + in roundTripGeneric decoded encoded + + it "can encode 4-tuples with a mix of args - (UInt32, String, Boolean, Array Int256)" $ do + let decoded = (1 :: IntN 32, "dave" :: Text, True, [1, 2, 3] :: [IntN 256]) + encoded = "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x0000000000000000000000000000000000000000000000000000000000000080" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x00000000000000000000000000000000000000000000000000000000000000c0" + <> "0x0000000000000000000000000000000000000000000000000000000000000004" + <> "0x6461766500000000000000000000000000000000000000000000000000000000" + <> "0x0000000000000000000000000000000000000000000000000000000000000003" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x0000000000000000000000000000000000000000000000000000000000000002" + <> "0x0000000000000000000000000000000000000000000000000000000000000003" + in roundTripGeneric decoded encoded + + it "can do something really complicated" $ do + let uint = 1 :: UIntN 256 + int = (-1) :: IntN 256 + bool = True + int224 = 221 :: IntN 224 + bools = [True, False] :: ListN 2 Bool + ints = [1, (-1), 3] :: [IntN 32] + string = "hello" :: Text + bytes16 = "0x12345678123456781234567812345678" :: BytesN 16 + elem = "0x1234" :: BytesN 2 + bytes2s = [ [elem, elem, elem, elem] + , [elem, elem, elem, elem] + ] :: [ListN 4 (BytesN 2)] + + decoded = (uint, int, bool, int224, bools, ints, string, bytes16, bytes2s) + + encoded = "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x00000000000000000000000000000000000000000000000000000000000000dd" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0x0000000000000000000000000000000000000000000000000000000000000000" + <> "0x0000000000000000000000000000000000000000000000000000000000000140" + <> "0x00000000000000000000000000000000000000000000000000000000000001c0" + <> "0x1234567812345678123456781234567800000000000000000000000000000000" + <> "0x0000000000000000000000000000000000000000000000000000000000000200" + <> "0x0000000000000000000000000000000000000000000000000000000000000003" + <> "0x0000000000000000000000000000000000000000000000000000000000000001" + <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + <> "0x0000000000000000000000000000000000000000000000000000000000000003" + <> "0x0000000000000000000000000000000000000000000000000000000000000005" + <> "0x68656c6c6f000000000000000000000000000000000000000000000000000000" + <> "0x0000000000000000000000000000000000000000000000000000000000000002" + <> "0x1234000000000000000000000000000000000000000000000000000000000000" + <> "0x1234000000000000000000000000000000000000000000000000000000000000" + <> "0x1234000000000000000000000000000000000000000000000000000000000000" + <> "0x1234000000000000000000000000000000000000000000000000000000000000" + <> "0x1234000000000000000000000000000000000000000000000000000000000000" + <> "0x1234000000000000000000000000000000000000000000000000000000000000" + <> "0x1234000000000000000000000000000000000000000000000000000000000000" + <> "0x1234000000000000000000000000000000000000000000000000000000000000" + + in roundTripGeneric decoded encoded + +-- | Run encoded/decoded comaration +roundTrip :: ( Show a + , Eq a + , ABIPut a + , ABIGet a + ) + => a + -> Bytes + -> IO () +roundTrip decoded encoded = do + encoded `shouldBe` encode decoded + decode encoded `shouldBe` Right decoded + +-- | Run generic encoded/decoded comaration +roundTripGeneric :: ( Show a + , Eq a + , Generic a + , Rep a ~ rep + , GenericABIPut rep + , GenericABIGet rep + ) + => a + -> Bytes + -> IO () +roundTripGeneric decoded encoded = do + encoded `shouldBe` encode' decoded + decode' encoded `shouldBe` Right decoded diff --git a/unit/Network/Ethereum/Web3/Test/EventSpec.hs b/unit/Network/Ethereum/Web3/Test/EventSpec.hs new file mode 100644 --- /dev/null +++ b/unit/Network/Ethereum/Web3/Test/EventSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Ethereum.Web3.Test.EventSpec where + +import Data.Tagged (Tagged) +import Generics.SOP (Generic) +import qualified GHC.Generics as GHC (Generic) +import Test.Hspec (Spec, describe, it, + shouldBe) + +import Network.Ethereum.ABI.Class (ABIGet) +import Network.Ethereum.ABI.Event (IndexedEvent (..), + decodeEvent) +import Network.Ethereum.ABI.Prim.Address (Address) +import Network.Ethereum.ABI.Prim.Bytes () +import Network.Ethereum.ABI.Prim.Int (UIntN) +import Network.Ethereum.ABI.Prim.Tagged () +import Network.Ethereum.Web3.Types (Change (..)) + + +spec :: Spec +spec = eventTest + +eventTest :: Spec +eventTest = + describe "event tests" $ do + + it "can decode simple storage" $ + let change = Change { changeLogIndex = "0x2" + , changeTransactionIndex = "0x2" + , changeTransactionHash = "0xe8cac6af0ceb3cecbcb2a5639361fc9811b1aa753672cf7c7e8b528df53e0e94" + , changeBlockHash = "0x0c7e1701858232ac210e3bcc8ab3b33cc6b08025692b22abb39059dc41f6a76e" + , changeBlockNumber = 0 + , changeAddress = "0x617e5941507aab5d2d8bcb56cb8c6ce2eeb16b21" + , changeData = "0x000000000000000000000000000000000000000000000000000000000000000a" + , changeTopics = ["0xa32bc18230dd172221ac5c4821a5f1f1a831f27b1396d244cdd891c58f132435"] + } + in decodeEvent change `shouldBe` Right (NewCount 10) + + it "can decode erc20" $ + let ercchange = Change { changeLogIndex = "0x2" + , changeTransactionIndex = "0x2" + , changeTransactionHash = "0xe8cac6af0ceb3cecbcb2a5639361fc9811b1aa753672cf7c7e8b528df53e0e94" + , changeBlockHash = "0x0c7e1701858232ac210e3bcc8ab3b33cc6b08025692b22abb39059dc41f6a76e" + , changeBlockNumber = 0 + , changeAddress = "0x617e5941507aab5d2d8bcb56cb8c6ce2eeb16b21" + , changeData = "0x000000000000000000000000000000000000000000000000000000000000000a" + , changeTopics = [ "0xb32bc18230dd172221ac5c4821a5f1f1a831f27b1396d244cdd891c58f132435" + , "0x0000000000000000000000000000000000000000000000000000000000000001" + , "0x0000000000000000000000000000000000000000000000000000000000000002" + ] + } + in decodeEvent ercchange `shouldBe` Right (Transfer "0x0000000000000000000000000000000000000001" 10 "0x0000000000000000000000000000000000000002") + +-- SimpleStorage Event Types + +data NewCount = NewCount (UIntN 256) deriving (Eq, Show, GHC.Generic) +instance Generic NewCount + +data NewCountIndexed = NewCountIndexed deriving (Eq, Show, GHC.Generic) +instance Generic NewCountIndexed + +data NewCountNonIndexed = NewCountNonIndexed (Tagged 1 (UIntN 256)) deriving (Eq, Show, GHC.Generic) +instance Generic NewCountNonIndexed + +instance IndexedEvent NewCountIndexed NewCountNonIndexed NewCount where + isAnonymous = const False + +-- WeirdERC20 Event Types (Transfer type wrong order for testing purposes) +data Transfer = Transfer Address (UIntN 256) Address deriving (Eq, Show, GHC.Generic) +instance Generic Transfer + +data TransferIndexed = TransferIndexed (Tagged 1 Address) (Tagged 3 Address) deriving (Eq, Show, GHC.Generic) +instance Generic TransferIndexed + +data TransferNonIndexed = TransferNonIndexed (Tagged 2 (UIntN 256)) deriving (Eq, Show, GHC.Generic) +instance Generic TransferNonIndexed + +instance IndexedEvent TransferIndexed TransferNonIndexed Transfer where + isAnonymous = const False diff --git a/unit/Network/Ethereum/Web3/Test/MethodDumpSpec.hs b/unit/Network/Ethereum/Web3/Test/MethodDumpSpec.hs new file mode 100644 --- /dev/null +++ b/unit/Network/Ethereum/Web3/Test/MethodDumpSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Network.Ethereum.Web3.Test.MethodDumpSpec where + +import Network.Ethereum.Contract.TH +import Test.Hspec +import Text.Printf + + +spec :: Spec +spec = describe "methodDump" $ + it "can dump an ABI" $ do + let theApiDump = [abiFrom|examples/ERC20.json|] + in theApiDump `shouldNotBe` "" diff --git a/unit/Spec.hs b/unit/Spec.hs new file mode 100644 --- /dev/null +++ b/unit/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/web3.cabal b/web3.cabal --- a/web3.cabal +++ b/web3.cabal @@ -1,5 +1,5 @@ name: web3 -version: 0.6.0.0 +version: 0.7.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -14,7 +14,17 @@ author: Alexander Krupenkin extra-source-files: README.md - data/ERC20.json + CHANGELOG.md + test-support/contracts/Migrations.sol + test-support/contracts/SimpleStorage.sol + test-support/truffle.js + test-support/migrations/1_initial_migration.js + test-support/migrations/2_deploy_contracts.js + test-support/convertAbi.sh + test-support/inject-contract-addresses.sh + examples/ERC20.hs + examples/ERC20.json + examples/TokenInfo.hs source-repository head type: git @@ -23,51 +33,112 @@ library exposed-modules: Network.Ethereum.Web3 - Network.Ethereum.Unit - Network.Ethereum.Web3.TH - Network.Ethereum.Web3.Web3 Network.Ethereum.Web3.Eth Network.Ethereum.Web3.Net + Network.Ethereum.Web3.Web3 Network.Ethereum.Web3.Types - Network.Ethereum.Web3.Address - Network.Ethereum.Web3.JsonAbi Network.Ethereum.Web3.Provider - Network.Ethereum.Web3.Encoding - Network.Ethereum.Web3.Contract - Network.Ethereum.Web3.Encoding.Bytes - Network.Ethereum.Web3.Encoding.Tuple + Network.Ethereum.Unit + Network.Ethereum.ABI.Json + Network.Ethereum.ABI.Class + Network.Ethereum.ABI.Codec + Network.Ethereum.ABI.Event + Network.Ethereum.ABI.Event.Internal + Network.Ethereum.ABI.Generic + Network.Ethereum.ABI.Prim.Int + Network.Ethereum.ABI.Prim.Bool + Network.Ethereum.ABI.Prim.List + Network.Ethereum.ABI.Prim.Bytes + Network.Ethereum.ABI.Prim.Tuple + Network.Ethereum.ABI.Prim.Tuple.TH + Network.Ethereum.ABI.Prim.String + Network.Ethereum.ABI.Prim.Tagged + Network.Ethereum.ABI.Prim.Address + Network.Ethereum.Contract.TH + Network.Ethereum.Contract.Event + Network.Ethereum.Contract.Method + Network.JsonRpc.TinyClient + Data.String.Extra build-depends: base >4.8 && <4.11, - base16-bytestring >=0.1.1.6 && <0.2, - template-haskell >=2.11.1.0 && <2.12, - http-client-tls >=0.3.5.1 && <0.4, + template-haskell >=2.12.0.0 && <2.13, + data-default >=0.7.1.1 && <0.8, + generics-sop >=0.3.2.0 && <0.4, transformers >=0.5.2.0 && <0.6, - http-client >=0.5.7.0 && <0.6, - attoparsec >=0.13.1.0 && <0.14, - bytestring >=0.10.8.1 && <0.11, - cryptonite ==0.23.*, - vector >=0.12.0.1 && <0.13, - memory >=0.14.8 && <0.15, - aeson >=1.1.2.0 && <1.2, - text >=1.2.2.2 && <1.3 + http-client >=0.5.12.1 && <0.6, + http-client-tls >=0.3.5.3 && <0.4, + exceptions >=0.8.3 && <0.9, + bytestring >=0.10.8.2 && <0.11, + cryptonite ==0.25.*, + basement >=0.0.7 && <0.1, + machines >=0.6.3 && <0.7, + tagged >=0.8.5 && <0.9, + parsec >=3.1.13.0 && <3.2, + memory >=0.14.16 && <0.15, + cereal >=0.5.5.0 && <0.6, + aeson >=1.2.4.0 && <1.3, + async >=2.1.1.1 && <2.2, + text >=1.2.3.0 && <1.3, + mtl >=2.2.2 && <2.3 default-language: Haskell2010 - default-extensions: OverloadedStrings hs-source-dirs: src - other-modules: - Network.Ethereum.Web3.JsonRpc - Network.Ethereum.Web3.Internal - Network.Ethereum.Web3.Encoding.TupleTH - Network.Ethereum.Web3.Encoding.Internal + ghc-options: -Wduplicate-exports -Whi-shadowing -Widentities -Wnoncanonical-monoid-instances -Woverlapping-patterns -Wtabs -Wpartial-type-signatures -Wderiving-typeable -Wunrecognised-pragmas -Wunticked-promoted-constructors -Wtyped-holes -Wincomplete-patterns -Wincomplete-uni-patterns -Wmissing-fields -Wmissing-methods -Wmissing-exported-signatures -Wmissing-monadfail-instances -Wmissing-signatures -Wname-shadowing -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -Wunused-binds -Wunused-top-binds -Wunused-local-binds -Wunused-pattern-binds -Wunused-imports -Wunused-matches -Wunused-foralls -Wunused-do-bind -Wwrong-do-bind -Wtrustworthy-safe -Wwarnings-deprecations -Wdeferred-type-errors -test-suite web3-test +test-suite unit type: exitcode-stdio-1.0 main-is: Spec.hs build-depends: - base >=4.9.1.0 && <4.10, - memory >=0.14.8 && <0.15, - text >=1.2.2.2 && <1.3, - web3 + base >4.8 && <4.11, + hspec-expectations >=0.8.2 && <0.9, + hspec-discover >=2.4.8 && <2.5, + hspec-contrib >=0.4.0 && <0.5, + hspec >=2.4.8 && <2.5, + data-default >=0.7.1.1 && <0.8, + generics-sop >=0.3.2.0 && <0.4, + transformers >=0.5.2.0 && <0.6, + bytestring >=0.10.8.2 && <0.11, + memory >=0.14.16 && <0.15, + tagged >=0.8.5 && <0.9, + split >=0.2.3.3 && <0.3, + time >=1.8.0.2 && <1.9, + text >=1.2.3.0 && <1.3, + web3 -any default-language: Haskell2010 - default-extensions: OverloadedStrings + hs-source-dirs: unit + other-modules: + Network.Ethereum.Web3.Test.MethodDumpSpec + Network.Ethereum.Web3.Test.EncodingSpec + Network.Ethereum.Web3.Test.EventSpec + ghc-options: -threaded -rtsopts -with-rtsopts=-N +test-suite live + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + async >=2.1.1.1 && <2.2, + base >=4.10.1.0 && <4.11, + bytestring >=0.10.8.2 && <0.11, + data-default >=0.7.1.1 && <0.8, + hspec >=2.4.8 && <2.5, + hspec-contrib >=0.4.0 && <0.5, + hspec-discover >=2.4.8 && <2.5, + hspec-expectations >=0.8.2 && <0.9, + hspec-discover >=2.4.8 && <2.5, + hspec-contrib >=0.4.0 && <0.5, + hspec >=2.4.8 && <2.5, + transformers >=0.5.2.0 && <0.6, + data-default >=0.7.1.1 && <0.8, + bytestring >=0.10.8.2 && <0.11, + memory >=0.14.16 && <0.15, + split >=0.2.3.3 && <0.3, + text >=1.2.3.0 && <1.3, + time >=1.8.0.2 && <1.9, + text >=1.2.3.0 && <1.3, + web3 -any, + stm >=2.4.5.0 && <2.5 + default-language: Haskell2010 hs-source-dirs: test + other-modules: + Network.Ethereum.Web3.Test.ComplexStorageSpec + Network.Ethereum.Web3.Test.SimpleStorageSpec + Network.Ethereum.Web3.Test.Utils ghc-options: -threaded -rtsopts -with-rtsopts=-N