diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,20 @@ # Changelog All notable changes to this project will be documented in this file. +## [0.9.0.0] 2020-05-24 +### Added +- Experimental IPFS REST API client +- Experimental Polkadot JSON-RPC API client + +### Changed +- Web3 abstraction moved to `Network.Web3` +- Ethereum entry point renamed `Network.Ethereum.Web3` -> `Network.Ethereum` +- Split from common ECDSA staff from `Crypto.Ethereum` to `Crypto.Ecdsa` +- Ethereum related tests moved to `Network.Ethereum.Test` + +### Removed +- Support for build on LTS-11, LTS-12, LTS-13 + ## [0.8.4.0] 2020-05-03 ### Added - Tuple support for `pragma experimental ABIEncoderV2` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ -Ethereum API for Haskell -======================== +Web3 API for Haskell +==================== -The Haskell Ethereum API which implements the [Generic JSON RPC](https://github.com/ethereum/wiki/wiki/JSON-RPC). +This library implements Haskell API client for popular Web3 platforms. [![Documentation Status](https://readthedocs.org/projects/hs-web3/badge/?version=latest)](https://hs-web3.readthedocs.io/en/latest/?badge=latest) [![Build Status](https://travis-ci.org/airalab/hs-web3.svg?branch=master)](https://travis-ci.org/airalab/hs-web3) @@ -25,7 +25,8 @@ module Main where -- Basic imports -import Network.Ethereum.Web3 +import Network.Ethereum +import Network.Web3 -- Eth API support import qualified Network.Ethereum.Api.Eth as Eth diff --git a/examples/polkadot/Main.hs b/examples/polkadot/Main.hs new file mode 100644 --- /dev/null +++ b/examples/polkadot/Main.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad.IO.Class (liftIO) + +import qualified Network.Polkadot.Api.Chain as Chain +import qualified Network.Polkadot.Api.State as State +import qualified Network.Polkadot.Api.System as System +import Network.Web3.Provider (Provider (..), runWeb3') + +main :: IO () +main = do + result <- runWeb3' (WsProvider "127.0.0.1" 9944) $ do + name <- System.name + liftIO . putStrLn $ "System name: " ++ show name + + best <- Chain.getBlockHash Nothing + liftIO . putStrLn $ "Best hash: " ++ show best + + State.getRuntimeVersion best + + case result of + Left err -> error (show err) + Right version -> putStrLn (show version) diff --git a/examples/token/Main.hs b/examples/token/Main.hs --- a/examples/token/Main.hs +++ b/examples/token/Main.hs @@ -6,8 +6,9 @@ import Text.Printf (printf) import Lens.Micro ((.~)) +import Network.Ethereum hiding (name) import Network.Ethereum.Account -import Network.Ethereum.Web3 hiding (name) +import Network.Web3 import ERC20 diff --git a/src/Crypto/Ecdsa/Signature.hs b/src/Crypto/Ecdsa/Signature.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Ecdsa/Signature.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Crypto.Ecdsa.Signature +-- Copyright : Alexander Krupenkin 2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Recoverable ECC signature support. +-- + +module Crypto.Ecdsa.Signature + ( + sign + , pack + , unpack + ) where + +import Control.Monad (when) +import Crypto.Hash (SHA256) +import Crypto.Number.Generate (generateBetween) +import Crypto.Number.ModArithmetic (inverse) +import Crypto.Number.Serialize (i2osp, os2ip) +import Crypto.PubKey.ECC.ECDSA (PrivateKey (..)) +import Crypto.PubKey.ECC.Prim (pointMul) +import Crypto.PubKey.ECC.Types (CurveCommon (ecc_g, ecc_n), + Point (..), common_curve) +import Crypto.Random (MonadRandom, withDRG) +import Crypto.Random.HmacDrbg (HmacDrbg, initialize) +import Data.Bits (xor, (.|.)) +import Data.ByteArray (ByteArray, ByteArrayAccess, Bytes, + convert, singleton, takeView, + view) +import qualified Data.ByteArray as BA (unpack) +import Data.Monoid ((<>)) +import Data.Word (Word8) + +import Crypto.Ecdsa.Utils (exportKey) + +-- | Sign arbitrary data by given private key. +-- +-- /WARNING:/ Vulnerable to timing attacks. +sign :: ByteArrayAccess bin + => PrivateKey + -> bin + -> (Integer, Integer, Word8) +sign pk bin = fst $ withDRG hmac_drbg $ ecsign pk (os2ip truncated) + where + hmac_drbg :: HmacDrbg SHA256 + hmac_drbg = initialize $ exportKey pk <> truncated + truncated = convert $ takeView bin 32 :: Bytes + +ecsign :: MonadRandom m + => PrivateKey + -> Integer + -> m (Integer, Integer, Word8) +ecsign pk@(PrivateKey curve d) z = do + k <- generateBetween 0 (n - 1) + case trySign k of + Nothing -> ecsign pk z + Just rsv -> return rsv + where + n = ecc_n (common_curve curve) + g = ecc_g (common_curve curve) + recoveryParam x y r = fromIntegral $ + fromEnum (odd y) .|. if x /= r then 2 else 0 + trySign k = do + (kpX, kpY) <- case pointMul curve k g of + PointO -> Nothing + Point x y -> return (x, y) + let r = kpX `mod` n + kInv <- inverse k n + let s = kInv * (z + r * d) `mod` n + when (r == 0 || s == 0) Nothing + -- Recovery param + let v = recoveryParam kpX kpY r + -- Use complement of s if it > n / 2 + let (s', v') | s > n `div` 2 = (n - s, v `xor` 1) + | otherwise = (s, v) + return $ (r, s', v' + 27) + +-- | Unpack recoverable signature from byte array. +-- +-- Input array should have 65 byte length. +unpack :: ByteArrayAccess rsv => rsv -> (Integer, Integer, Word8) +unpack vrs = (r, s, v) + where + r = os2ip (view vrs 1 33) + s = os2ip (view vrs 33 65) + v = head (BA.unpack vrs) + +-- | Pack recoverable signature as byte array (65 byte length). +pack :: ByteArray rsv => (Integer, Integer, Word8) -> rsv +pack (r, s, v) = i2osp r <> i2osp s <> singleton v diff --git a/src/Crypto/Ecdsa/Utils.hs b/src/Crypto/Ecdsa/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Ecdsa/Utils.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Crypto.Ecdsa.Utils +-- Copyright : Alexander Krupenkin 2018 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- ECDSA module helper functions. +-- + +module Crypto.Ecdsa.Utils where + +import Crypto.Number.Serialize (i2osp, os2ip) +import Crypto.PubKey.ECC.ECDSA (PrivateKey (..), PublicKey (..)) +import Crypto.PubKey.ECC.Generate (generateQ) +import Crypto.PubKey.ECC.Types (CurveName (SEC_p256k1), Point (..), + getCurveByName) +import Data.ByteArray (ByteArray, ByteArrayAccess) +import Data.Monoid ((<>)) + +-- | Import ECDSA private key from byte array. +-- +-- Input array should have 32 byte length. +importKey :: ByteArrayAccess privateKey => privateKey -> PrivateKey +{-# INLINE importKey #-} +importKey = PrivateKey (getCurveByName SEC_p256k1) . os2ip + +-- | Export private key to byte array (32 byte length). +exportKey :: ByteArray privateKey => PrivateKey -> privateKey +{-# INLINE exportKey #-} +exportKey (PrivateKey _ key) = i2osp key + +-- | Get public key appropriate to private key. +-- +-- /WARNING:/ Vulnerable to timing attacks. +derivePubKey :: PrivateKey -> PublicKey +{-# INLINE derivePubKey #-} +derivePubKey (PrivateKey curve p) = PublicKey curve (generateQ curve p) + +-- | Export public key to byte array (64 byte length). +exportPubKey :: ByteArray publicKey => PublicKey -> publicKey +{-# INLINE exportPubKey #-} +exportPubKey (PublicKey _ (Point x y)) = i2osp x <> i2osp y +exportPubKey (PublicKey _ PointO) = mempty diff --git a/src/Crypto/Ethereum.hs b/src/Crypto/Ethereum.hs --- a/src/Crypto/Ethereum.hs +++ b/src/Crypto/Ethereum.hs @@ -7,12 +7,12 @@ -- Stability : experimental -- Portability : unportable -- --- Ethereum ECC support module. +-- Ethereum cryptography primitives. -- module Crypto.Ethereum ( - -- * Ethereum crypto key ops + -- * ECDSA crypto key ops PrivateKey , PublicKey , importKey @@ -22,9 +22,10 @@ , signMessage -- * Hash function - , sha3 + , keccak256 ) where +import Crypto.Ecdsa.Utils (derivePubKey, importKey) import Crypto.Ethereum.Signature (signMessage) -import Crypto.Ethereum.Utils (derivePubKey, importKey, sha3) +import Crypto.Ethereum.Utils (keccak256) import Crypto.PubKey.ECC.ECDSA (PrivateKey, PublicKey) diff --git a/src/Crypto/Ethereum/Keyfile.hs b/src/Crypto/Ethereum/Keyfile.hs --- a/src/Crypto/Ethereum/Keyfile.hs +++ b/src/Crypto/Ethereum/Keyfile.hs @@ -10,7 +10,7 @@ -- Stability : experimental -- Portability : portable -- --- Web3 Secret Storage implementation. +-- Ethereum Secret Storage implementation. -- Spec https://github.com/ethereum/wiki/wiki/Web3-Secret-Storage-Definition. -- @@ -44,25 +44,32 @@ import Data.UUID.Types (UUID) import Data.UUID.Types.Internal (buildFromBytes) -import Crypto.Ethereum.Utils (sha3) +import Crypto.Ethereum.Utils (keccak256) import Data.ByteArray.HexString (HexString) -- | Key derivation function parameters and salt. data Kdf = Pbkdf2 !Pbkdf2.Parameters !HexString - | Scrypt !Scrypt.Parameters !HexString + | Scrypt !Scrypt.Parameters !HexString -- | Cipher parameters. data Cipher = Aes128Ctr - { cipherIv :: !(IV AES128), cipherText :: !HexString } + { cipherIv :: !(IV AES128) + , cipherText :: !HexString + } -- | Secret Storage representation on memory. data EncryptedKey = EncryptedKey - { encryptedKeyId :: !UUID -- ^ Random key ID - , encryptedKeyVersion :: !Int -- ^ Version (suppoted version 3 only) - , encryptedKeyCipher :: !Cipher -- ^ Cipher (supported AES-128-CTR only) - , encryptedKeyKdf :: !Kdf -- ^ Key derivation function - , encryptedKeyMac :: !HexString -- ^ MAC - } + { encryptedKeyId :: !UUID + -- ^ Random key ID + , encryptedKeyVersion :: !Int + -- ^ Version (suppoted version 3 only) + , encryptedKeyCipher :: !Cipher + -- ^ Cipher (supported AES-128-CTR only) + , encryptedKeyKdf :: !Kdf + -- ^ Key derivation function + , encryptedKeyMac :: !HexString + -- ^ MAC + } instance Eq EncryptedKey where a == b = encryptedKeyId a == encryptedKeyId b @@ -195,7 +202,7 @@ cipher = throwCryptoError $ cipherInit (BA.take 16 derivedKey) :: AES128 derivedKey = deriveKey encryptedKeyKdf password ciphertext = cipherText encryptedKeyCipher - mac = sha3 (BA.drop 16 derivedKey <> ciphertext) + mac = keccak256 (BA.drop 16 derivedKey <> ciphertext) iv = cipherIv encryptedKeyCipher -- | Encrypt Ethereum private key. @@ -213,7 +220,7 @@ let derivedKey = deriveKey kdf password cipher = throwCryptoError $ cipherInit (BA.take 16 derivedKey) :: AES128 ciphertext = ctrCombine cipher iv privateKey - mac = sha3 (BA.drop 16 derivedKey <> ciphertext) + mac = keccak256 (BA.drop 16 derivedKey <> ciphertext) uuid <- randomUUID return $ EncryptedKey uuid 3 (Aes128Ctr iv $ convert ciphertext) kdf mac where diff --git a/src/Crypto/Ethereum/Signature.hs b/src/Crypto/Ethereum/Signature.hs --- a/src/Crypto/Ethereum/Signature.hs +++ b/src/Crypto/Ethereum/Signature.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | --- Module : Crypto.Ethereum +-- Module : Crypto.Ecdsa.Signature -- Copyright : Alexander Krupenkin 2018 -- License : BSD3 -- @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable -- --- Recoverable ECC signature support. +-- Recoverable Ethereum signature support. -- module Crypto.Ethereum.Signature @@ -17,35 +17,18 @@ hashMessage , signMessage , signTransaction - , pack - , unpack ) where -import Control.Monad (when) -import Crypto.Hash (Digest, Keccak_256 (..), SHA256, - hashWith) -import Crypto.Number.Generate (generateBetween) -import Crypto.Number.ModArithmetic (inverse) -import Crypto.Number.Serialize (i2osp, os2ip) -import Crypto.PubKey.ECC.ECDSA (PrivateKey (..)) -import Crypto.PubKey.ECC.Prim (pointMul) -import Crypto.PubKey.ECC.Types (CurveCommon (ecc_g, ecc_n), - Point (..), common_curve) -import Crypto.Random (MonadRandom, withDRG) -import Crypto.Random.HmacDrbg (HmacDrbg, initialize) -import Data.Bits (xor, (.|.)) -import Data.ByteArray (ByteArray, ByteArrayAccess, - convert, singleton, takeView, - view) -import qualified Data.ByteArray as BA (length, unpack) -import Data.ByteString.Builder (intDec, toLazyByteString) -import qualified Data.ByteString.Lazy as LBS (toStrict) -import Data.Monoid ((<>)) -import Data.Word (Word8) +import Crypto.Hash (Digest, Keccak_256 (..), hashWith) +import Crypto.PubKey.ECC.ECDSA (PrivateKey (..)) +import Data.ByteArray (ByteArray, ByteArrayAccess, convert) +import qualified Data.ByteArray as BA (length) +import Data.ByteString.Builder (intDec, toLazyByteString) +import qualified Data.ByteString.Lazy as LBS (toStrict) +import Data.Monoid ((<>)) +import Data.Word (Word8) -import Crypto.Ethereum.Utils (exportKey) -import Data.ByteArray.HexString (HexString) -import Data.Solidity.Prim.Address (Address) +import Crypto.Ecdsa.Signature (pack, sign) -- | Make Ethereum standard signature. -- @@ -84,59 +67,3 @@ where unsigned = encode Nothing signed = sign key (hashWith Keccak_256 unsigned) - --- | Sign arbitrary data by given private key. --- --- /WARNING:/ Vulnerable to timing attacks. -sign :: ByteArrayAccess bin - => PrivateKey - -> bin - -> (Integer, Integer, Word8) -sign pk bin = fst $ withDRG hmac_drbg $ ecsign pk (os2ip truncated) - where - hmac_drbg :: HmacDrbg SHA256 - hmac_drbg = initialize $ exportKey pk <> truncated - truncated = convert $ takeView bin 32 :: HexString - -ecsign :: MonadRandom m - => PrivateKey - -> Integer - -> m (Integer, Integer, Word8) -ecsign pk@(PrivateKey curve d) z = do - k <- generateBetween 0 (n - 1) - case trySign k of - Nothing -> ecsign pk z - Just rsv -> return rsv - where - n = ecc_n (common_curve curve) - g = ecc_g (common_curve curve) - recoveryParam x y r = fromIntegral $ - fromEnum (odd y) .|. if x /= r then 2 else 0 - trySign k = do - (kpX, kpY) <- case pointMul curve k g of - PointO -> Nothing - Point x y -> return (x, y) - let r = kpX `mod` n - kInv <- inverse k n - let s = kInv * (z + r * d) `mod` n - when (r == 0 || s == 0) Nothing - -- Recovery param - let v = recoveryParam kpX kpY r - -- Use complement of s if it > n / 2 - let (s', v') | s > n `div` 2 = (n - s, v `xor` 1) - | otherwise = (s, v) - return $ (r, s', v' + 27) - --- | Unpack recoverable signature from byte array. --- --- Input array should have 65 byte length. -unpack :: ByteArrayAccess rsv => rsv -> (Integer, Integer, Word8) -unpack vrs = (r, s, v) - where - r = os2ip (view vrs 1 33) - s = os2ip (view vrs 33 65) - v = head (BA.unpack vrs) - --- | Pack recoverable signature as byte array (65 byte length). -pack :: ByteArray rsv => (Integer, Integer, Word8) -> rsv -pack (r, s, v) = i2osp r <> i2osp s <> singleton v diff --git a/src/Crypto/Ethereum/Utils.hs b/src/Crypto/Ethereum/Utils.hs --- a/src/Crypto/Ethereum/Utils.hs +++ b/src/Crypto/Ethereum/Utils.hs @@ -7,47 +7,15 @@ -- Stability : experimental -- Portability : portable -- --- EC cryptography on Secp256k1 curve. +-- Ethereum crypto module helper functions. -- module Crypto.Ethereum.Utils where -import Crypto.Hash (Keccak_256 (..), hashWith) -import Crypto.Number.Serialize (i2osp, os2ip) -import Crypto.PubKey.ECC.ECDSA (PrivateKey (..), PublicKey (..)) -import Crypto.PubKey.ECC.Generate (generateQ) -import Crypto.PubKey.ECC.Types (CurveName (SEC_p256k1), Point (..), - getCurveByName) -import Data.ByteArray (ByteArray, ByteArrayAccess, - convert) -import Data.Monoid ((<>)) - --- | Import Ethereum private key from byte array. --- --- Input array should have 32 byte length. -importKey :: ByteArrayAccess privateKey => privateKey -> PrivateKey -{-# INLINE importKey #-} -importKey = PrivateKey (getCurveByName SEC_p256k1) . os2ip - --- | Export private key to byte array (32 byte length). -exportKey :: ByteArray privateKey => PrivateKey -> privateKey -{-# INLINE exportKey #-} -exportKey (PrivateKey _ key) = i2osp key - --- | Get public key appropriate to private key. --- --- /WARNING:/ Vulnerable to timing attacks. -derivePubKey :: PrivateKey -> PublicKey -{-# INLINE derivePubKey #-} -derivePubKey (PrivateKey curve p) = PublicKey curve (generateQ curve p) - --- | Export public key to byte array (64 byte length). -exportPubKey :: ByteArray publicKey => PublicKey -> publicKey -{-# INLINE exportPubKey #-} -exportPubKey (PublicKey _ (Point x y)) = i2osp x <> i2osp y -exportPubKey (PublicKey _ PointO) = mempty +import Crypto.Hash (Keccak_256 (..), hashWith) +import Data.ByteArray (ByteArray, ByteArrayAccess, convert) -- | Keccak 256 hash function. -sha3 :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout -{-# INLINE sha3 #-} -sha3 = convert . hashWith Keccak_256 +keccak256 :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout +{-# INLINE keccak256 #-} +keccak256 = convert . hashWith Keccak_256 diff --git a/src/Data/Solidity/Prim/Address.hs b/src/Data/Solidity/Prim/Address.hs --- a/src/Data/Solidity/Prim/Address.hs +++ b/src/Data/Solidity/Prim/Address.hs @@ -49,7 +49,8 @@ import Generics.SOP (Generic) import qualified GHC.Generics as GHC (Generic) -import Crypto.Ethereum.Utils (exportPubKey, sha3) +import Crypto.Ecdsa.Utils (exportPubKey) +import Crypto.Ethereum.Utils (keccak256) import Data.ByteArray.HexString (HexString, fromBytes, toBytes, toText) import Data.Solidity.Abi (AbiGet (..), AbiPut (..), @@ -95,7 +96,7 @@ Left e -> error $ "Impossible error: " ++ e where toAddress :: HexString -> HexString - toAddress = BA.drop 12 . sha3 + toAddress = BA.drop 12 . keccak256 -- | Decode address from hex string fromHexString :: HexString -> Either String Address @@ -113,7 +114,7 @@ toChecksum :: ByteString -> ByteString toChecksum addr = ("0x" <>) . C8.pack $ zipWith ($) upcaseVector lower where - upcaseVector = (>>= fourthBits) . BS.unpack . BS.take 20 $ sha3 (C8.pack lower) + upcaseVector = (>>= fourthBits) . BS.unpack . BS.take 20 $ keccak256 (C8.pack lower) fourthBits n = bool id C.toUpper <$> [n .&. 0x80 /= 0, n .&. 0x08 /= 0] lower = drop 2 . fmap C.toLower . C8.unpack $ addr diff --git a/src/Network/Ethereum.hs b/src/Network/Ethereum.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ethereum.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Network.Ethereum +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- TODO +-- + +module Network.Ethereum + ( + -- * Basic transaction sending + module Account + + -- * Basic EVM event listening + , EventAction(..) + , event + + -- * Primitive Solidity data types + , module Prim + + -- * Metric unit system + , module Unit + ) where + +import Data.Solidity.Prim as Prim +import Network.Ethereum.Account as Account +import Network.Ethereum.Contract.Event (EventAction (..), event) +import Network.Ethereum.Unit as Unit diff --git a/src/Network/Ethereum/Account/Default.hs b/src/Network/Ethereum/Account/Default.hs --- a/src/Network/Ethereum/Account/Default.hs +++ b/src/Network/Ethereum/Account/Default.hs @@ -17,6 +17,7 @@ module Network.Ethereum.Account.Default where +import Control.Exception (TypeError (..)) import Control.Monad.Catch (throwM) import Control.Monad.State.Strict (get, runStateT) import Control.Monad.Trans (MonadTrans (..)) @@ -34,7 +35,6 @@ import qualified Network.Ethereum.Api.Eth as Eth (accounts, call, estimateGas, sendTransaction) -import Network.Ethereum.Api.Provider (Web3Error (ParserFail)) import Network.Ethereum.Api.Types (Call (callData, callFrom, callGas)) import Network.Ethereum.Contract.Method (Method (..)) @@ -71,4 +71,4 @@ Eth.call params _block case decode res of Right r -> return r - Left e -> lift $ throwM (ParserFail e) + Left e -> lift (throwM $ TypeError e) diff --git a/src/Network/Ethereum/Account/LocalKey.hs b/src/Network/Ethereum/Account/LocalKey.hs --- a/src/Network/Ethereum/Account/LocalKey.hs +++ b/src/Network/Ethereum/Account/LocalKey.hs @@ -19,6 +19,7 @@ module Network.Ethereum.Account.LocalKey where +import Control.Exception (TypeError (..)) import Control.Monad.Catch (throwM) import Control.Monad.State.Strict (get, runStateT) import Control.Monad.Trans (lift) @@ -41,7 +42,6 @@ import qualified Network.Ethereum.Api.Eth as Eth (call, estimateGas, getTransactionCount, sendRawTransaction) -import Network.Ethereum.Api.Provider (Web3Error (ParserFail)) import Network.Ethereum.Api.Types (Call (..)) import Network.Ethereum.Chain (foundation) import Network.Ethereum.Contract.Method (selector) @@ -95,4 +95,4 @@ res <- lift $ Eth.call params _block case decode res of Right r -> return r - Left e -> lift $ throwM (ParserFail e) + Left e -> lift (throwM $ TypeError e) diff --git a/src/Network/Ethereum/Account/Personal.hs b/src/Network/Ethereum/Account/Personal.hs --- a/src/Network/Ethereum/Account/Personal.hs +++ b/src/Network/Ethereum/Account/Personal.hs @@ -19,6 +19,7 @@ module Network.Ethereum.Account.Personal where +import Control.Exception (TypeError (..)) import Control.Monad.Catch (throwM) import Control.Monad.State.Strict (get, runStateT) import Control.Monad.Trans (lift) @@ -37,7 +38,6 @@ import qualified Network.Ethereum.Api.Eth as Eth (call, estimateGas) import Network.Ethereum.Api.Personal (Passphrase) import qualified Network.Ethereum.Api.Personal as Personal (sendTransaction) -import Network.Ethereum.Api.Provider (Web3Error (ParserFail)) import Network.Ethereum.Api.Types (Call (callData, callFrom, callGas)) import Network.Ethereum.Contract.Method (selector) @@ -83,4 +83,4 @@ res <- lift $ Eth.call params block case decode res of Right r -> return r - Left e -> lift $ throwM (ParserFail e) + Left e -> lift (throwM $ TypeError e) diff --git a/src/Network/Ethereum/Api/Provider.hs b/src/Network/Ethereum/Api/Provider.hs deleted file mode 100644 --- a/src/Network/Ethereum/Api/Provider.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | --- Module : Network.Ethereum.Api.Provider --- Copyright : Alexander Krupenkin 2016-2018 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : portable --- --- Web3 service provider. --- - -module Network.Ethereum.Api.Provider where - -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.State (MonadState (..)) -import Control.Monad.Trans.State (StateT, evalStateT) -import Data.Default (Default (..)) -import GHC.Generics (Generic) -import Lens.Micro.Mtl ((.=)) -import Network.HTTP.Client (Manager) - -import Network.JsonRpc.TinyClient (JsonRpc, JsonRpcClient, - defaultSettings, jsonRpcManager) - --- | Any communication with Ethereum node wrapped with 'Web3' monad -newtype Web3 a = Web3 { unWeb3 :: StateT JsonRpcClient IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadState JsonRpcClient) - -instance JsonRpc Web3 - --- | 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 String - 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 provider f = - runWeb3' provider $ jsonRpcManager .= manager >> f - --- | 'Web3' monad runner -runWeb3' :: MonadIO m - => Provider - -> Web3 a - -> m (Either Web3Error a) -runWeb3' (HttpProvider uri) f = do - cfg <- defaultSettings uri - liftIO . try . flip evalStateT cfg . unWeb3 $ f - --- | 'Web3' runner for default provider -runWeb3 :: MonadIO m - => Web3 a - -> m (Either Web3Error a) -{-# INLINE runWeb3 #-} -runWeb3 = runWeb3' def - --- | Fork 'Web3' with the same 'Provider' and 'Manager' -forkWeb3 :: Web3 a -> Web3 (Async a) -forkWeb3 f = liftIO . async . evalStateT (unWeb3 f) =<< get diff --git a/src/Network/Ethereum/Contract/Event/Common.hs b/src/Network/Ethereum/Contract/Event/Common.hs --- a/src/Network/Ethereum/Contract/Event/Common.hs +++ b/src/Network/Ethereum/Contract/Event/Common.hs @@ -21,31 +21,30 @@ module Network.Ethereum.Contract.Event.Common where -import Control.Concurrent (threadDelay) -import Control.Exception (Exception, throwIO) -import Control.Monad.IO.Class (liftIO) -import Data.Either (lefts, rights) +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, throwIO) +import Control.Monad.IO.Class (liftIO) +import Data.Either (lefts, rights) -import Data.Solidity.Event (DecodeEvent (..)) -import qualified Network.Ethereum.Api.Eth as Eth -import Network.Ethereum.Api.Provider (Web3) -import Network.Ethereum.Api.Types (Change (..), DefaultBlock (..), - Filter (..), Quantity) +import Data.Solidity.Event (DecodeEvent (..)) +import qualified Network.Ethereum.Api.Eth as Eth +import Network.Ethereum.Api.Types (Change (..), DefaultBlock (..), + Filter (..), Quantity) +import Network.JsonRpc.TinyClient (JsonRpc (..)) -- | Event callback control response data EventAction = ContinueEvent - -- ^ Continue to listen events - | TerminateEvent - -- ^ Terminate event listener - deriving (Show, Eq) + | TerminateEvent + deriving (Show, Eq) -data FilterChange a = - FilterChange { filterChangeRawChange :: Change - , filterChangeEvent :: a - } +data FilterChange a = FilterChange + { filterChangeRawChange :: Change + , filterChangeEvent :: a + } -data EventParseFailure = EventParseFailure String deriving (Show) +data EventParseFailure = EventParseFailure String + deriving (Show) instance Exception EventParseFailure @@ -59,24 +58,22 @@ in if ls /= [] then throwIO (EventParseFailure $ show ls) else pure rs -data FilterStreamState e = - FilterStreamState { fssCurrentBlock :: Quantity - , fssInitialFilter :: Filter e - , fssWindowSize :: Integer - } +data FilterStreamState e = FilterStreamState + { fssCurrentBlock :: Quantity + , fssInitialFilter :: Filter e + , fssWindowSize :: Integer + } -- | Coerce a 'DefaultBlock' into a numerical block number. -mkBlockNumber :: DefaultBlock -> Web3 Quantity +mkBlockNumber :: JsonRpc m => DefaultBlock -> m Quantity mkBlockNumber bm = case bm of BlockWithNumber bn -> return bn Earliest -> return 0 _ -> Eth.blockNumber -pollTillBlockProgress - :: Quantity - -> Web3 Quantity +pollTillBlockProgress :: JsonRpc m => Quantity -> m Quantity pollTillBlockProgress currentBlock = do bn <- Eth.blockNumber if currentBlock >= bn diff --git a/src/Network/Ethereum/Contract/Event/MultiFilter.hs b/src/Network/Ethereum/Contract/Event/MultiFilter.hs --- a/src/Network/Ethereum/Contract/Event/MultiFilter.hs +++ b/src/Network/Ethereum/Contract/Event/MultiFilter.hs @@ -21,7 +21,7 @@ -- Stability : experimental -- Portability : unportable -- --- Support for parallel multiple event filters. +-- Parallel multiple event filters. -- module Network.Ethereum.Contract.Event.MultiFilter @@ -34,13 +34,11 @@ -- * With geth filters , multiEvent - , multiEvent' - , multiEventMany' + , multiEventMany -- * Without geth filters , multiEventNoFilter - , multiEventNoFilter' - , multiEventManyNoFilter' + , multiEventManyNoFilter -- * Re-exports , Handlers @@ -49,7 +47,6 @@ ) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (Async) import Control.Monad (forM, void, when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) @@ -83,10 +80,10 @@ import Data.Solidity.Event (DecodeEvent (..)) import qualified Network.Ethereum.Api.Eth as Eth -import Network.Ethereum.Api.Provider (Web3, forkWeb3) import Network.Ethereum.Api.Types (Change (..), DefaultBlock (..), Filter (..), Quantity) +import Network.JsonRpc.TinyClient (JsonRpc(..)) import Network.Ethereum.Contract.Event.Common -------------------------------------------------------------------------------- @@ -122,34 +119,19 @@ multiEvent :: ( PollFilters es , QueryAllLogs es - , MapHandlers Web3 es (WithChange es) -#if MIN_VERSION_vinyl(0,10,0) - , RPureConstrained HasLogIndex (WithChange es) -#else - , AllAllSat '[HasLogIndex] (WithChange es) -#endif - , RecApplicative (WithChange es) - ) - => MultiFilter es - -> Handlers es (ReaderT Change Web3 EventAction) - -> Web3 (Async ()) -multiEvent fltrs = forkWeb3 . multiEvent' fltrs - -multiEvent' - :: ( PollFilters es - , QueryAllLogs es - , MapHandlers Web3 es (WithChange es) + , MapHandlers m es (WithChange es) #if MIN_VERSION_vinyl(0,10,0) , RPureConstrained HasLogIndex (WithChange es) #else , AllAllSat '[HasLogIndex] (WithChange es) #endif , RecApplicative (WithChange es) + , JsonRpc m ) => MultiFilter es - -> Handlers es (ReaderT Change Web3 EventAction) - -> Web3 () -multiEvent' fltrs = multiEventMany' fltrs 0 + -> Handlers es (ReaderT Change m EventAction) + -> m () +multiEvent fltrs = multiEventMany fltrs 0 data MultiFilterStreamState es = MultiFilterStreamState { mfssCurrentBlock :: Quantity @@ -158,22 +140,23 @@ } -multiEventMany' +multiEventMany :: ( PollFilters es , QueryAllLogs es - , MapHandlers Web3 es (WithChange es) + , MapHandlers m es (WithChange es) #if MIN_VERSION_vinyl(0,10,0) , RPureConstrained HasLogIndex (WithChange es) #else , AllAllSat '[HasLogIndex] (WithChange es) #endif , RecApplicative (WithChange es) + , JsonRpc m ) => MultiFilter es -> Integer - -> Handlers es (ReaderT Change Web3 EventAction) - -> Web3 () -multiEventMany' fltrs window handlers = do + -> Handlers es (ReaderT Change m EventAction) + -> m () +multiEventMany fltrs window handlers = do start <- mkBlockNumber $ minStartBlock fltrs let initState = MultiFilterStreamState { mfssCurrentBlock = start @@ -194,15 +177,18 @@ let pollTo = minEndBlock fltrs' void $ reduceMultiEventStream (pollMultiFilter fIds pollTo) handlers -multiFilterStream - :: MultiFilterStreamState es - -> MachineT Web3 k (MultiFilter es) +multiFilterStream :: JsonRpc m + => MultiFilterStreamState es + -> MachineT m k (MultiFilter es) multiFilterStream initialPlan = do unfoldPlan initialPlan $ \s -> do end <- lift . mkBlockNumber . minEndBlock . mfssInitialMultiFilter $ initialPlan filterPlan end s where - filterPlan :: Quantity -> MultiFilterStreamState es -> PlanT k (MultiFilter es) Web3 (MultiFilterStreamState es) + filterPlan :: JsonRpc m + => Quantity + -> MultiFilterStreamState es + -> PlanT k (MultiFilter es) m (MultiFilterStreamState es) filterPlan end initialState@MultiFilterStreamState{..} = do if mfssCurrentBlock > end then stop @@ -228,7 +214,7 @@ WithChange (e : es) = FilterChange e : WithChange es class QueryAllLogs (es :: [*]) where - queryAllLogs :: MultiFilter es -> Web3 [Field (WithChange es)] + queryAllLogs :: JsonRpc m => MultiFilter es -> m [Field (WithChange es)] instance QueryAllLogs '[] where queryAllLogs NilFilters = pure [] @@ -315,7 +301,7 @@ -- | 'playLogs' streams the 'filterStream' and calls eth_getLogs on these 'Filter' objects. playMultiLogs - :: forall es k. + :: forall es k m. ( QueryAllLogs es #if MIN_VERSION_vinyl(0,10,0) , RPureConstrained HasLogIndex (WithChange es) @@ -323,26 +309,27 @@ , AllAllSat '[HasLogIndex] (WithChange es) #endif , RecApplicative (WithChange es) + , JsonRpc m ) => MultiFilterStreamState es - -> MachineT Web3 k [Field (WithChange es)] + -> MachineT m k [Field (WithChange es)] playMultiLogs s = fmap sortChanges $ multiFilterStream s ~> autoM queryAllLogs data TaggedFilterIds (es :: [*]) where - TaggedFilterNil :: TaggedFilterIds '[] - TaggedFilterCons :: Tagged e Quantity -> TaggedFilterIds es -> TaggedFilterIds (e : es) + TaggedFilterNil :: TaggedFilterIds '[] + TaggedFilterCons :: Tagged e Quantity -> TaggedFilterIds es -> TaggedFilterIds (e : es) class PollFilters (es :: [*]) where - openMultiFilter :: MultiFilter es -> Web3 (TaggedFilterIds es) - checkMultiFilter :: TaggedFilterIds es -> Web3 [Field (WithChange es)] - closeMultiFilter :: TaggedFilterIds es -> Web3 () + openMultiFilter :: JsonRpc m => MultiFilter es -> m (TaggedFilterIds es) + checkMultiFilter :: JsonRpc m => TaggedFilterIds es -> m [Field (WithChange es)] + closeMultiFilter :: JsonRpc m => TaggedFilterIds es -> m () instance PollFilters '[] where - openMultiFilter _ = pure TaggedFilterNil - checkMultiFilter _ = pure [] - closeMultiFilter _ = pure () + openMultiFilter _ = pure TaggedFilterNil + checkMultiFilter _ = pure [] + closeMultiFilter _ = pure () instance forall e i ni es. ( DecodeEvent i ni e @@ -375,13 +362,13 @@ #else , AllAllSat '[HasLogIndex] (WithChange es) #endif + , JsonRpc m ) => TaggedFilterIds es -> DefaultBlock - -> MachineT Web3 k [Field (WithChange es)] + -> MachineT m k [Field (WithChange es)] pollMultiFilter is = construct . pollPlan is where - -- pollPlan :: TaggedFilterIds es -> DefaultBlock -> PlanT k [Field (Map (TyCon1 FilterChange) es)] Web3 () pollPlan (fIds :: TaggedFilterIds es) end = do bn <- lift $ Eth.blockNumber if BlockWithNumber bn > end @@ -396,53 +383,39 @@ -------------------------------------------------------------------------------- - multiEventNoFilter :: ( QueryAllLogs es - , MapHandlers Web3 es (WithChange es) -#if MIN_VERSION_vinyl(0,10,0) - , RPureConstrained HasLogIndex (WithChange es) -#else - , AllAllSat '[HasLogIndex] (WithChange es) -#endif - , RecApplicative (WithChange es) - ) - => MultiFilter es - -> Handlers es (ReaderT Change Web3 EventAction) - -> Web3 (Async ()) -multiEventNoFilter fltrs = forkWeb3 . multiEventNoFilter' fltrs - -multiEventNoFilter' - :: ( QueryAllLogs es - , MapHandlers Web3 es (WithChange es) + , MapHandlers m es (WithChange es) #if MIN_VERSION_vinyl(0,10,0) , RPureConstrained HasLogIndex (WithChange es) #else , AllAllSat '[HasLogIndex] (WithChange es) #endif , RecApplicative (WithChange es) + , JsonRpc m ) => MultiFilter es - -> Handlers es (ReaderT Change Web3 EventAction) - -> Web3 () -multiEventNoFilter' fltrs = multiEventManyNoFilter' fltrs 0 + -> Handlers es (ReaderT Change m EventAction) + -> m () +multiEventNoFilter fltrs = multiEventManyNoFilter fltrs 0 -multiEventManyNoFilter' +multiEventManyNoFilter :: ( QueryAllLogs es - , MapHandlers Web3 es (WithChange es) + , MapHandlers m es (WithChange es) #if MIN_VERSION_vinyl(0,10,0) , RPureConstrained HasLogIndex (WithChange es) #else , AllAllSat '[HasLogIndex] (WithChange es) #endif , RecApplicative (WithChange es) + , JsonRpc m ) => MultiFilter es -> Integer - -> Handlers es (ReaderT Change Web3 EventAction) - -> Web3 () -multiEventManyNoFilter' fltrs window handlers = do + -> Handlers es (ReaderT Change m EventAction) + -> m () +multiEventManyNoFilter fltrs window handlers = do start <- mkBlockNumber $ minStartBlock fltrs let initState = MultiFilterStreamState { mfssCurrentBlock = start @@ -467,15 +440,18 @@ } in void $ reduceMultiEventStream (playNewMultiLogs pollingFilterState) handlers -newMultiFilterStream - :: MultiFilterStreamState es - -> MachineT Web3 k (MultiFilter es) +newMultiFilterStream :: JsonRpc m + => MultiFilterStreamState es + -> MachineT m k (MultiFilter es) newMultiFilterStream initialPlan = do unfoldPlan initialPlan $ \s -> do let end = minEndBlock . mfssInitialMultiFilter $ initialPlan filterPlan end s where - filterPlan :: DefaultBlock -> MultiFilterStreamState es -> PlanT k (MultiFilter es) Web3 (MultiFilterStreamState es) + filterPlan :: JsonRpc m + => DefaultBlock + -> MultiFilterStreamState es + -> PlanT k (MultiFilter es) m (MultiFilterStreamState es) filterPlan end initialState@MultiFilterStreamState{..} = do if BlockWithNumber mfssCurrentBlock > end then stop @@ -489,7 +465,7 @@ filterPlan end initialState { mfssCurrentBlock = newestBlockNumber + 1 } playNewMultiLogs - :: forall es k. + :: forall es k m. ( QueryAllLogs es #if MIN_VERSION_vinyl(0,10,0) , RPureConstrained HasLogIndex (WithChange es) @@ -497,9 +473,10 @@ , AllAllSat '[HasLogIndex] (WithChange es) #endif , RecApplicative (WithChange es) + , JsonRpc m ) => MultiFilterStreamState es - -> MachineT Web3 k [Field (WithChange es)] + -> MachineT m k [Field (WithChange es)] playNewMultiLogs s = fmap sortChanges $ newMultiFilterStream s ~> autoM queryAllLogs diff --git a/src/Network/Ethereum/Contract/Event/SingleFilter.hs b/src/Network/Ethereum/Contract/Event/SingleFilter.hs --- a/src/Network/Ethereum/Contract/Event/SingleFilter.hs +++ b/src/Network/Ethereum/Contract/Event/SingleFilter.hs @@ -19,21 +19,18 @@ -- Stability : experimental -- Portability : unportable -- --- Simple contract event filter support. +-- Contract event filters. -- module Network.Ethereum.Contract.Event.SingleFilter ( event - , event' - , eventMany' + , eventMany , eventNoFilter - , eventNoFilter' - , eventManyNoFilter' + , eventManyNoFilter ) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (Async) import Control.Monad (forM, void, when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) @@ -48,38 +45,31 @@ import Data.Solidity.Event (DecodeEvent (..)) import qualified Network.Ethereum.Api.Eth as Eth -import Network.Ethereum.Api.Provider (Web3, forkWeb3) import Network.Ethereum.Api.Types (Change (..), DefaultBlock (..), Filter (..), Quantity) import Network.Ethereum.Contract.Event.Common - --- | 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 +import Network.JsonRpc.TinyClient (JsonRpc (..)) --- | Same as 'event', but does not immediately spawn a new thread. -event' :: DecodeEvent i ni e +-- | Run one block at a time. +event :: (DecodeEvent i ni e, JsonRpc m) => Filter e - -> (e -> ReaderT Change Web3 EventAction) - -> Web3 () -event' fltr = eventMany' fltr 0 + -> (e -> ReaderT Change m EventAction) + -> m () +event fltr = eventMany fltr 0 --- | 'eventMany\'' take s a filter, a window size, and a handler. +-- | '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 +eventMany :: (DecodeEvent i ni e, JsonRpc m) => Filter e -> Integer - -> (e -> ReaderT Change Web3 EventAction) - -> Web3 () -eventMany' fltr window handler = do + -> (e -> ReaderT Change m EventAction) + -> m () +eventMany fltr window handler = do start <- mkBlockNumber $ filterFromBlock fltr let initState = FilterStreamState { fssCurrentBlock = start , fssInitialFilter = fltr @@ -127,22 +117,21 @@ return ((,) act <$> changeBlockNumber filterChangeRawChange) -- | 'playLogs' streams the 'filterStream' and calls eth_getLogs on these 'Filter' objects. -playOldLogs - :: DecodeEvent i ni e - => FilterStreamState e - -> MachineT Web3 k [FilterChange e] +playOldLogs :: (DecodeEvent i ni e, JsonRpc m) + => FilterStreamState e + -> MachineT m k [FilterChange e] playOldLogs s = filterStream s ~> autoM Eth.getLogs ~> autoM (liftIO . mkFilterChanges) -- | Polls a filter from the given filterId until the target toBlock is reached. -pollFilter :: forall i ni e k . DecodeEvent i ni e +pollFilter :: forall i ni e k m . (DecodeEvent i ni e, JsonRpc m) => Quantity -> DefaultBlock - -> MachineT Web3 k [FilterChange e] + -> MachineT m k [FilterChange e] pollFilter i = construct . pollPlan i where - pollPlan :: Quantity -> DefaultBlock -> PlanT k [FilterChange e] Web3 () + pollPlan :: Quantity -> DefaultBlock -> PlanT k [FilterChange e] m () pollPlan fid end = do bn <- lift $ Eth.blockNumber if BlockWithNumber bn > end @@ -162,11 +151,12 @@ -- 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 block number. -filterStream :: FilterStreamState e - -> MachineT Web3 k (Filter e) +filterStream :: JsonRpc m + => FilterStreamState e + -> MachineT m k (Filter e) filterStream initialPlan = unfoldPlan initialPlan filterPlan where - filterPlan :: FilterStreamState e -> PlanT k (Filter e) Web3 (FilterStreamState e) + filterPlan :: JsonRpc m => FilterStreamState e -> PlanT k (Filter e) m (FilterStreamState e) filterPlan initialState@FilterStreamState{..} = do end <- lift . mkBlockNumber $ filterToBlock fssInitialFilter if fssCurrentBlock > end @@ -181,29 +171,18 @@ -------------------------------------------------------------------------------- --- | Run 'event\'' one block at a time. -eventNoFilter - :: DecodeEvent i ni e - => Filter e - -> (e -> ReaderT Change Web3 EventAction) - -> Web3 (Async ()) -eventNoFilter fltr = forkWeb3 . event' fltr - --- | Same as 'event', but does not immediately spawn a new thread. -eventNoFilter' - :: DecodeEvent i ni e - => Filter e - -> (e -> ReaderT Change Web3 EventAction) - -> Web3 () -eventNoFilter' fltr = eventManyNoFilter' fltr 0 +eventNoFilter :: (DecodeEvent i ni e, JsonRpc m) + => Filter e + -> (e -> ReaderT Change m EventAction) + -> m () +eventNoFilter fltr = eventManyNoFilter fltr 0 -eventManyNoFilter' - :: DecodeEvent i ni e - => Filter e - -> Integer - -> (e -> ReaderT Change Web3 EventAction) - -> Web3 () -eventManyNoFilter' fltr window handler = do +eventManyNoFilter :: (DecodeEvent i ni e, JsonRpc m) + => Filter e + -> Integer + -> (e -> ReaderT Change m EventAction) + -> m () +eventManyNoFilter fltr window handler = do start <- mkBlockNumber $ filterFromBlock fltr let initState = FilterStreamState { fssCurrentBlock = start , fssInitialFilter = fltr @@ -228,21 +207,20 @@ in void $ reduceEventStream (playNewLogs pollingFilterState) handler -- | 'playLogs' streams the 'filterStream' and calls eth_getLogs on these 'Filter' objects. -playNewLogs - :: DecodeEvent i ni e - => FilterStreamState e - -> MachineT Web3 k [FilterChange e] +playNewLogs :: (DecodeEvent i ni e, JsonRpc m) + => FilterStreamState e + -> MachineT m k [FilterChange e] playNewLogs s = newFilterStream s ~> autoM Eth.getLogs ~> autoM (liftIO . mkFilterChanges) -newFilterStream - :: FilterStreamState e - -> MachineT Web3 k (Filter e) +newFilterStream :: JsonRpc m + => FilterStreamState e + -> MachineT m k (Filter e) newFilterStream initialState = unfoldPlan initialState filterPlan where - filterPlan :: FilterStreamState e -> PlanT k (Filter e) Web3 (FilterStreamState e) + filterPlan :: JsonRpc m => FilterStreamState e -> PlanT k (Filter e) m (FilterStreamState e) filterPlan s@FilterStreamState{..} = do if BlockWithNumber fssCurrentBlock > filterToBlock fssInitialFilter then stop diff --git a/src/Network/Ethereum/Contract/TH.hs b/src/Network/Ethereum/Contract/TH.hs --- a/src/Network/Ethereum/Contract/TH.hs +++ b/src/Network/Ethereum/Contract/TH.hs @@ -239,7 +239,7 @@ [funD' 'selector [] [|const mIdent|]] ] where mIdent = T.unpack (methodId $ fun {funName = T.replace "'" "" name}) - dataName = mkName (toUpperFirst (T.unpack $ name <> "Data")) + dataName = mkName (toUpperFirst (T.unpack $ T.dropWhile (== '_') name <> "Data")) fnName = mkName (toLowerFirst (T.unpack name)) bangInput = fmap funBangType inputs derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic] diff --git a/src/Network/Ethereum/Web3.hs b/src/Network/Ethereum/Web3.hs deleted file mode 100644 --- a/src/Network/Ethereum/Web3.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | --- Module : Network.Ethereum.Web3 --- Copyright : Alexander Krupenkin 2016-2018 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- 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, --- such as compiling smart contract code. It uses a subset of the JSON-RPC 2.0 --- specification (no support for notifications or named parameters) as serialisation --- protocol and is available over HTTP and IPC (unix domain sockets on linux/OSX --- and named pipe’s on Windows). --- --- Web3 Haskell library currently use JSON-RPC over HTTP to access node functionality. --- - -module Network.Ethereum.Web3 - ( - -- * Base monad for any Ethereum node communication - Web3 - , runWeb3 - - -- * Basic transaction sending - , module Account - - -- * Basic event listening - , EventAction(..) - , event - - -- * Primitive data types - , module Prim - - -- * Metric unit system - , module Unit - ) where - -import Data.Solidity.Prim as Prim -import Network.Ethereum.Account as Account -import Network.Ethereum.Api.Provider (Web3, runWeb3) -import Network.Ethereum.Contract.Event (EventAction (..), event) -import Network.Ethereum.Unit as Unit diff --git a/src/Network/Ipfs/Api/Bitswap.hs b/src/Network/Ipfs/Api/Bitswap.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Bitswap.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Network.Ipfs.Api.Bitswap +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `bitswap` prefix. +-- + +module Network.Ipfs.Api.Bitswap where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Text (Text) + +import Network.Ipfs.Api.Internal (_bitswapLedger, + _bitswapReprovide, + _bitswapStat, _bitswapWL) +import Network.Ipfs.Api.Internal.Call (call) +import Network.Ipfs.Api.Types (BitswapLedgerObj, + BitswapStatObj, BitswapWLObj, + ReprovideReturnType) +import Network.Ipfs.Client (IpfsT) + +-- | 'Show some diagnostic information on the bitswap agent. +stat :: MonadIO m => IpfsT m BitswapStatObj +stat = call _bitswapStat + +-- | Show blocks currently on the wantlist. +wl :: MonadIO m => IpfsT m BitswapWLObj +wl = call _bitswapWL + +-- | Show the current ledger for a peer. +ledger :: MonadIO m => Text -> IpfsT m BitswapLedgerObj +ledger = call . _bitswapLedger + +-- | Trigger reprovider. +reprovide :: MonadIO m => IpfsT m ReprovideReturnType +reprovide = call _bitswapReprovide diff --git a/src/Network/Ipfs/Api/Block.hs b/src/Network/Ipfs/Api/Block.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Block.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Ipfs.Api.Block +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `block` prefix. +-- + +module Network.Ipfs.Api.Block where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (decode) +import Data.Text (Text) +import Network.HTTP.Client (responseBody) + +import Network.Ipfs.Api.Internal (_blockGet, _blockStat) +import Network.Ipfs.Api.Internal.Call (call, multipartCall) +import Network.Ipfs.Api.Types (BlockObj, BlockReturnType) +import Network.Ipfs.Client (IpfsT) + +-- | Get a raw IPFS block. +get :: MonadIO m => Text -> IpfsT m BlockReturnType +get = call . _blockGet + +-- | Store input as an IPFS block. +put :: MonadIO m => Text -> IpfsT m (Maybe BlockObj) +put = fmap decodeResponse . multipartCall "block/put" + where + decodeResponse = decode . responseBody + +-- | Print information of a raw IPFS block. +stat :: MonadIO m => Text -> IpfsT m BlockObj +stat = call . _blockStat diff --git a/src/Network/Ipfs/Api/Bootstrap.hs b/src/Network/Ipfs/Api/Bootstrap.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Bootstrap.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Network.Ipfs.Api.Bootstrap +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `bootstrap` prefix. +-- + +module Network.Ipfs.Api.Bootstrap where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) + +import Network.Ipfs.Api.Internal (_bootstrapAdd, _bootstrapList, + _bootstrapRM) +import Network.Ipfs.Api.Internal.Call (call) +import Network.Ipfs.Api.Types (BootstrapObj) +import Network.Ipfs.Client (IpfsT) + +-- | Add peers to the bootstrap list. +add :: MonadIO m => Text -> IpfsT m BootstrapObj +add = call . _bootstrapAdd . Just + +-- | Show peers in the bootstrap list. +list :: MonadIO m => IpfsT m BootstrapObj +list = call _bootstrapList + +-- | Remove peers from the bootstrap list. +rm :: MonadIO m => Text -> IpfsT m BootstrapObj +rm = call . _bootstrapRM . Just diff --git a/src/Network/Ipfs/Api/Cid.hs b/src/Network/Ipfs/Api/Cid.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Cid.hs @@ -0,0 +1,44 @@ +-- | +-- Module : Network.Ipfs.Api.Cid +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `cid` prefix. +-- + +module Network.Ipfs.Api.Cid where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) + +import Network.Ipfs.Api.Internal (_cidBase32, _cidBases, + _cidCodecs, _cidFormat, + _cidHashes) +import Network.Ipfs.Api.Internal.Call (call) +import Network.Ipfs.Api.Types (CidBasesObj, CidCodecsObj, + CidHashesObj, CidObj) +import Network.Ipfs.Client (IpfsT) + +-- | List available multibase encodings. +bases :: MonadIO m => IpfsT m [CidBasesObj] +bases = call _cidBases + +-- | List available CID codecs. +codecs :: MonadIO m => IpfsT m [CidCodecsObj] +codecs = call _cidCodecs + +-- | List available multihashes. +hashes :: MonadIO m => IpfsT m [CidHashesObj] +hashes = call _cidHashes + +-- | Convert CIDs to Base32 CID version 1. +base32 :: MonadIO m => Text -> IpfsT m CidObj +base32 = call . _cidBase32 + +-- | Format and convert a CID in various useful ways. +format :: MonadIO m => Text -> IpfsT m CidObj +format = call . _cidFormat diff --git a/src/Network/Ipfs/Api/Config.hs b/src/Network/Ipfs/Api/Config.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Config.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Ipfs.Api.Config +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `config` prefix. +-- + +module Network.Ipfs.Api.Config where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Types (Status (..)) + +import Network.Ipfs.Api.Internal (_configGet, _configSet) +import Network.Ipfs.Api.Internal.Call (call, multipartCall) +import Network.Ipfs.Api.Types (ConfigObj) +import Network.Ipfs.Client (IpfsT) + + +-- | Get ipfs config values. +get :: MonadIO m => Text -> IpfsT m ConfigObj +get = call . _configGet + +-- | Set ipfs config values. +set :: MonadIO m => Text -> Maybe Text -> IpfsT m ConfigObj +set key = call . _configSet key + +-- | Replace the config with the file at . +replace :: MonadIO m => Text -> IpfsT m Bool +replace = fmap isSuccess . multipartCall "config/replace" + where + isSuccess = (== 200) . statusCode . responseStatus diff --git a/src/Network/Ipfs/Api/Core.hs b/src/Network/Ipfs/Api/Core.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Core.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Ipfs.Api.Core +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Core IPFS API calls. +-- + +module Network.Ipfs.Api.Core where + +import qualified Codec.Archive.Tar as Tar +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Aeson (decode) +import Data.ByteString.Lazy (fromStrict) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Client (responseBody) +import Servant.API.ContentTypes (NoContent) + +import Network.Ipfs.Api.Internal (_cat, _dns, _get, _id, + _idPeer, _ls, _shutdown, + _version) +import Network.Ipfs.Api.Internal.Call (call, multipartCall, + streamCall) +import Network.Ipfs.Api.Internal.Stream (_ping, _refs, _refsLocal) +import Network.Ipfs.Api.Types (AddObj, CatReturnType, + DnsObj, IdObj, LsObj, + VersionObj) +import Network.Ipfs.Client (IpfsT) + +-- | Show IPFS object data. +cat :: MonadIO m => Text -> IpfsT m CatReturnType +cat = call . _cat + +-- | Add a file or directory to ipfs. +add :: MonadIO m => Text -> IpfsT m (Maybe AddObj) +add = fmap decodeResponse . multipartCall "add" + where + decodeResponse = decode . responseBody + +-- | List directory contents for Unix filesystem objects. +ls :: MonadIO m => Text -> IpfsT m LsObj +ls = call . _ls + +-- | Download IPFS objects. +get :: MonadIO m => Text -> IpfsT m Text +get hash = do + ret <- call $ _get hash + do liftIO $ Tar.unpack "getResponseDirectory" . Tar.read . fromStrict $ encodeUtf8 ret + pure "The content has been stored in getResponseDirectory." + +-- | Show ipfs version information. +version :: MonadIO m => IpfsT m VersionObj +version = call _version + +-- | Show ipfs node id info. +id :: MonadIO m => IpfsT m IdObj +id = call _id + +-- | Show ipfs node id info of the given peerId. +idPeer :: MonadIO m => Text -> IpfsT m IdObj +idPeer = call . _idPeer + +-- | Resolve DNS links. +dns :: MonadIO m => Text -> IpfsT m DnsObj +dns = call . _dns + +-- | List links (references) from an object. +refs :: MonadIO m => Text -> m () +refs = streamCall . _refs + +-- | List all local references. +refsLocal :: MonadIO m => m () +refsLocal = streamCall _refsLocal + +-- | Send echo request packets to IPFS hosts. +ping :: MonadIO m => Text -> m () +ping = streamCall . _ping + +-- | Shut down the ipfs daemon. +shutdown :: MonadIO m => IpfsT m NoContent +shutdown = call _shutdown diff --git a/src/Network/Ipfs/Api/Dag.hs b/src/Network/Ipfs/Api/Dag.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Dag.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Ipfs.Api.Dag +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `dag` prefix. +-- + +module Network.Ipfs.Api.Dag where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (decode) +import Data.Text (Text) +import Network.HTTP.Client (responseBody) + +import Network.Ipfs.Api.Internal (_dagGet, _dagResolve) +import Network.Ipfs.Api.Internal.Call (call, multipartCall) +import Network.Ipfs.Api.Types (DagPutObj, DagResolveObj, + DagReturnType) +import Network.Ipfs.Client (IpfsT) + +-- | Get a dag node from ipfs. +get :: MonadIO m => Text -> IpfsT m DagReturnType +get = call . _dagGet + +-- | Resolve ipld block. +resolve :: MonadIO m => Text -> IpfsT m DagResolveObj +resolve = call . _dagResolve + +-- | Add a dag node to ipfs. +put :: MonadIO m => Text -> IpfsT m (Maybe DagPutObj) +put = fmap decodeResponse . multipartCall "dag/put" + where + decodeResponse = decode . responseBody diff --git a/src/Network/Ipfs/Api/Dht.hs b/src/Network/Ipfs/Api/Dht.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Dht.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Network.Ipfs.Api.Dht +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `dht` prefix. +-- + +module Network.Ipfs.Api.Dht where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) + +import Network.Ipfs.Api.Internal.Call (streamCall) +import Network.Ipfs.Api.Internal.Stream (_dhtFindPeer, _dhtFindProvs, + _dhtGet, _dhtProvide, + _dhtQuery) + +-- | Find the multiaddresses associated with the given peerId. +findPeer :: MonadIO m => Text -> m () +findPeer = streamCall . _dhtFindPeer + +-- | Find peers that can provide a specific value, given a key. +findProvs :: MonadIO m => Text -> m () +findProvs = streamCall . _dhtFindProvs + +-- | Given a key, query the routing system for its best value. +get :: MonadIO m => Text -> m () +get cid = streamCall $ _dhtGet cid + +-- | Announce to the network that you are providing given values. +provide :: MonadIO m => Text -> m () +provide = streamCall . _dhtProvide + +-- | Find the closest Peer IDs to a given peerID by querying the DHT. +query :: MonadIO m => Text -> m () +query = streamCall . _dhtQuery diff --git a/src/Network/Ipfs/Api/Files.hs b/src/Network/Ipfs/Api/Files.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Files.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Ipfs.Api.Files +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `files` prefix. +-- + +module Network.Ipfs.Api.Files where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text, pack) +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Types (Status (..)) +import Servant.API.ContentTypes (NoContent) + +import Network.Ipfs.Api.Internal (_filesChcid, _filesCp, + _filesFlush, _filesLs, + _filesMkdir, _filesMv, + _filesRead, _filesRm, + _filesStat) +import Network.Ipfs.Api.Internal.Call (call, multipartCall) +import Network.Ipfs.Api.Types (FilesFlushObj, FilesLsObj, + FilesReadType, FilesStatObj) +import Network.Ipfs.Client (IpfsT) + +-- | Change the cid version or hash function of the root node of a given mfsPath. +chcidVer :: MonadIO m => Text -> Int -> IpfsT m NoContent +chcidVer mfsPath = call . _filesChcid (Just mfsPath) . Just + +-- | Copy files into mfs. +cp :: MonadIO m => Text -> Text -> IpfsT m NoContent +cp src = call . _filesCp (Just src) . Just + +-- | Flush a given path's data to disk. +flush :: MonadIO m => Text -> IpfsT m FilesFlushObj +flush = call . _filesFlush . Just + +-- | List directories in the local mutable namespace. +ls :: MonadIO m => Text -> IpfsT m FilesLsObj +ls = call . _filesLs . Just + +-- | Make directories. +mkdir :: MonadIO m => Text -> IpfsT m NoContent +mkdir = call . _filesMkdir . Just + +-- | Move files. +mv :: MonadIO m => Text -> Text -> IpfsT m NoContent +mv src = call . _filesMv (Just src) . Just + +-- | Read a file in a given mfs. +read :: MonadIO m => Text -> IpfsT m FilesReadType +read = call . _filesRead . Just + +-- | Display file status. +stat :: MonadIO m => Text -> IpfsT m FilesStatObj +stat = call . _filesStat . Just + +-- | Remove a file. +filesRm :: MonadIO m => Text -> IpfsT m NoContent +filesRm = call . flip _filesRm (Just True) . Just + +-- | Write to a mutable file in a given filesystem. +write :: MonadIO m => Text -> Text -> Bool -> IpfsT m Bool +write mfsPath filePath toTruncate = isSuccess <$> multipartCall uri filePath + where + uri = "files/write?arg=" <> mfsPath <> "&create=true" <> "&truncate=" <> (pack $ show toTruncate) + isSuccess = (200 ==) . statusCode . responseStatus diff --git a/src/Network/Ipfs/Api/Internal.hs b/src/Network/Ipfs/Api/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Internal.hs @@ -0,0 +1,100 @@ +-- | +-- Module : Network.Ipfs.Api.Internal +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- IPFS API internals. +-- + +module Network.Ipfs.Api.Internal where + +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Servant.API +import Servant.Client (ClientM, client) + +import Network.Ipfs.Api.Types + +_ipfsApi :: Proxy IpfsApi +_ipfsApi = Proxy + +_cat :: Text -> ClientM CatReturnType +_ls :: Text -> ClientM LsObj +_get :: Text -> ClientM GetReturnType +_swarmPeers :: ClientM SwarmPeersObj +_swarmConnect :: Maybe Text -> ClientM SwarmObj +_swarmDisconnect :: Maybe Text -> ClientM SwarmObj +_swarmFilters :: ClientM SwarmObj +_swarmFilterAdd :: Maybe Text -> ClientM SwarmObj +_swarmFilterRm :: Maybe Text -> ClientM SwarmObj +_bitswapStat :: ClientM BitswapStatObj +_bitswapWL :: ClientM BitswapWLObj +_bitswapLedger :: Text -> ClientM BitswapLedgerObj +_bitswapReprovide :: ClientM ReprovideReturnType +_cidBases :: ClientM [CidBasesObj] +_cidCodecs :: ClientM [CidCodecsObj] +_cidHashes :: ClientM [CidHashesObj] +_cidBase32 :: Text -> ClientM CidObj +_cidFormat :: Text -> ClientM CidObj +_blockGet :: Text -> ClientM BlockReturnType +_blockStat :: Text -> ClientM BlockObj +_dagGet :: Text -> ClientM DagReturnType +_dagResolve :: Text -> ClientM DagResolveObj +_configGet :: Text -> ClientM ConfigObj +_configSet :: Text -> Maybe Text -> ClientM ConfigObj +_objectData :: Text -> ClientM ObjectReturnType +_objectNew :: ClientM ObjectObj +_objectGetLinks :: Text -> ClientM ObjectLinksObj +_objectAddLink :: Text -> Maybe Text -> Maybe Text -> ClientM ObjectLinksObj +_objectRmLink :: Text -> Maybe Text -> ClientM ObjectLinksObj +_objectGet :: Text -> ClientM ObjectGetObj +_objectDiff :: Text -> Maybe Text -> ClientM ObjectDiffObj +_objectStat :: Text -> ClientM ObjectStatObj +_pinAdd :: Text -> ClientM PinObj +_pinRemove :: Text -> ClientM PinObj +_bootstrapAdd :: Maybe Text -> ClientM BootstrapObj +_bootstrapList :: ClientM BootstrapObj +_bootstrapRM :: Maybe Text -> ClientM BootstrapObj +_statsBw :: ClientM StatsBwObj +_statsRepo :: ClientM StatsRepoObj +_version :: ClientM VersionObj +_id :: ClientM IdObj +_idPeer :: Text -> ClientM IdObj +_dns :: Text -> ClientM DnsObj +_pubsubLs :: ClientM PubsubObj +_pubsubPeers :: ClientM PubsubObj +_pubsubPublish :: Text -> Maybe Text -> ClientM NoContent +_logLs :: ClientM LogLsObj +_logLevel :: Text -> Maybe Text -> ClientM LogLevelObj +_repoVersion :: ClientM RepoVersionObj +_repoFsck :: ClientM RepoFsckObj +_keyGen :: Text -> (Maybe Text) -> ClientM KeyDetailsObj +_keyList :: ClientM KeyObj +_keyRename :: Text -> (Maybe Text) -> ClientM KeyRenameObj +_keyRm :: Text -> ClientM KeyObj +_filesChcid :: Maybe Text -> Maybe Int -> ClientM NoContent +_filesCp :: Maybe Text -> Maybe Text -> ClientM NoContent +_filesFlush :: Maybe Text -> ClientM FilesFlushObj +_filesLs :: Maybe Text -> ClientM FilesLsObj +_filesMkdir :: Maybe Text -> ClientM NoContent +_filesMv :: Maybe Text -> Maybe Text -> ClientM NoContent +_filesRead :: Maybe Text -> ClientM FilesReadType +_filesRm :: Maybe Text -> Maybe Bool -> ClientM NoContent +_filesStat :: Maybe Text -> ClientM FilesStatObj +_shutdown :: ClientM NoContent + +_cat :<|> _ls :<|> _get :<|> _swarmPeers :<|> _swarmConnect :<|> _swarmDisconnect :<|> + _swarmFilters :<|> _swarmFilterAdd :<|> _swarmFilterRm :<|> _bitswapStat :<|> _bitswapWL :<|> _bitswapLedger :<|> + _bitswapReprovide :<|> _cidBases :<|> _cidCodecs :<|> _cidHashes :<|> _cidBase32 :<|> _cidFormat :<|> + _blockGet :<|> _blockStat :<|> _dagGet :<|> _dagResolve :<|> _configGet :<|> + _configSet :<|> _objectData :<|> _objectNew :<|> _objectGetLinks :<|> _objectAddLink :<|> _objectRmLink :<|> + _objectGet :<|> _objectDiff :<|> _objectStat :<|> _pinAdd :<|> _pinRemove :<|> _bootstrapAdd :<|> + _bootstrapList :<|> _bootstrapRM :<|> _statsBw :<|> _statsRepo :<|> _version :<|> _id :<|> _idPeer :<|> + _dns :<|> _pubsubLs :<|> _pubsubPeers :<|> _pubsubPublish :<|> _logLs :<|> _logLevel :<|> _repoVersion :<|> + _repoFsck :<|> _keyGen :<|> _keyList :<|> _keyRename :<|> _keyRm :<|> _filesChcid :<|> _filesCp :<|> + _filesFlush :<|> _filesLs :<|> _filesMkdir :<|> _filesMv :<|> _filesRead :<|> _filesRm :<|> _filesStat :<|> + _shutdown = client _ipfsApi diff --git a/src/Network/Ipfs/Api/Internal/Call.hs b/src/Network/Ipfs/Api/Internal/Call.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Internal/Call.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Network.Ipfs.Api.Internal.Call +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Module containing IPFS API call functions. +-- + +module Network.Ipfs.Api.Internal.Call where + +import Control.Monad.Except +import Control.Monad.Reader +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text, pack, unpack) +import Network.HTTP.Client as Net hiding (Proxy) +import Network.HTTP.Client.MultipartFormData +import Servant.Client +import qualified Servant.Client.Streaming as S +import Servant.Types.SourceT (SourceT (..), foreach) + +import Network.Ipfs.Client (IpfsT) + +-- | Regular Call function. +call :: MonadIO m => ClientM a -> IpfsT m a +call func = do + (manager', url, _) <- ask + resp <- liftIO (runClientM func (mkClientEnv manager' url)) + case resp of + Left l -> throwError l + Right r -> return r + +-- | Call function for ‘multipart/form-data’. +multipartCall :: MonadIO m => Text -> Text -> IpfsT m (Net.Response ByteString) +multipartCall funcUri filePath = do + (reqManager, _, url) <- ask + req <- liftIO $ parseRequest $ unpack (pack url <> "/" <> funcUri ) + liftIO $ flip httpLbs reqManager =<< formDataBody form req + where + form = [ partFileSource "file" $ unpack filePath ] + +-- | Call function for Streams. +streamCall :: (MonadIO m, Show a) => S.ClientM (SourceT IO a) -> m () +streamCall func = liftIO $ do + manager' <- newManager defaultManagerSettings + S.withClientM func (S.mkClientEnv manager' (BaseUrl Http "localhost" 5001 "/api/v0")) $ \e -> case e of + Left err -> putStrLn $ "Error: " ++ show err + Right rs -> foreach fail print rs diff --git a/src/Network/Ipfs/Api/Internal/Stream.hs b/src/Network/Ipfs/Api/Internal/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Internal/Stream.hs @@ -0,0 +1,41 @@ +-- | +-- Module : Network.Ipfs.Api.Internal.Stream +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Ipfs Stream API provider. +-- + +module Network.Ipfs.Api.Internal.Stream where + +import qualified Data.ByteString.Lazy.Char8 () +import Data.Proxy +import Data.Text +import Network.HTTP.Client () +import Servant.API +import Servant.Client.Streaming as S + +import Network.Ipfs.Api.Types.Stream + +_ipfsStreamApi :: Proxy IpfsStreamApi +_ipfsStreamApi = Proxy + +_ping :: Text -> ClientM (SourceIO PingObj) +_dhtFindPeer :: Text -> ClientM (SourceIO DhtObj) +_dhtFindProvs :: Text -> ClientM (SourceIO DhtObj) +_dhtGet :: Text -> ClientM (SourceIO DhtObj) +_dhtProvide :: Text -> ClientM (SourceIO DhtObj) +_dhtQuery :: Text -> ClientM (SourceIO DhtObj) +_logTail :: ClientM (SourceIO LogReturnType) +_repoGc :: ClientM (SourceIO RepoGcObj) +_repoVerify :: ClientM (SourceIO RepoVerifyObj) +_refs :: Text -> ClientM (SourceIO RefsObj) +_refsLocal :: ClientM (SourceIO RefsObj) +_pubsubSubscribe :: Text -> ClientM (SourceIO PubsubSubObj) + +_ping :<|> _dhtFindPeer :<|> _dhtFindProvs :<|> _dhtGet :<|> _dhtProvide :<|> _dhtQuery :<|> + _logTail :<|> _repoGc :<|> _repoVerify :<|> _refs :<|> _refsLocal :<|> _pubsubSubscribe = client _ipfsStreamApi diff --git a/src/Network/Ipfs/Api/Key.hs b/src/Network/Ipfs/Api/Key.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Key.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Network.Ipfs.Api.Key +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `key` prefix. +-- + +module Network.Ipfs.Api.Key where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) + +import Network.Ipfs.Api.Internal (_keyGen, _keyList, _keyRename, + _keyRm) +import Network.Ipfs.Api.Internal.Call (call) +import Network.Ipfs.Api.Types (KeyDetailsObj, KeyObj, + KeyRenameObj) +import Network.Ipfs.Client (IpfsT) + + +-- | 'List all local keypairs. +list :: MonadIO m => IpfsT m KeyObj +list = call _keyList + +-- | Create a new keypair. +gen :: MonadIO m => Text -> Text -> IpfsT m KeyDetailsObj +gen name = call . _keyGen name . Just + +-- | Rename a keypair. +rename :: MonadIO m => Text -> Text -> IpfsT m KeyRenameObj +rename was = call . _keyRename was . Just + +-- | Remove a keypair. +rm :: MonadIO m => Text -> IpfsT m KeyObj +rm = call . _keyRm + diff --git a/src/Network/Ipfs/Api/Log.hs b/src/Network/Ipfs/Api/Log.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Log.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Network.Ipfs.Api.Log +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `log` prefix. +-- + +module Network.Ipfs.Api.Log where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) + +import Network.Ipfs.Api.Internal (_logLevel, _logLs) +import Network.Ipfs.Api.Internal.Call (call, streamCall) +import Network.Ipfs.Api.Internal.Stream (_logTail) +import Network.Ipfs.Api.Types (LogLevelObj, LogLsObj) +import Network.Ipfs.Client (IpfsT) + + +-- | Change the logging level. +level :: MonadIO m => Text -> Text -> IpfsT m LogLevelObj +level subsystem = call . _logLevel subsystem . Just + +-- | Read the event log. +tail :: MonadIO m => m () +tail = streamCall _logTail + +-- | List the logging subsystems. +ls :: MonadIO m => IpfsT m LogLsObj +ls = call _logLs diff --git a/src/Network/Ipfs/Api/Object.hs b/src/Network/Ipfs/Api/Object.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Object.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Ipfs.Api.Object +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `object` prefix. +-- + +module Network.Ipfs.Api.Object where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson (decode) +import Data.Text (Text) +import Network.HTTP.Client (responseBody) + +import Network.Ipfs.Api.Internal (_objectAddLink, _objectData, + _objectDiff, _objectGet, + _objectGetLinks, _objectNew, + _objectRmLink, _objectStat) +import Network.Ipfs.Api.Internal.Call (call, multipartCall) +import Network.Ipfs.Api.Types (ObjectDiffObj, ObjectGetObj, + ObjectLinksObj, ObjectObj, + ObjectReturnType, + ObjectStatObj) +import Network.Ipfs.Client (IpfsT) + +-- | Output the raw bytes of an IPFS object. +object :: MonadIO m => Text -> IpfsT m ObjectReturnType +object = call . _objectData + +-- | Create a new object from an ipfs template. +new :: MonadIO m => IpfsT m ObjectObj +new = call _objectNew + +-- | Output the links pointed to by the specified object. +getLinks :: MonadIO m => Text -> IpfsT m ObjectLinksObj +getLinks = call . _objectGetLinks + +-- | Add a Merkle-link to the given object and return the hash of the result. +addLink :: MonadIO m => Text -> Text -> Text -> IpfsT m ObjectLinksObj +addLink hash name = call . _objectAddLink hash (Just name) . Just + +-- | Remove a Merkle-link from the given object and return the hash of the result. +rmLink :: MonadIO m => Text -> Text -> IpfsT m ObjectLinksObj +rmLink key = call . _objectRmLink key . Just + +-- | Append data to what already exists in the data segment in the given object. +appendData :: MonadIO m => Text -> Text -> IpfsT m (Maybe ObjectLinksObj) +appendData key = fmap decodeResponse . multipartCall ("object/patch/append-data?arg=" <> key) + where + decodeResponse = decode . responseBody + +-- | Set the data field of an IPFS object. +setData :: MonadIO m => Text -> Text -> IpfsT m (Maybe ObjectLinksObj) +setData key = fmap decodeResponse . multipartCall ("object/patch/set-data?arg=" <> key) + where + decodeResponse = decode . responseBody + +-- | Get and serialize the DAG node named by key. +get :: MonadIO m => Text -> IpfsT m ObjectGetObj +get = call . _objectGet + +-- | 'Display the diff between two ipfs objects. +diff :: MonadIO m => Text -> Text -> IpfsT m ObjectDiffObj +diff firstKey = call . _objectDiff firstKey . Just + +-- | Store input as a DAG object, print its key. +put :: MonadIO m => Text -> IpfsT m (Maybe ObjectObj) +put = fmap decodeResponse . multipartCall "object/put" + where + decodeResponse = decode . responseBody + +-- | Get stats for the DAG node named by key. +objectStat :: MonadIO m => Text -> IpfsT m ObjectStatObj +objectStat = call . _objectStat diff --git a/src/Network/Ipfs/Api/Pin.hs b/src/Network/Ipfs/Api/Pin.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Pin.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Network.Ipfs.Api.Pin +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `pin` prefix. +-- + +module Network.Ipfs.Api.Pin where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) + +import Network.Ipfs.Api.Internal (_pinAdd, _pinRemove) +import Network.Ipfs.Api.Internal.Call (call) +import Network.Ipfs.Api.Types (PinObj) +import Network.Ipfs.Client (IpfsT) + +-- | Pin objects to local storage. +add :: MonadIO m => Text -> IpfsT m PinObj +add = call . _pinAdd + +-- | Remove pinned objects from local storage. +remove :: MonadIO m => Text -> IpfsT m PinObj +remove = call . _pinRemove diff --git a/src/Network/Ipfs/Api/Pubsub.hs b/src/Network/Ipfs/Api/Pubsub.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Pubsub.hs @@ -0,0 +1,39 @@ +-- | +-- Module : Network.Ipfs.Api.Pubsub +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `pubsub` prefix. +-- + +module Network.Ipfs.Api.Pubsub where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) +import Servant.API.ContentTypes (NoContent) + +import Network.Ipfs.Api.Internal (_pubsubLs, _pubsubPeers, + _pubsubPublish) +import Network.Ipfs.Api.Internal.Call (call) +import Network.Ipfs.Api.Types (PubsubObj) +import Network.Ipfs.Client (IpfsT) + +-- | List subscribed topics by name. +ls :: MonadIO m => IpfsT m PubsubObj +ls = call _pubsubLs + +-- | List peers we are currently pubsubbing with. +peers :: MonadIO m => IpfsT m PubsubObj +peers = call _pubsubPeers + +-- | Publish a message to a given pubsub topic. +publish :: MonadIO m => Text -> Text -> IpfsT m NoContent +publish topic = call . _pubsubPublish topic . Just + +-- | Subscribe to messages on a given topic. +--subscribe :: Text -> m () +--subscribe = pubsubCall . _pubsubSubscribe diff --git a/src/Network/Ipfs/Api/Repo.hs b/src/Network/Ipfs/Api/Repo.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Repo.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Network.Ipfs.Api.Repo +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `repo` prefix. +-- + +module Network.Ipfs.Api.Repo where + +import Control.Monad.IO.Class (MonadIO) + +import Network.Ipfs.Api.Internal (_repoFsck, _repoVersion) +import Network.Ipfs.Api.Internal.Call (call, streamCall) +import Network.Ipfs.Api.Internal.Stream (_repoGc, _repoVerify) +import Network.Ipfs.Api.Types (RepoFsckObj, RepoVersionObj) +import Network.Ipfs.Client (IpfsT) + +-- | Show the repo version. +version :: MonadIO m => IpfsT m RepoVersionObj +version = call _repoVersion + +-- | Remove repo lockfiles. +fsck :: MonadIO m => IpfsT m RepoFsckObj +fsck = call _repoFsck + +-- | Perform a garbage collection sweep on the repo. +gc :: MonadIO m => m () +gc = streamCall _repoGc + +-- | Verify all blocks in repo are not corrupted. +repoVerify :: MonadIO m => m () +repoVerify = streamCall _repoVerify diff --git a/src/Network/Ipfs/Api/Stats.hs b/src/Network/Ipfs/Api/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Stats.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Network.Ipfs.Api.Stats +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `stats` prefix. +-- + +module Network.Ipfs.Api.Stats where + +import Control.Monad.IO.Class (MonadIO) + +import Network.Ipfs.Api.Internal (_statsBw, _statsRepo) +import Network.Ipfs.Api.Internal.Call (call) +import Network.Ipfs.Api.Types (StatsBwObj, StatsRepoObj) +import Network.Ipfs.Client (IpfsT) + +-- | IPFS bandwidth information. +bw :: MonadIO m => IpfsT m StatsBwObj +bw = call _statsBw + +-- | Get stats for the currently used repo. +repo :: MonadIO m => IpfsT m StatsRepoObj +repo = call _statsRepo diff --git a/src/Network/Ipfs/Api/Swarm.hs b/src/Network/Ipfs/Api/Swarm.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Swarm.hs @@ -0,0 +1,49 @@ +-- | +-- Module : Network.Ipfs.Api.Swarm +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Api calls with `swarm` prefix. +-- + +module Network.Ipfs.Api.Swarm where + +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) + +import Network.Ipfs.Api.Internal (_swarmConnect, + _swarmDisconnect, + _swarmFilterAdd, + _swarmFilterRm, _swarmFilters, + _swarmPeers) +import Network.Ipfs.Api.Internal.Call (call) +import Network.Ipfs.Api.Types (SwarmObj, SwarmPeersObj) +import Network.Ipfs.Client (IpfsT) + +-- | List peers with open connections. +swarmPeers :: MonadIO m => IpfsT m SwarmPeersObj +swarmPeers = call _swarmPeers + +-- | Open connection to a given address. 'peerId' has to be of the format - /ipfs/id +connect :: MonadIO m => Text -> IpfsT m SwarmObj +connect = call . _swarmConnect . Just + +-- | Close connection to a given address. 'peerId' has to be of the format - /ipfs/id +disconnect :: MonadIO m => Text -> IpfsT m SwarmObj +disconnect = call . _swarmDisconnect . Just + +-- | Manipulate address filters. +filters :: MonadIO m => IpfsT m SwarmObj +filters = call _swarmFilters + +-- | Add an address filter. 'peerId' has to be of the format - /ip4/{IP addr of peer}/ipcidr/{ip network prefix} +filterAdd :: MonadIO m => Text -> IpfsT m SwarmObj +filterAdd = call . _swarmFilterAdd . Just + +-- | Remove an address filter. +filterRm :: MonadIO m => Text -> IpfsT m SwarmObj +filterRm = call . _swarmFilterRm . Just diff --git a/src/Network/Ipfs/Api/Types.hs b/src/Network/Ipfs/Api/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Types.hs @@ -0,0 +1,823 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Network.Ipfs.Api.Types +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- IPFS API types. +-- + +module Network.Ipfs.Api.Types where + +import Control.Arrow (left) +import Control.Monad +import Data.Aeson +import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString.Lazy.Char8 () +import qualified Data.HashMap.Strict as H +import Data.Int +import Data.Text (Text) +import qualified Data.Text.Encoding as TextS +import Data.Typeable +import Network.HTTP.Client () +import qualified Network.HTTP.Media as M ((//)) +import Servant.API + +type CatReturnType = Text +type ReprovideReturnType = Text +type GetReturnType = Text +type BlockReturnType = Text +type DagReturnType = Text +type ObjectReturnType = Text +type FilesReadType = Text + +data DirLink = DirLink + { dlName :: Text + , dlHash :: Text + , dlSize :: Int64 + , dlContentType :: Int + , dlTarget :: Text + } + deriving (Show, Eq) + +data DirObj = DirObj + { dirHash :: Text + , links :: [DirLink] + } + deriving (Show, Eq) + +data AddObj = AddObj + { name :: Text + , hash :: Text + , size :: Text + } + deriving (Show, Eq) + +instance FromJSON AddObj where + parseJSON (Object o) = + AddObj <$> o .: "Name" + <*> o .: "Hash" + <*> o .: "Size" + + parseJSON _ = mzero + +data LsObj = LsObj + { objs :: [DirObj] + } + deriving (Show, Eq) + +data SwarmStreamObj = SwarmStreamObj + { protocol :: Text + } + deriving (Show, Eq) + +data SwarmPeerObj = SwarmPeerObj + { address :: Text + , direction :: Int + , latency :: Text + , muxer :: Text + , peer :: Text + , streams :: Maybe [SwarmStreamObj] + } + deriving (Show, Eq) + +data SwarmPeersObj = SwarmPeersObj + { peers :: [SwarmPeerObj] + } + deriving (Show, Eq) + +data SwarmObj = SwarmObj + { strings :: [Text] + } + deriving (Show, Eq) + +data WantlistObj = WantlistObj + { forSlash :: Text + } + deriving (Show, Eq) + +data BitswapStatObj = BitswapStatObj + { blocksReceived :: Int64 + , blocksSent :: Int64 + , dataReceived :: Int64 + , dataSent :: Int64 + , dupBlksReceived :: Int64 + , dupDataReceived :: Int64 + , messagesReceived :: Int64 + , bitswapPeers :: [Text] + , provideBufLen :: Int + , wantlist :: [WantlistObj] + } + deriving (Show, Eq) + +data BitswapWLObj = BitswapWLObj + { bitswapKeys :: [WantlistObj] + } + deriving (Show, Eq) + +data BitswapLedgerObj = BitswapLedgerObj + { exchanged :: Int64 + , ledgerPeer :: Text + , recv :: Int64 + , sent :: Int64 + , value :: Double + } + deriving (Show, Eq) + +data CidBasesObj = CidBasesObj + { baseCode :: Int + , baseName :: Text + } + deriving (Show, Eq) + +data CidCodecsObj = CidCodecsObj + { codecCode :: Int + , codecName :: Text + } + deriving (Show, Eq) + +data CidHashesObj = CidHashesObj + { multihashCode :: Int + , multihashName :: Text + } + deriving (Show, Eq) + +data CidObj = CidObj + { cidStr :: Text + , errorMsg :: Text + , formatted :: Text + } + deriving (Show, Eq) + +data BlockObj = BlockObj + { key :: Text + , blockSize :: Int + } + deriving (Show, Eq) + +data DagCidObj = DagCidObj + { cidSlash :: Text + } + deriving (Show, Eq) + +data DagResolveObj = DagResolveObj + { cid :: DagCidObj + , remPath :: Text + } + deriving (Show, Eq) + +data DagPutObj = DagPutObj + { putCid :: DagCidObj + } + deriving (Show, Eq) + +data ConfigObj = ConfigObj + { configKey :: Text + , configValue :: Text + } + deriving (Show, Eq) + +data ObjectLinkObj = ObjectLinkObj + { linkHash :: Text + , linkName :: Text + , linkSize :: Int64 + } + deriving (Show, Eq) + +data ObjectObj = ObjectObj + { newObjectHash :: Text + } + deriving (Show, Eq) + +data ObjectLinksObj = WithLinks + { objectHash :: Text + , objectLinks :: [ObjectLinkObj] + } + | WithoutLinks + { objectHash :: Text + } + deriving (Show, Eq) + +data ObjectGetObj = ObjectGetObj + { objectName :: Text + , objectGetLinks :: [ObjectLinkObj] + } + deriving (Show, Eq) + +data ObjectStatObj = ObjectStatObj + { objBlockSize :: Int + , cumulativeSize :: Int + , dataSize :: Int + , objHash :: Text + , linksSize :: Int + , numLinks :: Int + } + deriving (Show, Eq) + +data DiffObj = DiffObj + { diffSlash :: Text + } + deriving (Show, Eq) + +data ObjectChangeObj = ObjectChangeObj + { after :: Maybe DiffObj + , before :: DiffObj + , path :: Text + , diffType :: Int + } + deriving (Show, Eq) + +data ObjectDiffObj = ObjectDiffObj + { changes :: [ObjectChangeObj] + } + deriving (Show, Eq) + +data PinObj = WithoutProgress + { pins :: [Text] + } + | WithProgress + { pins :: [Text] + , progress :: Int + } + deriving (Show, Eq) + +data BootstrapObj = BootstrapObj + { bootstrapPeers :: [Text] + } + deriving (Show, Eq) + +data StatsBwObj = StatsBwObj + { rateIn :: Double + , rateOut :: Double + , totalIn :: Int64 + , totalOut :: Int64 + } + deriving (Show, Eq) + +data StatsRepoObj = StatsRepoObj + { numObjects :: Int64 + , repoPath :: Text + , repoSize :: Int64 + , storageMax :: Int64 + , repoVersion :: Text + } + deriving (Show, Eq) + +data VersionObj = VersionObj + { commit :: Text + , golang :: Text + , repo :: Text + , system :: Text + , version :: Text + } + deriving (Show, Eq) + +data IdObj = IdObj + { addresses :: [Text] + , agentVersion :: Text + , id :: Text + , protocolVersion :: Text + , publicKey :: Text + } + deriving (Show, Eq) + +data DnsObj = DnsObj + { dnsPath :: Text + } + deriving (Show, Eq) + +data PubsubObj = PubsubObj + { pubsubStrings :: [Text] + } + deriving (Show, Eq) + +data LogLsObj = LogLsObj + { logLsStrings :: [Text] + } + deriving (Show, Eq) + +data LogLevelObj = LogLevelObj + { message :: Text + } + deriving (Show, Eq) + +data RepoVersionObj = RepoVersionObj + { repoVer :: Text + } + deriving (Show, Eq) + +data RepoFsckObj = RepoFsckObj + { repoMessage :: Text + } + deriving (Show, Eq) + +data KeyDetailsObj = KeyDetailsObj + { keyId :: Text + , keyName :: Text + } + deriving (Show, Eq) + +data KeyObj = KeyObj + { keys :: [KeyDetailsObj] + } + deriving (Show, Eq) + +data KeyRenameObj = KeyRenameObj + { peerId :: Text + , now :: Text + , overwrite :: Bool + , was :: Text + } + deriving (Show, Eq) + +data FilesStatObj = FilesStatObj + { fileObjectHash :: Text + , objectSize :: Int + , cumulativeObjectSize :: Int + , blocks :: Int + , objectType :: Text + } + deriving (Show, Eq) + +data FilesEntryObj = FilesEntryObj + { entryName :: Text + , entryType :: Int + , entrySize :: Int + , entryHash :: Text + } + deriving (Show, Eq) + +data FilesLsObj = FilesLsObj + { enteries :: [FilesEntryObj] + } + deriving (Show, Eq) + +data FilesFlushObj = FilesFlushObj + { fileCid :: Text + } + deriving (Show, Eq) + +instance FromJSON DirLink where + parseJSON (Object o) = + DirLink <$> o .: "Name" + <*> o .: "Hash" + <*> o .: "Size" + <*> o .: "Type" + <*> o .: "Target" + + parseJSON _ = mzero + +instance FromJSON DirObj where + parseJSON (Object o) = + DirObj <$> o .: "Hash" + <*> o .: "Links" + + parseJSON _ = mzero + +instance FromJSON LsObj where + parseJSON (Object o) = + LsObj <$> o .: "Objects" + + parseJSON _ = mzero + + +instance FromJSON SwarmStreamObj where + parseJSON (Object o) = + SwarmStreamObj <$> o .: "Protocol" + + parseJSON _ = mzero + +instance FromJSON SwarmPeerObj where + parseJSON (Object o) = + SwarmPeerObj <$> o .: "Addr" + <*> o .: "Direction" + <*> o .: "Latency" + <*> o .: "Muxer" + <*> o .: "Peer" + <*> o .: "Streams" + + parseJSON _ = mzero + +instance FromJSON SwarmPeersObj where + parseJSON (Object o) = + SwarmPeersObj <$> o .: "Peers" + + parseJSON _ = mzero + + +instance FromJSON SwarmObj where + parseJSON (Object o) = + SwarmObj <$> o .: "Strings" + + parseJSON _ = mzero + +instance FromJSON WantlistObj where + parseJSON (Object o) = + WantlistObj <$> o .: "/" + + parseJSON _ = mzero + +instance FromJSON BitswapStatObj where + parseJSON (Object o) = + BitswapStatObj <$> o .: "BlocksReceived" + <*> o .: "BlocksSent" + <*> o .: "DataReceived" + <*> o .: "DataSent" + <*> o .: "DupBlksReceived" + <*> o .: "DupDataReceived" + <*> o .: "MessagesReceived" + <*> o .: "Peers" + <*> o .: "ProvideBufLen" + <*> o .: "Wantlist" + + parseJSON _ = mzero + + +instance FromJSON BitswapWLObj where + parseJSON (Object o) = + BitswapWLObj <$> o .: "Keys" + + parseJSON _ = mzero + +instance FromJSON BitswapLedgerObj where + parseJSON (Object o) = + BitswapLedgerObj <$> o .: "Exchanged" + <*> o .: "Peer" + <*> o .: "Recv" + <*> o .: "Sent" + <*> o .: "Value" + + parseJSON _ = mzero + +instance FromJSON CidBasesObj where + parseJSON (Object o) = + CidBasesObj <$> o .: "Code" + <*> o .: "Name" + + parseJSON _ = mzero + +instance FromJSON CidCodecsObj where + parseJSON (Object o) = + CidCodecsObj <$> o .: "Code" + <*> o .: "Name" + + parseJSON _ = mzero + +instance FromJSON CidHashesObj where + parseJSON (Object o) = + CidHashesObj <$> o .: "Code" + <*> o .: "Name" + + parseJSON _ = mzero + +instance FromJSON CidObj where + parseJSON (Object o) = + CidObj <$> o .: "CidStr" + <*> o .: "ErrorMsg" + <*> o .: "Formatted" + + parseJSON _ = mzero + +instance FromJSON BlockObj where + parseJSON (Object o) = + BlockObj <$> o .: "Key" + <*> o .: "Size" + + parseJSON _ = mzero + +instance FromJSON DagCidObj where + parseJSON (Object o) = + DagCidObj <$> o .: "/" + + parseJSON _ = mzero + +instance FromJSON DagResolveObj where + parseJSON (Object o) = + DagResolveObj <$> o .: "Cid" + <*> o .: "RemPath" + + parseJSON _ = mzero + +instance FromJSON DagPutObj where + parseJSON (Object o) = + DagPutObj <$> o .: "Cid" + + parseJSON _ = mzero + +instance FromJSON ConfigObj where + parseJSON (Object o) = + ConfigObj <$> o .: "Key" + <*> o .: "Value" + + parseJSON _ = mzero + +instance FromJSON ObjectLinkObj where + parseJSON (Object o) = + ObjectLinkObj <$> o .: "Hash" + <*> o .: "Name" + <*> o .: "Size" + + parseJSON _ = mzero + +instance FromJSON ObjectObj where + parseJSON (Object o) = + ObjectObj <$> o .: "Hash" + + parseJSON _ = mzero + +instance FromJSON ObjectLinksObj where + parseJSON (Object v) = + case H.lookup "Links" v of + Just (_) -> WithLinks <$> v .: "Hash" + <*> v .: "Links" + + Nothing -> + case H.lookup "Hash" v of + Just (_) -> WithoutLinks <$> v .: "Hash" + Nothing -> mzero + + parseJSON _ = mzero + +instance FromJSON ObjectGetObj where + parseJSON (Object o) = + ObjectGetObj <$> o .: "Data" + <*> o .: "Links" + + parseJSON _ = mzero + +instance FromJSON ObjectStatObj where + parseJSON (Object o) = + ObjectStatObj <$> o .: "BlockSize" + <*> o .: "CumulativeSize" + <*> o .: "DataSize" + <*> o .: "Hash" + <*> o .: "LinksSize" + <*> o .: "NumLinks" + + parseJSON _ = mzero + +instance FromJSON ObjectChangeObj where + parseJSON (Object o) = + ObjectChangeObj <$> o .: "After" + <*> o .: "Before" + <*> o .: "Path" + <*> o .: "Type" + + parseJSON _ = mzero + +instance FromJSON DiffObj where + parseJSON (Object o) = + DiffObj <$> o .: "/" + + parseJSON _ = mzero + +instance FromJSON ObjectDiffObj where + parseJSON (Object o) = + ObjectDiffObj <$> o .: "Changes" + + parseJSON _ = mzero + +instance FromJSON PinObj where + parseJSON (Object v) = + case H.lookup "Progress" v of + Just (_) -> WithProgress <$> v .: "Pins" + <*> v .: "Progress" + + Nothing -> + case H.lookup "Pins" v of + Just (_) -> WithoutProgress <$> v .: "Pins" + Nothing -> mzero + + parseJSON _ = mzero + +instance FromJSON BootstrapObj where + parseJSON (Object o) = + BootstrapObj <$> o .: "Peers" + + parseJSON _ = mzero + +instance FromJSON StatsBwObj where + parseJSON (Object o) = + StatsBwObj <$> o .: "RateIn" + <*> o .: "RateOut" + <*> o .: "TotalIn" + <*> o .: "TotalOut" + + parseJSON _ = mzero + +instance FromJSON StatsRepoObj where + parseJSON (Object o) = + StatsRepoObj <$> o .: "NumObjects" + <*> o .: "RepoPath" + <*> o .: "RepoSize" + <*> o .: "StorageMax" + <*> o .: "Version" + + parseJSON _ = mzero + +instance FromJSON VersionObj where + parseJSON (Object o) = + VersionObj <$> o .: "Commit" + <*> o .: "Golang" + <*> o .: "Repo" + <*> o .: "System" + <*> o .: "Version" + + parseJSON _ = mzero + +instance FromJSON IdObj where + parseJSON (Object o) = + IdObj <$> o .: "Addresses" + <*> o .: "AgentVersion" + <*> o .: "ID" + <*> o .: "ProtocolVersion" + <*> o .: "PublicKey" + + parseJSON _ = mzero + +instance FromJSON DnsObj where + parseJSON (Object o) = + DnsObj <$> o .: "Path" + + parseJSON _ = mzero + +instance FromJSON PubsubObj where + parseJSON (Object o) = + PubsubObj <$> o .: "Strings" + + parseJSON _ = mzero + +instance FromJSON LogLsObj where + parseJSON (Object o) = + LogLsObj <$> o .: "Strings" + + parseJSON _ = mzero + +instance FromJSON LogLevelObj where + parseJSON (Object o) = + LogLevelObj <$> o .: "Message" + + parseJSON _ = mzero + +instance FromJSON RepoVersionObj where + parseJSON (Object o) = + RepoVersionObj <$> o .: "Version" + + parseJSON _ = mzero + +instance FromJSON RepoFsckObj where + parseJSON (Object o) = + RepoFsckObj <$> o .: "Message" + + parseJSON _ = mzero + + +instance FromJSON KeyDetailsObj where + parseJSON (Object o) = + KeyDetailsObj <$> o .: "Id" + <*> o .: "Name" + + parseJSON _ = mzero + +instance FromJSON KeyObj where + parseJSON (Object o) = + KeyObj <$> o .: "Keys" + + parseJSON _ = mzero + +instance FromJSON KeyRenameObj where + parseJSON (Object o) = + KeyRenameObj <$> o .: "Id" + <*> o .: "Now" + <*> o .: "Overwrite" + <*> o .: "Was" + + parseJSON _ = mzero + +instance FromJSON FilesStatObj where + parseJSON (Object o) = + FilesStatObj <$> o .: "Hash" + <*> o .: "Size" + <*> o .: "CumulativeSize" + <*> o .: "Blocks" + <*> o .: "Type" + + parseJSON _ = mzero + +instance FromJSON FilesEntryObj where + parseJSON (Object o) = + FilesEntryObj <$> o .: "Name" + <*> o .: "Type" + <*> o .: "Size" + <*> o .: "Hash" + + parseJSON _ = mzero + +instance FromJSON FilesLsObj where + parseJSON (Object o) = + FilesLsObj <$> o .: "Entries" + + parseJSON _ = mzero + +instance FromJSON FilesFlushObj where + parseJSON (Object o) = + FilesFlushObj <$> o .: "Cid" + + parseJSON _ = mzero + +-- | Defining a content type same as PlainText without charset +data IpfsText deriving Typeable + +instance Servant.API.Accept IpfsText where + contentType _ = "text" M.// "plain" + +-- | @left show . TextS.decodeUtf8' . toStrict@ +instance MimeUnrender IpfsText Text where + mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict + + +-- | Defining a content type same as IpfsJSON +data IpfsJSON deriving Typeable + +instance Servant.API.Accept IpfsJSON where + contentType _ = "application" M.// "json" + +-- | @left show . TextS.decodeUtf8' . toStrict@ +instance MimeUnrender IpfsJSON Text where + mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict + +type IpfsApi = "cat" :> Capture "arg" Text :> Get '[IpfsText] CatReturnType + :<|> "ls" :> Capture "arg" Text :> Get '[JSON] LsObj + :<|> "get" :> Capture "arg" Text :> Get '[IpfsText] GetReturnType + :<|> "swarm" :> "peers" :> Get '[JSON] SwarmPeersObj + :<|> "swarm" :> "connect" :> QueryParam "arg" Text :> Get '[JSON] SwarmObj + :<|> "swarm" :> "disconnect" :> QueryParam "arg" Text :> Get '[JSON] SwarmObj + :<|> "swarm" :> "filters" :> Get '[JSON] SwarmObj + :<|> "swarm" :> "filters" :> "add" :> QueryParam "arg" Text :> Get '[JSON] SwarmObj + :<|> "swarm" :> "filters" :> "rm" :> QueryParam "arg" Text :> Get '[JSON] SwarmObj + :<|> "bitswap" :> "stat" :> Get '[JSON] BitswapStatObj + :<|> "bitswap" :> "wantlist" :> Get '[JSON] BitswapWLObj + :<|> "bitswap" :> "ledger" :> Capture "peerId" Text :> Get '[JSON] BitswapLedgerObj + :<|> "bitswap" :> "reprovide" :> Get '[IpfsText] ReprovideReturnType + :<|> "cid" :> "bases" :> Get '[JSON] [CidBasesObj] + :<|> "cid" :> "codecs" :> Get '[JSON] [CidCodecsObj] + :<|> "cid" :> "hashes" :> Get '[JSON] [CidHashesObj] + :<|> "cid" :> "base32" :> Capture "cid" Text :> Get '[JSON] CidObj + :<|> "cid" :> "format" :> Capture "cid" Text :> Get '[JSON] CidObj + :<|> "block" :> "get" :> Capture "key" Text :> Get '[IpfsText] BlockReturnType + :<|> "block" :> "stat" :> Capture "key" Text :> Get '[JSON] BlockObj + :<|> "dag" :> "get" :> Capture "ref" Text :> Get '[IpfsJSON] DagReturnType + :<|> "dag" :> "resolve" :> Capture "ref" Text :> Get '[JSON] DagResolveObj + :<|> "config" :> Capture "ref" Text :> Get '[JSON] ConfigObj + :<|> "config" :> Capture "arg" Text :> QueryParam "arg" Text :> Get '[JSON] ConfigObj + :<|> "object" :> "data" :> Capture "ref" Text :> Get '[IpfsText] ObjectReturnType + :<|> "object" :> "new" :> Get '[JSON] ObjectObj + :<|> "object" :> "links" :> Capture "ref" Text :> Get '[JSON] ObjectLinksObj + :<|> "object" :> "patch" :> "add-link" :> Capture "arg" Text + :> QueryParam "arg" Text :> QueryParam "arg" Text :> Get '[JSON] ObjectLinksObj + :<|> "object" :> "patch" :> "rm-link" :> Capture "arg" Text + :> QueryParam "arg" Text :> Get '[JSON] ObjectLinksObj + :<|> "object" :> "get" :> Capture "arg" Text :> Get '[JSON] ObjectGetObj + :<|> "object" :> "diff" :> Capture "arg" Text :> QueryParam "arg" Text :> Get '[JSON] ObjectDiffObj + :<|> "object" :> "stat" :> Capture "arg" Text :> Get '[JSON] ObjectStatObj + :<|> "pin" :> "add" :> Capture "arg" Text :> Get '[JSON] PinObj + :<|> "pin" :> "rm" :> Capture "arg" Text :> Get '[JSON] PinObj + :<|> "bootstrap" :> "add" :> QueryParam "arg" Text :> Get '[JSON] BootstrapObj + :<|> "bootstrap" :> "list" :> Get '[JSON] BootstrapObj + :<|> "bootstrap" :> "rm" :> QueryParam "arg" Text :> Get '[JSON] BootstrapObj + :<|> "stats" :> "bw" :> Get '[JSON] StatsBwObj + :<|> "stats" :> "repo" :> Get '[JSON] StatsRepoObj + :<|> "version" :> Get '[JSON] VersionObj + :<|> "id" :> Get '[JSON] IdObj + :<|> "id" :> Capture "arg" Text :> Get '[JSON] IdObj + :<|> "dns" :> Capture "arg" Text :> Get '[JSON] DnsObj + :<|> "pubsub" :> "ls" :> Get '[JSON] PubsubObj + :<|> "pubsub" :> "peers" :> Get '[JSON] PubsubObj + :<|> "pubsub" :> "pub" :> Capture "arg" Text :> QueryParam "arg" Text :> Get '[JSON] NoContent + :<|> "log" :> "ls" :> Get '[JSON] LogLsObj + :<|> "log" :> "level" :> Capture "arg" Text :> QueryParam "arg" Text :> Get '[JSON] LogLevelObj + :<|> "repo" :> "version" :> Get '[JSON] RepoVersionObj + :<|> "repo" :> "fsck" :> Get '[JSON] RepoFsckObj + :<|> "key" :> "gen" :> Capture "arg" Text :> QueryParam "type" Text :> Get '[JSON] KeyDetailsObj + :<|> "key" :> "list" :> Get '[JSON] KeyObj + :<|> "key" :> "rename" :> Capture "arg" Text :> QueryParam "arg" Text :> Get '[JSON] KeyRenameObj + :<|> "key" :> "rm" :> Capture "arg" Text :> Get '[JSON] KeyObj + :<|> "files" :> "chcid" :> QueryParam "arg" Text :> QueryParam "cid-version" Int :> Get '[JSON] NoContent + :<|> "files" :> "cp" :> QueryParam "arg" Text :> QueryParam "arg" Text :> Get '[JSON] NoContent + :<|> "files" :> "flush" :> QueryParam "arg" Text :> Get '[JSON] FilesFlushObj + :<|> "files" :> "ls" :> QueryParam "arg" Text :> Get '[JSON] FilesLsObj + :<|> "files" :> "mkdir" :> QueryParam "arg" Text :> Get '[JSON] NoContent + :<|> "files" :> "mv" :> QueryParam "arg" Text :> QueryParam "arg" Text :> Get '[JSON] NoContent + :<|> "files" :> "read" :> QueryParam "arg" Text :> Get '[IpfsText] FilesReadType + :<|> "files" :> "rm" :> QueryParam "arg" Text :> QueryParam "recursive" Bool :> Get '[JSON] NoContent + :<|> "files" :> "stat" :> QueryParam "arg" Text :> Get '[JSON] FilesStatObj + :<|> "shutdown" :> Get '[JSON] NoContent diff --git a/src/Network/Ipfs/Api/Types/Stream.hs b/src/Network/Ipfs/Api/Types/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Api/Types/Stream.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Network.Ipfs.Api.Types.Stream +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Ipfs Stream API types. +-- + +module Network.Ipfs.Api.Types.Stream where + +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 () +import Data.Int +import Data.Text +import Network.HTTP.Client () +import Servant.API + +import Network.Ipfs.Api.Types (IpfsText) + +type LogReturnType = Text + +data PingObj = PingObj + { success :: Bool + , text :: Text + , time :: Int64 + } + deriving (Show, Eq) + +data ResponseObj = ResponseObj + { addrs :: Maybe [Text] + , id :: Text + } + deriving (Show, Eq) + +data DhtObj = DhtObj + { extra :: Text + , addrid :: Text + , responses :: Maybe [ResponseObj] + , addrType :: Int + } + deriving (Show, Eq) + +data RepoKeyObj = RepoKeyObj + { repoSlash :: Text + } + deriving (Show, Eq) + +data RepoGcObj = RepoGcObj + { repoKey :: RepoKeyObj + } + deriving (Show, Eq) + +data RepoVerifyObj = RepoVerifyObj + { msg :: Text + , progress :: Int + } + deriving (Show, Eq) + +data RefsObj = RefsObj + { error :: Text + , ref :: Text + } + deriving (Show, Eq) + +data PubsubSubObj = PubsubSubObj + { mssgdata :: Text + , from :: Text + , seqno :: Text + , topicIDs :: [Text] + } + deriving (Show, Eq) + +instance FromJSON PingObj where + parseJSON (Object o) = + PingObj <$> o .: "Success" + <*> o .: "Text" + <*> o .: "Time" + + parseJSON _ = mzero + +instance FromJSON DhtObj where + parseJSON (Object o) = + DhtObj <$> o .: "Extra" + <*> o .: "ID" + <*> o .: "Responses" + <*> o .: "Type" + + parseJSON _ = mzero + +instance FromJSON ResponseObj where + parseJSON (Object o) = + ResponseObj <$> o .: "Addrs" + <*> o .: "ID" + + parseJSON _ = mzero + +instance FromJSON RepoKeyObj where + parseJSON (Object o) = + RepoKeyObj <$> o .: "/" + + parseJSON _ = mzero + +instance FromJSON RepoGcObj where + parseJSON (Object o) = + RepoGcObj <$> o .: "Key" + + parseJSON _ = mzero + +instance FromJSON RepoVerifyObj where + parseJSON (Object o) = + RepoVerifyObj <$> o .: "Msg" + <*> o .: "Progress" + + parseJSON _ = mzero + +instance FromJSON RefsObj where + parseJSON (Object o) = + RefsObj <$> o .: "Err" + <*> o .: "Ref" + + parseJSON _ = mzero + +instance FromJSON PubsubSubObj where + parseJSON (Object o) = + PubsubSubObj <$> o .: "data" + <*> o .: "from" + <*> o .: "seqno" + <*> o .: "topicIDs" + + parseJSON _ = mzero + +type IpfsStreamApi = "ping" :> Capture "arg" Text :> StreamGet NewlineFraming JSON ( SourceIO PingObj ) + :<|> "dht" :> "findpeer" :> Capture "arg" Text :> StreamGet NewlineFraming JSON ( SourceIO DhtObj ) + :<|> "dht" :> "findprovs" :> Capture "arg" Text :> StreamGet NewlineFraming JSON ( SourceIO DhtObj ) + :<|> "dht" :> "get" :> Capture "arg" Text :> StreamGet NewlineFraming JSON ( SourceIO DhtObj ) + :<|> "dht" :> "provide" :> Capture "arg" Text :> StreamGet NewlineFraming JSON ( SourceIO DhtObj ) + :<|> "dht" :> "query" :> Capture "arg" Text :> StreamGet NewlineFraming JSON ( SourceIO DhtObj ) + :<|> "log" :> "tail" :> StreamGet NewlineFraming IpfsText ( SourceIO LogReturnType) + :<|> "repo" :> "gc" :> StreamGet NewlineFraming JSON ( SourceIO RepoGcObj) + :<|> "repo" :> "verify" :> StreamGet NewlineFraming JSON ( SourceIO RepoVerifyObj) + :<|> "refs" :> Capture "arg" Text :> StreamGet NewlineFraming JSON (SourceIO RefsObj) + :<|> "refs" :> "local" :> StreamGet NewlineFraming JSON (SourceIO RefsObj) + :<|> "pubsub" :> "sub" :> Capture "arg" Text :> StreamGet NewlineFraming JSON ( SourceIO PubsubSubObj ) diff --git a/src/Network/Ipfs/Client.hs b/src/Network/Ipfs/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/Ipfs/Client.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Network.Ipfs.Client +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- IPFS daemon HTTP client. +-- + +module Network.Ipfs.Client where + +import Control.Monad.Except +import Control.Monad.Reader +import Network.HTTP.Client as Net hiding (Proxy) +import Servant.Client + +newtype IpfsT m a = IpfsT { unIpfs :: ReaderT (Manager, BaseUrl, String) (ExceptT ClientError m) a } + deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader (Manager, BaseUrl, String) + , MonadError ClientError + ) + +instance MonadTrans IpfsT where + lift = IpfsT . lift . lift + +type Ipfs a = IpfsT IO a + +-- | 'IpfsT' monad runner. +runIpfs' :: BaseUrl -> Ipfs a -> IO () +runIpfs' url ipfs = do + manager' <- liftIO $ newManager defaultManagerSettings + ret <- runExceptT (runReaderT (unIpfs ipfs) (manager', url, showBaseUrl url)) + case ret of + Left err -> putStrLn $ "Error: " ++ show err + Right _ -> putStr "" + +-- | 'IpfsT' monad runner with default arguments. +runIpfs :: Ipfs a -> IO () +runIpfs = runIpfs' (BaseUrl Http "localhost" 5001 "/api/v0") diff --git a/src/Network/JsonRpc/TinyClient.hs b/src/Network/JsonRpc/TinyClient.hs --- a/src/Network/JsonRpc/TinyClient.hs +++ b/src/Network/JsonRpc/TinyClient.hs @@ -53,10 +53,8 @@ , MethodName -- * JSON-RPC client settings - , JsonRpcClient + , JsonRpcClient(..) , defaultSettings - , jsonRpcServer - , jsonRpcManager -- * Error handling , JsonRpcException(..) @@ -68,49 +66,55 @@ import Control.Monad ((<=<)) import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.State (MonadState) +import Control.Monad.State (MonadState, get) import Crypto.Number.Generate (generateMax) import Data.Aeson (FromJSON (..), ToJSON (..), Value (String), eitherDecode, encode, object, withObject, (.:), (.:?), (.=)) import Data.ByteString.Lazy (ByteString) import Data.Text (Text, unpack) -import Lens.Micro.Mtl (use) -import Lens.Micro.TH (makeLenses) import Network.HTTP.Client (Manager, RequestBody (RequestBodyLBS), httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseBody) import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Network.WebSockets as WS (Connection, receiveData, + sendTextData) -- | JSON-RPC monad constrait. type JsonRpcM m = (MonadIO m, MonadThrow m, MonadState JsonRpcClient m) -- | JSON-RPC client state vars. -data JsonRpcClient = JsonRpcClient - { _jsonRpcManager :: !Manager -- ^ HTTP connection manager. - , _jsonRpcServer :: !String -- ^ Remote server URI. +data JsonRpcClient = JsonRpcHttpClient + { jsonRpcManager :: Manager + -- ^ HTTP connection manager. + , jsonRpcServer :: String + -- ^ Remote server URI. } - -$(makeLenses ''JsonRpcClient) + | JsonRpcWsClient + { jsonRpcWsConnection :: WS.Connection + -- ^ WebSocket connection. + } -- | Create default 'JsonRpcClient' settings. defaultSettings :: MonadIO m => String -- ^ JSON-RPC server URI -> m JsonRpcClient -defaultSettings srv = liftIO $ JsonRpcClient +defaultSettings srv = liftIO $ JsonRpcHttpClient <$> newManager tlsManagerSettings <*> pure srv instance Show JsonRpcClient where - show JsonRpcClient{..} = "JsonRpcClient<" ++ _jsonRpcServer ++ ">" + show JsonRpcHttpClient{..} = "" + show JsonRpcWsClient{..} = "" -- | JSON-RPC request. data Request = Request { rqMethod :: !Text , rqId :: !Int , rqParams :: !Value - } deriving (Eq, Show) + } + deriving (Eq, Show) instance ToJSON Request where toJSON rq = object [ "jsonrpc" .= String "2.0" @@ -122,7 +126,8 @@ -- | JSON-RPC response. data Response = Response { rsResult :: !(Either RpcError Value) - } deriving (Eq, Show) + } + deriving (Eq, Show) instance FromJSON Response where parseJSON = @@ -135,7 +140,8 @@ { errCode :: !Int , errMessage :: !Text , errData :: !(Maybe Value) - } deriving Eq + } + deriving Eq instance Show RpcError where show (RpcError code msg dat) = @@ -148,8 +154,7 @@ <*> v .: "message" <*> v .:? "data" -data JsonRpcException - = ParsingException String +data JsonRpcException = ParsingException String | CallException RpcError deriving (Show, Eq) @@ -184,15 +189,22 @@ where maxInt = toInteger (maxBound :: Int) connection body = do - serverUri <- use jsonRpcServer - request <- parseRequest serverUri - let request' = request - { requestBody = RequestBodyLBS body - , requestHeaders = [("Content-Type", "application/json")] - , method = "POST" - } - manager <- use jsonRpcManager - responseBody <$> liftIO (httpLbs request' manager) + jsonRpcInstance <- get + case jsonRpcInstance of + JsonRpcHttpClient{..} -> do + request <- parseRequest jsonRpcServer + let request' = request { + requestBody = RequestBodyLBS body + , requestHeaders = [("Content-Type", "application/json")] + , method = "POST" + } + responseBody <$> liftIO (httpLbs request' jsonRpcManager) + + JsonRpcWsClient{..} -> liftIO $ do + WS.sendTextData jsonRpcWsConnection body + WS.receiveData jsonRpcWsConnection + + decodeResponse :: (MonadThrow m, FromJSON a) => ByteString diff --git a/src/Network/Polkadot/Api/Account.hs b/src/Network/Polkadot/Api/Account.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Account.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Account +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `account` prefix. +-- + +module Network.Polkadot.Api.Account where + +import Data.Text (Text) + +import Network.JsonRpc.TinyClient (JsonRpc (..)) + +-- | Retrieves the next accountIndex as available on the node. +nextIndex :: JsonRpc m + => Text + -- ^ AccountId + -> m Int +{-# INLINE nextIndex #-} +nextIndex = remote "account_nextIndex" diff --git a/src/Network/Polkadot/Api/Author.hs b/src/Network/Polkadot/Api/Author.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Author.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Author +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `author` prefix. +-- + +module Network.Polkadot.Api.Author where + +import Data.Text (Text) + +import Data.ByteArray.HexString (HexString) +import Network.JsonRpc.TinyClient (JsonRpc (..)) + +-- | Returns true if the keystore has private keys for the given public key and key type. +hasKey :: JsonRpc m + => HexString + -- ^ Public key + -> Text + -- ^ Key type + -> m Bool +{-# INLINE hasKey #-} +hasKey = remote "author_hasKey" + +-- | Returns true if the keystore has private keys for the given session public keys. +hasSessionKeys :: JsonRpc m + => HexString + -- ^ Session keys + -> m Bool +{-# INLINE hasSessionKeys #-} +hasSessionKeys = remote "author_hasSessionKeys" + +-- | Insert a key into the keystore. +insertKey :: JsonRpc m + => Text + -- ^ Key type + -> Text + -- ^ Key secret URI + -> HexString + -- ^ Public key + -> m HexString +{-# INLINE insertKey #-} +insertKey = remote "author_insertKey" + +-- | Returns all pending extrinsics, potentially grouped by sender. +pendingExtrinsics :: JsonRpc m => m [HexString] +{-# INLINE pendingExtrinsics #-} +pendingExtrinsics = remote "author_pendingExtrinsics" + +-- | Remove given extrinsic from the pool and temporarily ban it to prevent reimporting. +removeExtrinsic :: JsonRpc m + => [HexString] + -- ^ Extrinsic or hash + -> m HexString +{-# INLINE removeExtrinsic #-} +removeExtrinsic = remote "author_removeExtrinsic" + +-- | Generate new session keys and returns the corresponding public keys. +rotateKeys :: JsonRpc m => m HexString +{-# INLINE rotateKeys #-} +rotateKeys = remote "author_rotateKeys" + +-- | Submit a fully formatted extrinsic for block inclusion. +submitExtrinsic :: JsonRpc m + => HexString + -- ^ Extrinsic + -> m HexString + -- ^ Hash +{-# INLINE submitExtrinsic #-} +submitExtrinsic = remote "author_submitExtrinsic" diff --git a/src/Network/Polkadot/Api/Babe.hs b/src/Network/Polkadot/Api/Babe.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Babe.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Babe +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `babe` prefix. +-- + +module Network.Polkadot.Api.Babe where + +import Data.Aeson (Object) + +import Network.JsonRpc.TinyClient (JsonRpc (..)) + +-- | Returns data about which slots (primary or secondary) can be claimed +-- in the current epoch with the keys in the keystore. +epochAuthorship :: JsonRpc m => m Object +{-# INLINE epochAuthorship #-} +epochAuthorship = remote "babe_epochAuthorship" diff --git a/src/Network/Polkadot/Api/Chain.hs b/src/Network/Polkadot/Api/Chain.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Chain.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Chain +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `chain` prefix. +-- + +module Network.Polkadot.Api.Chain where + +import Data.ByteArray.HexString (HexString) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Polkadot.Api.Types (Header, SignedBlock) + +-- | Get header and body of a relay chain block. +getBlock :: JsonRpc m + => Maybe HexString + -- ^ Block hash + -> m (Maybe SignedBlock) +{-# INLINE getBlock #-} +getBlock = remote "chain_getBlock" + +-- | Get the block hash for a specific block. +getBlockHash :: JsonRpc m + => Maybe Int + -- ^ Block number + -> m (Maybe HexString) +{-# INLINE getBlockHash #-} +getBlockHash = remote "chain_getBlockHash" + +-- | Get hash of the last finalized block in the canon chain. +getFinalizedHead :: JsonRpc m => m HexString +{-# INLINE getFinalizedHead #-} +getFinalizedHead = remote "chain_getFinalizedHead" + +-- | Retrieves the header for a specific block. +getHeader :: JsonRpc m + => Maybe HexString + -- ^ Block hash + -> m (Maybe Header) +{-# INLINE getHeader #-} +getHeader = remote "chain_getHeader" diff --git a/src/Network/Polkadot/Api/Childstate.hs b/src/Network/Polkadot/Api/Childstate.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Childstate.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Childstate +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `childstate` prefix. +-- + +module Network.Polkadot.Api.Childstate where + +import Data.Text (Text) + +import Data.ByteArray.HexString (HexString) +import Network.JsonRpc.TinyClient (JsonRpc (..)) + +-- | Returns the keys with prefix from a child storage, leave empty to get all the keys. +getKeys :: JsonRpc m + => HexString + -- ^ Prefixed storage key + -> HexString + -- ^ Storage key + -> Maybe HexString + -- ^ Block hash + -> m [HexString] +{-# INLINE getKeys #-} +getKeys = remote "childstate_getKeys" + +-- | Returns a child storage entry at a specific block state. +getStorage :: JsonRpc m + => HexString + -- ^ Prefixed storage key + -> HexString + -- ^ Storage key + -> Maybe HexString + -- ^ Block hash + -> m (Maybe HexString) +{-# INLINE getStorage #-} +getStorage = remote "childstate_getStorage" + +-- | Returns the hash of a child storage entry at a block state +getStorageHash :: JsonRpc m + => HexString + -- ^ Prefixed storage key + -> HexString + -- ^ Storage key + -> Maybe HexString + -- ^ Block hash + -> m (Maybe HexString) +{-# INLINE getStorageHash #-} +getStorageHash = remote "childstate_getStorageHash" + +-- | Returns the size of a child storage entry at a block state. +getStorageSize :: JsonRpc m + => HexString + -- ^ Prefixed storage key + -> HexString + -- ^ Storage key + -> Maybe HexString + -- ^ Block hash + -> m (Maybe Int) +{-# INLINE getStorageSize #-} +getStorageSize = remote "childstate_getStorageSize" diff --git a/src/Network/Polkadot/Api/Contracts.hs b/src/Network/Polkadot/Api/Contracts.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Contracts.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Contracts +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `contracts` prefix. +-- + +module Network.Polkadot.Api.Contracts where + +import Data.Text (Text) + +import Data.ByteArray.HexString (HexString) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Polkadot.Api.Types (ContractCall, ContractExecResult) + +-- | Executes a call to a contract. +call :: JsonRpc m + => ContractCall + -- ^ Contract call + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m ContractExecResult +{-# INLINE call #-} +call = remote "contracts_call" + +-- | Returns the value under a specified storage key in a contract +getStorage :: JsonRpc m + => Text + -- ^ AccountId + -> HexString + -- ^ Storage key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m (Maybe HexString) +{-# INLINE getStorage #-} +getStorage = remote "contracts_getStorage" + +-- | Returns the projected time a given contract will be able to sustain paying its rent. +rentProjection :: JsonRpc m + => Text + -- ^ AccountId + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m (Maybe Int) +{-# INLINE rentProjection #-} +rentProjection = remote "contracts_rentProjection" diff --git a/src/Network/Polkadot/Api/Engine.hs b/src/Network/Polkadot/Api/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Engine.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Engine +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `engine` prefix. +-- + +module Network.Polkadot.Api.Engine where + +import Data.ByteArray.HexString (HexString) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Polkadot.Api.Types (CreatedBlock) + +-- | Instructs the manual-seal authorship task to create a new block. +createBlock :: JsonRpc m + => Bool + -- ^ Create empty + -> Bool + -- ^ Finalize + -> Maybe HexString + -- ^ Parent hash + -> m CreatedBlock +{-# INLINE createBlock #-} +createBlock = remote "engine_createBlock" + +-- | Instructs the manual-seal authorship task to finalize a block. +finalizeBlock :: JsonRpc m + => HexString + -- ^ Block hash + -> Maybe HexString + -- ^ Justification + -> m Bool +{-# INLINE finalizeBlock #-} +finalizeBlock = remote "engine_finalizeBlock" diff --git a/src/Network/Polkadot/Api/Grandpa.hs b/src/Network/Polkadot/Api/Grandpa.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Grandpa.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Grandpa +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `grandpa` prefix. +-- + +module Network.Polkadot.Api.Grandpa where + +import Data.Aeson (Object) +import Data.Text (Text) + +import Network.JsonRpc.TinyClient (JsonRpc (..)) + +-- | Returns the state of the current best round state as well as the ongoing background rounds. +roundState :: JsonRpc m => m Object +{-# INLINE roundState #-} +roundState = remote "grandpa_roundState" diff --git a/src/Network/Polkadot/Api/Offchain.hs b/src/Network/Polkadot/Api/Offchain.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Offchain.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Offchain +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `offchain` prefix. +-- + +module Network.Polkadot.Api.Offchain where + +import Data.ByteArray.HexString (HexString) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Polkadot.Api.Types (StorageKind) + +-- | Get offchain local storage under given key and prefix. +localStorageGet :: JsonRpc m + => StorageKind + -- ^ Offchain storage kind + -> HexString + -- ^ Key + -> m (Maybe HexString) +{-# INLINE localStorageGet #-} +localStorageGet = remote "offchain_localStorageGet" + +-- | Set offchain local storage under given key and prefix +localStorageSet :: JsonRpc m + => StorageKind + -- ^ Offchain storage kind + -> HexString + -- ^ Key + -> HexString + -- ^ Value + -> m () +{-# INLINE localStorageSet #-} +localStorageSet = remote "offchain_localStorageSet" diff --git a/src/Network/Polkadot/Api/Payment.hs b/src/Network/Polkadot/Api/Payment.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Payment.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Payment +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `payment` prefix. +-- + +module Network.Polkadot.Api.Payment where + +import Data.ByteArray.HexString (HexString) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Polkadot.Api.Types (RuntimeDispatchInfo) + +-- | Retrieves the fee information for an encoded extrinsic. +queryInfo :: JsonRpc m + => HexString + -- ^ Extrinsic + -> Maybe HexString + -- ^ Block hash or nothing for head block + -> m RuntimeDispatchInfo +{-# INLINE queryInfo #-} +queryInfo = remote "payment_queryInfo" diff --git a/src/Network/Polkadot/Api/Rpc.hs b/src/Network/Polkadot/Api/Rpc.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Rpc.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.Rpc +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `rpc` prefix. +-- + +module Network.Polkadot.Api.Rpc where + +import Data.Aeson (Value) + +import Network.JsonRpc.TinyClient (JsonRpc (..)) + +-- | Retrieves the list of RPC methods that are exposed by the node. +methods :: JsonRpc m => m Value +{-# INLINE methods #-} +methods = remote "rpc_methods" diff --git a/src/Network/Polkadot/Api/State.hs b/src/Network/Polkadot/Api/State.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/State.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.State +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `state` prefix. +-- + +module Network.Polkadot.Api.State where + +import Data.Text (Text) + +import Data.ByteArray.HexString (HexString) +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Polkadot.Api.Types (Metadata, ReadProof, + RuntimeVersion, StorageChangeSet) + +-- | Perform a call to a builtin on the chain. +call :: JsonRpc m + => Text + -- ^ Call method + -> HexString + -- ^ Call data + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m HexString +{-# INLINE call #-} +call = remote "state_call" + +-- | Retrieves the keys with prefix of a specific child storage. +getChildKeys :: JsonRpc m + => HexString + -- ^ Child storage key + -> HexString + -- ^ Child definition + -> Int + -- ^ Child type + -> HexString + -- ^ Key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m [HexString] +{-# INLINE getChildKeys #-} +getChildKeys = remote "state_getChildKeys" + +-- | Retrieves the child storage for a key. +getChildStorage :: JsonRpc m + => HexString + -- ^ Child storage key + -> HexString + -- ^ Child definition + -> Int + -- ^ Child type + -> HexString + -- ^ Key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m HexString +{-# INLINE getChildStorage #-} +getChildStorage = remote "state_getChildStorage" + +-- | Retrieves the child storage hash. +getChildStorageHash :: JsonRpc m + => HexString + -- ^ Child storage key + -> HexString + -- ^ Child definition + -> Int + -- ^ Child type + -> HexString + -- ^ Key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m HexString +{-# INLINE getChildStorageHash #-} +getChildStorageHash = remote "state_getChildStorageHash" + +-- | Retrieves the child storage size. +getChildStorageSize :: JsonRpc m + => HexString + -- ^ Child storage key + -> HexString + -- ^ Child definition + -> Int + -- ^ Child type + -> HexString + -- ^ Key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m Int +{-# INLINE getChildStorageSize #-} +getChildStorageSize = remote "state_getChildStorageSize" + +-- | Retrieves the keys with a certain prefix. +getKeys :: JsonRpc m + => HexString + -- ^ Key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m [HexString] +{-# INLINE getKeys #-} +getKeys = remote "state_getKeys" + +-- | Returns the runtime metadata. +getMetadata :: JsonRpc m => m Metadata +{-# INLINE getMetadata #-} +getMetadata = remote "state_getMetadata" + +-- | Returns proof of storage entries at a specific block state. +getReadProof :: JsonRpc m + => [HexString] + -- ^ Keys + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m ReadProof +{-# INLINE getReadProof #-} +getReadProof = remote "state_getReadProof" + +-- | Get runtime version. +getRuntimeVersion :: JsonRpc m + => Maybe HexString + -- ^ Block hash or nothing for head + -> m RuntimeVersion +{-# INLINE getRuntimeVersion #-} +getRuntimeVersion = remote "state_getRuntimeVersion" + +-- | Retrieves the storage for a key. +getStorage :: JsonRpc m + => HexString + -- ^ Key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m HexString +{-# INLINE getStorage #-} +getStorage = remote "state_getStorage" + +-- | Retrieves the storage hash. +getStorageHash :: JsonRpc m + => HexString + -- ^ Key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m HexString +{-# INLINE getStorageHash #-} +getStorageHash = remote "state_getStorageHash" + +-- | Retrieves the storage size. +getStorageSize :: JsonRpc m + => HexString + -- ^ Key + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m Int +{-# INLINE getStorageSize #-} +getStorageSize = remote "state_getStorageSize" + +-- | Query historical storage entries (by key) starting from a start block. +queryStorage :: JsonRpc m + => [HexString] + -- ^ Storage keys + -> HexString + -- ^ From block hash + -> Maybe HexString + -- ^ To block hash + -> m [StorageChangeSet] +{-# INLINE queryStorage #-} +queryStorage = remote "state_queryStorage" + +-- | Query storage entries (by key) starting at block hash given as the second parameter. +queryStorageAt :: JsonRpc m + => [HexString] + -- ^ Storage keys + -> Maybe HexString + -- ^ Block hash or nothing for head + -> m [StorageChangeSet] +{-# INLINE queryStorageAt #-} +queryStorageAt = remote "state_queryStorageAt" diff --git a/src/Network/Polkadot/Api/System.hs b/src/Network/Polkadot/Api/System.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/System.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Polkadot.Api.System +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot RPC methods with `system` prefix. +-- + +module Network.Polkadot.Api.System where + +import Data.Aeson (Object) +import Data.Text (Text) + +import Network.JsonRpc.TinyClient (JsonRpc (..)) +import Network.Polkadot.Api.Types (ChainType, Health, NodeRole, + PeerInfo) + +-- | Adds a reserved peer. +addReservedPeer :: JsonRpc m + => Text + -- ^ Peer URI + -> m Text +{-# INLINE addReservedPeer #-} +addReservedPeer = remote "system_addReservedPeer" + +-- | Retrieves the chain. +chain :: JsonRpc m => m Text +{-# INLINE chain #-} +chain = remote "system_chain" + +-- | Retrieves the chain type. +chainType :: JsonRpc m => m ChainType +{-# INLINE chainType #-} +chainType = remote "system_chainType" + +-- | Return health status of the node. +health :: JsonRpc m => m Health +{-# INLINE health #-} +health = remote "system_health" + +-- | The addresses include a trailing /p2p/ with the local PeerId, +-- and are thus suitable to be passed to addReservedPeer or as a bootnode address. +localListenAddresses :: JsonRpc m => m [Text] +{-# INLINE localListenAddresses #-} +localListenAddresses = remote "system_localListenAddresses" + +-- | Returns the base58-encoded PeerId of the node. +localPeerId :: JsonRpc m => m Text +{-# INLINE localPeerId #-} +localPeerId = remote "system_localPeerId" + +-- | Retrieves the node name. +name :: JsonRpc m => m Text +{-# INLINE name #-} +name = remote "system_name" + +-- | Returns current state of the network. +-- +-- Warning: This API isn't stable. +networkState :: JsonRpc m => m Object +{-# INLINE networkState #-} +networkState = remote "system_networkState" + +-- | Returns the roles the node is running as. +nodeRoles :: JsonRpc m => m [NodeRole] +{-# INLINE nodeRoles #-} +nodeRoles = remote "system_nodeRoles" + +-- | Returns the currently connected peers. +peers :: JsonRpc m => m [PeerInfo] +{-# INLINE peers #-} +peers = remote "system_peers" + +-- | Get a custom set of properties as a JSON object, defined in the chain spec. +properties :: JsonRpc m => m Object +{-# INLINE properties #-} +properties = remote "system_properties" + +-- | Remove a reserved peer. +removeReservedPeer :: JsonRpc m + => Text + -- ^ Peer URI + -> m Text +{-# INLINE removeReservedPeer #-} +removeReservedPeer = remote "system_removeReservedPeer" + +-- | Retrieves the version of the node. +version :: JsonRpc m => m Text +{-# INLINE version #-} +version = remote "system_version" diff --git a/src/Network/Polkadot/Api/Types.hs b/src/Network/Polkadot/Api/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Polkadot/Api/Types.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Network.Polkadot.Api.Types +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Polkadot JSON-RPC types. +-- + +module Network.Polkadot.Api.Types where + +import Data.Aeson (FromJSON (..), + Options (fieldLabelModifier), + ToJSON (..), Value (String), + defaultOptions) +import Data.Aeson.TH (deriveJSON) +import Data.Text (Text) +import Data.Word (Word32, Word64, Word8) +import GHC.Generics (Generic) + +import Data.ByteArray.HexString (HexString) +import Data.String.Extra (toLowerFirst) + +-- | The role the node is running as. +data NodeRole = Full + | LightClient + | Authority + | Sentry + deriving (Eq, Generic, Show) + +$(deriveJSON defaultOptions ''NodeRole) + +-- | Type op a chain. +data ChainType = Development + | Local + | Live + | Custom Text + deriving (Eq, Generic, Show) + +instance FromJSON ChainType where + parseJSON (String v) = return $ case v of + "Development" -> Development + "Local" -> Local + "Live" -> Live + custom_name -> Custom custom_name + parseJSON _ = fail "ChainType should be a JSON String" + +instance ToJSON ChainType where + toJSON (Custom v) = toJSON v + toJSON v = toJSON (show v) + +-- | System health struct returned by the RPC +data Health = Health + { healthPeers :: Int + -- ^ Number of connected peers. + , healthIsSyncing :: Bool + -- ^ Is the node syncing. + , healthShouldHavePeers :: Bool + -- ^ Should this node have any peers. + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 6 }) ''Health) + +-- | Network Peer information. +data PeerInfo = PeerInfo + { peerInfoPeerId :: Text + -- ^ Peer ID + , peerInfoRoles :: [NodeRole] + -- ^ Roles + , peerInfoProtocolVersion :: Int + -- ^ Protocol version. + , peerInfoBestHash :: Text + -- ^ Peer best block hash + , peerInfoBestNumber :: Int + -- ^ Peer best block number + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 8 }) ''PeerInfo) + +-- | Executes a call to a contract. +data ContractCall = ContractCall + { callOrigin :: HexString + , callDest :: HexString + , callValue :: Integer + , callGasLimit :: Integer + , callInputData :: HexString + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 4 }) ''ContractCall) + +-- | A result of execution of a contract. +data ContractExecResult = SuccessExec + { execStatus :: Word8 + -- ^ Status code returned by contract. + , execData :: Maybe HexString + -- ^ Output data returned by contract. Can be empty. + } + | ExecResultError + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 4 }) ''ContractExecResult) + +type Metadata = Value + +-- | ReadProof struct returned by RPC. +data ReadProof = ReadProof + { readProofAt :: HexString + -- ^ Block hash used to generate the proof. + , readProofProof :: [HexString] + -- ^ A proof used to prove that storage entries are included in the storage trie. + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 9 }) ''ReadProof) + +-- | Runtime version. +-- This should not be thought of as classic Semver (major/minor/tiny). +-- This triplet have different semantics and mis-interpretation could cause problems. +-- In particular: bug fixes should result in an increment of `spec_version` and possibly `authoring_version`, +-- absolutely not `impl_version` since they change the semantics of the runtime. +data RuntimeVersion = RuntimeVersion + { runtimeSpecName :: Text + -- ^ Identifies the different Substrate runtimes. + , runtimeImplName :: Text + -- ^ Name of the implementation of the spec. + , runtimeAuthoringVersion :: Word32 + -- ^ `authoring_version` is the version of the authorship interface. + , runtimeSpecVersion :: Word32 + -- ^ Version of the runtime specification. + , runtimeImplVersion :: Word32 + -- ^ Version of the implementation of the specification. + , runtimeApis :: [(HexString, Word32)] + -- ^ List of supported API "features" along with their versions. + , runtimeTransactionVersion :: Word32 + -- ^ All existing dispatches are fully compatible when this number doesn't change. + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 7 }) ''RuntimeVersion) + +-- | Type of supported offchain storages. +-- +-- 1: persistent storage is non-revertible and not fork-aware; +-- 2: local storage is revertible and fork-aware. +type StorageKind = Word8 + +-- | Storage changes. +data StorageChangeSet = StorageChangeSet + { storageBlock :: HexString + -- ^ Block hash. + , storageChanges :: [(HexString, Maybe HexString)] + -- ^ A list of changes. + } + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 7 }) ''StorageChangeSet) + +-- | Numeric range of transaction weight. +type Weight = Word64 + +-- | Generalized group of dispatch types. +data DispatchClass = Normal + | Operational + | Mandatory + deriving (Eq, Generic, Show) + +$(deriveJSON defaultOptions ''DispatchClass) + +-- | Some information related to a dispatchable that can be queried from the runtime. +data RuntimeDispatchInfo = RuntimeDispatchInfo + { dispatchWeight :: Weight + -- ^ Weight of this dispatch. + , dispatchClass :: DispatchClass + -- ^ Class of this dispatch. + , dispatchPartialFee :: Integer + -- ^ The partial inclusion fee of this dispatch. + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 8 }) ''RuntimeDispatchInfo) + +-- | Auxiliary data associated with an imported block result. +data ImportedAux = ImportedAux + { auxHeaderOnly :: Bool + -- ^ Only the header has been imported. Block body verification was skipped. + , auxClearJustificationRequests :: Bool + -- ^ Clear all pending justification requests. + , auxNeedsJustification :: Bool + -- ^ Request a justification for the given block. + , auxBadJustification :: Bool + -- ^ Received a bad justification. + , auxNeedsFinalityProof :: Bool + -- ^ Request a finality proof for the given block. + , auxIsNewBest :: Bool + -- ^ Whether the block that was imported is the new best block. + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 3 }) ''ImportedAux) + +data CreatedBlock = CreatedBlock + { createdBlockHash :: HexString + , createdBlockAux :: ImportedAux + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 12 }) ''CreatedBlock) + +-- | Abstraction over a block header for a substrate chain. +data Header = Header + { headerParentHash :: HexString + -- ^ The parent hash. + , headerNumber :: Int + -- ^ The block number. + , headerStateRoot :: HexString + -- ^ The state trie merkle root + , headerExtrinsicsRoot :: HexString + -- ^ The merkle root of the extrinsics. + , headerDigest :: HexString + -- ^ A chain-specific digest of data useful for light clients or referencing auxiliary data. + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 5 }) ''Header) + +-- | Abstraction over a substrate block. +data Block = Block + { blockHeader :: Header + -- ^ The block header. + , blockExtrinsics :: [HexString] + -- ^ The accompanying extrinsics. + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 5 }) ''Block) + +-- | Abstraction over a substrate block and justification. +data SignedBlock = SignedBlock + { signedBlock :: Block + -- ^ Full block. + , signedJustification :: Maybe HexString + -- ^ Block justification. + } + deriving (Eq, Generic, Show) + +$(deriveJSON (defaultOptions + { fieldLabelModifier = toLowerFirst . drop 6 }) ''SignedBlock) diff --git a/src/Network/Web3.hs b/src/Network/Web3.hs new file mode 100644 --- /dev/null +++ b/src/Network/Web3.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Network.Web3 +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Client library for Third Generation of Web. +-- + +module Network.Web3 + ( + -- * Web3 library uses JSON-RPC over WebSocket/HTTP(S) to access node functionality. + Web3 + , runWeb3 + ) where + +import Network.Web3.Provider (Web3, runWeb3) diff --git a/src/Network/Web3/Provider.hs b/src/Network/Web3/Provider.hs new file mode 100644 --- /dev/null +++ b/src/Network/Web3/Provider.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.Web3.Provider +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Web3 service provider. +-- + +module Network.Web3.Provider where + +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.State (MonadState (..)) +import Control.Monad.Trans.State (StateT, evalStateT, withStateT) +import Data.Default (Default (..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.HTTP.Client (Manager) +import qualified Network.Socket as S +import qualified Network.WebSockets as WS (Connection, + defaultConnectionOptions, + newClientConnection, + sendClose) +import qualified Network.WebSockets.Stream as Stream + +import Network.JsonRpc.TinyClient (JsonRpc, JsonRpcClient (..), + defaultSettings, jsonRpcManager) + +-- | Any communication with node wrapped with 'Web3' monad +newtype Web3 a = Web3 { unWeb3 :: StateT JsonRpcClient IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadState JsonRpcClient) + +instance JsonRpc Web3 + +-- | Some peace of error response +data Web3Error = JsonRpcFail !String + | ParserFail !String + | UserFail !String + deriving (Show, Eq, Generic) + +instance Exception Web3Error + +--TODO: Change to `HttpProvider ServerUri | IpcProvider FilePath` to support IPC +-- | Web3 Provider +data Provider = HttpProvider String + | WsProvider String Int + deriving (Show, Eq, Generic) + +-- | Default Provider URI +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 provider f = do + runWeb3' provider Web3 { unWeb3 = withStateT changeManager $ unWeb3 f} + where + changeManager jRpcClient = case jRpcClient of + JsonRpcHttpClient{..} -> jRpcClient { jsonRpcManager = manager } + JsonRpcWsClient{..} -> jRpcClient + +-- | 'Web3' monad runner +runWeb3' :: MonadIO m + => Provider + -> Web3 a + -> m (Either Web3Error a) +runWeb3' (HttpProvider uri) f = do + cfg <- defaultSettings uri + liftIO . try . flip evalStateT cfg . unWeb3 $ f + +runWeb3' (WsProvider host port) f = do + connection <- liftIO $ getConnection host port "/" + let currentClient = JsonRpcWsClient { jsonRpcWsConnection = connection } + response <- liftIO $ try . flip evalStateT currentClient . unWeb3 $ f + liftIO $ WS.sendClose connection ("Bye-" :: Text) + return response + +-- | 'Web3' runner for default Http provider +runWeb3 :: MonadIO m + => Web3 a + -> m (Either Web3Error a) +{-# INLINE runWeb3 #-} +runWeb3 = runWeb3' def + +-- | Fork 'Web3' with the same 'Provider' and 'Manager' +forkWeb3 :: Web3 a -> Web3 (Async a) +forkWeb3 f = liftIO . async . evalStateT (unWeb3 f) =<< get + +-- | Returns a WebSocket Connection Instance +getConnection :: String -- ^ Host + -> Int -- ^ Port + -> String -- ^ Path + -> IO WS.Connection +{-# INLINE getConnection #-} +getConnection host port path = do + -- Create and connect socket + let hints = S.defaultHints + {S.addrSocketType = S.Stream} + + -- Correct host and path. + fullHost = if port == 80 then host else (host ++ ":" ++ show port) + path0 = if null path then "/" else path + + addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just $ show port) + sock <- S.socket (S.addrFamily addr) S.Stream S.defaultProtocol + S.setSocketOption sock S.NoDelay 1 + + -- Connect WebSocket and run client + + res <- ( S.connect sock (S.addrAddress addr) >> + Stream.makeSocketStream sock) >>= + (\stream -> + WS.newClientConnection stream fullHost + path0 WS.defaultConnectionOptions [] ) + return res diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,5 @@ # Resolver to choose a 'specific' stackage snapshot or a compiler version. -resolver: lts-15.10 +resolver: lts-15.13 # User packages to be built. packages: @@ -9,7 +9,6 @@ extra-deps: - relapse-1.0.0.0@sha256:b89ea23189e07f377be4e2a4deccf3d6ba7f547ed8ad77e27b35d78801efd81c - vinyl-0.12.1@sha256:03f5e246fae2434250987bbfe708015dc6e23f60c20739c34738acde1383b96c -- time-1.8.0.4@sha256:3f6eddf238b828eb4f82683acce1c3afe64784f0d20114239b738c123316c85c # Dependencies bounds pvp-bounds: both diff --git a/test/Network/Ethereum/Test/ComplexStorageSpec.hs b/test/Network/Ethereum/Test/ComplexStorageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Test/ComplexStorageSpec.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Network.Ethereum.Test.ComplexStorageSpec +-- 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.Test.ComplexStorageSpec where + +import Control.Concurrent.Async (async, wait) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Monad.IO.Class (liftIO) +import Data.Default (def) + +import Network.Ethereum hiding (convert) +import Network.Ethereum.Api.Types (Filter (..)) +import Network.Ethereum.Contract (new) +import Network.Ethereum.Contract.TH +import Network.Ethereum.Test.Utils + + +import Test.Hspec + +[abiFrom|test/contracts/ComplexStorage.json|] + +deploy :: IO Address +deploy = do + Just address <- web3 $ withAccount () $ withParam id $ new ComplexStorageContract + putStrLn $ "ComplexStorage: " ++ show address + return address + +spec :: Spec +spec = deploy `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" $ \storage -> do + let fltr = (def :: Filter ValsSet) { filterAddress = Just [storage] } + -- kick off listening for the ValsSet event + vals <- newEmptyMVar + fiber <- async . web3 $ + event fltr $ \vs -> do + liftIO $ putMVar vals vs + pure TerminateEvent + -- kick off tx + _ <- contract storage $ setValues + 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" $ \storage -> do + -- Write a values + _ <- contract storage $ setValues + sUint + sInt + sBool + sInt224 + sBools + sInts + sString + sBytes16 + sByte2s + -- Read a couple of values + (uintVal', intVal', boolVal', int224Val', boolsVal, intsVal, stringVal', bytes16Val', bytes2s) + <- contract storage $ (,,,,,,,,) + <$> uintVal + <*> intVal + <*> boolVal + <*> int224Val + <*> boolVectorVal 0 + <*> intListVal 0 + <*> stringVal + <*> bytes16Val + <*> bytes2VectorListVal 0 0 + + uintVal' `shouldBe` sUint + intVal' `shouldBe` sInt + boolVal' `shouldBe` sBool + int224Val' `shouldBe` sInt224 + boolsVal `shouldBe` True + intsVal `shouldBe` head sInts + stringVal' `shouldBe` sString + bytes16Val' `shouldBe` sBytes16 + bytes2s `shouldBe` sByte2sElem + + it "can decode a complicated value correctly" $ \storage -> do + -- Write a values + _ <- contract storage $ setValues + sUint + sInt + sBool + sInt224 + sBools + sInts + sString + sBytes16 + sByte2s + -- Read a all values + allVals <- contract storage getVals + allVals `shouldBe` (sUint, sInt, sBool, sInt224, sBools, sInts, sString, sBytes16, sByte2s) diff --git a/test/Network/Ethereum/Test/ERC20Spec.hs b/test/Network/Ethereum/Test/ERC20Spec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Test/ERC20Spec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | +-- Module : Network.Ethereum.Test.ERC20Spec +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- + +module Network.Ethereum.Test.ERC20Spec where + +import Test.Hspec + +import Network.Ethereum (Account, UIntN) +import Network.Ethereum.Contract.TH (abiFrom) +import Network.JsonRpc.TinyClient (JsonRpc) + +[abiFrom|examples/token/ERC20.json|] + +-- this spec is just to test compilation +spec :: Spec +spec = return () + +getBalance :: (JsonRpc m, Account p t, Functor (t m)) + => t m (UIntN 256) +getBalance = balanceOf "0x1234567890123456789011234567890234567890" diff --git a/test/Network/Ethereum/Test/LinearizationSpec.hs b/test/Network/Ethereum/Test/LinearizationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Test/LinearizationSpec.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- Module : Network.Ethereum.Test.LinearizationSpec +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- + +module Network.Ethereum.Test.LinearizationSpec where + +import Control.Concurrent (forkIO) +import Control.Concurrent.Async (forConcurrently_) +import Control.Concurrent.MVar +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue (TQueue, flushTQueue, + newTQueueIO, writeTQueue) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Reader (ReaderT, ask) +import Data.Default +import Data.Either +import Data.List (sort) +import Data.Maybe (fromJust) +import System.Random (randomRIO) +import Test.Hspec + +import Network.Ethereum +import qualified Network.Ethereum.Api.Eth as Eth +import Network.Ethereum.Api.Types (Change (..), Filter (..), + TxReceipt, unQuantity) +import Network.Ethereum.Contract (new) +import Network.Ethereum.Contract.Event +import Network.Ethereum.Contract.TH (abiFrom) +import Network.Ethereum.Test.Utils +import Network.Web3 + +[abiFrom|test/contracts/Linearization.json|] + +deploy :: IO Address +deploy = do + Just address <- web3 $ withAccount () $ withParam id $ new LinearizationContract + putStrLn $ "Linearization: " ++ show address + return address + +spec :: Spec +spec = do + deploy `before` linearizationSpec + deploy `before` floodSpec + +floodCount :: Int +floodCount = 200 + +linearizationSpec :: SpecWith Address +linearizationSpec = + describe "can bundle and linearize events" $ do + it "can call e12" $ \linearization -> do + var <- monitorE1OrE2 linearization + _ <- contract linearization e12 + res <- takeMVar var + res `shouldSatisfy` isLeft + + it "can call e21" $ \linearization -> do + -- wait on the next block + web3 Eth.blockNumber >>= \bn -> awaitBlock (bn + 1) + var <- monitorE1OrE2 linearization + _ <- contract linearization e21 + res <- takeMVar var + res `shouldSatisfy` isRight + +singleFlood :: forall m. (MonadIO m) => Address -> m TxReceipt +singleFlood linearization = liftIO $ do + rando :: Int <- randomRIO (1, 4) + contract linearization $ + case rando of + 1 -> e1 + 2 -> e2 + 3 -> e3 + 4 -> e4 + _ -> error "got a number outside of (1,4) after randomR (1,4)" + +floodSpec :: SpecWith Address +floodSpec = describe "can correctly demonstrate the difference between `multiEvent` and multiple `event`s" $ do + it "properly linearizes with `multiEvent` when flooded and doesn't with multiple `event`s" $ \linearization -> do + multiQ <- monitorAllFourMulti linearization + parQ <- monitorAllFourPar linearization + -- to let the filter settle so we dont block indefinitely on missing events? + sleepBlocks 10 + + -- flood em and wait for all to finish + liftIO . forConcurrently_ [1..floodCount] . const $ singleFlood linearization + + -- to let the event listeners catch up + sleepBlocks 10 + + -- wait for all multiEvents to be received and flush em out + multiReceivedEvents <- liftIO . atomically $ flushTQueue multiQ + parReceivedEvents <- liftIO . atomically $ flushTQueue parQ + + -- did we get at least 1/4 of the events? (this is a gotcha when flooding, sometimes nonces get repeated) + length multiReceivedEvents `shouldSatisfy` (>= (floodCount `div` 4)) + length parReceivedEvents `shouldSatisfy` (>= (floodCount `div` 4)) + + -- did both listeners see the same amount of events? + length multiReceivedEvents `shouldBe` length parReceivedEvents + + -- the events pushed into the multi TQueue should already be sorted if they happened in the right order + sort multiReceivedEvents `shouldBe` multiReceivedEvents + -- the events pushed into the TQueue should not be sorted if they didnt come in in the right order + sort parReceivedEvents `shouldNotBe` parReceivedEvents + +monitorE1OrE2 :: Address -> IO (MVar (Either E1 E2)) +monitorE1OrE2 addr = do + var <- newEmptyMVar + let fltr1 = (def :: Filter E1) { filterAddress = Just [addr] } + fltr2 = (def :: Filter E2) { filterAddress = Just [addr] } + filters = fltr1 :? fltr2 :? NilFilters + handler1 ev1 = do + liftIO $ putMVar var (Left ev1) + return TerminateEvent + handler2 ev2 = do + liftIO $ putMVar var (Right ev2) + return TerminateEvent + handlers = H handler1 :& H handler2 :& RNil + _ <- web3 $ multiEvent filters handlers + return var + +data EventTag = ETE1 + | ETE2 + | ETE3 + | ETE4 + deriving (Eq, Read, Show) + +instance {-# OVERLAPPING #-} Ord (EventTag, Integer, Integer) where + (_, b1, t1) `compare` (_, b2, t2) = + let bCmp = b1 `compare` b2 + in if bCmp == EQ then t1 `compare` t2 + else bCmp + +monitorAllFourMulti :: Address + -> IO (TQueue (EventTag, Integer, Integer)) +monitorAllFourMulti addr = do + q <- newTQueueIO + let f :: forall a. Default (Filter a) => Filter a + f = defFilter addr + h = enqueueingHandler q + filters = f @E1 :? f @E2 :? f @E3 :? f @E4 :? NilFilters + handlers = h ETE1 :& h ETE2 :& h ETE3 :& h ETE4 :& RNil + void . web3 $ multiEvent filters handlers + return q + +monitorAllFourPar :: Address + -> IO (TQueue (EventTag, Integer, Integer)) +monitorAllFourPar addr = do + q <- newTQueueIO + let f :: forall a. Default (Filter a) => Filter a + f = defFilter addr + h = enqueueingHandler q + unH (H h) = h + + void . forkIO . web3 $ event (f @E1) (unH $ h ETE1) + void . forkIO . web3 $ event (f @E2) (unH $ h ETE2) + void . forkIO . web3 $ event (f @E3) (unH $ h ETE3) + void . forkIO . web3 $ event (f @E4) (unH $ h ETE4) + return q + +defFilter :: forall a. Default (Filter a) => Address -> Filter a +defFilter addr = (def :: Filter a) { filterAddress = Just [addr] } + +enqueueingHandler :: forall a. TQueue (EventTag, Integer, Integer) + -> EventTag + -> Handler (ReaderT Change Web3 EventAction) a +enqueueingHandler q tag = H . const $ do + Change{..} <- ask + let bn = unQuantity $ fromJust changeBlockNumber + li = unQuantity $ fromJust changeLogIndex + liftIO . atomically $ writeTQueue q (tag, bn, li) + return ContinueEvent diff --git a/test/Network/Ethereum/Test/LocalAccountSpec.hs b/test/Network/Ethereum/Test/LocalAccountSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Test/LocalAccountSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Network.Ethereum.Test.LocalAccountSpec +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Simple local account transaction test. +-- + +module Network.Ethereum.Test.LocalAccountSpec where + +import Lens.Micro ((.~)) +import Lens.Micro.Mtl ((.=)) +import Test.Hspec + +import Crypto.Ecdsa.Utils (derivePubKey, importKey) +import Data.ByteArray.HexString (HexString) +import Data.Solidity.Prim.Address (fromPubKey) +import Network.Ethereum.Account (LocalKey (..), send, to, value, + withAccount, withParam) +import Network.Ethereum.Api.Eth (getBalance) +import Network.Ethereum.Api.Types (DefaultBlock (Pending)) +import Network.Ethereum.Test.Utils (web3) +import Network.Ethereum.Unit (Ether, toWei) + +spec :: Spec +spec = describe "Local account transactions" $ do + it "should send value" $ do + let key = "0x0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f20" :: HexString + local = LocalKey (importKey key) 420123 + localAddress = fromPubKey (derivePubKey $ importKey key) + dest = "0x0000000000000000000000000000000000000042" + + -- Prepare + web3 $ withAccount () $ + withParam (to .~ localAddress) $ do + value .= (1 :: Ether) + send () + + balance <- web3 $ do + withAccount local $ + withParam (to .~ dest) $ do + value .= (0.5 :: Ether) + send () + getBalance dest Pending + + fromIntegral balance `shouldBe` toWei (0.5 :: Ether) diff --git a/test/Network/Ethereum/Test/RegistrySpec.hs b/test/Network/Ethereum/Test/RegistrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Test/RegistrySpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Ethereum.Test.RegistrySpec where + +import Data.Default (def) +import Test.Hspec (Spec) + +import Network.Ethereum (EventAction (TerminateEvent), + event) +import Network.Ethereum.Api.Types (Filter) +import Network.Ethereum.Contract.TH (abiFrom) +import Network.Web3 (Web3) + +[abiFrom|test/contracts/Registry.json|] + +-- this spec is just to test compilation +spec :: Spec +spec = return () + +monitor :: Web3 () +monitor = do + let fltr1 = def :: Filter A + fltr2 = def :: Filter B + event fltr1 $ \_ -> pure TerminateEvent + event fltr2 $ \_ -> pure TerminateEvent + pure () diff --git a/test/Network/Ethereum/Test/SimpleStorageSpec.hs b/test/Network/Ethereum/Test/SimpleStorageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Test/SimpleStorageSpec.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Network.Ethereum.Test.SimpleStorageSpec +-- 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.Test.SimpleStorageSpec where + +import Control.Concurrent.Async (wait) +import Control.Concurrent.MVar +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ask) +import Data.Default (def) +import Data.List (sort) +import Data.Monoid ((<>)) +import Lens.Micro ((.~)) +import Test.Hspec + +import Network.Ethereum +import qualified Network.Ethereum.Api.Eth as Eth +import Network.Ethereum.Api.Types +import Network.Ethereum.Contract (new) +import Network.Ethereum.Contract.TH +import Network.Web3 +import Network.Web3.Provider (forkWeb3) + +import Network.Ethereum.Test.Utils + +[abiFrom|test/contracts/SimpleStorage.json|] + +unEvT_CountSet :: EvT_CountSet -> UIntN 256 +unEvT_CountSet (EvT_CountSet n) = n + +deploy :: IO Address +deploy = do + Just address <- web3 $ withAccount () $ withParam id $ new SimpleStorageContract + putStrLn $ "SimpleStorage: " ++ show address + return address + +spec :: Spec +spec = deploy `before` do + interactions + 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 and read the value back" $ \storage -> do + _ <- contract storage $ setCount theValue + + now <- web3 Eth.blockNumber + let later = now + 3 + awaitBlock later + + v <- contract storage count + v `shouldBe` theValue + + it "can set transaction gas limit" $ \storage -> do + TxReceipt{..} <- contract storage $ withParam (gasLimit .~ 500000) $ setCount theValue + Just Transaction{..} <- web3 $ Eth.getTransactionByHash receiptTransactionHash + txGas `shouldBe` 500000 + + it "can estimate transaction gas limit" $ \storage -> do + TxReceipt{..} <- contract storage $ setCount theValue + Just Transaction{..} <- web3 $ Eth.getTransactionByHash receiptTransactionHash + txGas `shouldBe` 42822 + +events :: SpecWith Address +events = do + describe "can interact with a SimpleStorage contract across block intervals" $ do + it "can stream events starting and ending in the future, unbounded" $ \storage -> do + var <- newMVar [] + let theSets = [1, 2, 3] + putStrLn "Setting up the filter..." + fiber <- web3 $ do + let fltr = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] } + forkWeb3 $ processUntil' var fltr ((3 ==) . length) + putStrLn "Setting the values..." + setValues storage theSets + wait fiber + putStrLn "Filter caught 3 values..." + vals <- takeMVar var + sort (unEvT_CountSet <$> vals) `shouldBe` sort theSets + + it "can stream events starting and ending in the future, bounded" $ \storage -> do + var <- newMVar [] + let theSets = [13, 14, 15] + start <- web3 Eth.blockNumber + let later = BlockWithNumber (start + 3) + latest = BlockWithNumber (start + 8) + fltr = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] + , filterFromBlock = later + , filterToBlock = latest + } + putStrLn "Setting up the filter..." + fiber <- web3 $ + forkWeb3 $ processUntil' var fltr ((3 ==) . length) + awaitBlock (start + 3) + putStrLn "Setting the values..." + setValues storage theSets + wait fiber + putStrLn "Filter caught 3 values..." + vals <- takeMVar var + sort (unEvT_CountSet <$> vals) `shouldBe` init (sort theSets) + + it "can stream events starting in the past and ending in the future" $ \storage -> do + var <- newMVar [] + blockNumberVar <- newEmptyMVar + let theSets1 = [7, 8, 9] + theSets2 = [10, 11, 12] + start <- web3 Eth.blockNumber + let fltr = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] } + fiber <- web3 $ do + forkWeb3 $ processUntil var fltr ((3 ==) . length) (liftIO . putMVar blockNumberVar . changeBlockNumber) + putStrLn "Running first transactions as past transactions..." + setValues storage theSets1 + wait fiber + putStrLn "All past transactions succeeded... " + Just end <- takeMVar blockNumberVar + awaitBlock $ end + 1 -- make past transactions definitively in past + var' <- newMVar [] + fiber' <- web3 $ do + let fltr' = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] + , filterFromBlock = BlockWithNumber start} + forkWeb3 $ processUntil' var' fltr' ((6 ==) . length) + putStrLn "Setting more values" + setValues storage theSets2 + wait fiber' + putStrLn "All new values have ben set" + vals <- takeMVar var' + sort (unEvT_CountSet <$> vals) `shouldBe` sort (theSets1 <> theSets2) + + it "can stream events starting and ending in the past, bounded" $ \storage -> do + var <- newMVar [] + let theSets = [4, 5, 6] + start <- web3 Eth.blockNumber + blockNumberVar <- newEmptyMVar + let fltr = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] } + putStrLn "Setting up filter for past transactions..." + fiber <- web3 $ do + forkWeb3 $ processUntil var fltr ((3 ==) . length) (liftIO . putMVar blockNumberVar . changeBlockNumber) + putStrLn "Setting values" + setValues storage theSets + wait fiber + putStrLn "All values have been set" + Just end <- takeMVar blockNumberVar + var' <- newMVar [] + let fltr' = fltr { filterFromBlock = BlockWithNumber start + , filterToBlock = BlockWithNumber end + } + awaitBlock $ end + 1 -- make it definitively in the past + web3 $ processUntil' var' fltr' ((3 ==) . length) + vals <- takeMVar var' + sort (unEvT_CountSet <$> vals) `shouldBe` sort theSets + +processUntil :: MVar [EvT_CountSet] + -> Filter EvT_CountSet + -> ([EvT_CountSet] -> Bool) -- TODO: make it work for any event + -> (Change -> Web3 ()) + -> Web3 () +processUntil var fltr predicate action = do + event fltr $ \(ev :: EvT_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 [EvT_CountSet] + -> Filter EvT_CountSet + -> ([EvT_CountSet] -> Bool) + -> Web3 () +processUntil' var fltr predicate = processUntil var fltr predicate (const $ return ()) + +setValues :: Address -> [UIntN 256] -> IO () +setValues storage = mapM_ (contract storage . setCount) diff --git a/test/Network/Ethereum/Test/Utils.hs b/test/Network/Ethereum/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ethereum/Test/Utils.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Ethereum.Test.Utils where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, catch) +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromMaybe) +import Data.Ratio (numerator) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Lens.Micro ((.~)) +import Network.HTTP.Client (Manager, defaultManagerSettings, + managerConnCount, + managerRawConnection, + managerRetryableException, + newManager) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) + +import Data.Solidity.Prim.Address (Address) +import Network.Ethereum.Account (DefaultAccount, to, withAccount, + withParam) +import Network.Ethereum.Api.Eth (accounts, blockNumber) +import Network.Ethereum.Api.Types (Quantity) +import Network.Web3.Provider (Provider (..), Web3, runWeb3With) + +-- shared manager used throughout the helpers here to prevent hammering geth from ruining everything +-- this also retrys on ALL exceptions, including ConnectionResetByPeer and stuff like that +sharedManager :: Manager +sharedManager = unsafePerformIO $ newManager defaultManagerSettings + { managerConnCount = 5 + , managerRetryableException = const False + , managerRawConnection = fixRawConnection retryOpenConnection + } + + where retryOpenConnection = threadDelay 500000 >> managerRawConnection defaultManagerSettings + fixRawConnection f = f `catch` (\(_ :: SomeException) -> fixRawConnection f) +{-# NOINLINE sharedManager #-} + +rpcUri :: IO String +rpcUri = liftIO (fromMaybe "http://localhost:8545" <$> lookupEnv "WEB3_PROVIDER") + +contract :: Address + -> DefaultAccount Web3 a + -> IO a +contract a = web3 . withAccount () . withParam (to .~ a) + +web3 :: Web3 a -> IO a +web3 ma = do + provider <- HttpProvider <$> rpcUri + v <- runWeb3With sharedManager provider ma + case v of + Left e -> print e >> threadDelay 1000000 >> web3 ma + Right v' -> return v' + +withAccounts :: ([Address] -> IO a) -> IO a +withAccounts f = web3 accounts >>= f + +withPrimaryEthereumAccount :: IO Address +withPrimaryEthereumAccount = withAccounts (pure . head) + +sleepSeconds :: Int -> IO () +sleepSeconds = threadDelay . (* 1000000) + +microtime :: IO Integer +microtime = numerator . toRational . (* 1000000) <$> getPOSIXTime + +awaitBlock :: Quantity -> IO () +awaitBlock bn = do + bn' <- web3 blockNumber + -- putStrLn $ "awaiting block " ++ show bn ++ ", currently " ++ show bn' + if bn' >= bn + then return () + else threadDelay 1000000 >> awaitBlock bn + +sleepBlocks :: Int -> IO () +sleepBlocks n = do + now <- web3 blockNumber + awaitBlock $ now + fromIntegral n diff --git a/test/Network/Ethereum/Web3/Test/ComplexStorageSpec.hs b/test/Network/Ethereum/Web3/Test/ComplexStorageSpec.hs deleted file mode 100644 --- a/test/Network/Ethereum/Web3/Test/ComplexStorageSpec.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- Module : Network.Ethereum.Web3.Test.ComplexStorageSpec --- 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 (newEmptyMVar, putMVar, - takeMVar) -import Control.Monad.IO.Class (liftIO) -import Data.Default (def) - -import Network.Ethereum.Api.Types (Filter (..)) -import Network.Ethereum.Contract (new) -import Network.Ethereum.Contract.TH -import Network.Ethereum.Web3 hiding (convert) -import Network.Ethereum.Web3.Test.Utils - - -import Test.Hspec - -[abiFrom|test/contracts/ComplexStorage.json|] - -deploy :: IO Address -deploy = do - Just address <- web3 $ withAccount () $ withParam id $ new ComplexStorageContract - putStrLn $ "ComplexStorage: " ++ show address - return address - -spec :: Spec -spec = deploy `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" $ \storage -> do - let fltr = (def :: Filter ValsSet) { filterAddress = Just [storage] } - -- kick off listening for the ValsSet event - vals <- newEmptyMVar - fiber <- web3 $ - event fltr $ \vs -> do - liftIO $ putMVar vals vs - pure TerminateEvent - -- kick off tx - _ <- contract storage $ setValues - 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" $ \storage -> do - -- Write a values - _ <- contract storage $ setValues - sUint - sInt - sBool - sInt224 - sBools - sInts - sString - sBytes16 - sByte2s - -- Read a couple of values - (uintVal', intVal', boolVal', int224Val', boolsVal, intsVal, stringVal', bytes16Val', bytes2s) - <- contract storage $ (,,,,,,,,) - <$> uintVal - <*> intVal - <*> boolVal - <*> int224Val - <*> boolVectorVal 0 - <*> intListVal 0 - <*> stringVal - <*> bytes16Val - <*> bytes2VectorListVal 0 0 - - uintVal' `shouldBe` sUint - intVal' `shouldBe` sInt - boolVal' `shouldBe` sBool - int224Val' `shouldBe` sInt224 - boolsVal `shouldBe` True - intsVal `shouldBe` head sInts - stringVal' `shouldBe` sString - bytes16Val' `shouldBe` sBytes16 - bytes2s `shouldBe` sByte2sElem - - it "can decode a complicated value correctly" $ \storage -> do - -- Write a values - _ <- contract storage $ setValues - sUint - sInt - sBool - sInt224 - sBools - sInts - sString - sBytes16 - sByte2s - -- Read a all values - allVals <- contract storage getVals - allVals `shouldBe` (sUint, sInt, sBool, sInt224, sBools, sInts, sString, sBytes16, sByte2s) diff --git a/test/Network/Ethereum/Web3/Test/ERC20Spec.hs b/test/Network/Ethereum/Web3/Test/ERC20Spec.hs deleted file mode 100644 --- a/test/Network/Ethereum/Web3/Test/ERC20Spec.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module Network.Ethereum.Web3.Test.ERC20Spec where - -import Test.Hspec - -import Network.Ethereum.Contract.TH (abiFrom) -import Network.Ethereum.Web3 (Account, UIntN) -import Network.JsonRpc.TinyClient (JsonRpc) - -[abiFrom|examples/token/ERC20.json|] - --- this spec is just to test compilation -spec :: Spec -spec = return () - -getBalance :: (JsonRpc m, Account p t, Functor (t m)) - => t m (UIntN 256) -getBalance = balanceOf "0x1234567890123456789011234567890234567890" diff --git a/test/Network/Ethereum/Web3/Test/LinearizationSpec.hs b/test/Network/Ethereum/Web3/Test/LinearizationSpec.hs deleted file mode 100644 --- a/test/Network/Ethereum/Web3/Test/LinearizationSpec.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - --- Module : Network.Ethereum.Web3.Test.LinearizationSpec --- Copyright : Alexander Krupenkin 2016 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : unportable --- - -module Network.Ethereum.Web3.Test.LinearizationSpec where - -import Control.Concurrent (forkIO) -import Control.Concurrent.Async (forConcurrently_) -import Control.Concurrent.MVar -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TQueue (TQueue, flushTQueue, - newTQueueIO, writeTQueue) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Reader (ReaderT, ask) -import Data.Default -import Data.Either -import Data.List (sort) -import Data.Maybe (fromJust) -import System.Random (randomRIO) -import Test.Hspec - -import qualified Network.Ethereum.Api.Eth as Eth -import Network.Ethereum.Api.Types (Change (..), Filter (..), - TxReceipt, unQuantity) -import Network.Ethereum.Contract (new) -import Network.Ethereum.Contract.Event -import Network.Ethereum.Contract.TH (abiFrom) -import Network.Ethereum.Web3 -import Network.Ethereum.Web3.Test.Utils - -[abiFrom|test/contracts/Linearization.json|] - -deploy :: IO Address -deploy = do - Just address <- web3 $ withAccount () $ withParam id $ new LinearizationContract - putStrLn $ "Linearization: " ++ show address - return address - -spec :: Spec -spec = do - deploy `before` linearizationSpec - deploy `before` floodSpec - -floodCount :: Int -floodCount = 200 - -linearizationSpec :: SpecWith Address -linearizationSpec = - describe "can bundle and linearize events" $ do - it "can call e12" $ \linearization -> do - var <- monitorE1OrE2 linearization - _ <- contract linearization e12 - res <- takeMVar var - res `shouldSatisfy` isLeft - - it "can call e21" $ \linearization -> do - -- wait on the next block - web3 Eth.blockNumber >>= \bn -> awaitBlock (bn + 1) - var <- monitorE1OrE2 linearization - _ <- contract linearization e21 - res <- takeMVar var - res `shouldSatisfy` isRight - -singleFlood :: forall m. (MonadIO m) => Address -> m TxReceipt -singleFlood linearization = liftIO $ do - rando :: Int <- randomRIO (1, 4) - contract linearization $ - case rando of - 1 -> e1 - 2 -> e2 - 3 -> e3 - 4 -> e4 - _ -> error "got a number outside of (1,4) after randomR (1,4)" - -floodSpec :: SpecWith Address -floodSpec = describe "can correctly demonstrate the difference between `multiEvent` and multiple `event'`s" $ do - it "properly linearizes with `multiEvent` when flooded and doesn't with multiple `event`s" $ \linearization -> do - multiQ <- monitorAllFourMulti linearization - parQ <- monitorAllFourPar linearization - -- to let the filter settle so we dont block indefinitely on missing events? - sleepBlocks 10 - - -- flood em and wait for all to finish - liftIO . forConcurrently_ [1..floodCount] . const $ singleFlood linearization - - -- to let the event listeners catch up - sleepBlocks 10 - - -- wait for all multiEvents to be received and flush em out - multiReceivedEvents <- liftIO . atomically $ flushTQueue multiQ - parReceivedEvents <- liftIO . atomically $ flushTQueue parQ - - -- did we get at least 1/4 of the events? (this is a gotcha when flooding, sometimes nonces get repeated) - length multiReceivedEvents `shouldSatisfy` (>= (floodCount `div` 4)) - length parReceivedEvents `shouldSatisfy` (>= (floodCount `div` 4)) - - -- did both listeners see the same amount of events? - length multiReceivedEvents `shouldBe` length parReceivedEvents - - -- the events pushed into the multi TQueue should already be sorted if they happened in the right order - sort multiReceivedEvents `shouldBe` multiReceivedEvents - -- the events pushed into the TQueue should not be sorted if they didnt come in in the right order - sort parReceivedEvents `shouldNotBe` parReceivedEvents - -monitorE1OrE2 :: Address -> IO (MVar (Either E1 E2)) -monitorE1OrE2 addr = do - var <- newEmptyMVar - let fltr1 = (def :: Filter E1) { filterAddress = Just [addr] } - fltr2 = (def :: Filter E2) { filterAddress = Just [addr] } - filters = fltr1 :? fltr2 :? NilFilters - handler1 ev1 = do - liftIO $ putMVar var (Left ev1) - return TerminateEvent - handler2 ev2 = do - liftIO $ putMVar var (Right ev2) - return TerminateEvent - handlers = H handler1 :& H handler2 :& RNil - _ <- web3 $ multiEvent filters handlers - return var - -data EventTag = ETE1 | ETE2 | ETE3 | ETE4 - deriving (Eq, Read, Show) - -instance {-# OVERLAPPING #-} Ord (EventTag, Integer, Integer) where - (_, b1, t1) `compare` (_, b2, t2) = - let bCmp = b1 `compare` b2 - in if bCmp == EQ then t1 `compare` t2 - else bCmp - -monitorAllFourMulti :: Address - -> IO (TQueue (EventTag, Integer, Integer)) -monitorAllFourMulti addr = do - q <- newTQueueIO - let f :: forall a. Default (Filter a) => Filter a - f = defFilter addr - h = enqueueingHandler q - filters = f @E1 :? f @E2 :? f @E3 :? f @E4 :? NilFilters - handlers = h ETE1 :& h ETE2 :& h ETE3 :& h ETE4 :& RNil - void . web3 $ multiEvent filters handlers - return q - -monitorAllFourPar :: Address - -> IO (TQueue (EventTag, Integer, Integer)) -monitorAllFourPar addr = do - q <- newTQueueIO - let f :: forall a. Default (Filter a) => Filter a - f = defFilter addr - h = enqueueingHandler q - unH (H h) = h - - void . forkIO . web3 $ event' (f @E1) (unH $ h ETE1) - void . forkIO . web3 $ event' (f @E2) (unH $ h ETE2) - void . forkIO . web3 $ event' (f @E3) (unH $ h ETE3) - void . forkIO . web3 $ event' (f @E4) (unH $ h ETE4) - return q - -defFilter :: forall a. Default (Filter a) => Address -> Filter a -defFilter addr = (def :: Filter a) { filterAddress = Just [addr] } - -enqueueingHandler :: forall a. TQueue (EventTag, Integer, Integer) - -> EventTag - -> Handler (ReaderT Change Web3 EventAction) a -enqueueingHandler q tag = H . const $ do - Change{..} <- ask - let bn = unQuantity $ fromJust changeBlockNumber - li = unQuantity $ fromJust changeLogIndex - liftIO . atomically $ writeTQueue q (tag, bn, li) - return ContinueEvent diff --git a/test/Network/Ethereum/Web3/Test/LocalAccountSpec.hs b/test/Network/Ethereum/Web3/Test/LocalAccountSpec.hs deleted file mode 100644 --- a/test/Network/Ethereum/Web3/Test/LocalAccountSpec.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Module : Network.Ethereum.Web3.Test.LocalAccountSpec --- Copyright : Alexander Krupenkin 2018 --- License : BSD3 --- --- Maintainer : mail@akru.me --- Stability : experimental --- Portability : unportable --- --- Simple local account transaction test. --- - -module Network.Ethereum.Web3.Test.LocalAccountSpec where - -import Lens.Micro ((.~)) -import Lens.Micro.Mtl ((.=)) -import Test.Hspec - -import Crypto.Ethereum.Utils (derivePubKey, importKey) -import Data.ByteArray.HexString (HexString) -import Data.Solidity.Prim.Address (fromPubKey) -import Network.Ethereum.Account (LocalKey (..), send, to, - value, withAccount, - withParam) -import Network.Ethereum.Api.Eth (getBalance) -import Network.Ethereum.Api.Types (DefaultBlock (Pending)) -import Network.Ethereum.Unit (Ether, toWei) -import Network.Ethereum.Web3.Test.Utils (web3) - -spec :: Spec -spec = describe "Local account transactions" $ do - it "should send value" $ do - let key = "0x0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f20" :: HexString - local = LocalKey (importKey key) 420123 - localAddress = fromPubKey (derivePubKey $ importKey key) - dest = "0x0000000000000000000000000000000000000042" - - -- Prepare - web3 $ withAccount () $ - withParam (to .~ localAddress) $ do - value .= (1 :: Ether) - send () - - balance <- web3 $ do - withAccount local $ - withParam (to .~ dest) $ do - value .= (0.5 :: Ether) - send () - getBalance dest Pending - - fromIntegral balance `shouldBe` toWei (0.5 :: Ether) diff --git a/test/Network/Ethereum/Web3/Test/RegistrySpec.hs b/test/Network/Ethereum/Web3/Test/RegistrySpec.hs deleted file mode 100644 --- a/test/Network/Ethereum/Web3/Test/RegistrySpec.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -module Network.Ethereum.Web3.Test.RegistrySpec where - -import Data.Default (def) -import Test.Hspec (Spec) - -import Network.Ethereum.Api.Types (Filter) -import Network.Ethereum.Contract.TH (abiFrom) -import Network.Ethereum.Web3 (EventAction (TerminateEvent), - Web3, event) - -[abiFrom|test/contracts/Registry.json|] - --- this spec is just to test compilation -spec :: Spec -spec = return () - -monitor :: Web3 () -monitor = do - let fltr1 = def :: Filter A - fltr2 = def :: Filter B - event fltr1 $ \_ -> pure TerminateEvent - event fltr2 $ \_ -> pure TerminateEvent - pure () diff --git a/test/Network/Ethereum/Web3/Test/SimpleStorageSpec.hs b/test/Network/Ethereum/Web3/Test/SimpleStorageSpec.hs deleted file mode 100644 --- a/test/Network/Ethereum/Web3/Test/SimpleStorageSpec.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - --- Module : Network.Ethereum.Web3.Test.SimpleStorageSpec --- 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.Async (wait) -import Control.Concurrent.MVar -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.Default (def) -import Data.List (sort) -import Data.Monoid ((<>)) -import Lens.Micro ((.~)) -import Test.Hspec - -import qualified Network.Ethereum.Api.Eth as Eth -import Network.Ethereum.Api.Provider (forkWeb3) -import Network.Ethereum.Api.Types -import Network.Ethereum.Contract (new) -import Network.Ethereum.Contract.Event (event') -import Network.Ethereum.Contract.TH -import Network.Ethereum.Web3 - - -import Network.Ethereum.Web3.Test.Utils - -[abiFrom|test/contracts/SimpleStorage.json|] - -unEvT_CountSet :: EvT_CountSet -> UIntN 256 -unEvT_CountSet (EvT_CountSet n) = n - -deploy :: IO Address -deploy = do - Just address <- web3 $ withAccount () $ withParam id $ new SimpleStorageContract - putStrLn $ "SimpleStorage: " ++ show address - return address - -spec :: Spec -spec = deploy `before` do - interactions - 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 and read the value back" $ \storage -> do - _ <- contract storage $ setCount theValue - - now <- web3 Eth.blockNumber - let later = now + 3 - awaitBlock later - - v <- contract storage count - v `shouldBe` theValue - - it "can set transaction gas limit" $ \storage -> do - TxReceipt{..} <- contract storage $ withParam (gasLimit .~ 500000) $ setCount theValue - Just Transaction{..} <- web3 $ Eth.getTransactionByHash receiptTransactionHash - txGas `shouldBe` 500000 - - it "can estimate transaction gas limit" $ \storage -> do - TxReceipt{..} <- contract storage $ setCount theValue - Just Transaction{..} <- web3 $ Eth.getTransactionByHash receiptTransactionHash - txGas `shouldBe` 42822 - -events :: SpecWith Address -events = do - describe "can interact with a SimpleStorage contract across block intervals" $ do - it "can stream events starting and ending in the future, unbounded" $ \storage -> do - var <- newMVar [] - let theSets = [1, 2, 3] - putStrLn "Setting up the filter..." - fiber <- web3 $ do - let fltr = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] } - forkWeb3 $ processUntil' var fltr ((3 ==) . length) - putStrLn "Setting the values..." - setValues storage theSets - wait fiber - putStrLn "Filter caught 3 values..." - vals <- takeMVar var - sort (unEvT_CountSet <$> vals) `shouldBe` sort theSets - - it "can stream events starting and ending in the future, bounded" $ \storage -> do - var <- newMVar [] - let theSets = [13, 14, 15] - start <- web3 Eth.blockNumber - let later = BlockWithNumber (start + 3) - latest = BlockWithNumber (start + 8) - fltr = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] - , filterFromBlock = later - , filterToBlock = latest - } - putStrLn "Setting up the filter..." - fiber <- web3 $ - forkWeb3 $ processUntil' var fltr ((3 ==) . length) - awaitBlock (start + 3) - putStrLn "Setting the values..." - setValues storage theSets - wait fiber - putStrLn "Filter caught 3 values..." - vals <- takeMVar var - sort (unEvT_CountSet <$> vals) `shouldBe` init (sort theSets) - - it "can stream events starting in the past and ending in the future" $ \storage -> do - var <- newMVar [] - blockNumberVar <- newEmptyMVar - let theSets1 = [7, 8, 9] - theSets2 = [10, 11, 12] - start <- web3 Eth.blockNumber - let fltr = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] } - fiber <- web3 $ do - forkWeb3 $ processUntil var fltr ((3 ==) . length) (liftIO . putMVar blockNumberVar . changeBlockNumber) - putStrLn "Running first transactions as past transactions..." - setValues storage theSets1 - wait fiber - putStrLn "All past transactions succeeded... " - Just end <- takeMVar blockNumberVar - awaitBlock $ end + 1 -- make past transactions definitively in past - var' <- newMVar [] - fiber' <- web3 $ do - let fltr' = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] - , filterFromBlock = BlockWithNumber start} - forkWeb3 $ processUntil' var' fltr' ((6 ==) . length) - putStrLn "Setting more values" - setValues storage theSets2 - wait fiber' - putStrLn "All new values have ben set" - vals <- takeMVar var' - sort (unEvT_CountSet <$> vals) `shouldBe` sort (theSets1 <> theSets2) - - it "can stream events starting and ending in the past, bounded" $ \storage -> do - var <- newMVar [] - let theSets = [4, 5, 6] - start <- web3 Eth.blockNumber - blockNumberVar <- newEmptyMVar - let fltr = (def :: Filter EvT_CountSet) { filterAddress = Just [storage] } - putStrLn "Setting up filter for past transactions..." - fiber <- web3 $ do - forkWeb3 $ processUntil var fltr ((3 ==) . length) (liftIO . putMVar blockNumberVar . changeBlockNumber) - putStrLn "Setting values" - setValues storage theSets - wait fiber - putStrLn "All values have been set" - Just end <- takeMVar blockNumberVar - var' <- newMVar [] - let fltr' = fltr { filterFromBlock = BlockWithNumber start - , filterToBlock = BlockWithNumber end - } - awaitBlock $ end + 1 -- make it definitively in the past - web3 $ processUntil' var' fltr' ((3 ==) . length) - vals <- takeMVar var' - sort (unEvT_CountSet <$> vals) `shouldBe` sort theSets - -processUntil :: MVar [EvT_CountSet] - -> Filter EvT_CountSet - -> ([EvT_CountSet] -> Bool) -- TODO: make it work for any event - -> (Change -> Web3 ()) - -> Web3 () -processUntil var fltr predicate action = do - event' fltr $ \(ev :: EvT_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 [EvT_CountSet] - -> Filter EvT_CountSet - -> ([EvT_CountSet] -> Bool) - -> Web3 () -processUntil' var fltr predicate = processUntil var fltr predicate (const $ return ()) - -setValues :: Address -> [UIntN 256] -> IO () -setValues storage = mapM_ (contract storage . setCount) diff --git a/test/Network/Ethereum/Web3/Test/Utils.hs b/test/Network/Ethereum/Web3/Test/Utils.hs deleted file mode 100644 --- a/test/Network/Ethereum/Web3/Test/Utils.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Network.Ethereum.Web3.Test.Utils where - -import Control.Concurrent (threadDelay) -import Control.Exception (SomeException, catch) -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (fromMaybe) -import Data.Ratio (numerator) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Lens.Micro ((.~)) -import Network.HTTP.Client (Manager, defaultManagerSettings, - managerConnCount, - managerRawConnection, - managerRetryableException, - newManager) -import System.Environment (lookupEnv) -import System.IO.Unsafe (unsafePerformIO) - -import Data.Solidity.Prim.Address (Address) -import Network.Ethereum.Account (DefaultAccount, to, withAccount, - withParam) -import Network.Ethereum.Api.Eth (accounts, blockNumber) -import Network.Ethereum.Api.Provider (Provider (..), Web3, - runWeb3With) -import Network.Ethereum.Api.Types (Quantity) - --- shared manager used throughout the helpers here to prevent hammering geth from ruining everything --- this also retrys on ALL exceptions, including ConnectionResetByPeer and stuff like that -sharedManager :: Manager -sharedManager = unsafePerformIO $ newManager defaultManagerSettings - { managerConnCount = 5 - , managerRetryableException = const False - , managerRawConnection = fixRawConnection retryOpenConnection - } - - where retryOpenConnection = threadDelay 500000 >> managerRawConnection defaultManagerSettings - fixRawConnection f = f `catch` (\(_ :: SomeException) -> fixRawConnection f) -{-# NOINLINE sharedManager #-} - -rpcUri :: IO String -rpcUri = liftIO (fromMaybe "http://localhost:8545" <$> lookupEnv "WEB3_PROVIDER") - -contract :: Address - -> DefaultAccount Web3 a - -> IO a -contract a = web3 . withAccount () . withParam (to .~ a) - -web3 :: Web3 a -> IO a -web3 ma = do - provider <- HttpProvider <$> rpcUri - v <- runWeb3With sharedManager provider ma - case v of - Left e -> print e >> threadDelay 1000000 >> web3 ma - Right v' -> return v' - -withAccounts :: ([Address] -> IO a) -> IO a -withAccounts f = web3 accounts >>= f - -withPrimaryEthereumAccount :: IO Address -withPrimaryEthereumAccount = withAccounts (pure . head) - -sleepSeconds :: Int -> IO () -sleepSeconds = threadDelay . (* 1000000) - -microtime :: IO Integer -microtime = numerator . toRational . (* 1000000) <$> getPOSIXTime - -awaitBlock :: Quantity -> IO () -awaitBlock bn = do - bn' <- web3 blockNumber - -- putStrLn $ "awaiting block " ++ show bn ++ ", currently " ++ show bn' - if bn' >= bn - then return () - else threadDelay 1000000 >> awaitBlock bn - -sleepBlocks :: Int -> IO () -sleepBlocks n = do - now <- web3 blockNumber - awaitBlock $ now + fromIntegral n diff --git a/test/Network/Ipfs/Api/Test/Key.hs b/test/Network/Ipfs/Api/Test/Key.hs new file mode 100644 --- /dev/null +++ b/test/Network/Ipfs/Api/Test/Key.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.Ipfs.Api.Test.Key +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unknown +-- +-- Key IPFS API testing module. +-- + +module Network.Ipfs.Api.Test.Key where + +import Control.Exception () +import Control.Monad.Trans +import Test.Hspec + +import qualified Network.Ipfs.Api.Key as Key +import Network.Ipfs.Api.Types (KeyDetailsObj (..), KeyObj (..)) +import Network.Ipfs.Client (runIpfs) + +main :: IO () +main = hspec $ do + describe "keyGen" $ do + it "should return the given key name in its response" $ runIpfs $ do + res <- Key.gen "TestA" "rsa" + liftIO $ keyName res `shouldBe` "TestA" + + it "KeyDetailsObj returned by KeyGen should be present in the KeyObj's list returned returned by KeyList" $ + runIpfs $ do + resGen <- Key.gen "TestB" "rsa" + resList <- Key.list + liftIO $ keys resList `shouldContain` [resGen] + + describe "keyRm" $ do + it "should return the given key name in its response" $ runIpfs $ do + res <- Key.rm "TestA" + liftIO $ (keyName $ Prelude.head $ keys res) `shouldBe` "TestA" + + it "KeyDetailsObj returned by KeyRm should not be present in the KeyObj's list returned returned by KeyList" $ + runIpfs $ do + resRm <- Key.rm "TestB" + resList <- Key.list + liftIO $ keys resList `shouldNotContain` keys resRm diff --git a/unit/Crypto/Ethereum/Test/SignatureSpec.hs b/unit/Crypto/Ethereum/Test/SignatureSpec.hs --- a/unit/Crypto/Ethereum/Test/SignatureSpec.hs +++ b/unit/Crypto/Ethereum/Test/SignatureSpec.hs @@ -6,9 +6,9 @@ import Test.Hspec import Test.Hspec.QuickCheck +import Crypto.Ecdsa.Utils (importKey) import Crypto.Ethereum.Signature (hashMessage, signMessage, signTransaction) -import Crypto.Ethereum.Utils (importKey) import Data.ByteArray.HexString (HexString) import Data.Solidity.Prim.Address (fromPubKey) import Network.Ethereum.Api.Types (Call (..)) diff --git a/unit/Data/Solidity/Test/AddressSpec.hs b/unit/Data/Solidity/Test/AddressSpec.hs --- a/unit/Data/Solidity/Test/AddressSpec.hs +++ b/unit/Data/Solidity/Test/AddressSpec.hs @@ -7,7 +7,7 @@ import Data.Monoid ((<>)) import Test.Hspec -import Crypto.Ethereum.Utils (derivePubKey, importKey) +import Crypto.Ecdsa.Utils (derivePubKey, importKey) import Data.ByteArray.HexString (HexString) import Data.Solidity.Prim.Address diff --git a/web3.cabal b/web3.cabal --- a/web3.cabal +++ b/web3.cabal @@ -1,15 +1,15 @@ -cabal-version: 2.4 +cabal-version: 2.2 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 52f53efab4c596377b85d0718660446c92da89530ee76214df53a18a0fdd589d +-- hash: 916c1e312da75f2dfe78e0e6a6613adc7b6a4e68a1da8d57e82be1facc937203 name: web3 -version: 0.8.4.0 -synopsis: Ethereum API for Haskell -description: Web3 is a Haskell client library for Ethereum +version: 0.9.0.0 +synopsis: Web3 API for Haskell. +description: Client library for Third Generation of Web. category: Network homepage: https://github.com/airalab/hs-web3#readme bug-reports: https://github.com/airalab/hs-web3/issues @@ -26,6 +26,7 @@ examples/token/ERC20.hs examples/token/ERC20.json examples/token/Main.hs + examples/polkadot/Main.hs test/contracts/Registry.json test/contracts/SimpleStorage.json test/contracts/ComplexStorage.json @@ -47,6 +48,8 @@ library exposed-modules: + Crypto.Ecdsa.Signature + Crypto.Ecdsa.Utils Crypto.Ethereum Crypto.Ethereum.Keyfile Crypto.Ethereum.Signature @@ -70,6 +73,7 @@ Data.Solidity.Prim.Tuple.TH Data.String.Extra Language.Solidity.Abi + Network.Ethereum Network.Ethereum.Account Network.Ethereum.Account.Class Network.Ethereum.Account.Default @@ -80,7 +84,6 @@ Network.Ethereum.Api.Eth Network.Ethereum.Api.Net Network.Ethereum.Api.Personal - Network.Ethereum.Api.Provider Network.Ethereum.Api.Types Network.Ethereum.Api.Web3 Network.Ethereum.Chain @@ -96,8 +99,46 @@ Network.Ethereum.Ens.Registry Network.Ethereum.Transaction Network.Ethereum.Unit - Network.Ethereum.Web3 + Network.Ipfs.Api.Bitswap + Network.Ipfs.Api.Block + Network.Ipfs.Api.Bootstrap + Network.Ipfs.Api.Cid + Network.Ipfs.Api.Config + Network.Ipfs.Api.Core + Network.Ipfs.Api.Dag + Network.Ipfs.Api.Dht + Network.Ipfs.Api.Files + Network.Ipfs.Api.Internal + Network.Ipfs.Api.Internal.Call + Network.Ipfs.Api.Internal.Stream + Network.Ipfs.Api.Key + Network.Ipfs.Api.Log + Network.Ipfs.Api.Object + Network.Ipfs.Api.Pin + Network.Ipfs.Api.Pubsub + Network.Ipfs.Api.Repo + Network.Ipfs.Api.Stats + Network.Ipfs.Api.Swarm + Network.Ipfs.Api.Types + Network.Ipfs.Api.Types.Stream + Network.Ipfs.Client Network.JsonRpc.TinyClient + Network.Polkadot.Api.Account + Network.Polkadot.Api.Author + Network.Polkadot.Api.Babe + Network.Polkadot.Api.Chain + Network.Polkadot.Api.Childstate + Network.Polkadot.Api.Contracts + Network.Polkadot.Api.Engine + Network.Polkadot.Api.Grandpa + Network.Polkadot.Api.Offchain + Network.Polkadot.Api.Payment + Network.Polkadot.Api.Rpc + Network.Polkadot.Api.State + Network.Polkadot.Api.System + Network.Polkadot.Api.Types + Network.Web3 + Network.Web3.Provider other-modules: Paths_web3 autogen-modules: @@ -109,16 +150,22 @@ OneTuple >=0.2.1 && <0.3 , aeson >=1.2.2.0 && <1.5 , async >=2.1.1.1 && <2.3 + , attoparsec >=0.13.2.1 && <0.14 , base >4.10 && <4.14 + , base58string >=0.10.0 && <0.11 , basement >=0.0.4 && <0.1 , bytestring >=0.10.8.1 && <0.11 , cereal >=0.5.4.0 && <0.6 , cryptonite >=0.23 && <0.27 , data-default >=0.7.1.1 && <0.8 + , errors >=2.2 && <2.4 , exceptions >=0.8.3 && <0.11 , generics-sop >=0.3.1.0 && <0.6 + , hspec >=2.4 && <2.8 , http-client >=0.5.7.1 && <0.7 , http-client-tls >=0.3.5.1 && <0.4 + , http-media >=0.7 && <0.8.1 + , http-types >=0.12 && <0.14 , machines >=0.6.3 && <0.8 , memory >=0.14.11 && <0.16 , microlens >=0.4.8.1 && <0.5 @@ -126,14 +173,20 @@ , microlens-mtl >=0.1.11.0 && <0.3 , microlens-th >=0.4.1.1 && <0.5 , mtl >=2.2.1 && <2.3 + , network >=2.6 && <3.2 , parsec >=3.1.11 && <3.2 , relapse >=1.0.0.0 && <2.0 + , servant >=0.13 && <0.17 + , servant-client >=0.13 && <0.17 , tagged >=0.8.5 && <0.9 + , tar >=0.5 && <0.6 , template-haskell >=2.12 && <2.16 , text >=1.2.2.2 && <1.3 , transformers >=0.5.2.0 && <0.6 + , unordered-containers >=0.2 && <0.3 , uuid-types >=1.0.3 && <1.1 , vinyl >=0.5.3 && <0.13 + , websockets >=0.11 && <0.13 if flag(debug) ghc-options: -ddump-splices if flag(compiler) @@ -157,13 +210,16 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Network.Ethereum.Web3.Test.ComplexStorageSpec - Network.Ethereum.Web3.Test.ERC20Spec - Network.Ethereum.Web3.Test.LinearizationSpec - Network.Ethereum.Web3.Test.LocalAccountSpec - Network.Ethereum.Web3.Test.RegistrySpec - Network.Ethereum.Web3.Test.SimpleStorageSpec - Network.Ethereum.Web3.Test.Utils + Network.Ethereum.Test.ComplexStorageSpec + Network.Ethereum.Test.ERC20Spec + Network.Ethereum.Test.LinearizationSpec + Network.Ethereum.Test.LocalAccountSpec + Network.Ethereum.Test.RegistrySpec + Network.Ethereum.Test.SimpleStorageSpec + Network.Ethereum.Test.Utils + Network.Ipfs.Api.Test.Key + Crypto.Ecdsa.Signature + Crypto.Ecdsa.Utils Crypto.Ethereum Crypto.Ethereum.Keyfile Crypto.Ethereum.Signature @@ -187,6 +243,7 @@ Data.Solidity.Prim.Tuple.TH Data.String.Extra Language.Solidity.Abi + Network.Ethereum Network.Ethereum.Account Network.Ethereum.Account.Class Network.Ethereum.Account.Default @@ -197,7 +254,6 @@ Network.Ethereum.Api.Eth Network.Ethereum.Api.Net Network.Ethereum.Api.Personal - Network.Ethereum.Api.Provider Network.Ethereum.Api.Types Network.Ethereum.Api.Web3 Network.Ethereum.Chain @@ -213,8 +269,46 @@ Network.Ethereum.Ens.Registry Network.Ethereum.Transaction Network.Ethereum.Unit - Network.Ethereum.Web3 + Network.Ipfs.Api.Bitswap + Network.Ipfs.Api.Block + Network.Ipfs.Api.Bootstrap + Network.Ipfs.Api.Cid + Network.Ipfs.Api.Config + Network.Ipfs.Api.Core + Network.Ipfs.Api.Dag + Network.Ipfs.Api.Dht + Network.Ipfs.Api.Files + Network.Ipfs.Api.Internal + Network.Ipfs.Api.Internal.Call + Network.Ipfs.Api.Internal.Stream + Network.Ipfs.Api.Key + Network.Ipfs.Api.Log + Network.Ipfs.Api.Object + Network.Ipfs.Api.Pin + Network.Ipfs.Api.Pubsub + Network.Ipfs.Api.Repo + Network.Ipfs.Api.Stats + Network.Ipfs.Api.Swarm + Network.Ipfs.Api.Types + Network.Ipfs.Api.Types.Stream + Network.Ipfs.Client Network.JsonRpc.TinyClient + Network.Polkadot.Api.Account + Network.Polkadot.Api.Author + Network.Polkadot.Api.Babe + Network.Polkadot.Api.Chain + Network.Polkadot.Api.Childstate + Network.Polkadot.Api.Contracts + Network.Polkadot.Api.Engine + Network.Polkadot.Api.Grandpa + Network.Polkadot.Api.Offchain + Network.Polkadot.Api.Payment + Network.Polkadot.Api.Rpc + Network.Polkadot.Api.State + Network.Polkadot.Api.System + Network.Polkadot.Api.Types + Network.Web3 + Network.Web3.Provider Paths_web3 hs-source-dirs: test @@ -224,12 +318,15 @@ OneTuple >=0.2.1 && <0.3 , aeson >=1.2.2.0 && <1.5 , async >=2.1.1.1 && <2.3 + , attoparsec >=0.13.2.1 && <0.14 , base >4.10 && <4.14 + , base58string >=0.10.0 && <0.11 , basement >=0.0.4 && <0.1 , bytestring >=0.10.8.1 && <0.11 , cereal >=0.5.4.0 && <0.6 , cryptonite >=0.23 && <0.27 , data-default >=0.7.1.1 && <0.8 + , errors >=2.2 && <2.4 , exceptions >=0.8.3 && <0.11 , generics-sop >=0.3.1.0 && <0.6 , hspec >=2.4.4 && <2.8 @@ -238,6 +335,8 @@ , hspec-expectations >=0.8.2 && <0.9 , http-client >=0.5.7.1 && <0.7 , http-client-tls >=0.3.5.1 && <0.4 + , http-media >=0.7 && <0.8.1 + , http-types >=0.12 && <0.14 , machines >=0.6.3 && <0.8 , memory >=0.14.11 && <0.16 , microlens >=0.4.8.1 && <0.5 @@ -245,18 +344,24 @@ , microlens-mtl >=0.1.11.0 && <0.3 , microlens-th >=0.4.1.1 && <0.5 , mtl >=2.2.1 && <2.3 + , network >=2.6 && <3.2 , parsec >=3.1.11 && <3.2 , random >=1.1 && <1.2 , relapse >=1.0.0.0 && <2.0 + , servant >=0.13 && <0.17 + , servant-client >=0.13 && <0.17 , split >=0.2.3 && <0.3 , stm >=2.4.4 && <2.6 , tagged >=0.8.5 && <0.9 + , tar >=0.5 && <0.6 , template-haskell >=2.12 && <2.16 , text >=1.2.2.2 && <1.3 , time >=1.6.0 && <1.11 , transformers >=0.5.2.0 && <0.6 + , unordered-containers >=0.2 && <0.3 , uuid-types >=1.0.3 && <1.1 , vinyl >=0.5.3 && <0.13 + , websockets >=0.11 && <0.13 if flag(debug) ghc-options: -ddump-splices if flag(compiler) @@ -291,6 +396,8 @@ Network.Ethereum.Contract.Test.THSpec Network.Ethereum.Web3.Test.EventSpec Network.Ethereum.Web3.Test.MethodDumpSpec + Crypto.Ecdsa.Signature + Crypto.Ecdsa.Utils Crypto.Ethereum Crypto.Ethereum.Keyfile Crypto.Ethereum.Signature @@ -314,6 +421,7 @@ Data.Solidity.Prim.Tuple.TH Data.String.Extra Language.Solidity.Abi + Network.Ethereum Network.Ethereum.Account Network.Ethereum.Account.Class Network.Ethereum.Account.Default @@ -324,7 +432,6 @@ Network.Ethereum.Api.Eth Network.Ethereum.Api.Net Network.Ethereum.Api.Personal - Network.Ethereum.Api.Provider Network.Ethereum.Api.Types Network.Ethereum.Api.Web3 Network.Ethereum.Chain @@ -340,8 +447,46 @@ Network.Ethereum.Ens.Registry Network.Ethereum.Transaction Network.Ethereum.Unit - Network.Ethereum.Web3 + Network.Ipfs.Api.Bitswap + Network.Ipfs.Api.Block + Network.Ipfs.Api.Bootstrap + Network.Ipfs.Api.Cid + Network.Ipfs.Api.Config + Network.Ipfs.Api.Core + Network.Ipfs.Api.Dag + Network.Ipfs.Api.Dht + Network.Ipfs.Api.Files + Network.Ipfs.Api.Internal + Network.Ipfs.Api.Internal.Call + Network.Ipfs.Api.Internal.Stream + Network.Ipfs.Api.Key + Network.Ipfs.Api.Log + Network.Ipfs.Api.Object + Network.Ipfs.Api.Pin + Network.Ipfs.Api.Pubsub + Network.Ipfs.Api.Repo + Network.Ipfs.Api.Stats + Network.Ipfs.Api.Swarm + Network.Ipfs.Api.Types + Network.Ipfs.Api.Types.Stream + Network.Ipfs.Client Network.JsonRpc.TinyClient + Network.Polkadot.Api.Account + Network.Polkadot.Api.Author + Network.Polkadot.Api.Babe + Network.Polkadot.Api.Chain + Network.Polkadot.Api.Childstate + Network.Polkadot.Api.Contracts + Network.Polkadot.Api.Engine + Network.Polkadot.Api.Grandpa + Network.Polkadot.Api.Offchain + Network.Polkadot.Api.Payment + Network.Polkadot.Api.Rpc + Network.Polkadot.Api.State + Network.Polkadot.Api.System + Network.Polkadot.Api.Types + Network.Web3 + Network.Web3.Provider Paths_web3 hs-source-dirs: unit @@ -351,12 +496,15 @@ OneTuple >=0.2.1 && <0.3 , aeson >=1.2.2.0 && <1.5 , async >=2.1.1.1 && <2.3 + , attoparsec >=0.13.2.1 && <0.14 , base >4.10 && <4.14 + , base58string >=0.10.0 && <0.11 , basement >=0.0.4 && <0.1 , bytestring >=0.10.8.1 && <0.11 , cereal >=0.5.4.0 && <0.6 , cryptonite >=0.23 && <0.27 , data-default >=0.7.1.1 && <0.8 + , errors >=2.2 && <2.4 , exceptions >=0.8.3 && <0.11 , generics-sop >=0.3.1.0 && <0.6 , hspec >=2.4.4 && <2.8 @@ -365,6 +513,8 @@ , hspec-expectations >=0.8.2 && <0.9 , http-client >=0.5.7.1 && <0.7 , http-client-tls >=0.3.5.1 && <0.4 + , http-media >=0.7 && <0.8.1 + , http-types >=0.12 && <0.14 , machines >=0.6.3 && <0.8 , memory >=0.14.11 && <0.16 , microlens >=0.4.8.1 && <0.5 @@ -372,14 +522,20 @@ , microlens-mtl >=0.1.11.0 && <0.3 , microlens-th >=0.4.1.1 && <0.5 , mtl >=2.2.1 && <2.3 + , network >=2.6 && <3.2 , parsec >=3.1.11 && <3.2 , relapse >=1.0.0.0 && <2.0 + , servant >=0.13 && <0.17 + , servant-client >=0.13 && <0.17 , tagged >=0.8.5 && <0.9 + , tar >=0.5 && <0.6 , template-haskell >=2.12 && <2.16 , text >=1.2.2.2 && <1.3 , transformers >=0.5.2.0 && <0.6 + , unordered-containers >=0.2 && <0.3 , uuid-types >=1.0.3 && <1.1 , vinyl >=0.5.3 && <0.13 + , websockets >=0.11 && <0.13 if flag(debug) ghc-options: -ddump-splices if flag(compiler)