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/scale.cabal b/scale.cabal new file mode 100644 --- /dev/null +++ b/scale.cabal @@ -0,0 +1,100 @@ +cabal-version: 1.12 +name: scale +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: SCALE v2.0 codec for Haskell Web3 library. +description: Client library for Third Generation of Web. +category: Network +build-type: Simple + +source-repository head + type: git + location: https://github.com/airalab/hs-web3 + +library + exposed-modules: + Codec.Scale + Codec.Scale.Class + Codec.Scale.Compact + Codec.Scale.Core + Codec.Scale.Generic + Codec.Scale.SingletonEnum + Codec.Scale.Skip + Codec.Scale.TH + + hs-source-dirs: src + other-modules: Paths_scale + 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: + base >4.11 && <4.15, + bitvec >1.0 && <2.0, + 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, + template-haskell >2.11 && <2.17, + text >1.2 && <1.3, + vector >0.12 && <0.13 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests src + other-modules: + Codec.Scale.Test.CoreSpec + Codec.Scale.Test.SingleFieldStructSpec + Codec.Scale.Test.SkipSpec + Codec.Scale + Codec.Scale.Class + Codec.Scale.Compact + Codec.Scale.Core + Codec.Scale.Generic + Codec.Scale.SingletonEnum + Codec.Scale.Skip + Codec.Scale.TH + Paths_scale + + 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: + base >4.11 && <4.15, + bitvec >1.0 && <2.0, + 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, + template-haskell >2.11 && <2.17, + text >1.2 && <1.3, + vector >0.12 && <0.13 diff --git a/src/Codec/Scale.hs b/src/Codec/Scale.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Scale.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Codec.Scale.Class +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- The SCALE (Simple Concatenated Aggregate Little-Endian) Codec is +-- a lightweight, efficient, binary serialization and deserialization codec. +-- +-- It is designed for high-performance, copy-free encoding and decoding of data in +-- resource-constrained execution contexts, like the Substrate runtime. It is not +-- self-describing in any way and assumes the decoding context has all type +-- knowledge about the encoded data. +-- + +module Codec.Scale + ( encode + , decode + , encode' + , decode' + , Encode + , Decode + , Generic + , module Core + ) where + +import Data.ByteArray (ByteArray, ByteArrayAccess, convert) +import Data.Serialize (runGet, runPut) +import Generics.SOP (Generic, Rep, from, to) + +import Codec.Scale.Class (Decode (..), Encode (..), GDecode (..), + GEncode (..)) +import Codec.Scale.Core as Core + +-- | Encode datatype to SCALE format. +encode :: (Encode a, ByteArray ba) + => a + -> ba +{-# INLINE encode #-} +encode = convert . runPut . put + +-- | Generic driven version of 'encode' +encode' :: (Generic a, + Rep a ~ rep, + GEncode rep, + ByteArray ba) + => a + -> ba +{-# INLINE encode' #-} +encode' = convert . runPut . gPut . from + +-- | Decode datatype from SCALE format. +decode :: (ByteArrayAccess ba, Decode a) + => ba + -> Either String a +{-# INLINE decode #-} +decode = runGet get . convert + +-- | Generic driven version of 'decode' +decode' :: (Generic a, + Rep a ~ rep, + GDecode rep, + ByteArrayAccess ba) + => ba + -> Either String a +{-# INLINE decode' #-} +decode' = runGet (to <$> gGet) . convert diff --git a/src/Codec/Scale/Class.hs b/src/Codec/Scale/Class.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Scale/Class.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Codec.Scale.Class +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- +-- + +module Codec.Scale.Class where + +import Data.Serialize (Get, Putter) +import Generics.SOP (Generic, Rep, from, to) + +-- | A class for encoding datatypes to SCALE format. +-- +-- If your compiler has support for the @DeriveGeneric@ and +-- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@), +-- the 'put' method will have default generic implementations. +-- +-- To use this option, simply add a @deriving 'Generic'@ clause +-- to your datatype and declare a 'Encode' instance for it without +-- giving a definition for 'put'. +-- +class Encode a where + put :: Putter a + + default put :: (Generic a, Rep a ~ rep, GEncode rep) => Putter a + put = gPut . from + +-- | A class for encoding generically composed datatypes to SCALE format. +class GEncode a where + gPut :: Putter a + +-- | A class for decoding datatypes from SCALE format. +-- +-- If your compiler has support for the @DeriveGeneric@ and +-- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@), +-- the 'get' method will have default generic implementations. +-- +-- To use this option, simply add a @deriving 'Generic'@ clause +-- to your datatype and declare a 'Decode' instance for it without +-- giving a definition for 'get'. +-- +class Decode a where + get :: Get a + + default get :: (Generic a, Rep a ~ rep, GDecode rep) => Get a + get = to <$> gGet + +-- | A class for decoding generically composed datatypes from SCALE format. +class GDecode a where + gGet :: Get a diff --git a/src/Codec/Scale/Compact.hs b/src/Codec/Scale/Compact.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Scale/Compact.hs @@ -0,0 +1,70 @@ +-- | +-- Module : Codec.Scale.Compact +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- Efficient general integer codec. +-- + +module Codec.Scale.Compact (Compact(..)) where + +import Control.Monad (replicateM) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.List (unfoldr) +import Data.Serialize.Get (getWord16le, getWord32le, getWord8, + lookAhead) +import Data.Serialize.Put (putWord16le, putWord32le, putWord8) + +import Codec.Scale.Class (Decode (..), Encode (..)) + +-- | A "compact" or general integer encoding is sufficient for encoding +-- large integers (up to 2**536) and is more efficient at encoding most +-- values than the fixed-width version. +newtype Compact a = Compact { unCompact :: a } + deriving (Eq, Ord) + +instance Show a => Show (Compact a) where + show = ("Compact " ++) . show . unCompact + +instance Integral a => Encode (Compact a) where + put (Compact x) + | n < 0 = error "negatives not supported by compact codec" + | n < 64 = singleByteMode + | n < 2^14 = twoByteMode + | n < 2^30 = fourByteMode + | n < 2^536 = bigIntegerMode + | otherwise = error $ "unable to encode " ++ show n ++ " as compact" + where + n = toInteger x + singleByteMode = putWord8 (fromIntegral x `shiftL` 2) + twoByteMode = putWord16le (fromIntegral x `shiftL` 2 .|. 1) + fourByteMode = putWord32le (fromIntegral x `shiftL` 2 .|. 2) + bigIntegerMode = do + let step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + unroll = unfoldr step n + putWord8 (fromIntegral (length unroll - 4) `shiftL` 2 .|. 3) + mapM_ putWord8 unroll + +instance Integral a => Decode (Compact a) where + get = do + mode <- lookAhead ((3 .&.) <$> getWord8) + Compact <$> case mode of + 0 -> fromIntegral <$> singleByteMode + 1 -> fromIntegral <$> twoByteMode + 2 -> fromIntegral <$> fourByteMode + 3 -> bigIntegerMode + _ -> fail "unexpected prefix decoding compact number" + where + singleByteMode = flip shiftR 2 <$> getWord8 + twoByteMode = flip shiftR 2 <$> getWord16le + fourByteMode = flip shiftR 2 <$> getWord32le + bigIntegerMode = do + let unstep b a = a `shiftL` 8 .|. fromIntegral b + roll = fromInteger . foldr unstep 0 + len <- ((+4) . flip shiftR 2) <$> getWord8 + roll <$> replicateM (fromIntegral len) getWord8 diff --git a/src/Codec/Scale/Core.hs b/src/Codec/Scale/Core.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Scale/Core.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Codec.Scale.Core +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Particular core type instances. +-- + +module Codec.Scale.Core (Compact(..)) where + +import Control.Monad (replicateM) +import Data.Bit (Bit, castFromWords8, cloneToWords8) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (length) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Serialize.Get (getByteString, getInt16le, getInt32le, + getInt64le, getInt8, getWord16le, + getWord32le, getWord64le, getWord8) +import Data.Serialize.Put (putByteString, putInt16le, putInt32le, + putInt64le, putInt8, putWord16le, + putWord32le, putWord64le, putWord8) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Data.Vector.Unboxed (Unbox, Vector) +import qualified Data.Vector.Unboxed as V +import Data.Word (Word16, Word32, Word64, Word8) +import Generics.SOP () + +import Codec.Scale.Class (Decode (..), Encode (..)) +import Codec.Scale.Compact (Compact (..)) +import Codec.Scale.Generic () +import Codec.Scale.TH (tupleInstances) + +-- +-- Empty instance. +-- + +instance Encode () where + put = return + +instance Decode () where + get = return () + +-- +-- Boolean instance. +-- + +instance Encode Bool where + put False = putWord8 0 + put True = putWord8 1 + +instance Decode Bool where + get = do x <- getWord8 + case x of + 0 -> return False + 1 -> return True + _ -> fail "invalid boolean representation" + +-- +-- Integer instances. +-- + +instance Encode Word8 where + put = putWord8 + +instance Decode Word8 where + get = getWord8 + +instance Encode Word16 where + put = putWord16le + +instance Decode Word16 where + get = getWord16le + +instance Encode Word32 where + put = putWord32le + +instance Decode Word32 where + get = getWord32le + +instance Encode Word64 where + put = putWord64le + +instance Decode Word64 where + get = getWord64le + +instance Encode Int8 where + put = putInt8 + +instance Decode Int8 where + get = getInt8 + +instance Encode Int16 where + put = putInt16le + +instance Decode Int16 where + get = getInt16le + +instance Encode Int32 where + put = putInt32le + +instance Decode Int32 where + get = getInt32le + +instance Encode Int64 where + put = putInt64le + +instance Decode Int64 where + get = getInt64le + +-- +-- Option type instances. +-- + +-- Let's map `Maybe a` type to Rust `Option`: Just -> Some, Nothing -> None + +instance Encode a => Encode (Maybe a) where + put (Just a) = putWord8 1 >> put a + put Nothing = putWord8 0 + +instance Decode a => Decode (Maybe a) where + get = do + x <- getWord8 + case x of + 0 -> return Nothing + 1 -> Just <$> get + _ -> fail "unexpecded first byte decoding Option" + +-- Option is exception and it is always one byte + +instance {-# OVERLAPPING #-} Encode (Maybe Bool) where + put Nothing = putWord8 0 + put (Just False) = putWord8 1 + put (Just True) = putWord8 2 + +instance {-# OVERLAPPING #-} Decode (Maybe Bool) where + get = do + x <- getWord8 + case x of + 0 -> return Nothing + 1 -> return (Just False) + 2 -> return (Just True) + _ -> fail "unexpecded first byte decoding OptionBool" + +-- +-- Result type isntances. +-- + +-- Let's map `Ether a b` type to Rust `Result`: Left -> Error, Right -> Ok + +instance (Encode a, Encode b) => Encode (Either a b) where + put (Right a) = putWord8 0 >> put a + put (Left a) = putWord8 1 >> put a + +instance (Decode a, Decode b) => Decode (Either a b) where + get = do + x <- getWord8 + case x of + 0 -> Right <$> get + 1 -> Left <$> get + _ -> fail "unexpected first byte decoding Result" + + +-- +-- Tuple type instances. +-- + +$(concat <$> mapM tupleInstances [2..20]) + +-- +-- Vector type instances. +-- + +instance Encode a => Encode [a] where + put list = do + put (Compact $ length list) + mapM_ put list + +instance Decode a => Decode [a] where + get = do + len <- get + replicateM (unCompact len) get + +instance (Encode a, Unbox a) => Encode (Vector a) where + put vec = do + put (Compact $ V.length vec) + V.mapM_ put vec + +instance (Decode a, Unbox a) => Decode (Vector a) where + get = do + len <- get + V.replicateM (unCompact len) get + +instance {-# OVERLAPPING #-} Encode (Vector Bit) where + put vec = do + let encoded = cloneToWords8 vec + put (Compact $ V.length encoded) + V.mapM_ put encoded + +instance {-# OVERLAPPING #-} Decode (Vector Bit) where + get = do + len <- get + castFromWords8 <$> V.replicateM (unCompact len) get + +instance Encode ByteString where + put bs = do + put (Compact $ BS.length bs) + putByteString bs + +instance Decode ByteString where + get = do + len <- get + getByteString (unCompact len) + +-- +-- Text type instances. +-- + +instance Encode Text where + put str = do + let encoded = encodeUtf8 str + put (Compact $ BS.length encoded) + putByteString encoded + +instance Decode Text where + get = do + len <- get + str <- getByteString (unCompact len) + either (fail . show) return (decodeUtf8' str) diff --git a/src/Codec/Scale/Generic.hs b/src/Codec/Scale/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Scale/Generic.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Codec.Scale.Generic +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- This module defines generic codec instances for data structures (including tuples) +-- and enums (tagged-unions in Rust). +-- + +module Codec.Scale.Generic () where + +import Data.Serialize.Get (Get, getWord8) +import Data.Serialize.Put (PutM, putWord8) +import Data.Word (Word8) +import Generics.SOP (All, Compose, I (..), NP (..), NS (..), + SOP (..), unSOP, unZ) + +import Codec.Scale.Class (Decode (..), Encode (..), GDecode (..), + GEncode (..)) + +-- Enum has multiple sum types. +instance ( GEncode (NP f xs) + , GEncode (NP f ys) + , All (GEncode `Compose` NP f) xss + ) => GEncode (SOP f (xs ': ys ': xss)) where + gPut = go 0 . unSOP + where + go :: forall f as . All (GEncode `Compose` f) as => Word8 -> NS f as -> PutM () + go !acc (Z x) = putWord8 acc >> gPut x + go !acc (S x) = go (acc + 1) x + +-- Structures has only one sum type. +instance GEncode (NP f xs) => GEncode (SOP f '[xs]) where + gPut = gPut . unZ . unSOP + +-- Product serialization is just encode each field step by step. +instance (Encode a, GEncode (NP I as)) => GEncode (NP I (a ': as)) where + gPut (I a :* as) = put a >> gPut as + +-- Finish when all fields handled. +instance GEncode (NP I '[]) where + gPut _ = mempty + +-- | Enum parser definition. +-- +-- The index of sum type to parse given as an argument. +class EnumParser xs where + enumParser :: All (GDecode `Compose` NP f) xs => Word8 -> Get (NS (NP f) xs) + +-- Enumerate enum index, zero means that we reach the goal. +instance EnumParser as => EnumParser (a ': as) where + enumParser !i | i > 0 = S <$> enumParser (i - 1) + | otherwise = Z <$> gGet + +-- When index out of type scope raise the error. +instance EnumParser '[] where + enumParser i = fail ("index out of enum constructors count: " ++ show i) + +-- Decode enum when multiple sum types. +instance ( GDecode (NP f xs) + , GDecode (NP f ys) + , All (GDecode `Compose` NP f) xss + , EnumParser xss + ) => GDecode (SOP f (xs ': ys ': xss)) where + gGet = SOP <$> (enumParser =<< getWord8) + +-- Decode plain structure when only one sum type. +instance GDecode (NP f as) => GDecode (SOP f '[as]) where + gGet = SOP . Z <$> gGet + +-- Decode each field in sequence. +instance (Decode a, GDecode (NP I as)) => GDecode (NP I (a ': as)) where + gGet = (:*) <$> (I <$> get) <*> gGet + +-- Finish decoding when empty. +instance GDecode (NP I '[]) where + gGet = return Nil diff --git a/src/Codec/Scale/SingletonEnum.hs b/src/Codec/Scale/SingletonEnum.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Scale/SingletonEnum.hs @@ -0,0 +1,30 @@ +-- | +-- Module : Codec.Scale.SingletonEnum +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- This type helps to encode/decode singleton Rust enums like: +-- `enum Enum { Data { some_data: u32 } }` +-- + +module Codec.Scale.SingletonEnum (SingletonEnum(..)) where + +import Data.Serialize.Get (getWord8) +import Data.Serialize.Put (putWord8) + +import Codec.Scale.Class (Decode (..), Encode (..)) + +-- | Haskell don't permit to make Rust-like enum type with only one element. +-- For this reason it is impossible to make generic parser for singleton enum type. +-- This type helps to parse Rust encoded singleton enums. +newtype SingletonEnum a = SingletonEnum { unSingletonEnum :: a } + +instance Encode a => Encode (SingletonEnum a) where + put (SingletonEnum x) = putWord8 0 >> put x + +instance Decode a => Decode (SingletonEnum a) where + get = getWord8 >> (SingletonEnum <$> get) diff --git a/src/Codec/Scale/Skip.hs b/src/Codec/Scale/Skip.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Scale/Skip.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Codec.Scale.Skip +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- This type helps to skip fields in encoded data type. +-- + +module Codec.Scale.Skip (Skip(..)) where + +import Data.Default (Default (..)) + +import Codec.Scale.Class (Decode (..), Encode (..)) + +-- | This type hide filed from encoding context. +-- It's useful in cases when serialization impossible or not needed. +-- For decoding wrapped type should have 'Default' instance. +newtype Skip a = Skip { unSkip :: a } + deriving (Eq, Ord, Show) + +instance Encode (Skip a) where + put _ = return () + +instance Default a => Decode (Skip a) where + get = return def + +instance Default a => Default (Skip a) where + def = Skip def diff --git a/src/Codec/Scale/TH.hs b/src/Codec/Scale/TH.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Scale/TH.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Codec.Scale.TH +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : noportable +-- +-- It contains template haskell SCALE helper functions. +-- + +module Codec.Scale.TH where + + +import Control.Monad (replicateM) +import Language.Haskell.TH (DecsQ, Type (VarT), appT, conT, cxt, + instanceD, newName, tupleT) + +import Codec.Scale.Class (Decode, Encode) + +tupleInstances :: Int -> DecsQ +tupleInstances n = do + vars <- replicateM n $ newName "a" + let types = fmap (pure . VarT) vars + sequence $ + [ instanceD (cxt $ map (appT $ conT ''Decode) types) (appT (conT ''Decode) (foldl appT (tupleT n) types)) [] + , instanceD (cxt $ map (appT $ conT ''Encode) types) (appT (conT ''Encode) (foldl appT (tupleT n) types)) [] + ] diff --git a/tests/Codec/Scale/Test/CoreSpec.hs b/tests/Codec/Scale/Test/CoreSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Codec/Scale/Test/CoreSpec.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Codec.Scale.Test.CoreSpec +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Ported to Haskell rust test spec: +-- https://github.com/paritytech/parity-scale-codec/blob/master/tests/single_field_struct_encoding.rs +-- + +module Codec.Scale.Test.CoreSpec where + +import Control.Monad (forM_) +import Data.Bit (castFromWords8) +import Data.Bits (bit) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (length, pack, unpack) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T (pack) +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V (fromList) +import Data.Word (Word16, Word32, Word64, Word8) +import qualified GHC.Generics as GHC (Generic) +import Test.Hspec +import Test.Hspec.QuickCheck + +import Codec.Scale + +data Unit = Unit + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +data Indexed = Indexed Word32 Word64 + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +data Struct a b c = Struct + { _a :: a + , _b :: b + , _c :: c + } + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +data StructWithPhantom a = StructWithPhantom + { a1 :: Word32 + , b1 :: Word64 + } + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +type TestType = Struct Word32 Word64 (Vector Word8); + +data EnumType = A + | B Word32 Word64 + | C + { a2 :: Word32 + , b2 :: Word64 + } + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +data TestHasCompact a = TestHasCompact + { bar1 :: Compact a + } + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +data TestHasCompactEnum a = Unnamed (Compact a) + | Named + { bar2 :: Compact a + } + | UnnamedCompact (Compact a) + | NamedCompact + { bar3 :: Compact a + } + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +data TestGenericEnum = UnnamedGenericEnum (Compact Integer) (Vector Word16) + | NamedGenericEnum + { bar5 :: Compact Word64 + , bar6 :: Word32 + } + deriving (Eq, Show, GHC.Generic, Generic) + +data RecursiveVariant1 a = RecursiveVariant1 + { payload1 :: a + , other1 :: [RecursiveVariant1 a] + } + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +data RecursiveVariant2 a b n = RecursiveVariant2 + { payload2 :: n + , other2 :: [Struct a b (RecursiveVariant1 n)] + } + deriving (Eq, Show, GHC.Generic, Generic, Encode, Decode) + +spec :: Spec +spec = parallel $ do + describe "Regular types" $ do + prop "Bool" $ \(v :: Bool) -> decode (encode v :: ByteString) == Right v + + prop "Option" $ \(v :: Maybe Bool) -> decode (encode v :: ByteString) == Right v + + prop "Result>" $ \v vec -> do + let success = Right v :: Either (Vector Word8) Bool + failure = Left (V.fromList vec) :: Either (Vector Word8) Bool + decode (encode success :: ByteString) == Right success + && decode (encode failure :: ByteString) == Right failure + + prop "u64" $ \(v :: Word64) -> decode (encode v :: ByteString) == Right v + prop "u32" $ \(v :: Word32) -> decode (encode v :: ByteString) == Right v + prop "u16" $ \(v :: Word16) -> decode (encode v :: ByteString) == Right v + prop "u8" $ \(v :: Word8) -> decode (encode v :: ByteString) == Right v + + prop "i64" $ \(v :: Int64) -> decode (encode v :: ByteString) == Right v + prop "i32" $ \(v :: Int32) -> decode (encode v :: ByteString) == Right v + prop "i16" $ \(v :: Int16) -> decode (encode v :: ByteString) == Right v + prop "i8" $ \(v :: Int8) -> decode (encode v :: ByteString) == Right v + + prop "Compact" $ \(v :: Integer) -> decode (encode (Compact $ abs v) :: ByteString) == Right (Compact $ abs v) + prop "Compact" $ \(v :: Word64) -> decode (encode (Compact v) :: ByteString) == Right (Compact v) + prop "Compact" $ \(v :: Word32) -> decode (encode (Compact v) :: ByteString) == Right (Compact v) + prop "Compact" $ \(v :: Word16) -> decode (encode (Compact v) :: ByteString) == Right (Compact v) + prop "Compact" $ \(v :: Word8) -> decode (encode (Compact v) :: ByteString) == Right (Compact v) + + prop "Vector" $ \(v :: [Word64]) -> decode (encode (V.fromList v) :: ByteString) == Right v + prop "Vector" $ \(v :: [Word32]) -> decode (encode (V.fromList v) :: ByteString) == Right v + prop "Vector" $ \(v :: [Word16]) -> decode (encode (V.fromList v) :: ByteString) == Right v + prop "Vector" $ \(v :: [Word8]) -> decode (encode (V.fromList v) :: ByteString) == Right v + + prop "BitVec" $ \(v :: [Word8]) -> decode (encode $ castFromWords8 $ V.fromList v :: ByteString) == Right v + + prop "ByteString" $ \(v :: [Word8]) -> decode (encode (BS.pack v) :: ByteString) == Right (BS.pack v) + + prop "Text" $ \(v :: String) -> decode (encode (T.pack v) :: ByteString) == Right (T.pack v) + + prop "List" $ \(v :: [Word64]) -> decode (encode v :: ByteString) == Right v + prop "List" $ \(v :: [Word32]) -> decode (encode v :: ByteString) == Right v + prop "List" $ \(v :: [Word16]) -> decode (encode v :: ByteString) == Right v + prop "List" $ \(v :: [Word8]) -> decode (encode v :: ByteString) == Right v + + describe "Generic types" $ do + prop "unamed_enum" $ \v vec -> + let e = UnnamedGenericEnum (Compact $ abs v) (V.fromList vec) + in decode' (encode' e :: ByteString) == Right e + prop "named_struct_enum" $ \a b -> + let e = NamedGenericEnum (Compact a) b + in decode' (encode' e :: ByteString) == Right e + + describe "Recursive types" $ do + prop "variant_1" $ \(n :: Word32) -> + let v = RecursiveVariant1 n [RecursiveVariant1 (n+1) []] + in decode (encode v :: ByteString) == Right v + + prop "variant_2" $ \(a :: Word8) (b :: Word16) (n :: Word32) -> + let v = RecursiveVariant2 n [Struct a b (RecursiveVariant1 (n+1) [])] + in decode (encode v :: ByteString) == Right v + + describe "SCALE Rust core tests" $ do + it "option_excheption_works" $ do + encode (Nothing :: Maybe Bool) `shouldBe` ("\0" :: ByteString) + encode (Just False) `shouldBe` ("\x01" :: ByteString) + encode (Just True) `shouldBe` ("\x02" :: ByteString) + + it "should_work_for_simple_enum" $ do + -- Index modificator isn't support yet, skip codec test for A + let sb = B 1 2 + sc = C 1 2 + encoded_b = "\x01\x01\0\0\0\x02\0\0\0\0\0\0\0" :: ByteString + encoded_c = "\x02\x01\0\0\0\x02\0\0\0\0\0\0\0" :: ByteString + + encode sc `shouldBe` encoded_c + encode sb `shouldBe` encoded_b + + decode encoded_b `shouldBe` Right sb + decode encoded_c `shouldBe` Right sc + decode ("\x0a" :: ByteString) `shouldBe` (Left "Failed reading: index out of enum constructors count: 7\nEmpty call stack\n" :: Either String EnumType) + + it "should_derive_encode" $ do + let v :: TestType + v = Struct 15 9 (V.fromList $ BS.unpack "Hello world") + v_encoded :: ByteString + v_encoded = "\x0f\0\0\0\x09\0\0\0\0\0\0\0\x2cHello world" + encode v `shouldBe` v_encoded + Right v `shouldBe` decode v_encoded + + it "should_work_for_unit" $ do + encode Unit `shouldBe` ("" :: ByteString) + decode ("" :: ByteString) `shouldBe` Right Unit + + it "should_work_for_indexed" $ do + let v = Indexed 1 2 + v_encoded :: ByteString + v_encoded = "\x01\0\0\0\x02\0\0\0\0\0\0\0" + encode v `shouldBe` v_encoded + Right v `shouldBe` decode v_encoded + + it "correct_error_for_indexed_0" $ do + let wrong = "\x08" :: ByteString + decode wrong `shouldBe` (Left "too few bytes\nFrom:\tdemandInput\n\n" :: Either String Indexed) + + it "correct_error_for_indexed_1" $ do + let wrong = "\0\0\0\0\x01" :: ByteString + decode wrong `shouldBe` (Left "too few bytes\nFrom:\tdemandInput\n\n" :: Either String Indexed) + + it "correct_error_for_enumtype" $ do + let wrong = "\x01" :: ByteString + decode wrong `shouldBe` (Left "too few bytes\nFrom:\tdemandInput\n\n" :: Either String EnumType) + + it "correct_error_for_named_struct_1" $ do + let wrong = "\x01" :: ByteString + decode wrong `shouldBe` (Left "too few bytes\nFrom:\tdemandInput\n\n" :: Either String TestType) + + it "correct_error_for_named_struct_2" $ do + let wrong = "\0\0\0\0\x01" :: ByteString + decode wrong `shouldBe` (Left "too few bytes\nFrom:\tdemandInput\n\n" :: Either String TestType) + + let u64_TEST_COMPACT_VALUES :: [(Word64, Int)] + u64_TEST_COMPACT_VALUES = + [ (0, 1), (63, 1), (64, 2), (16383, 2) + , (16384, 4), (1073741823, 4), (1073741824, 5) + , (bit 32 - 1, 5), (bit 32, 6), (bit 40, 7) + , (bit 48, 8), (bit 56 - 1, 8), (bit 56, 9) + , (maxBound, 9) + ] + + it "compact_works" $ forM_ u64_TEST_COMPACT_VALUES $ \(n, l) -> do + let encoded = encode (TestHasCompact $ Compact n) + BS.length encoded `shouldBe` l + decode encoded `shouldBe` Right (Compact n) + + let u64_TEST_COMPACT_VALUES_FOR_ENUM :: [(Word64, Int)] + u64_TEST_COMPACT_VALUES_FOR_ENUM = + [ (0, 2), (63, 2), (64, 3), (16383, 3), (16384, 5) + , (1073741823, 5), (1073741824, 6), (bit 32 - 1, 6) + , (bit 32, 7), (bit 40, 8), (bit 48, 9), (bit 56 - 1, 9) + , (bit 56, 10), (maxBound, 10) + ] + + it "enum_compact_works" $ forM_ u64_TEST_COMPACT_VALUES_FOR_ENUM $ \(x, l) -> do + let u = encode $ Unnamed (Compact x) + BS.length u `shouldBe` l + decode u `shouldBe` Right (Unnamed $ Compact x) + + let n = encode $ Named (Compact x) + BS.length n `shouldBe` l + decode n `shouldBe` Right (Named $ Compact x) + + let uc = encode $ UnnamedCompact (Compact x) + BS.length uc `shouldBe` l + decode uc `shouldBe` Right (UnnamedCompact $ Compact x) + + let nc = encode $ NamedCompact (Compact x) + BS.length nc `shouldBe` l + decode nc `shouldBe` Right (NamedCompact $ Compact x) diff --git a/tests/Codec/Scale/Test/SingleFieldStructSpec.hs b/tests/Codec/Scale/Test/SingleFieldStructSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Codec/Scale/Test/SingleFieldStructSpec.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Codec.Scale.Test.SingleFieldStructSpec +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : Apache-2.0 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Ported to Haskell rust test spec: +-- https://github.com/paritytech/parity-scale-codec/blob/master/tests/single_field_struct_encoding.rs +-- + +module Codec.Scale.Test.SingleFieldStructSpec where + +import Data.ByteString as BS (pack) +import Data.Default (def) +import Data.Word (Word32, Word64) +import qualified GHC.Generics as GHC (Generic) +import Test.Hspec + +import Codec.Scale +import Codec.Scale.Skip + +newtype S = S { x1 :: Word32 } + deriving (Eq, Ord, Show, Encode, Decode) + +data SSkip = SSkip + { s1 :: Skip Word32 + , x2 :: Word32 + , s2 :: Skip Word32 + } + deriving (Eq, Ord, Show, GHC.Generic) + +instance Generic SSkip +instance Encode SSkip +instance Decode SSkip + +newtype Sc = Sc { x3 :: Compact Word32 } + deriving (Eq, Ord, Show, Encode, Decode) + +newtype U = U Word32 + deriving (Eq, Ord, Show, Enum, Num, Real, Integral, Encode, Decode) + +newtype U2 = U2 { a :: Word64 } + deriving (Eq, Ord, Show, Encode, Decode) + +data USkip = USkip (Skip Word32) Word32 (Skip Word32) + deriving (Eq, Ord, Show, GHC.Generic) + +instance Generic USkip +instance Encode USkip +instance Decode USkip + +newtype Uc = Uc (Compact Word32) + deriving (Eq, Ord, Show, Encode, Decode) + +newtype Ucas = Ucas (Compact U) + deriving (Eq, Ord, Show, Encode, Decode) + +spec :: Spec +spec = parallel $ do + describe "Single field struct encoding" $ do + let x = 3 + s = S x + s_skip = SSkip def x def + sc = Sc (Compact x) + u = U x + u_skip = USkip def x def + uc = Uc (Compact x) + ucom = Compact u + ucas = Ucas (Compact u) + + s_encoded = BS.pack [3, 0, 0, 0] + s_skip_encoded = BS.pack [3, 0, 0, 0] + sc_encoded = BS.pack [12] + u_encoded = BS.pack [3, 0, 0, 0] + u_skip_encoded = BS.pack [3, 0, 0, 0] + uc_encoded = BS.pack [12] + ucom_encoded = BS.pack [12] + ucas_encoded = BS.pack [12] + + it "encoding" $ do + encode s `shouldBe` s_encoded + encode s_skip `shouldBe` s_skip_encoded + encode sc `shouldBe` sc_encoded + encode u `shouldBe` u_encoded + encode u_skip `shouldBe` u_skip_encoded + encode uc `shouldBe` uc_encoded + encode ucom `shouldBe` ucom_encoded + encode ucas `shouldBe` ucas_encoded + + it "decoding" $ do + Right s `shouldBe` decode s_encoded + Right s_skip `shouldBe` decode s_skip_encoded + Right sc `shouldBe` decode sc_encoded + Right u `shouldBe` decode u_encoded + Right u_skip `shouldBe` decode u_skip_encoded + Right uc `shouldBe` decode uc_encoded + Right ucom `shouldBe` decode ucom_encoded + Right ucas `shouldBe` decode ucas_encoded diff --git a/tests/Codec/Scale/Test/SkipSpec.hs b/tests/Codec/Scale/Test/SkipSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Codec/Scale/Test/SkipSpec.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Codec.Scale.Test.SkipSpec +-- Copyright : Aleksandr Krupenkin 2016-2021 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : unportable +-- +-- Ported to Haskell rust test spec: +-- https://github.com/paritytech/parity-scale-codec/blob/master/tests/skip.rs +-- + +module Codec.Scale.Test.SkipSpec where + +import Data.ByteString (ByteString, pack) +import Data.Default (Default) +import Data.Word (Word32) +import qualified GHC.Generics as GHC (Generic) +import Test.Hspec + +import Codec.Scale +import Codec.Scale.SingletonEnum +import Codec.Scale.Skip + +data UncodecType = UncodecType + deriving (Eq, Ord, Show, GHC.Generic, Default) + +-- Implementing A constructor is impossible +data EnumType = B + { _b1 :: Skip UncodecType + , b2 :: Word32 + } + | C (Skip UncodecType) Word32 + deriving (Eq, Ord, Show, GHC.Generic, Generic, Encode, Decode) + + +data StructNamed = StructNamed + { a :: Skip UncodecType + , b :: Word32 + } + deriving (Eq, Ord, Show, GHC.Generic, Generic, Encode, Decode) + +data StructUnnamed = StructUnnamed (Skip UncodecType) Word32 + deriving (Eq, Ord, Show, GHC.Generic, Generic, Encode, Decode) + +data NamedStruct = NamedStruct + { some_named :: Word32 + , ignore :: Skip (Maybe Word32) + } + deriving (Eq, Ord, Show, GHC.Generic, Generic, Encode, Decode) + +spec :: Spec +spec = parallel $ do + describe "Type encoding modificators" $ do + it "enum_struct_test" $ do + let eb = B { _b1 = Skip UncodecType, b2 = 1 } + ec = C (Skip UncodecType) 1 + sn = StructNamed { a = Skip UncodecType, b = 1 } + su = StructUnnamed (Skip UncodecType) 1 + + let eb_encoded = encode eb :: ByteString + let ec_encoded = encode ec :: ByteString + let sn_encoded = encode sn :: ByteString + let su_encoded = encode su :: ByteString + + decode eb_encoded `shouldBe` Right eb + decode ec_encoded `shouldBe` Right ec + decode sn_encoded `shouldBe` Right sn + decode su_encoded `shouldBe` Right su + + it "skip_enum_struct_inner_variant" $ do + let struct = NamedStruct { some_named = 1, ignore = Skip (Just 1) } + single = SingletonEnum struct + encoded = pack [0x00, 0x01, 0x00, 0x00, 0x00] + encode single `shouldBe` encoded 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 #-}