web3-solidity (empty) → 1.0.0.0
raw patch · 24 files changed
+2285/−0 lines, 24 filesdep +OneTupledep +aesondep +basesetup-changed
Dependencies added: OneTuple, aeson, base, basement, bytestring, cereal, data-default, generics-sop, hspec, hspec-contrib, hspec-discover, hspec-expectations, memory, memory-hexstring, microlens, parsec, tagged, template-haskell, text, web3-crypto
Files
- LICENSE +211/−0
- Setup.hs +2/−0
- src/Data/Solidity/Abi.hs +68/−0
- src/Data/Solidity/Abi/Codec.hs +70/−0
- src/Data/Solidity/Abi/Generic.hs +122/−0
- src/Data/Solidity/Event.hs +143/−0
- src/Data/Solidity/Event/Internal.hs +135/−0
- src/Data/Solidity/Prim.hs +30/−0
- src/Data/Solidity/Prim/Address.hs +123/−0
- src/Data/Solidity/Prim/Bool.hs +25/−0
- src/Data/Solidity/Prim/Bytes.hs +129/−0
- src/Data/Solidity/Prim/Int.hs +140/−0
- src/Data/Solidity/Prim/List.hs +56/−0
- src/Data/Solidity/Prim/String.hs +29/−0
- src/Data/Solidity/Prim/Tagged.hs +37/−0
- src/Data/Solidity/Prim/Tuple.hs +38/−0
- src/Data/Solidity/Prim/Tuple/TH.hs +37/−0
- src/Language/Solidity/Abi.hs +336/−0
- tests/Data/Solidity/Test/AddressSpec.hs +62/−0
- tests/Data/Solidity/Test/EncodingSpec.hs +264/−0
- tests/Data/Solidity/Test/IntSpec.hs +33/−0
- tests/Language/Solidity/Test/AbiSpec.hs +63/−0
- tests/Spec.hs +1/−0
- web3-solidity.cabal +131/−0
+ LICENSE view
@@ -0,0 +1,211 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++END OF TERMS AND CONDITIONS++APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++Copyright 2016-2021 Aleksandr Krupenkin ++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.++ NOTE+ +Individual files contain the following tag instead of the full license+text.++ SPDX-License-Identifier: Apache-2.0++This enables machine processing of license information based on the SPDX+License Identifiers that are here available: http://spdx.org/licenses/
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Solidity/Abi.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Data.Solidity.Abi+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- The Application Binary Interface is the standard way to interact with contracts+-- in the Ethereum ecosystem, both from outside the blockchain and for contract-to-contract+-- interaction. Data is encoded according to its type, as described in this specification.+-- The encoding is not self describing and thus requires a schema in order to decode.+--++module Data.Solidity.Abi where++import Data.Proxy (Proxy)+import Data.Serialize (Get, Putter)+import Generics.SOP (Generic, Rep, from, to)++-- | A class for abi encoding datatype descriptions+class AbiType a where+ isDynamic :: Proxy a -> Bool++-- | A class for encoding datatypes to their abi encoding+--+-- If your compiler has support for the @DeriveGeneric@ and+-- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@),+-- the 'abiPut' method will have default generic implementations.+--+-- To use this option, simply add a @deriving 'Generic'@ clause+-- to your datatype and declare a 'AbiPut' instance for it without+-- giving a definition for 'abiPut'.+--+class AbiType a => AbiPut a where+ abiPut :: Putter a++ default abiPut :: (Generic a, Rep a ~ rep, GenericAbiPut rep) => Putter a+ abiPut = gAbiPut . from++-- | A class for encoding generically composed datatypes to their abi encoding+class GenericAbiPut a where+ gAbiPut :: Putter a++-- | A class for decoding datatypes from their abi encoding+--+-- If your compiler has support for the @DeriveGeneric@ and+-- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@),+-- the 'abiGet' method will have default generic implementations.+--+-- To use this option, simply add a @deriving 'Generic'@ clause+-- to your datatype and declare a 'AbiGet' instance for it without+-- giving a definition for 'abiGet'.+--+class AbiType a => AbiGet a where+ abiGet :: Get a++ default abiGet :: (Generic a, Rep a ~ rep, GenericAbiGet rep) => Get a+ abiGet = to <$> gAbiGet++-- | A class for decoding generically composed datatypes from their abi encoding+class GenericAbiGet a where+ gAbiGet :: Get a
+ src/Data/Solidity/Abi/Codec.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Data.Solidity.Abi.Codec+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Solidity contract ABI encoding functions.+--++module Data.Solidity.Abi.Codec+ (+ -- * @AbiPut@/@AbiGet@ type class encoding+ encode+ , decode++ -- * Generic encoding+ , encode'+ , decode'++ -- * Generic type re-export+ , Generic+ ) where++import Data.ByteArray (ByteArray, ByteArrayAccess, convert)+import Data.Serialize (runGet, runPut)+import Generics.SOP (Generic, Rep, from, to)++import Data.Solidity.Abi (AbiGet (..), AbiPut (..),+ GenericAbiGet (..),+ GenericAbiPut (..))+import Data.Solidity.Abi.Generic ()++-- | Encode datatype to Ethereum Abi-encoding+encode :: (AbiPut a, ByteArray ba)+ => a+ -> ba+{-# INLINE encode #-}+encode = convert . runPut . abiPut++-- | Generic driven version of 'encode'+encode' :: (Generic a,+ Rep a ~ rep,+ GenericAbiPut rep,+ ByteArray ba)+ => a+ -> ba+{-# INLINE encode' #-}+encode' = convert . runPut . gAbiPut . from++-- | Decode datatype from Ethereum Abi-encoding+decode :: (ByteArrayAccess ba, AbiGet a)+ => ba+ -> Either String a+{-# INLINE decode #-}+decode = runGet abiGet . convert++-- | Generic driven version of 'decode'+decode' :: (Generic a,+ Rep a ~ rep,+ GenericAbiGet rep,+ ByteArrayAccess ba)+ => ba+ -> Either String a+{-# INLINE decode' #-}+decode' = runGet (to <$> gAbiGet) . convert
+ src/Data/Solidity/Abi/Generic.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Data.Solidity.Abi.Generic+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- This module is internal, the purpose is to define helper classes and functions+-- to assist in encoding and decoding Solidity types for function calls and events.+-- The user of this library should have no need to use this directly in application code.+--++module Data.Solidity.Abi.Generic () where++import qualified Data.ByteString.Lazy as LBS+import Data.Int (Int64)+import qualified Data.List as L+import Data.Proxy (Proxy (..))+import Data.Serialize (Get, Put)+import Data.Serialize.Get (bytesRead, lookAheadE, skip)+import Data.Serialize.Put (runPutLazy)+import Generics.SOP (I (..), NP (..), NS (..), SOP (..))++import Data.Solidity.Abi (AbiGet (..), AbiPut (..), AbiType (..),+ GenericAbiGet (..), GenericAbiPut (..))+import Data.Solidity.Prim.Int (getWord256, putWord256)++data EncodedValue = EncodedValue+ { order :: Int64+ , offset :: Maybe Int64+ , encoding :: Put+ }++instance Eq EncodedValue where+ ev1 == ev2 = order ev1 == order ev2++instance Ord EncodedValue where+ compare ev1 ev2 = order ev1 `compare` order ev2++combineEncodedValues :: [EncodedValue] -> Put+combineEncodedValues encodings =+ let sortedEs = adjust headsOffset $ L.sort encodings+ encodings' = addTailOffsets headsOffset [] sortedEs+ in let heads = foldl (\acc EncodedValue{..} -> case offset of+ Nothing -> acc <> encoding+ Just o -> acc <> putWord256 (fromIntegral o)+ ) mempty encodings'+ tails = foldl (\acc EncodedValue{..} -> case offset of+ Nothing -> acc+ Just _ -> acc <> encoding+ ) mempty encodings'+ in heads <> tails+ where+ adjust :: Int64 -> [EncodedValue] -> [EncodedValue]+ adjust n = map (\ev -> ev {offset = (+) n <$> offset ev})+ addTailOffsets :: Int64 -> [EncodedValue] -> [EncodedValue] -> [EncodedValue]+ addTailOffsets init' acc es = case es of+ [] -> reverse acc+ (e : tail') -> case offset e of+ Nothing -> addTailOffsets init' (e : acc) tail'+ Just _ -> addTailOffsets init' (e : acc) (adjust (LBS.length . runPutLazy . encoding $ e) tail')+ headsOffset :: Int64+ headsOffset = foldl (\acc e -> case offset e of+ Nothing -> acc + (LBS.length . runPutLazy . encoding $ e)+ Just _ -> acc + 32+ ) 0 encodings++class AbiData a where+ _serialize :: [EncodedValue] -> a -> [EncodedValue]++instance AbiData (NP f '[]) where+ _serialize encoded _ = encoded++instance (AbiType b, AbiPut b, AbiData (NP I as)) => AbiData (NP I (b :as)) where+ _serialize encoded (I b :* a) =+ if isDynamic (Proxy :: Proxy b)+ then _serialize (dynEncoding : encoded) a+ else _serialize (staticEncoding : encoded) a+ where+ staticEncoding = EncodedValue { encoding = abiPut b+ , offset = Nothing+ , order = 1 + (fromInteger . toInteger . L.length $ encoded)+ }+ dynEncoding = EncodedValue { encoding = abiPut b+ , offset = Just 0+ , order = 1 + (fromInteger . toInteger . L.length $ encoded)+ }++instance AbiData (NP f as) => GenericAbiPut (SOP f '[as]) where+ gAbiPut (SOP (Z a)) = combineEncodedValues $ _serialize [] a+ gAbiPut _ = error "Impossible branch"++instance GenericAbiGet (NP f '[]) where+ gAbiGet = return Nil++instance (AbiGet a, GenericAbiGet (NP I as)) => GenericAbiGet (NP I (a : as)) where+ gAbiGet = (:*) <$> (I <$> factorParser) <*> gAbiGet++instance GenericAbiGet (NP f as) => GenericAbiGet (SOP f '[as]) where+ gAbiGet = SOP . Z <$> gAbiGet++factorParser :: forall a . AbiGet a => Get a+factorParser+ | not $ isDynamic (Proxy :: Proxy a) = abiGet+ | otherwise = do+ dataOffset <- fromIntegral <$> getWord256+ currentOffset <- bytesRead+ Left x <- lookAheadE $ do+ skip (dataOffset - currentOffset)+ Left <$> abiGet+ return x
+ src/Data/Solidity/Event.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Data.Solidity.Event+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : unportable+--+-- This module is internal, the purpose is to define+-- helper classes and functions to assist in event decoding.+-- The user of this library should have no need to use+-- this directly in application code.+--++module Data.Solidity.Event+ (+ DecodeEvent(..)+ , IndexedEvent(..)+ ) where++import Data.ByteArray (ByteArrayAccess)+import Data.Proxy (Proxy (..))+import Generics.SOP (Generic, I (..), NP (..),+ NS (..), Rep, SOP (..), from, to)++import Data.Solidity.Abi (AbiGet)+import Data.Solidity.Abi.Codec (decode)+import Data.Solidity.Event.Internal++-- | Indexed event args come back in as a list of encoded values. 'ArrayParser'+-- | is used to decode these values so that they can be used to reconstruct the+-- | entire decoded event.+class ArrayParser a where+ arrayParser :: ByteArrayAccess ba+ => [ba]+ -> Either String a++instance ArrayParser (NP f '[]) where+ arrayParser _ = Right Nil++instance (ArrayParser (NP I as), AbiGet a)+ => ArrayParser (NP I (a : as)) where+ arrayParser [] = Left "Empty"+ arrayParser (a : as) = do+ a' <- decode a+ as' <- arrayParser as+ return $ I a' :* as'++instance ArrayParser (NP f as) => ArrayParser (SOP f '[as]) where+ arrayParser = fmap (SOP . Z) . arrayParser++genericArrayParser :: ( Generic a+ , Rep a ~ rep+ , ArrayParser rep+ , ByteArrayAccess ba+ )+ => [ba]+ -> Either String a+genericArrayParser = fmap to . arrayParser++--------------------------------------------------------------------------------+-- Event Parsing+--------------------------------------------------------------------------------++data Event i ni = Event i ni++-- | 'parseChange' decodes both the indexed and non-indexed event components.+parseChange :: ( Generic i+ , Rep i ~ irep+ , ArrayParser irep+ , AbiGet ni+ , ByteArrayAccess ba+ )+ => [ba]+ -- ^ event change topics+ -> ba+ -- ^ event change data+ -> Bool+ -- ^ is anonymous event+ -> Either String (Event i ni)+parseChange topics data_ anonymous =+ Event <$> genericArrayParser topics' <*> decode data_+ where+ topics' | anonymous = topics+ | otherwise = tail topics++class IndexedEvent i ni e | e -> i ni where+ isAnonymous :: Proxy e -> Bool++-- | 'CombineChange' is a class which indicates that given event components of types 'i'+-- | and 'ni', we can construct an event of type 'e'. The functional dependency is valid+-- | becasue of how the template haskell generates the event types.+class CombineChange i ni e | e -> i ni where+ combineChange :: i -> ni -> e++instance ( Generic i+ , Rep i ~ irep+ , Generic ni+ , Rep ni ~ nirep+ , Generic e+ , Rep e ~ erep+ , HListRep irep hli+ , HListRep nirep hlni+ , MergeIndexedArguments hli hlni+ , MergeIndexedArguments' hli hlni ~ hle+ , HListRep erep hle+ , IndexedEvent i ni e+ ) => CombineChange i ni e where+ combineChange i ni =+ let hli = toHList . from $ i+ hlni = toHList . from $ ni+ hle = mergeIndexedArguments hli hlni+ in to . fromHList $ hle++class DecodeEvent i ni e | e -> i ni where+ decodeEvent :: ByteArrayAccess ba => [ba] -> ba -> Either String e++instance ( IndexedEvent i ni e+ , Generic i+ , Rep i ~ SOP I '[hli]+ , AbiGet ni+ , Generic ni+ , Rep ni ~ SOP I '[hlni]+ , Generic e+ , Rep e ~ SOP I '[hle]+ , CombineChange i ni e+ , ArrayParser (SOP I '[hli])+ ) => DecodeEvent i ni e where+ decodeEvent topics data_ = do+ let anonymous = isAnonymous (Proxy :: Proxy e)+ (Event i ni :: Event i ni) <- parseChange topics data_ anonymous+ return $ combineChange i ni
+ src/Data/Solidity/Event/Internal.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Data.Solidity.Event.Internal+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : unportable+--+-- This module is internal, the purpose is to define helper classes and types+-- to assist in event decoding. The user of this library should have no need to use+-- this directly in application code.+--++module Data.Solidity.Event.Internal where++import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.Tagged (Tagged (..))+import Generics.SOP (I (..), NP (..), NS (..), SOP (..))+import GHC.TypeLits (CmpNat)++data HList :: [Type] -> Type where+ HNil :: HList '[]+ (:<) :: a -> HList as -> HList (a : as)++infixr 0 :<++-- | Generic representation to HList representation+class HListRep a xs | a -> xs, a -> xs where+ toHList :: a -> HList xs+ fromHList :: HList xs -> a++instance HListRep (NP I '[]) '[] where+ toHList _ = HNil+ fromHList _ = Nil++instance HListRep (NP I as) as => HListRep (NP I (a:as)) (a:as) where+ toHList (I a :* rest) = a :< toHList rest+ fromHList (a :< rest) = I a :* fromHList rest++instance HListRep (NP f as') as => HListRep (SOP f '[as']) as where+ toHList (SOP (Z rep)) = toHList rep+ toHList _ = error "Impossible branch"+ fromHList = SOP . Z . fromHList++-- | Sort a Tagged HList+class Sort (xs :: [Type]) where+ type Sort' xs :: [Type]+ sort :: HList xs -> HList (Sort' xs)++instance Sort '[] where+ type Sort' '[] = '[]+ sort HNil = HNil++instance (Sort xs, Insert x (Sort' xs)) => Sort (x : xs) where+ type Sort' (x : xs) = Insert' x (Sort' xs)+ sort (x :< xs) = insert x (sort xs)++class Insert (x :: Type) (xs :: [Type]) where+ type Insert' x xs :: [Type]+ insert :: x -> HList xs -> HList (Insert' x xs)++instance Insert x '[] where+ type Insert' x '[] = '[x]+ insert x HNil = x :< HNil++instance InsertCmp (CmpNat n m) (Tagged n x) (Tagged m y) ys => Insert (Tagged n x) (Tagged m y : ys) where+ type Insert' (Tagged n x) (Tagged m y : ys) = InsertCmp' (CmpNat n m) (Tagged n x) (Tagged m y) ys+ insert (x :: Tagged n x) ((y :: Tagged m y) :< ys) = insertCmp (Proxy :: Proxy (CmpNat n m)) x y ys++class InsertCmp (b :: Ordering) (x :: Type) (y :: Type) (ys :: [Type]) where+ type InsertCmp' b x y ys :: [Type]+ insertCmp :: Proxy (b :: Ordering) -> x -> y -> HList ys -> HList (InsertCmp' b x y ys)++instance InsertCmp 'LT x y ys where+ type InsertCmp' 'LT x y ys = x : (y : ys)+ insertCmp _ x y ys = x :< y :< ys++instance Insert x ys => InsertCmp 'GT x y ys where+ type InsertCmp' 'GT x y ys = y : Insert' x ys+ insertCmp _ x y ys = y :< insert x ys++-- | Unwrap all the Tagged items in an HList+class UnTag t where+ type UnTag' t :: [Type]+ unTag :: HList t -> HList (UnTag' t)++instance UnTag '[] where+ type UnTag' '[] = '[]+ unTag a = a++instance UnTag ts => UnTag (Tagged n a : ts) where+ type UnTag' (Tagged n a : ts) = a : UnTag' ts+ unTag (Tagged a :< ts) = a :< unTag ts++class HListMerge (as :: [Type]) (bs :: [Type]) where+ type Concat as bs :: [Type]+ mergeHList :: HList as -> HList bs -> HList (Concat as bs)++instance HListMerge '[] bs where+ type Concat '[] bs = bs+ mergeHList _ bs = bs++instance HListMerge as bs => HListMerge (a : as) bs where+ type Concat (a : as) bs = a : Concat as bs+ mergeHList (a :< as) bs = a :< mergeHList as bs++class HListMergeSort as bs where+ type MergeSort' as bs :: [Type]+ mergeSortHList :: HList as -> HList bs -> HList (MergeSort' as bs)++instance (HListMerge as bs, Concat as bs ~ cs, Sort cs, Sort' cs ~ cs') => HListMergeSort as bs where+ type MergeSort' as bs = Sort' (Concat as bs)+ mergeSortHList as bs = sort $ (mergeHList as bs :: HList cs)++class MergeIndexedArguments as bs where+ type MergeIndexedArguments' as bs :: [Type]+ mergeIndexedArguments :: HList as -> HList bs -> HList (MergeIndexedArguments' as bs)++instance (HListMergeSort as bs, MergeSort' as bs ~ cs, UnTag cs, UnTag cs' ~ ds) => MergeIndexedArguments as bs where+ type MergeIndexedArguments' as bs = (UnTag' (MergeSort' as bs))+ mergeIndexedArguments as bs = unTag $ mergeSortHList as bs
+ src/Data/Solidity/Prim.hs view
@@ -0,0 +1,30 @@+-- |+-- Module : Data.Solidity.Prim+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Solidity primitive data types.+--++module Data.Solidity.Prim+ (+ Address+ , Bytes+ , BytesN+ , IntN+ , UIntN+ , ListN+ ) where++import Data.Solidity.Prim.Address (Address)+import Data.Solidity.Prim.Bool ()+import Data.Solidity.Prim.Bytes (Bytes, BytesN)+import Data.Solidity.Prim.Int (IntN, UIntN)+import Data.Solidity.Prim.List (ListN)+import Data.Solidity.Prim.String ()+import Data.Solidity.Prim.Tagged ()+import Data.Solidity.Prim.Tuple ()
+ src/Data/Solidity/Prim/Address.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Data.Solidity.Prim.Address+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Ethreum account address.+--++module Data.Solidity.Prim.Address+ (+ -- * The @Address@ type+ Address++ -- * Hex string encoding+ , toHexString+ , fromHexString++ -- * Derive address from public key+ , fromPubKey++ -- * EIP55 Mix-case checksum address encoding+ , toChecksum+ , verifyChecksum+ ) where++import Control.Monad ((<=<))+import Crypto.Ethereum (PublicKey)+import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.Bits ((.&.))+import Data.Bool (bool)+import Data.ByteArray (zero)+import qualified Data.ByteArray as BA (drop)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS (take, unpack)+import qualified Data.ByteString.Char8 as C8 (drop, length, pack, unpack)+import qualified Data.Char as C (toLower, toUpper)+import Data.Default (Default (..))+import Data.String (IsString (..))+import Data.Text.Encoding as T (encodeUtf8)+import Generics.SOP (Generic)+import qualified GHC.Generics as GHC (Generic)++import Crypto.Ecdsa.Utils (exportPubKey)+import Crypto.Ethereum.Utils (keccak256)+import Data.ByteArray.HexString (HexString, fromBytes, toBytes,+ toText)+import Data.Solidity.Abi (AbiGet (..), AbiPut (..),+ AbiType (..))+import Data.Solidity.Abi.Codec (decode, encode)+import Data.Solidity.Prim.Int (UIntN)++-- | Ethereum account address+newtype Address = Address { unAddress :: UIntN 160 }+ deriving (Eq, Ord, GHC.Generic)++instance Generic Address++instance Default Address where+ def = Address 0++instance Show Address where+ show = show . toChecksum . T.encodeUtf8 . toText . toHexString++instance IsString Address where+ fromString = either error id . fromHexString . fromString++instance AbiType Address where+ isDynamic _ = False++instance AbiGet Address where+ abiGet = Address <$> abiGet++instance AbiPut Address where+ abiPut = abiPut . unAddress++instance FromJSON Address where+ parseJSON = (either fail pure . fromHexString) <=< parseJSON++instance ToJSON Address where+ toJSON = toJSON . toHexString++-- | Derive address from secp256k1 public key+fromPubKey :: PublicKey -> Address+fromPubKey key =+ case decode $ zero 12 <> toAddress (exportPubKey key) of+ Right a -> a+ Left e -> error $ "Impossible error: " ++ e+ where+ toAddress :: HexString -> HexString+ toAddress = BA.drop 12 . keccak256++-- | Decode address from hex string+fromHexString :: HexString -> Either String Address+fromHexString bs+ | bslen == 20 = decode (zero 12 <> toBytes bs :: ByteString)+ | otherwise = Left $ "Incorrect address length: " ++ show bslen+ where bslen = C8.length (toBytes bs)++-- | Encode address to hex string+toHexString :: Address -> HexString+toHexString = fromBytes . C8.drop 12 . encode++-- | Encode address with mixed-case checksum+-- https://github.com/ethereum/EIPs/blob/master/EIPS/eip-55.md+toChecksum :: ByteString -> ByteString+toChecksum addr = ("0x" <>) . C8.pack $ zipWith ($) upcaseVector lower+ where+ 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++-- | Verify mixed-case address checksum+-- https://github.com/ethereum/EIPs/blob/master/EIPS/eip-55.md+verifyChecksum :: ByteString -> Bool+verifyChecksum = toChecksum >>= (==)
+ src/Data/Solidity/Prim/Bool.hs view
@@ -0,0 +1,25 @@+-- |+-- Module : Data.Solidity.Prim.Bool+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Ethereum Abi boolean type.+--++module Data.Solidity.Prim.Bool () where++import Data.Solidity.Abi (AbiGet (..), AbiPut (..), AbiType (..))+import Data.Solidity.Prim.Int (getWord256, putWord256)++instance AbiType Bool where+ isDynamic _ = False++instance AbiGet Bool where+ abiGet = toEnum . fromIntegral <$> getWord256++instance AbiPut Bool where+ abiPut = putWord256 . fromIntegral . fromEnum
+ src/Data/Solidity/Prim/Bytes.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Data.Solidity.Prim.Bytes+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Bytes and BytesN primitive types.+--++module Data.Solidity.Prim.Bytes+ (+ -- * The dynamic length @Bytes@ type+ Bytes++ -- * The fixed length @BytesN@ type+ , BytesN+ ) where++import Control.Monad (unless, void)+import Data.Aeson (FromJSON (..), ToJSON (..),+ Value (String))+import Data.ByteArray (Bytes, convert, length, zero)+import Data.ByteArray.Encoding (Base (Base16), convertFromBase,+ convertToBase)+import Data.ByteArray.Sized (SizedByteArray, unSizedByteArray,+ unsafeFromByteArrayAccess)+import qualified Data.ByteArray.Sized as S (take)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8+import Data.Proxy (Proxy (..))+import Data.Serialize (Get, Putter, getBytes, putByteString)+import Data.String (IsString (..))+import qualified Data.Text as T (append, drop, take)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import GHC.TypeLits+import Prelude hiding (length)++import Data.Solidity.Abi (AbiGet (..), AbiPut (..),+ AbiType (..))+import Data.Solidity.Prim.Int (getWord256, putWord256)++instance AbiType ByteString where+ isDynamic _ = True++instance AbiGet ByteString where+ abiGet = abiGetByteString++instance AbiPut ByteString where+ abiPut = abiPutByteString++instance AbiType Bytes where+ isDynamic _ = True++instance AbiGet Bytes where+ abiGet = convert <$> abiGetByteString++instance AbiPut Bytes where+ abiPut = abiPutByteString . convert++instance IsString Bytes where+ fromString ('0' : 'x' : hex) = either error id $ convertFromBase Base16 (C8.pack hex)+ fromString str = convert (C8.pack str)++instance FromJSON Bytes where+ parseJSON (String hex)+ | T.take 2 hex == "0x" =+ either fail pure $ convertFromBase Base16 $ encodeUtf8 $ T.drop 2 hex+ | otherwise = fail "Hex string should have '0x' prefix"+ parseJSON _ = fail "Bytes should be encoded as hex string"++instance ToJSON Bytes where+ toJSON = toJSON . T.append "0x" . decodeUtf8 . convertToBase Base16++-- | Sized byte array with fixed length in bytes+type BytesN n = SizedByteArray n Bytes++instance (n <= 32) => AbiType (BytesN n) where+ isDynamic _ = False++instance (KnownNat n, n <= 32) => AbiGet (BytesN n) where+ abiGet = do+ ba <- unsafeFromByteArrayAccess <$> getBytes 32+ return $ S.take (ba :: BytesN 32)++instance (KnownNat n, n <= 32) => AbiPut (BytesN n) where+ abiPut ba = putByteString $ convert ba <> zero (32 - len)+ where len = fromIntegral $ natVal (Proxy :: Proxy n)++instance (KnownNat n, n <= 32) => IsString (BytesN n) where+ fromString s = unsafeFromByteArrayAccess padded+ where bytes = fromString s :: Bytes+ len = fromIntegral $ natVal (Proxy :: Proxy n)+ padded = bytes <> zero (len - length bytes)++instance (KnownNat n, n <= 32) => FromJSON (BytesN n) where+ parseJSON v = do ba <- parseJSON v+ return $ unsafeFromByteArrayAccess (ba :: Bytes)++instance (KnownNat n, n <= 32) => ToJSON (BytesN n) where+ toJSON ba = toJSON (unSizedByteArray ba :: Bytes)++abiGetByteString :: Get ByteString+abiGetByteString = do+ len <- fromIntegral <$> getWord256+ res <- getBytes len+ let remainder = len `mod` 32+ unless (remainder == 0) $+ void $ getBytes (32 - remainder)+ pure res++abiPutByteString :: Putter ByteString+abiPutByteString bs = do+ putWord256 $ fromIntegral len+ putByteString bs+ unless (remainder == 0) $+ putByteString $ zero (32 - remainder)+ where len = length bs+ remainder = len `mod` 32
+ src/Data/Solidity/Prim/Int.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Data.Solidity.Prim.Int+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Ethereum Abi intN and uintN types.+--++module Data.Solidity.Prim.Int+ (+ -- * The @IntN@ type+ IntN++ -- * The @UIntN@ type+ , UIntN++ -- * @Word256@ serializers+ , getWord256+ , putWord256+ ) where++import qualified Basement.Numerical.Number as Basement (toInteger)+import Basement.Types.Word256 (Word256 (Word256))+import qualified Basement.Types.Word256 as Basement (quot, rem)+import Data.Bits (Bits (testBit), (.&.))+import Data.Proxy (Proxy (..))+import Data.Serialize (Get, Putter, Serialize (get, put))+import GHC.Generics (Generic)+import GHC.TypeLits++import Data.Solidity.Abi (AbiGet (..), AbiPut (..),+ AbiType (..))++instance Real Word256 where+ toRational = toRational . toInteger++instance Integral Word256 where+ toInteger = Basement.toInteger+ quotRem a b = (Basement.quot a b, Basement.rem a b)++-- | Unsigned integer with fixed length in bits.+newtype UIntN (n :: Nat) = UIntN { unUIntN :: Word256 }+ deriving (Eq, Ord, Enum, Bits, Generic)++instance (KnownNat n, n <= 256) => Num (UIntN n) where+ a + b = fromInteger (toInteger a + toInteger b)+ a - b = fromInteger (toInteger a - toInteger b)+ a * b = fromInteger (toInteger a * toInteger b)+ abs = fromInteger . abs . toInteger+ negate = fromInteger . negate . toInteger+ signum = fromInteger . signum . toInteger+ fromInteger x+ | x >= 0 = mask $ UIntN (fromInteger x)+ | otherwise = mask $ UIntN (fromInteger $ 2 ^ 256 + x)+ where+ mask = (maxBound .&.) :: UIntN n -> UIntN n++instance (KnownNat n, n <= 256) => Show (UIntN n) where+ show = show . unUIntN++instance (KnownNat n, n <= 256) => Bounded (UIntN n) where+ minBound = UIntN 0+ maxBound = UIntN $ 2 ^ natVal (Proxy :: Proxy n) - 1++instance (KnownNat n, n <= 256) => Real (UIntN n) where+ toRational = toRational . toInteger++instance (KnownNat n, n <= 256) => Integral (UIntN n) where+ toInteger = toInteger . unUIntN+ quotRem (UIntN a) (UIntN b) = (UIntN $ quot a b, UIntN $ rem a b)++instance (n <= 256) => AbiType (UIntN n) where+ isDynamic _ = False++instance (n <= 256) => AbiGet (UIntN n) where+ abiGet = UIntN <$> getWord256++instance (n <= 256) => AbiPut (UIntN n) where+ abiPut = putWord256 . unUIntN++-- | Signed integer with fixed length in bits.+newtype IntN (n :: Nat) = IntN { unIntN :: Word256 }+ deriving (Eq, Ord, Enum, Bits, Generic)++instance (KnownNat n, n <= 256) => Show (IntN n) where+ show = show . toInteger++instance (KnownNat n, n <= 256) => Bounded (IntN n) where+ minBound = IntN $ negate $ 2 ^ (natVal (Proxy :: Proxy (n :: Nat)) - 1)+ maxBound = IntN $ 2 ^ (natVal (Proxy :: Proxy (n :: Nat)) - 1) - 1++instance (KnownNat n, n <= 256) => Num (IntN n) where+ a + b = fromInteger (toInteger a + toInteger b)+ a - b = fromInteger (toInteger a - toInteger b)+ a * b = fromInteger (toInteger a * toInteger b)+ abs = fromInteger . abs . toInteger+ negate = fromInteger . negate . toInteger+ signum = fromInteger . signum . toInteger+ fromInteger x+ | x >= 0 = IntN (fromInteger x)+ | otherwise = IntN (fromInteger $ 2 ^ 256 + x)++instance (KnownNat n, n <= 256) => Real (IntN n) where+ toRational = toRational . toInteger++instance (KnownNat n, n <= 256) => Integral (IntN n) where+ quotRem (IntN a) (IntN b) = (IntN $ quot a b, IntN $ rem a b)+ toInteger x+ | testBit x 255 = toInteger (unIntN x) - 2 ^ 256+ | otherwise = toInteger $ unIntN x++instance (n <= 256) => AbiType (IntN n) where+ isDynamic _ = False++instance (n <= 256) => AbiGet (IntN n) where+ abiGet = IntN <$> getWord256++instance (n <= 256) => AbiPut (IntN n) where+ abiPut = putWord256 . unIntN++-- | Serialize 256 bit unsigned integer.+putWord256 :: Putter Word256+putWord256 (Word256 a3 a2 a1 a0) =+ put a3 >> put a2 >> put a1 >> put a0++-- | Deserialize 256 bit unsigned integer.+getWord256 :: Get Word256+getWord256 = Word256 <$> get <*> get <*> get <*> get
+ src/Data/Solidity/Prim/List.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Data.Solidity.Prim.List+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Ethereum Abi dynamic and static size vectors based on linked lists.+--++module Data.Solidity.Prim.List+ (+ -- * Fixed size linked list+ ListN+ ) where++import Basement.Nat (NatWithinBound)+import Basement.Sized.List (ListN, toListN_, unListN)+import qualified Basement.Sized.List as SL (mapM_, replicateM)+import Control.Monad (replicateM)+import GHC.Exts (IsList (..))+import GHC.TypeLits (KnownNat)++import Data.Solidity.Abi (AbiGet (..), AbiPut (..), AbiType (..))+import Data.Solidity.Prim.Int (getWord256, putWord256)++instance AbiType [a] where+ isDynamic _ = True++instance AbiPut a => AbiPut [a] where+ abiPut l = do putWord256 $ fromIntegral (length l)+ foldMap abiPut l++instance AbiGet a => AbiGet [a] where+ abiGet = do len <- fromIntegral <$> getWord256+ replicateM len abiGet++instance AbiType (ListN n a) where+ isDynamic _ = False++instance AbiPut a => AbiPut (ListN n a) where+ abiPut = SL.mapM_ abiPut++instance (NatWithinBound Int n, KnownNat n, AbiGet a) => AbiGet (ListN n a) where+ abiGet = SL.replicateM abiGet++instance (NatWithinBound Int n, KnownNat n) => IsList (ListN n a) where+ type Item (ListN n a) = a+ fromList = toListN_+ toList = unListN
+ src/Data/Solidity/Prim/String.hs view
@@ -0,0 +1,29 @@+-- |+-- Module : Data.Solidity.Prim.String+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Ethereum Abi UTF8-encoded string type.+--++module Data.Solidity.Prim.String where++import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)++import Data.Solidity.Abi (AbiGet (..), AbiPut (..),+ AbiType (..))+import Data.Solidity.Prim.Bytes ()++instance AbiType Text where+ isDynamic _ = True++instance AbiPut Text where+ abiPut = abiPut . encodeUtf8++instance AbiGet Text where+ abiGet = decodeUtf8 <$> abiGet
+ src/Data/Solidity/Prim/Tagged.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : Data.Solidity.Prim.Tagged+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Ethereum Abi tagged types.+--++module Data.Solidity.Prim.Tagged+ (+ -- * The @Tagged@ type+ Tagged+ ) where++import Data.Proxy (Proxy (..))+import Data.Tagged (Tagged (..))+import Generics.SOP (Generic)++import Data.Solidity.Abi (AbiGet (..), AbiPut (..), AbiType (..))++instance AbiType a => AbiType (Tagged t a) where+ isDynamic _ = isDynamic (Proxy :: Proxy a)++instance AbiPut a => AbiPut (Tagged t a) where+ abiPut (Tagged a) = abiPut a++instance AbiGet a => AbiGet (Tagged t a) where+ abiGet = Tagged <$> abiGet++instance Generic a => Generic (Tagged t a)
+ src/Data/Solidity/Prim/Tuple.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Data.Solidity.Prim.Tuple+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- Tuple type abi encoding instances.+--++module Data.Solidity.Prim.Tuple where++import Data.Proxy (Proxy (..))+import Data.Tuple.OneTuple (OneTuple (..))+import Generics.SOP (Generic)+import qualified GHC.Generics as GHC (Generic)++import Data.Solidity.Abi (AbiGet, AbiPut, AbiType (..))+import Data.Solidity.Abi.Generic ()+import Data.Solidity.Prim.Tuple.TH (tupleDecs)++deriving instance GHC.Generic (OneTuple a)+instance Generic (OneTuple a)++instance AbiType a => AbiType (OneTuple a) where+ isDynamic _ = isDynamic (Proxy :: Proxy a)++instance AbiGet a => AbiGet (OneTuple a)+instance AbiPut a => AbiPut (OneTuple a)++$(concat <$> mapM tupleDecs [2..20])
+ src/Data/Solidity/Prim/Tuple/TH.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Data.Solidity.Prim.Tuple.TH+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- This module is for internal usage only.+-- It contains tuple abi encoding template haskell generator.+--++module Data.Solidity.Prim.Tuple.TH (tupleDecs) where+++import Control.Monad (replicateM)+import Data.Proxy+import Language.Haskell.TH (DecsQ, Type (VarT), appT, clause, conT,+ cxt, funD, instanceD, listE, newName, normalB,+ tupleT)++import Data.Solidity.Abi (AbiGet, AbiPut, AbiType (..))++tupleDecs :: Int -> DecsQ+tupleDecs n = do+ vars <- replicateM n $ newName "a"+ let types = fmap (pure . VarT) vars+ areDynamic = listE $ flip fmap types $ \t -> [| isDynamic (Proxy :: Proxy $(t)) |]++ sequence $+ [ instanceD (cxt $ map (appT $ conT ''AbiType) types) (appT (conT ''AbiType) (foldl appT (tupleT n) types))+ [funD 'isDynamic [clause [] (normalB [|const (or $(areDynamic))|]) []]]+ , instanceD (cxt $ map (appT $ conT ''AbiGet) types) (appT (conT ''AbiGet) (foldl appT (tupleT n) types)) []+ , instanceD (cxt $ map (appT $ conT ''AbiPut) types) (appT (conT ''AbiPut) (foldl appT (tupleT n) types)) [] ]
+ src/Language/Solidity/Abi.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Data.Solidity.Abi.Json+-- Copyright : Aleksandr Krupenkin 2016-2021+-- License : Apache-2.0+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : noportable+--+-- JSON encoded contract ABI parsers.+--++module Language.Solidity.Abi+ (+ -- * Contract ABI declarations+ ContractAbi(..)+ , Declaration(..)+ , FunctionArg(..)+ , EventArg(..)+ , StateMutability(..)++ -- * Method/Event id encoder+ , signature+ , methodId+ , eventId++ -- * Solidity type parser+ , SolidityType(..)+ , parseSolidityFunctionArgType+ , parseSolidityEventArgType+ ) where++import Control.Monad (void)+import Crypto.Ethereum.Utils (keccak256)+import Data.Aeson (FromJSON (parseJSON), Options (constructorTagModifier, fieldLabelModifier, sumEncoding),+ SumEncoding (TaggedObject),+ ToJSON (toJSON), defaultOptions, withObject, (.:), (.:?))+import Data.Aeson.TH (deriveJSON, deriveToJSON)+import qualified Data.ByteArray as A (take)+import Data.ByteArray.HexString (toText)+import Data.Char (toLower)+import Data.Text (Text)+import qualified Data.Text as T (dropEnd, unlines, unpack)+import Data.Text.Encoding (encodeUtf8)+import Lens.Micro (over, _head)+import Text.Parsec (ParseError, char, choice, digit, eof,+ lookAhead, many1, manyTill,+ optionMaybe, parse, string, try,+ (<|>))+import Text.Parsec.Text (Parser)++-- | Method argument+data FunctionArg = FunctionArg+ { funArgName :: Text+ -- ^ Argument name+ , funArgType :: Text+ -- ^ Argument type+ , funArgComponents :: Maybe [FunctionArg]+ -- ^ Argument components for tuples+ }+ deriving (Show, Eq, Ord)++$(deriveJSON+ (defaultOptions {fieldLabelModifier = over _head toLower . drop 6})+ ''FunctionArg)++-- | Event argument+data EventArg = EventArg+ { eveArgName :: Text+ -- ^ Argument name+ , eveArgType :: Text+ -- ^ Argument type+ , eveArgIndexed :: Bool+ -- ^ Argument is indexed (e.g. placed on topics of event)+ }+ deriving (Show, Eq, Ord)++$(deriveJSON+ (defaultOptions {fieldLabelModifier = over _head toLower . drop 6})+ ''EventArg)++data StateMutability+ = SMPure+ | SMView+ | SMPayable+ | SMNonPayable+ deriving (Eq, Ord, Show)++-- | Elementary contract interface item+data Declaration = DConstructor+ { conInputs :: [FunctionArg]+ -- ^ Contract constructor+ }+ | DFunction+ { funName :: Text+ , funConstant :: Bool+ , funInputs :: [FunctionArg]+ , funOutputs :: Maybe [FunctionArg]+ -- ^ Method+ }+ | DEvent+ { eveName :: Text+ , eveInputs :: [EventArg]+ , eveAnonymous :: Bool+ -- ^ Event+ }+ | DFallback+ { falPayable :: Bool+ -- ^ Fallback function+ }+ deriving Show++instance Eq Declaration where+ (DConstructor a) == (DConstructor b) = length a == length b+ (DFunction a _ _ _) == (DFunction b _ _ _) = a == b+ (DEvent a _ _) == (DEvent b _ _) = a == b+ (DFallback _) == (DFallback _) = True+ (==) _ _ = False++instance Ord Declaration where+ compare (DConstructor a) (DConstructor b) = compare (length a) (length b)+ compare (DFunction a _ _ _) (DFunction b _ _ _) = compare a b+ compare (DEvent a _ _) (DEvent b _ _) = compare a b+ compare (DFallback _) (DFallback _) = EQ++ compare DConstructor {} DFunction {} = LT+ compare DConstructor {} DEvent {} = LT+ compare DConstructor {} DFallback {} = LT++ compare DFunction {} DConstructor {} = GT+ compare DFunction {} DEvent {} = LT+ compare DFunction {} DFallback {} = LT++ compare DEvent {} DConstructor {} = GT+ compare DEvent {} DFunction {} = GT+ compare DEvent {} DFallback {} = LT++ compare DFallback {} DConstructor {} = GT+ compare DFallback {} DFunction {} = GT+ compare DFallback {} DEvent {} = GT++instance FromJSON Declaration where+ parseJSON = withObject "Declaration" $ \o -> do+ t :: Text <- o .: "type"+ case t of+ "fallback" -> DFallback <$> o .: "payable"+ "constructor" -> DConstructor <$> o .: "inputs"+ "event" -> DEvent <$> o .: "name" <*> o .: "inputs" <*> o .: "anonymous"+ "function" -> DFunction <$> o .: "name" <*> parseSm o <*> o .: "inputs" <*> o .:? "outputs"+ _ -> fail "value of 'type' not recognized"+ where+ parseSm o = do+ o .:? "stateMutability" >>= \case+ Nothing -> o .: "constant"+ Just sm -> pure $ sm `elem` [SMPure, SMView]++$(deriveToJSON+ (defaultOptions {+ sumEncoding = TaggedObject "type" "contents"+ , constructorTagModifier = over _head toLower . drop 1+ , fieldLabelModifier = over _head toLower . drop 3 })+ ''Declaration)++$(deriveJSON (defaultOptions {+ sumEncoding = TaggedObject "stateMutability" "contents"+ , constructorTagModifier = fmap toLower . drop 2 })+ ''StateMutability)+++-- | Contract Abi is a list of method / event declarations+newtype ContractAbi = ContractAbi { unAbi :: [Declaration] }+ deriving (Eq, Ord)++instance FromJSON ContractAbi where+ parseJSON = fmap ContractAbi . parseJSON++instance ToJSON ContractAbi where+ toJSON = toJSON . unAbi++instance Show ContractAbi where+ show (ContractAbi c) = T.unpack $ T.unlines $+ [ "Contract:" ]+ ++ foldMap showConstructor c +++ [ "\tEvents:" ]+ ++ foldMap showEvent c +++ [ "\tMethods:" ]+ ++ foldMap showMethod c++showConstructor :: Declaration -> [Text]+showConstructor x = case x of+ DConstructor{} -> ["\tConstructor " <> signature x]+ _ -> []++showEvent :: Declaration -> [Text]+showEvent x = case x of+ DEvent{} -> ["\t\t" <> signature x]+ _ -> []++showMethod :: Declaration -> [Text]+showMethod x = case x of+ DFunction{} ->+ ["\t\t" <> methodId x <> " " <> signature x]+ _ -> []++-- | Take a signature by given decl, e.g. foo(uint,string)+signature :: Declaration -> Text++signature (DConstructor inputs) = "(" <> args inputs <> ")"+ where+ args [] = ""+ args [x] = funArgType x+ args (x:xs) = case funArgComponents x of+ Nothing -> funArgType x <> "," <> args xs+ Just cmps -> "(" <> args cmps <> ")," <> args xs++signature (DFallback _) = "()"++signature (DFunction name _ inputs _) = name <> "(" <> args inputs <> ")"+ where+ args :: [FunctionArg] -> Text+ args [] = ""+ args [x] = funArgType x+ args (x:xs) = case funArgComponents x of+ Nothing -> funArgType x <> "," <> args xs+ Just cmps -> "(" <> args cmps <> ")," <> args xs++signature (DEvent name inputs _) = name <> "(" <> args inputs <> ")"+ where+ args :: [EventArg] -> Text+ args = T.dropEnd 1 . foldMap (<> ",") . fmap eveArgType++-- | Generate method selector by given method 'Delcaration'+methodId :: Declaration -> Text+{-# INLINE methodId #-}+methodId = toText . A.take 4 . keccak256 . encodeUtf8 . signature++-- | Generate event `topic0` hash by givent event 'Delcaration'+eventId :: Declaration -> Text+{-# INLINE eventId #-}+eventId = toText . keccak256 . encodeUtf8 . signature++-- | Solidity types and parsers+data SolidityType = SolidityBool+ | SolidityAddress+ | SolidityUint Int+ | SolidityInt Int+ | SolidityString+ | SolidityBytesN Int+ | SolidityBytes+ | SolidityTuple [SolidityType]+ | SolidityVector [Int] SolidityType+ | SolidityArray SolidityType+ deriving (Eq, Show)++numberParser :: Parser Int+numberParser = read <$> many1 digit++parseUint :: Parser SolidityType+parseUint = do+ _ <- string "uint"+ SolidityUint <$> numberParser++parseInt :: Parser SolidityType+parseInt = do+ _ <- string "int"+ SolidityInt <$> numberParser++parseBool :: Parser SolidityType+parseBool = string "bool" >> pure SolidityBool++parseString :: Parser SolidityType+parseString = string "string" >> pure SolidityString++parseBytes :: Parser SolidityType+parseBytes = do+ _ <- string "bytes"+ mn <- optionMaybe numberParser+ pure $ maybe SolidityBytes SolidityBytesN mn++parseAddress :: Parser SolidityType+parseAddress = string "address" >> pure SolidityAddress++solidityBasicTypeParser :: Parser SolidityType+solidityBasicTypeParser =+ choice [ try parseUint+ , try parseInt+ , try parseAddress+ , try parseBool+ , try parseString+ , parseBytes+ ]++parseVector :: Parser SolidityType+parseVector = do+ s <- solidityBasicTypeParser+ ns <- many1Till lengthParser (lookAhead (void $ string "[]") <|> eof)+ pure $ SolidityVector ns s+ where+ many1Till :: Parser Int -> Parser () -> Parser [Int]+ many1Till p end = do+ a <- p+ as <- manyTill p end+ return (a : as)++ lengthParser = do+ _ <- char '['+ n <- numberParser+ _ <- char ']'+ pure n++parseArray :: Parser SolidityType+parseArray = do+ s <- try (parseVector <* string "[]") <|> (solidityBasicTypeParser <* string "[]")+ pure $ SolidityArray s+++solidityTypeParser :: Parser SolidityType+solidityTypeParser =+ choice [ try parseArray+ , try parseVector+ , solidityBasicTypeParser+ ]++parseSolidityFunctionArgType :: FunctionArg -> Either ParseError SolidityType+parseSolidityFunctionArgType (FunctionArg _ typ mcmps) = case mcmps of+ Nothing -> parse solidityTypeParser "Solidity" typ+ Just cmps -> SolidityTuple <$> mapM parseSolidityFunctionArgType cmps+++parseSolidityEventArgType :: EventArg -> Either ParseError SolidityType+parseSolidityEventArgType (EventArg _ typ _) = parse solidityTypeParser "Solidity" typ
+ tests/Data/Solidity/Test/AddressSpec.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Solidity.Test.AddressSpec where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 (unpack)+import Data.Foldable (for_)+import Test.Hspec++import Crypto.Ecdsa.Utils (derivePubKey, importKey)+import Data.ByteArray.HexString (HexString)+import Data.Solidity.Prim.Address++spec :: Spec+spec = parallel $ do+ describe "EIP55 Test Vectors" $ for_ checksummedAddrs $ \addr ->+ it (unpack addr <> " should be checksummed") $ verifyChecksum addr `shouldBe` True++ describe "EIP55 Test Vectors Tampered" $ for_ unchecksummedAddrs $ \addr ->+ it (unpack addr <> " should not be checksummed") $ verifyChecksum addr `shouldBe` False++ describe "Conversion from/to hex string" $ do+ it "should convert from/to on valid hex" $ do+ fromHexString "0x6370eF2f4Db3611D657b90667De398a2Cc2a370C"+ `shouldBe` Right "0x6370eF2f4Db3611D657b90667De398a2Cc2a370C"++ toHexString "0x6370eF2f4Db3611D657b90667De398a2Cc2a370C"+ `shouldBe` "0x6370eF2f4Db3611D657b90667De398a2Cc2a370C"++ it "should fail on broken hex" $ do+ fromHexString "0x42"+ `shouldBe` Left "Incorrect address length: 1"+++ describe "Conversion from ECC keys" $ do+ it "can derive address from public key" $ do+ let key = "0x0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f20" :: HexString+ fromPubKey (derivePubKey $ importKey key)+ `shouldBe` "0x6370eF2f4Db3611D657b90667De398a2Cc2a370C"++checksummedAddrs :: [ByteString]+checksummedAddrs =+ [ "0x52908400098527886E0F7030069857D2E4169EE7"+ , "0x8617E340B3D01FA5F11F306F4090FD50E238070D"+ , "0xde709f2102306220921060314715629080e2fb77"+ , "0x27b1fdb04752bbc536007a920d24acb045561c26"+ , "0x5aAeb6053F3E94C9b9A09f33669435E7Ef1BeAed"+ , "0xfB6916095ca1df60bB79Ce92cE3Ea74c37c5d359"+ , "0xdbF03B407c01E7cD3CBea99509d93f8DDDC8C6FB"+ , "0xD1220A0cf47c7B9Be7A2E6BA89F429762e7b9aDb"+ ]++unchecksummedAddrs :: [ByteString]+unchecksummedAddrs =+ [ "0x52908400098527886E0F7030069857D2E4169Ee7"+ , "0x8617E340B3D01FA5F11F306F4090FD50E238070d"+ , "0xde709f2102306220921060314715629080e2fB77"+ , "0x27b1fdb04752bbc536007a920d24acb045561C26"+ , "0x5aAeb6053F3E94C9b9A09f33669435E7Ef1BeAeD"+ , "0xfB6916095ca1df60bB79Ce92cE3Ea74c37c5D359"+ , "0xdbF03B407c01E7cD3CBea99509d93f8DDDC8C6Fb"+ , "0xD1220A0cf47c7B9Be7A2E6BA89F429762e7b9aDB"+ ]
+ tests/Data/Solidity/Test/EncodingSpec.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Solidity.Test.EncodingSpec where++import Control.Exception (evaluate)+import Data.Text (Text)+import Data.Tuple.OneTuple (OneTuple (..))+import Generics.SOP (Generic, Rep)+import Test.Hspec++import Data.Solidity.Abi (AbiGet, AbiPut, GenericAbiGet,+ GenericAbiPut)+import Data.Solidity.Abi.Codec (decode, decode', encode, encode')+import Data.Solidity.Prim (Address, Bytes, BytesN, IntN,+ ListN, UIntN)+import Data.Solidity.Prim.Address (fromHexString, toHexString)++spec :: Spec+spec = parallel $ do+ intNTest+ bytesTest+ bytesNTest+ vectorTest+ dynamicArraysTest+ tuplesTest+ addressTest++intNTest :: Spec+intNTest =+ describe "uint tests" $ do++ it "can encode int16" $+ let decoded = (-1) :: IntN 16+ encoded = "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ in roundTrip decoded encoded++ it "can encode larger uint256" $+ let decoded = (2 ^ 255) - 1 :: UIntN 256+ encoded = "0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ in roundTrip decoded encoded++bytesTest :: Spec+bytesTest = do+ describe "bytes tests" $ do++ it "can encode empty bytes" $ do+ let decoded :: Bytes+ decoded = "0x"+ encoded = "0x0000000000000000000000000000000000000000000000000000000000000000"+ in roundTrip decoded encoded++ it "can encode short bytes" $ do+ let decoded :: Bytes+ decoded = "0xc3a40000c3a4"+ encoded = "0x0000000000000000000000000000000000000000000000000000000000000006"+ <> "0xc3a40000c3a40000000000000000000000000000000000000000000000000000"+ in roundTrip decoded encoded++ it "can encode long bytes" $ do+ let decoded :: Bytes+ decoded = "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff1"+ encoded = "0x000000000000000000000000000000000000000000000000000000000000009f"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff100"+ in roundTrip decoded encoded++bytesNTest :: Spec+bytesNTest =+ describe "sized bytes tests" $ do++ it "can encode Bytes1" $ do+ let decoded = "0xcf" :: BytesN 1+ encoded = "0xcf00000000000000000000000000000000000000000000000000000000000000"+ roundTrip decoded encoded++ it "can encode Bytes12" $ do+ let decoded = "0x6761766f66796f726b000000" :: BytesN 12+ encoded = "0x6761766f66796f726b0000000000000000000000000000000000000000000000"+ roundTrip decoded encoded++ it "can pad shorter hex-literals" $ do+ let literal = "0xc3a4" :: BytesN 4+ expected = "0xc3a40000" :: BytesN 4+ literal `shouldBe` expected++ it "can pad shorter string-literals" $ do+ let literal = "hello" :: BytesN 8+ expected = "0x68656c6c6f000000" :: BytesN 8+ literal `shouldBe` expected++ it "fails on too long literals" $ do+ let literal = "hello" :: BytesN 4+ evaluate literal `shouldThrow` errorCall "Invalid Size"++vectorTest :: Spec+vectorTest =+ describe "statically sized array tests" $ do++ it "can encode statically sized vectors of addresses" $ do+ let decoded = [False, True] :: ListN 2 Bool+ encoded = "0x0000000000000000000000000000000000000000000000000000000000000000"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ in roundTrip decoded encoded++ it "can encode statically sized vectors of statically sized bytes"$ do+ let elem1 = "0xcf"+ elem2 = "0x68"+ elem3 = "0x4d"+ elem4 = "0xfb"+ decoded = [elem1, elem2, elem3, elem4] :: ListN 4 (BytesN 1)+ encoded = "0xcf00000000000000000000000000000000000000000000000000000000000000"+ <> "0x6800000000000000000000000000000000000000000000000000000000000000"+ <> "0x4d00000000000000000000000000000000000000000000000000000000000000"+ <> "0xfb00000000000000000000000000000000000000000000000000000000000000"+ in roundTrip decoded encoded++dynamicArraysTest :: Spec+dynamicArraysTest = do+ describe "dynamically sized array tests" $ do++ it "can encode dynamically sized lists of bools" $ do+ let decoded = [True, True, False] :: [Bool]+ encoded = "0x0000000000000000000000000000000000000000000000000000000000000003"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x0000000000000000000000000000000000000000000000000000000000000000"+ in roundTrip decoded encoded++tuplesTest :: Spec+tuplesTest =+ describe "tuples test" $ do++ it "can encode 2-tuples with both static args" $ do+ let decoded = (True, False)+ encoded = "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x0000000000000000000000000000000000000000000000000000000000000000"+ in roundTripGeneric decoded encoded++ it "can encode 1-tuples with dynamic arg" $ do+ let decoded = OneTuple ([True, False] :: [Bool])+ encoded = "0x0000000000000000000000000000000000000000000000000000000000000020"+ <> "0x0000000000000000000000000000000000000000000000000000000000000002"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x0000000000000000000000000000000000000000000000000000000000000000"+ in roundTripGeneric decoded encoded++ it "can encode 4-tuples with a mix of args - (UInt32, String, Boolean, Array Int256)" $ do+ let decoded = (1 :: IntN 32, "dave" :: Text, True, [1, 2, 3] :: [IntN 256])+ encoded = "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x0000000000000000000000000000000000000000000000000000000000000080"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x00000000000000000000000000000000000000000000000000000000000000c0"+ <> "0x0000000000000000000000000000000000000000000000000000000000000004"+ <> "0x6461766500000000000000000000000000000000000000000000000000000000"+ <> "0x0000000000000000000000000000000000000000000000000000000000000003"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x0000000000000000000000000000000000000000000000000000000000000002"+ <> "0x0000000000000000000000000000000000000000000000000000000000000003"+ in roundTripGeneric decoded encoded++ it "can do something really complicated" $ do+ let uint = 1 :: UIntN 256+ int = (-1) :: IntN 256+ bool = True+ int224 = 221 :: IntN 224+ bools = [True, False] :: ListN 2 Bool+ ints = [1, -1, 3] :: [IntN 32]+ string = "hello" :: Text+ bytes16 = "0x12345678123456781234567812345678" :: BytesN 16+ elem1 = "0x1234" :: BytesN 2+ bytes2s = [ [elem1, elem1, elem1, elem1]+ , [elem1, elem1, elem1, elem1]+ ] :: [ListN 4 (BytesN 2)]++ decoded = (uint, int, bool, int224, bools, ints, string, bytes16, bytes2s)++ encoded = "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x00000000000000000000000000000000000000000000000000000000000000dd"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0x0000000000000000000000000000000000000000000000000000000000000000"+ <> "0x0000000000000000000000000000000000000000000000000000000000000140"+ <> "0x00000000000000000000000000000000000000000000000000000000000001c0"+ <> "0x1234567812345678123456781234567800000000000000000000000000000000"+ <> "0x0000000000000000000000000000000000000000000000000000000000000200"+ <> "0x0000000000000000000000000000000000000000000000000000000000000003"+ <> "0x0000000000000000000000000000000000000000000000000000000000000001"+ <> "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"+ <> "0x0000000000000000000000000000000000000000000000000000000000000003"+ <> "0x0000000000000000000000000000000000000000000000000000000000000005"+ <> "0x68656c6c6f000000000000000000000000000000000000000000000000000000"+ <> "0x0000000000000000000000000000000000000000000000000000000000000002"+ <> "0x1234000000000000000000000000000000000000000000000000000000000000"+ <> "0x1234000000000000000000000000000000000000000000000000000000000000"+ <> "0x1234000000000000000000000000000000000000000000000000000000000000"+ <> "0x1234000000000000000000000000000000000000000000000000000000000000"+ <> "0x1234000000000000000000000000000000000000000000000000000000000000"+ <> "0x1234000000000000000000000000000000000000000000000000000000000000"+ <> "0x1234000000000000000000000000000000000000000000000000000000000000"+ <> "0x1234000000000000000000000000000000000000000000000000000000000000"++ in roundTripGeneric decoded encoded++addressTest :: Spec+addressTest =+ describe "address test" $ do+ it "can abi encode address" $ do+ let decoded = "0x4af013AfBAdb22D8A88c92D68Fc96B033b9Ebb8a" :: Address+ encoded = "0x0000000000000000000000004af013AfBAdb22D8A88c92D68Fc96B033b9Ebb8a"+ in roundTrip decoded encoded++ it "can decode address from/to bytestring" $ do+ fromHexString "0x4af013AfBAdb22D8A88c92D68Fc96B033b9Ebb8a"+ `shouldBe` Right ("0x4af013AfBAdb22D8A88c92D68Fc96B033b9Ebb8a" :: Address)++ toHexString "0x4af013AfBAdb22D8A88c92D68Fc96B033b9Ebb8a"+ `shouldBe` "0x4af013afbadb22d8a88c92d68fc96b033b9ebb8a"++ it "fails for invalid address length" $ do+ evaluate (fromHexString "0x0")+ `shouldThrow` errorCall "base16: input: invalid length"++ fromHexString "0x4af013AfBAdb22D8A88c92D68Fc96B033b9Ebb8a00"+ `shouldBe` Left "Incorrect address length: 21"++-- | Run encoded/decoded comaration+roundTrip :: ( Show a+ , Eq a+ , AbiPut a+ , AbiGet a+ )+ => a+ -> Bytes+ -> IO ()+roundTrip decoded encoded = do+ encoded `shouldBe` encode decoded+ decode encoded `shouldBe` Right decoded++-- | Run generic encoded/decoded comaration+roundTripGeneric :: ( Show a+ , Eq a+ , Generic a+ , Rep a ~ rep+ , GenericAbiPut rep+ , GenericAbiGet rep+ )+ => a+ -> Bytes+ -> IO ()+roundTripGeneric decoded encoded = do+ encoded `shouldBe` encode' decoded+ decode' encoded `shouldBe` Right decoded
+ tests/Data/Solidity/Test/IntSpec.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DataKinds #-}+module Data.Solidity.Test.IntSpec where++import Test.Hspec++import Data.Solidity.Prim.Int++spec :: Spec+spec = parallel $ do+ describe "Unsigned integer overflow" $ do+ it "UIntN 256" $ do+ (negate 1 :: UIntN 256) `shouldBe` 115792089237316195423570985008687907853269984665640564039457584007913129639935+ (maxBound + 1 :: UIntN 256) `shouldBe` 0++ it "UIntN 128" $ do+ (negate 1 :: UIntN 128) `shouldBe` 340282366920938463463374607431768211455+ (maxBound + 1 :: UIntN 128) `shouldBe` 0++ it "UIntN 64" $ do+ (negate 1 :: UIntN 64) `shouldBe` 18446744073709551615+ (maxBound + 1 :: UIntN 64) `shouldBe` 0++ it "UIntN 32" $ do+ (negate 1 :: UIntN 32) `shouldBe` 4294967295+ (maxBound + 1 :: UIntN 32) `shouldBe` 0++ it "UIntN 16" $ do+ (negate 1 :: UIntN 16) `shouldBe` 65535+ (maxBound + 1 :: UIntN 16) `shouldBe` 0++ it "UIntN 8" $ do+ (negate 1 :: UIntN 8) `shouldBe` 255+ (maxBound + 1 :: UIntN 8) `shouldBe` 0
+ tests/Language/Solidity/Test/AbiSpec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.Solidity.Test.AbiSpec where+++import Data.Either (isLeft)+import Language.Solidity.Abi+import Test.Hspec+++spec :: Spec+spec = parallel $ do+ describe "parseSolidityType" $+ describe "tuple type" $ do+ it "can parses a FunctionArg with tuple type" $ do+ let maa = FunctionArg "makerAssetAmount" "uint256" Nothing+ ma = FunctionArg "makeAddress" "address" Nothing+ tupleFA = FunctionArg "order" "tuple" (Just [maa, ma])+ eRes = parseSolidityFunctionArgType tupleFA+ eRes `shouldBe` Right (SolidityTuple [SolidityUint 256, SolidityAddress])+ it "fails to parse a FunctionArg with invalid tuple" $ do+ let tupleFA = FunctionArg "order" "tuple" Nothing+ eRes = parseSolidityFunctionArgType tupleFA+ isLeft eRes `shouldBe` True+ describe "signature" $+ it "can generate signature for fillOrder" $ do+ let fillOrderDec = buildFillOrderDec+ expected = "fillOrder((address,address,address,address,uint256,uint256,uint256,uint256,uint256,uint256,bytes,bytes),uint256,bytes)"+ sig = signature fillOrderDec+ sig `shouldBe` expected+ describe "methodId" $+ it "can generate methodId for fillOrder" $ do+ let fillOrderDec = buildFillOrderDec+ expected = "0xb4be83d5"+ mId = methodId fillOrderDec+ mId `shouldBe` expected++buildFillOrderDec :: Declaration+buildFillOrderDec = DFunction "fillOrder" False funInputs' funOutputs'+ where+ funInputs' =+ [ makeTupleFuncArg ("order", "tuple") tupleComponents+ , makeBasicFuncArg ("takerAssetFillAmount", "uint256")+ , makeBasicFuncArg ("signature", "bytes")+ ]+ tupleComponents =+ [ ("makerAddress", "address")+ , ("takerAddress", "address")+ , ("feeRecipientAddress", "address")+ , ("senderAddress", "address")+ , ("makerAssetAmount", "uint256")+ , ("takerAssetAmount", "uint256")+ , ("makerFee", "uint256")+ , ("takerFee", "uint256")+ , ("expirationTimeSeconds", "uint256")+ , ("salt", "uint256")+ , ("makerAssetData", "bytes")+ , ("takerAssetData", "bytes")+ ]+ funOutputs' = Nothing+ makeBasicFuncArg (n,t) =+ FunctionArg n t Nothing+ makeTupleFuncArg (n,t) cmps =+ FunctionArg n t (Just $ map makeBasicFuncArg cmps)
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ web3-solidity.cabal view
@@ -0,0 +1,131 @@+cabal-version: 1.12+name: web3-solidity+version: 1.0.0.0+license: Apache-2.0+license-file: LICENSE+copyright: (c) Aleksandr Krupenkin 2016-2021+maintainer: mail@akru.me+author: Aleksandr Krupenkin+homepage: https://github.com/airalab/hs-web3#readme+bug-reports: https://github.com/airalab/hs-web3/issues+synopsis: Solidity language for Haskell Web3 library.+description:+ This package contains Solidity parsec-based parser and primitive types.++category: Network+build-type: Simple++source-repository head+ type: git+ location: https://github.com/airalab/hs-web3++library+ exposed-modules:+ Data.Solidity.Abi+ Data.Solidity.Abi.Codec+ Data.Solidity.Abi.Generic+ Data.Solidity.Event+ Data.Solidity.Event.Internal+ Data.Solidity.Prim+ Data.Solidity.Prim.Address+ Data.Solidity.Prim.Bool+ Data.Solidity.Prim.Bytes+ Data.Solidity.Prim.Int+ Data.Solidity.Prim.List+ Data.Solidity.Prim.String+ Data.Solidity.Prim.Tagged+ Data.Solidity.Prim.Tuple+ Data.Solidity.Prim.Tuple.TH+ Language.Solidity.Abi++ hs-source-dirs: src+ other-modules: Paths_web3_solidity+ default-language: Haskell2010+ ghc-options:+ -funbox-strict-fields -Wduplicate-exports -Whi-shadowing+ -Widentities -Woverlapping-patterns -Wpartial-type-signatures+ -Wunrecognised-pragmas -Wtyped-holes -Wincomplete-patterns+ -Wincomplete-uni-patterns -Wmissing-fields -Wmissing-methods+ -Wmissing-exported-signatures -Wmissing-monadfail-instances+ -Wmissing-signatures -Wname-shadowing -Wunused-binds+ -Wunused-top-binds -Wunused-local-binds -Wunused-pattern-binds+ -Wunused-imports -Wunused-matches -Wunused-foralls -Wtabs++ build-depends:+ OneTuple >0.2 && <0.3,+ aeson >1.2 && <1.6,+ base >4.11 && <4.15,+ basement >0.0 && <0.1,+ bytestring >0.10 && <0.11,+ cereal >0.5 && <0.6,+ data-default >0.7 && <0.8,+ generics-sop >0.3 && <0.6,+ memory >0.14 && <0.16,+ memory-hexstring ==1.0.*,+ microlens >0.4 && <0.5,+ parsec >3.1 && <3.2,+ tagged >0.8 && <0.9,+ template-haskell >2.11 && <2.17,+ text >1.2 && <1.3,+ web3-crypto ==1.0.*++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: tests src+ other-modules:+ Data.Solidity.Test.AddressSpec+ Data.Solidity.Test.EncodingSpec+ Data.Solidity.Test.IntSpec+ Language.Solidity.Test.AbiSpec+ Data.Solidity.Abi+ Data.Solidity.Abi.Codec+ Data.Solidity.Abi.Generic+ Data.Solidity.Event+ Data.Solidity.Event.Internal+ Data.Solidity.Prim+ Data.Solidity.Prim.Address+ Data.Solidity.Prim.Bool+ Data.Solidity.Prim.Bytes+ Data.Solidity.Prim.Int+ Data.Solidity.Prim.List+ Data.Solidity.Prim.String+ Data.Solidity.Prim.Tagged+ Data.Solidity.Prim.Tuple+ Data.Solidity.Prim.Tuple.TH+ Language.Solidity.Abi+ Paths_web3_solidity++ default-language: Haskell2010+ ghc-options:+ -funbox-strict-fields -Wduplicate-exports -Whi-shadowing+ -Widentities -Woverlapping-patterns -Wpartial-type-signatures+ -Wunrecognised-pragmas -Wtyped-holes -Wincomplete-patterns+ -Wincomplete-uni-patterns -Wmissing-fields -Wmissing-methods+ -Wmissing-exported-signatures -Wmissing-monadfail-instances+ -Wmissing-signatures -Wname-shadowing -Wunused-binds+ -Wunused-top-binds -Wunused-local-binds -Wunused-pattern-binds+ -Wunused-imports -Wunused-matches -Wunused-foralls -Wtabs -threaded+ -rtsopts -with-rtsopts=-N++ build-depends:+ OneTuple >0.2 && <0.3,+ aeson >1.2 && <1.6,+ base >4.11 && <4.15,+ basement >0.0 && <0.1,+ bytestring >0.10 && <0.11,+ cereal >0.5 && <0.6,+ data-default >0.7 && <0.8,+ generics-sop >0.3 && <0.6,+ hspec >=2.4.4 && <2.8,+ hspec-contrib >=0.4.0 && <0.6,+ hspec-discover >=2.4.4 && <2.8,+ hspec-expectations >=0.8.2 && <0.9,+ memory >0.14 && <0.16,+ memory-hexstring ==1.0.*,+ microlens >0.4 && <0.5,+ parsec >3.1 && <3.2,+ tagged >0.8 && <0.9,+ template-haskell >2.11 && <2.17,+ text >1.2 && <1.3,+ web3-crypto ==1.0.*