diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Solidity/Abi.hs b/src/Data/Solidity/Abi.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Abi.hs @@ -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 diff --git a/src/Data/Solidity/Abi/Codec.hs b/src/Data/Solidity/Abi/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Abi/Codec.hs @@ -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 diff --git a/src/Data/Solidity/Abi/Generic.hs b/src/Data/Solidity/Abi/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Abi/Generic.hs @@ -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 diff --git a/src/Data/Solidity/Event.hs b/src/Data/Solidity/Event.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Event.hs @@ -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 diff --git a/src/Data/Solidity/Event/Internal.hs b/src/Data/Solidity/Event/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Event/Internal.hs @@ -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 diff --git a/src/Data/Solidity/Prim.hs b/src/Data/Solidity/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim.hs @@ -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 () diff --git a/src/Data/Solidity/Prim/Address.hs b/src/Data/Solidity/Prim/Address.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/Address.hs @@ -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 >>= (==) diff --git a/src/Data/Solidity/Prim/Bool.hs b/src/Data/Solidity/Prim/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/Bool.hs @@ -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 diff --git a/src/Data/Solidity/Prim/Bytes.hs b/src/Data/Solidity/Prim/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/Bytes.hs @@ -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 diff --git a/src/Data/Solidity/Prim/Int.hs b/src/Data/Solidity/Prim/Int.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/Int.hs @@ -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 diff --git a/src/Data/Solidity/Prim/List.hs b/src/Data/Solidity/Prim/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/List.hs @@ -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 diff --git a/src/Data/Solidity/Prim/String.hs b/src/Data/Solidity/Prim/String.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/String.hs @@ -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 diff --git a/src/Data/Solidity/Prim/Tagged.hs b/src/Data/Solidity/Prim/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/Tagged.hs @@ -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) diff --git a/src/Data/Solidity/Prim/Tuple.hs b/src/Data/Solidity/Prim/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/Tuple.hs @@ -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]) diff --git a/src/Data/Solidity/Prim/Tuple/TH.hs b/src/Data/Solidity/Prim/Tuple/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Solidity/Prim/Tuple/TH.hs @@ -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)) [] ] diff --git a/src/Language/Solidity/Abi.hs b/src/Language/Solidity/Abi.hs new file mode 100644 --- /dev/null +++ b/src/Language/Solidity/Abi.hs @@ -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 diff --git a/tests/Data/Solidity/Test/AddressSpec.hs b/tests/Data/Solidity/Test/AddressSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Solidity/Test/AddressSpec.hs @@ -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" + ] diff --git a/tests/Data/Solidity/Test/EncodingSpec.hs b/tests/Data/Solidity/Test/EncodingSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Solidity/Test/EncodingSpec.hs @@ -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 diff --git a/tests/Data/Solidity/Test/IntSpec.hs b/tests/Data/Solidity/Test/IntSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Solidity/Test/IntSpec.hs @@ -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 diff --git a/tests/Language/Solidity/Test/AbiSpec.hs b/tests/Language/Solidity/Test/AbiSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Solidity/Test/AbiSpec.hs @@ -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) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/web3-solidity.cabal b/web3-solidity.cabal new file mode 100644 --- /dev/null +++ b/web3-solidity.cabal @@ -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.*