packages feed

web3 0.6.0.0 → 0.7.0.0

raw patch · 60 files changed

+3461/−1538 lines, 60 filesdep +asyncdep +basementdep +cerealdep −attoparsecdep −base16-bytestringdep −vectordep ~aesondep ~basedep ~bytestring

Dependencies added: async, basement, cereal, data-default, exceptions, generics-sop, hspec, hspec-contrib, hspec-discover, hspec-expectations, machines, mtl, parsec, split, stm, tagged, time

Dependencies removed: attoparsec, base16-bytestring, vector

Dependency ranges changed: aeson, base, bytestring, cryptonite, http-client, http-client-tls, memory, template-haskell, text

Files

+ CHANGELOG.md view
@@ -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).
README.md view
@@ -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.
− data/ERC20.json 
@@ -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"}]
+ examples/ERC20.hs view
@@ -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|]
+ examples/ERC20.json view
@@ -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"}]
+ examples/TokenInfo.hs view
@@ -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 }
+ src/Data/String/Extra.hs view
@@ -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
+ src/Network/Ethereum/ABI/Class.hs view
@@ -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
+ src/Network/Ethereum/ABI/Codec.hs view
@@ -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
+ src/Network/Ethereum/ABI/Event.hs view
@@ -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
+ src/Network/Ethereum/ABI/Event/Internal.hs view
@@ -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
+ src/Network/Ethereum/ABI/Generic.hs view
@@ -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
+ src/Network/Ethereum/ABI/Json.hs view
@@ -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"
+ src/Network/Ethereum/ABI/Prim/Address.hs view
@@ -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
+ src/Network/Ethereum/ABI/Prim/Bool.hs view
@@ -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
+ src/Network/Ethereum/ABI/Prim/Bytes.hs view
@@ -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
+ src/Network/Ethereum/ABI/Prim/Int.hs view
@@ -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
+ src/Network/Ethereum/ABI/Prim/List.hs view
@@ -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
+ src/Network/Ethereum/ABI/Prim/String.hs view
@@ -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
+ src/Network/Ethereum/ABI/Prim/Tagged.hs view
@@ -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)
+ src/Network/Ethereum/ABI/Prim/Tuple.hs view
@@ -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])
+ src/Network/Ethereum/ABI/Prim/Tuple/TH.hs view
@@ -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)) [] ]
+ src/Network/Ethereum/Contract/Event.hs view
@@ -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
+ src/Network/Ethereum/Contract/Method.hs view
@@ -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
+ src/Network/Ethereum/Contract/TH.hs view
@@ -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)
src/Network/Ethereum/Unit.hs view
@@ -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)
src/Network/Ethereum/Web3.hs view
@@ -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 (..))
− src/Network/Ethereum/Web3/Address.hs 
@@ -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
− src/Network/Ethereum/Web3/Contract.hs 
@@ -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
− src/Network/Ethereum/Web3/Encoding.hs 
@@ -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
− src/Network/Ethereum/Web3/Encoding/Bytes.hs 
@@ -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<M> 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
− src/Network/Ethereum/Web3/Encoding/Internal.hs 
@@ -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
− src/Network/Ethereum/Web3/Encoding/Tuple.hs 
@@ -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)
− src/Network/Ethereum/Web3/Encoding/TupleTH.hs 
@@ -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 ]
src/Network/Ethereum/Web3/Eth.hs view
@@ -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"
− src/Network/Ethereum/Web3/Internal.hs 
@@ -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
− src/Network/Ethereum/Web3/JsonAbi.hs 
@@ -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
− src/Network/Ethereum/Web3/JsonRpc.hs 
@@ -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 <http://www.jsonrpc.org/specification>.----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")
src/Network/Ethereum/Web3/Net.hs view
@@ -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"
src/Network/Ethereum/Web3/Provider.hs view
@@ -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
− src/Network/Ethereum/Web3/TH.hs 
@@ -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)
src/Network/Ethereum/Web3/Types.hs view
@@ -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
src/Network/Ethereum/Web3/Web3.hs view
@@ -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"
+ src/Network/JsonRpc/TinyClient.hs view
@@ -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 <http://www.jsonrpc.org/specification>.+--++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
+ test-support/contracts/Migrations.sol view
@@ -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);+  }+}
+ test-support/contracts/SimpleStorage.sol view
@@ -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);+    }+}
+ test-support/convertAbi.sh view
@@ -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+
+ test-support/inject-contract-addresses.sh view
@@ -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+$@
+ test-support/migrations/1_initial_migration.js view
@@ -0,0 +1,5 @@+var Migrations = artifacts.require("./Migrations.sol");++module.exports = function(deployer) {+  deployer.deploy(Migrations);+};
+ test-support/migrations/2_deploy_contracts.js view
@@ -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);+};
+ test-support/truffle.js view
@@ -0,0 +1,9 @@+module.exports = {+  networks: {+    development: {+      host: "localhost",+      port: 8545,+      network_id: "*" // Match any network id+    }+  }+};
+ test/Network/Ethereum/Web3/Test/ComplexStorageSpec.hs view
@@ -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)
+ test/Network/Ethereum/Web3/Test/SimpleStorageSpec.hs view
@@ -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
+ test/Network/Ethereum/Web3/Test/Utils.hs view
@@ -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
test/Spec.hs view
@@ -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 #-}
+ unit/Network/Ethereum/Web3/Test/EncodingSpec.hs view
@@ -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
+ unit/Network/Ethereum/Web3/Test/EventSpec.hs view
@@ -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
+ unit/Network/Ethereum/Web3/Test/MethodDumpSpec.hs view
@@ -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` ""
+ unit/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
web3.cabal view
@@ -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