bech32 (empty) → 1.0.0
raw patch · 7 files changed
+1777/−0 lines, 7 filesdep +QuickCheckdep +arraydep +base
Dependencies added: QuickCheck, array, base, bech32, bytestring, containers, deepseq, extra, hspec, text, vector
Files
- ChangeLog.md +5/−0
- LICENSE +201/−0
- bech32.cabal +83/−0
- src/Codec/Binary/Bech32.hs +37/−0
- src/Codec/Binary/Bech32/Internal.hs +813/−0
- test/Codec/Binary/Bech32Spec.hs +637/−0
- test/Main.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# ChangeLog for `bech32`++## 1.0.0 -- 2019-09-27+++ Initial release pulled from https://github.com/input-output-hk/cardano-wallet
+ LICENSE view
@@ -0,0 +1,201 @@+ 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 © 2018-2019 IOHK++ 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.
+ bech32.cabal view
@@ -0,0 +1,83 @@+name: bech32+version: 1.0.0+synopsis: Implementation of the Bech32 cryptocurrency address format (BIP 0173).+description: Implementation of the Bech32 cryptocurrency address format documented in the+ BIP (Bitcoin Improvement Proposal) 0173.+author: IOHK Engineering Team+maintainer: operations@iohk.io, erikd@mega-nerd.com+copyright: 2017 Marko Bencun, 2019 IOHK+license: Apache-2.0+license-file: LICENSE+homepage: https://github.com/input-output-hk/bech32+bug-reports: https://github.com/input-output-hk/bech32/issues+category: Web+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/input-output-hk/bech32.git++flag werror+ description: Enable `-Werror`+ default: False+ manual: True++library+ default-language:+ Haskell2010+ default-extensions:+ NoImplicitPrelude+ OverloadedStrings+ ghc-options:+ -Wall+ -Wcompat+ -fwarn-redundant-constraints+ if (flag(werror))+ ghc-options:+ -Werror+ build-depends:+ array+ , base < 4.14+ , bytestring+ , containers+ , extra+ , text+ hs-source-dirs:+ src+ exposed-modules:+ Codec.Binary.Bech32+ Codec.Binary.Bech32.Internal++test-suite bech32-test+ default-language:+ Haskell2010+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test+ ghc-options:+ -threaded -rtsopts -with-rtsopts=-N+ -O2+ -Wall+ if (flag(werror))+ ghc-options:+ -Werror+ build-depends:+ base+ , bech32+ , bytestring+ , containers+ , deepseq+ , extra+ , hspec+ , QuickCheck+ , text+ , vector+ build-tools:+ hspec-discover+ main-is:+ Main.hs+ other-modules:+ Codec.Binary.Bech32Spec
+ src/Codec/Binary/Bech32.hs view
@@ -0,0 +1,37 @@+-- |+-- Copyright: © 2017 Marko Bencun, 2018-2019 IOHK+-- License: Apache-2.0+--+-- Implementation of the [Bech32]+-- (https://github.com/bitcoin/bips/blob/master/bip-0173.mediawiki)+-- address format.+--+-- From an original implementation by Marko Bencun:+--+-- [sipa/bech32](https://github.com/sipa/bech32/tree/bdc264f84014c234e908d72026b7b780122be11f/ref/haskell)++module Codec.Binary.Bech32+ (+ -- * Encoding & Decoding+ encode+ , encodeLenient+ , EncodingError (..)+ , decode+ , decodeLenient+ , DecodingError (..)++ -- * Data Part+ , DataPart+ , dataPartFromBytes+ , dataPartFromText+ , dataPartToBytes+ , dataPartToText++ -- * Human-Readable Part+ , HumanReadablePart+ , HumanReadablePartError (..)+ , humanReadablePartFromText+ , humanReadablePartToText+ ) where++import Codec.Binary.Bech32.Internal
+ src/Codec/Binary/Bech32/Internal.hs view
@@ -0,0 +1,813 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Copyright: © 2017 Marko Bencun, 2018-2019 IOHK+-- License: Apache-2.0+--+-- Implementation of the [Bech32]+-- (https://github.com/bitcoin/bips/blob/master/bip-0173.mediawiki)+-- address format.+--+-- From an original implementation by Marko Bencun:+--+-- [sipa/bech32](https://git.io/fj8FV)+--+module Codec.Binary.Bech32.Internal+ (+ -- * Encoding & Decoding+ encode+ , encodeLenient+ , EncodingError (..)+ , decode+ , decodeLenient+ , DecodingError (..)+ , checksumLength+ , encodedStringMaxLength+ , encodedStringMinLength+ , separatorChar+ , separatorLength++ -- * Data Part+ , DataPart+ , dataPartIsValid+ , dataPartFromBytes+ , dataPartFromText+ , dataPartFromWords+ , dataPartToBytes+ , dataPartToText+ , dataPartToWords+ , dataCharToWord+ , dataCharFromWord+ , dataCharList++ -- * Human-Readable Part+ , HumanReadablePart+ , HumanReadablePartError (..)+ , humanReadablePartFromText+ , humanReadablePartToText+ , humanReadablePartToWords+ , humanReadablePartMinLength+ , humanReadablePartMaxLength+ , humanReadableCharMinBound+ , humanReadableCharMaxBound++ -- * Bit Manipulation+ , convertBits+ , Word5+ , word5+ , getWord5+ , toBase256+ , toBase32+ , noPadding+ , yesPadding++ -- * Character Manipulation+ , CharPosition (..)++ ) where++import Prelude++import Control.Monad+ ( guard, join )+import Data.Array+ ( Array )+import Data.Bifunctor+ ( first )+import Data.Bits+ ( Bits, testBit, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.) )+import Data.ByteString+ ( ByteString )+import Data.Char+ ( chr, ord, toLower, toUpper )+import Data.Either.Extra+ ( maybeToEither )+import Data.Foldable+ ( foldl' )+import Data.Functor.Identity+ ( Identity, runIdentity )+import Data.Ix+ ( Ix (..) )+import Data.List+ ( sort )+import Data.Map.Strict+ ( Map )+import Data.Maybe+ ( isNothing, mapMaybe )+import Data.Text+ ( Text )+import Data.Word+ ( Word8 )++import qualified Data.Array as Arr+import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import qualified Data.Text as T++{-------------------------------------------------------------------------------+ Data Part+-------------------------------------------------------------------------------}++-- | Represents the data part of a Bech32 string, as defined here:+-- https://git.io/fj8FS+newtype DataPart = DataPart Text+ deriving newtype (Eq, Monoid, Semigroup)+ deriving stock Show++-- | Returns true iff. the specified 'DataPart' is valid.+--+dataPartIsValid :: DataPart -> Bool+dataPartIsValid (DataPart dp) = T.all dataCharIsValid dp++-- | Constructs a 'DataPart' from a 'ByteString'.+--+-- This function encodes a 'ByteString' in such a way that guarantees it can be+-- successfully decoded with the 'dataPartToBytes' function:+--+-- > dataPartToBytes (dataPartFromBytes b) == Just b+--+dataPartFromBytes :: ByteString -> DataPart+dataPartFromBytes =+ DataPart . T.pack . fmap dataCharFromWord . toBase32 . BS.unpack++-- | Attempts to extract a 'ByteString' from a 'DataPart'.+--+-- This function guarantees to satisfy the following property:+--+-- > dataPartToBytes (dataPartFromBytes b) == Just b+--+dataPartToBytes :: DataPart -> Maybe ByteString+dataPartToBytes dp = BS.pack <$>+ (toBase256 =<< traverse dataCharToWord (T.unpack $ dataPartToText dp))++-- | Constructs a 'DataPart' from textual input. All characters in the input+-- must be a member of 'dataCharList', the set of characters permitted to+-- appear within the data part of a Bech32 string.+--+-- Returns 'Nothing' if any character in the input is not a member of+-- 'dataCharList'.+--+-- This function guarantees to satisfy the following property:+--+-- > dataPartFromText (dataPartToText d) == Just d+--+dataPartFromText :: Text -> Maybe DataPart+dataPartFromText text+ | T.any (not . dataCharIsValid) textLower = Nothing+ | otherwise = pure $ DataPart textLower+ where+ textLower = T.toLower text++-- | Converts a 'DataPart' to 'Text', using the Bech32 character set to render+-- the data.+--+-- This function guarantees to satisfy the following property:+--+-- > dataPartFromText (dataPartToText d) == Just d+--+dataPartToText :: DataPart -> Text+dataPartToText (DataPart t) = t++-- | Construct a 'DataPart' directly from words.+--+-- This function guarantees to satisfy the following properties:+--+-- > dataPartFromWords (dataPartToWords d) == d+-- > dataPartToWords (dataPartFromWords w) == w+--+dataPartFromWords :: [Word5] -> DataPart+dataPartFromWords = DataPart . T.pack . fmap dataCharFromWord++-- | Convert a 'DataPart' into words.+--+dataPartToWords :: DataPart -> [Word5]+dataPartToWords = mapMaybe dataCharToWord . T.unpack . dataPartToText++-- | Returns true iff. the specified character is permitted to appear within+-- the data part of a Bech32 string.+-- See here for more details: https://git.io/fj8FS+dataCharIsValid :: Char -> Bool+dataCharIsValid = (`Map.member` dataCharToWordMap)++-- | A list of all characters that are permitted to appear within the data part+-- of a Bech32 string. See here for more details: https://git.io/fj8FS+dataCharList :: String+dataCharList = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"++-- | If the specified character is permitted to appear within the data part+-- of a Bech32 string, this function returns that character's corresponding+-- 'Word5' value. If the specified character is not permitted, or if the+-- specified character is upper-case, returns 'Nothing'.+dataCharToWord :: Char -> Maybe Word5+dataCharToWord = (`Map.lookup` dataCharToWordMap)++dataCharToWordMap :: Map Char Word5+dataCharToWordMap = Map.fromList $ dataCharList `zip` [minBound .. maxBound]++-- | Maps the specified 'Word5' onto a character that is permitted to appear+-- within the data part of a Bech32 string.+dataCharFromWord :: Word5 -> Char+dataCharFromWord = (dataCharFromWordArray Arr.!)++dataCharFromWordArray :: Array Word5 Char+dataCharFromWordArray = Arr.listArray (minBound, maxBound) dataCharList++{-------------------------------------------------------------------------------+ Human Readable Part+-------------------------------------------------------------------------------}++-- | Represents the human-readable part of a Bech32 string, as defined here:+-- https://git.io/fj8FS+newtype HumanReadablePart = HumanReadablePart Text+ deriving newtype (Eq, Monoid, Semigroup)+ deriving stock Show++-- | Parses the human-readable part of a Bech32 string, as defined here:+-- https://git.io/fj8FS+humanReadablePartFromText+ :: Text -> Either HumanReadablePartError HumanReadablePart+humanReadablePartFromText hrp+ | T.length hrp < humanReadablePartMinLength =+ Left HumanReadablePartTooShort+ | T.length hrp > humanReadablePartMaxLength =+ Left HumanReadablePartTooLong+ | not (null invalidCharPositions) =+ Left $ HumanReadablePartContainsInvalidChars invalidCharPositions+ | otherwise =+ Right $ HumanReadablePart $ T.toLower hrp+ where+ invalidCharPositions = CharPosition . fst <$> filter+ ((not . humanReadableCharIsValid) . snd) ([0 .. ] `zip` T.unpack hrp)++-- | Represents the set of error conditions that may occur while parsing the+-- human-readable part of a Bech32 string.+data HumanReadablePartError+ = HumanReadablePartTooShort+ | HumanReadablePartTooLong+ | HumanReadablePartContainsInvalidChars [CharPosition]+ deriving (Eq, Show)++-- | Get the raw text of the human-readable part of a Bech32 string.+humanReadablePartToText :: HumanReadablePart -> Text+humanReadablePartToText (HumanReadablePart t) = t++-- | Convert the specified human-readable part to a list of words.+humanReadablePartToWords :: HumanReadablePart -> [Word5]+humanReadablePartToWords (HumanReadablePart hrp) =+ map (Word5 . (.>>. 5)) (fromIntegral . ord <$> T.unpack hrp)+ ++ [Word5 0]+ ++ map word5 (ord <$> T.unpack hrp)++-- | The shortest length permitted for the human-readable part of a Bech32+-- string.+humanReadablePartMinLength :: Int+humanReadablePartMinLength = 1++-- | The longest length permitted for the human-readable part of a Bech32+-- string.+humanReadablePartMaxLength :: Int+humanReadablePartMaxLength = 83++-- | Returns true iff. the specified character is permitted to appear+-- within the human-readable part of a Bech32 string.+humanReadableCharIsValid :: Char -> Bool+humanReadableCharIsValid c =+ c >= humanReadableCharMinBound &&+ c <= humanReadableCharMaxBound++-- | The lower bound of the set of characters permitted to appear within the+-- human-readable part of a Bech32 string.+humanReadableCharMinBound :: Char+humanReadableCharMinBound = chr 33++-- | The upper bound of the set of characters permitted to appear within the+-- human-readable part of a Bech32 string.+humanReadableCharMaxBound :: Char+humanReadableCharMaxBound = chr 126++{-------------------------------------------------------------------------------+ Encoding & Decoding+-------------------------------------------------------------------------------}++-- | Like 'encode' but allows output to be longer than 90 characters. This isn't+-- ideal as the error detection becomes worse as string get longer but it's+-- still acceptable.+--+-- From BIP-0173:+--+-- Even though the chosen code performs reasonably well up to 1023+-- characters, other designs are preferable for lengths above 89+-- characters (excluding the separator).+--+encodeLenient :: HumanReadablePart -> DataPart -> Text+encodeLenient hrp dp = humanReadablePartToText hrp+ <> T.singleton separatorChar+ <> T.pack dcp+ where+ dcp = dataCharFromWord <$> dataPartToWords dp <> createChecksum hrp dp++-- | Encode a human-readable string and data payload into a Bech32 string.+encode :: HumanReadablePart -> DataPart -> Either EncodingError Text+encode hrp dp+ | T.length result > encodedStringMaxLength = Left EncodedStringTooLong+ | otherwise = pure result+ where+ result = encodeLenient hrp dp++-- | Represents the set of error conditions that may occur while encoding a+-- Bech32 string.+data EncodingError = EncodedStringTooLong+ deriving (Eq, Show)++-- | Like 'decode' but does not enforce a maximum length. See also+-- 'encodeLenient' for details.+decodeLenient :: Text -> Either DecodingError (HumanReadablePart, DataPart)+decodeLenient bech32 = do+ guardE (T.length bech32 >= encodedStringMinLength) StringToDecodeTooShort+ guardE (T.map toUpper bech32 == bech32 || T.map toLower bech32 == bech32)+ StringToDecodeHasMixedCase+ (hrpUnparsed, dcpUnparsed) <-+ maybeToEither StringToDecodeMissingSeparatorChar $+ splitAtLastOccurrence separatorChar $ T.map toLower bech32+ hrp <- first humanReadablePartError $ humanReadablePartFromText hrpUnparsed+ dcp <- first+ (StringToDecodeContainsInvalidChars . fmap+ (\(CharPosition p) ->+ CharPosition $ p + T.length hrpUnparsed + separatorLength))+ (parseDataWithChecksumPart dcpUnparsed)+ guardE (length dcp >= checksumLength) StringToDecodeTooShort+ guardE (verifyChecksum hrp dcp) $+ StringToDecodeContainsInvalidChars $ findErrorPositions hrp dcp+ let dp = dataPartFromWords $ take (length dcp - checksumLength) dcp+ return (hrp, dp)+ where+ -- Use properties of the checksum algorithm to find the locations of errors+ -- within the human-readable part and data-with-checksum part.+ findErrorPositions :: HumanReadablePart -> [Word5] -> [CharPosition]+ findErrorPositions hrp dcp+ | residue == 0 = []+ | otherwise = sort $ toCharPosition <$> errorPositionsIgnoringSeparator+ where+ residue = polymod (humanReadablePartToWords hrp ++ dcp) `xor` 1+ toCharPosition i+ | i < T.length (humanReadablePartToText hrp) = CharPosition i+ | otherwise = CharPosition $ i + separatorLength+ errorPositionsIgnoringSeparator =+ (T.length bech32 - separatorLength - 1 - ) <$>+ locateErrors (fromIntegral residue) (T.length bech32 - 1)++-- | Decode a Bech32 string into a human-readable part and data part.+decode :: Text -> Either DecodingError (HumanReadablePart, DataPart)+decode bech32 = do+ guardE (T.length bech32 <= encodedStringMaxLength) StringToDecodeTooLong+ decodeLenient bech32++-- | Parse a data-with-checksum part, checking that each character is part+-- of the supported character set. If one or more characters are not in the+-- supported character set, return the list of illegal character positions.+parseDataWithChecksumPart :: Text -> Either [CharPosition] [Word5]+parseDataWithChecksumPart dcpUnparsed =+ case mapM dataCharToWord $ T.unpack dcpUnparsed of+ Nothing -> Left invalidCharPositions+ Just dcp -> Right dcp+ where+ invalidCharPositions =+ CharPosition . fst <$> filter (isNothing . snd)+ ([0 .. ] `zip` (dataCharToWord <$> T.unpack dcpUnparsed))++-- | Convert an error encountered while parsing a human-readable part into a+-- general decoding error.+humanReadablePartError :: HumanReadablePartError -> DecodingError+humanReadablePartError = \case+ HumanReadablePartTooLong ->+ StringToDecodeContainsInvalidChars+ [CharPosition humanReadablePartMaxLength]+ HumanReadablePartTooShort ->+ StringToDecodeContainsInvalidChars+ [CharPosition $ humanReadablePartMinLength - 1]+ HumanReadablePartContainsInvalidChars ps ->+ StringToDecodeContainsInvalidChars ps++-- | Represents the set of errors that may occur while decoding a Bech32+-- string with the 'decode' function.+data DecodingError+ = StringToDecodeTooLong+ | StringToDecodeTooShort+ | StringToDecodeHasMixedCase+ | StringToDecodeMissingSeparatorChar+ | StringToDecodeContainsInvalidChars [CharPosition]+ -- ^ In cases where it is possible to determine the exact locations of+ -- erroneous characters, this list will encode those locations. Clients+ -- can use this information to provide user feedback. In cases where it+ -- isn't possible to reliably determine the locations of erroneous+ -- characters, this list will be empty.+ deriving (Eq, Show)++-- | The separator character. This character appears immediately after the+-- human-readable part and before the data part.+separatorChar :: Char+separatorChar = '1'++-- | The length of the checksum portion of an encoded string, in bytes.+checksumLength :: Int+checksumLength = 6++-- | The length of the separator portion of an encoded string, in bytes.+separatorLength :: Int+separatorLength = 1++-- | The maximum length of an encoded string, in bytes. This length includes the+-- human-readable part, the separator character, the encoded data portion,+-- and the checksum.+encodedStringMaxLength :: Int+encodedStringMaxLength = 90++-- | The minimum length of an encoded string, in bytes. This length includes the+-- human-readable part, the separator character, the encoded data portion,+-- and the checksum.+encodedStringMinLength :: Int+encodedStringMinLength =+ humanReadablePartMinLength + separatorLength + checksumLength++{-------------------------------------------------------------------------------+ Character Manipulation+-------------------------------------------------------------------------------}++-- | The zero-based position of a character in a string, counting from the left.+newtype CharPosition = CharPosition Int+ deriving (Eq, Ord, Show)++{-------------------------------------------------------------------------------+ Bit Manipulation+-------------------------------------------------------------------------------}++(.>>.), (.<<.) :: Bits a => a -> Int -> a+(.>>.) = unsafeShiftR+(.<<.) = unsafeShiftL++newtype Word5 = Word5 { getWord5 :: Word8 }+ deriving (Eq, Ord, Show)++instance Bounded Word5 where+ minBound = Word5 0+ maxBound = Word5 31++instance Enum Word5 where+ toEnum = word5+ fromEnum = fromWord5++instance Ix Word5 where+ range (Word5 m, Word5 n) = map Word5 $ range (m, n)+ index (Word5 m, Word5 n) (Word5 i) = index (m, n) i+ inRange (m,n) i = m <= i && i <= n++word5 :: Integral a => a -> Word5+word5 x = Word5 ((fromIntegral x) .&. 31)+{-# INLINE word5 #-}+{-# SPECIALIZE INLINE word5 :: Word8 -> Word5 #-}++fromWord5 :: Integral a => Word5 -> a+fromWord5 (Word5 x) = fromIntegral x+{-# INLINE fromWord5 #-}+{-# SPECIALIZE INLINE fromWord5 :: Word5 -> Word8 #-}++polymod :: [Word5] -> Word+polymod values = foldl' go 1 values .&. 0x3fffffff+ where+ go chk value =+ foldl' xor chk' [g | (g, i) <- zip generator [25 ..], testBit chk i]+ where+ chk' = chk .<<. 5 `xor` (fromWord5 value)+ generator =+ [ 0x3b6a57b2+ , 0x26508e6d+ , 0x1ea119fa+ , 0x3d4233dd+ , 0x2a1462b3 ]++createChecksum :: HumanReadablePart -> DataPart -> [Word5]+createChecksum hrp dat = [word5 (polymod' .>>. i) | i <- [25, 20 .. 0]]+ where+ values = humanReadablePartToWords hrp ++ dataPartToWords dat+ polymod' =+ polymod (values ++ map Word5 [0, 0, 0, 0, 0, 0]) `xor` 1++verifyChecksum :: HumanReadablePart -> [Word5] -> Bool+verifyChecksum hrp dat = polymod (humanReadablePartToWords hrp ++ dat) == 1++type Pad f = Int -> Int -> Word -> [[Word]] -> f [[Word]]++yesPadding :: Pad Identity+yesPadding _ 0 _ result = return result+yesPadding _ _ padValue result = return $ [padValue] : result+{-# INLINE yesPadding #-}++noPadding :: Pad Maybe+noPadding frombits bits padValue result = do+ guard $ bits < frombits && padValue == 0+ return result+{-# INLINE noPadding #-}++-- | Big-endian conversion of a word string from base '2^frombits' to base+-- '2^tobits'. The 'frombits' and 'twobits' parameters must be positive, while+-- '2^frombits' and '2^tobits' must be smaller than the size of 'Word'. Every+-- value in 'dat' must be strictly smaller than '2^frombits'.+convertBits :: Functor f => [Word] -> Int -> Int -> Pad f -> f [Word]+convertBits dat frombits tobits pad = concat . reverse <$> go dat 0 0 []+ where+ go [] acc bits result =+ let padValue = (acc .<<. (tobits - bits)) .&. maxv+ in pad frombits bits padValue result+ go (value:dat') acc bits result =+ go dat' acc' (bits' `rem` tobits) (result' : result)+ where+ acc' = (acc .<<. frombits) .|. fromIntegral value+ bits' = bits + frombits+ result' =+ [ (acc' .>>. b) .&. maxv+ | b <- [bits' - tobits, bits' - 2 * tobits .. 0] ]+ maxv = (1 .<<. tobits) - 1+{-# INLINE convertBits #-}++toBase32 :: [Word8] -> [Word5]+toBase32 dat =+ map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding++toBase256 :: [Word5] -> Maybe [Word8]+toBase256 dat =+ map fromIntegral <$> convertBits (map fromWord5 dat) 5 8 noPadding++{-------------------------------------------------------------------------------+ Error Location Detection+-------------------------------------------------------------------------------}++-- | This lookup table is a Haskell translation of the reference JavaScript+-- implementation here: https://git.io/fj8FR+gf_1024_exp :: Array Int Int+gf_1024_exp = Arr.listArray (0, 1023) [+ 1, 303, 635, 446, 997, 640, 121, 142, 959, 420, 350, 438, 166, 39, 543,+ 335, 831, 691, 117, 632, 719, 97, 107, 374, 558, 797, 54, 150, 858, 877,+ 724, 1013, 294, 23, 354, 61, 164, 633, 992, 538, 469, 659, 174, 868, 184,+ 809, 766, 563, 866, 851, 257, 520, 45, 770, 535, 524, 408, 213, 436, 760,+ 472, 330, 933, 799, 616, 361, 15, 391, 756, 814, 58, 608, 554, 680, 993,+ 821, 942, 813, 843, 484, 193, 935, 321, 919, 572, 741, 423, 559, 562,+ 589, 296, 191, 493, 685, 891, 665, 435, 60, 395, 2, 606, 511, 853, 746,+ 32, 219, 284, 631, 840, 661, 837, 332, 78, 311, 670, 887, 111, 195, 505,+ 190, 194, 214, 709, 380, 819, 69, 261, 957, 1018, 161, 739, 588, 7, 708,+ 83, 328, 507, 736, 317, 899, 47, 348, 1000, 345, 882, 245, 367, 996, 943,+ 514, 304, 90, 804, 295, 312, 793, 387, 833, 249, 921, 660, 618, 823, 496,+ 722, 30, 782, 225, 892, 93, 480, 372, 112, 738, 867, 636, 890, 950, 968,+ 386, 622, 642, 551, 369, 234, 846, 382, 365, 442, 592, 343, 986, 122,+ 1023, 59, 847, 81, 790, 4, 437, 983, 931, 244, 64, 415, 529, 487, 944,+ 35, 938, 664, 156, 583, 53, 999, 222, 390, 987, 341, 388, 389, 170, 721,+ 879, 138, 522, 627, 765, 322, 230, 440, 14, 168, 143, 656, 991, 224, 595,+ 550, 94, 657, 752, 667, 1005, 451, 734, 744, 638, 292, 585, 157, 872,+ 590, 601, 827, 774, 930, 475, 571, 33, 500, 871, 969, 173, 21, 828, 450,+ 1009, 147, 960, 705, 201, 228, 998, 497, 1021, 613, 688, 772, 508, 36,+ 366, 715, 468, 956, 725, 730, 861, 425, 647, 701, 221, 759, 95, 958, 139,+ 805, 8, 835, 679, 614, 449, 128, 791, 299, 974, 617, 70, 628, 57, 273,+ 430, 67, 750, 405, 780, 703, 643, 776, 778, 340, 171, 1022, 276, 308,+ 495, 243, 644, 460, 857, 28, 336, 286, 41, 695, 448, 431, 364, 149, 43,+ 233, 63, 762, 902, 181, 240, 501, 584, 434, 275, 1008, 444, 443, 895,+ 812, 612, 927, 383, 66, 961, 1006, 690, 346, 3, 881, 900, 747, 271, 672,+ 162, 402, 456, 748, 971, 755, 490, 105, 808, 977, 72, 732, 182, 897, 625,+ 163, 189, 947, 850, 46, 115, 403, 231, 151, 629, 278, 874, 16, 934, 110,+ 492, 898, 256, 807, 598, 700, 498, 140, 481, 91, 523, 860, 134, 252, 771,+ 824, 119, 38, 816, 820, 641, 342, 757, 513, 577, 990, 463, 40, 920, 955,+ 17, 649, 533, 82, 103, 896, 862, 728, 259, 86, 466, 87, 253, 556, 323,+ 457, 963, 432, 845, 527, 745, 849, 863, 1015, 888, 488, 567, 727, 132,+ 674, 764, 109, 669, 6, 1003, 552, 246, 542, 96, 324, 781, 912, 248, 694,+ 239, 980, 210, 880, 683, 144, 177, 325, 546, 491, 326, 339, 623, 941, 92,+ 207, 783, 462, 263, 483, 517, 1012, 9, 620, 220, 984, 548, 512, 878, 421,+ 113, 973, 280, 962, 159, 310, 945, 268, 465, 806, 889, 199, 76, 873, 865,+ 34, 645, 227, 290, 418, 693, 926, 80, 569, 639, 11, 50, 291, 141, 206,+ 544, 949, 185, 518, 133, 909, 135, 467, 376, 646, 914, 678, 841, 954,+ 318, 242, 939, 951, 743, 1017, 976, 359, 167, 264, 100, 241, 218, 51, 12,+ 758, 368, 453, 309, 192, 648, 826, 553, 473, 101, 478, 673, 397, 1001,+ 118, 265, 331, 650, 356, 982, 652, 655, 510, 634, 145, 414, 830, 924,+ 526, 966, 298, 737, 18, 504, 401, 697, 360, 288, 1020, 842, 203, 698,+ 537, 676, 279, 581, 619, 536, 907, 876, 1019, 398, 152, 1010, 994, 68,+ 42, 454, 580, 836, 99, 565, 137, 379, 503, 22, 77, 582, 282, 412, 352,+ 611, 347, 300, 266, 570, 270, 911, 729, 44, 557, 108, 946, 637, 597, 461,+ 630, 615, 238, 763, 681, 718, 334, 528, 200, 459, 413, 79, 24, 229, 713,+ 906, 579, 384, 48, 893, 370, 923, 202, 917, 98, 794, 754, 197, 530, 662,+ 52, 712, 677, 56, 62, 981, 509, 267, 789, 885, 561, 316, 684, 596, 226,+ 13, 985, 779, 123, 720, 576, 753, 948, 406, 125, 315, 104, 519, 426, 502,+ 313, 566, 1016, 767, 796, 281, 749, 740, 136, 84, 908, 424, 936, 198,+ 355, 274, 735, 967, 5, 154, 428, 541, 785, 704, 486, 671, 600, 532, 381,+ 540, 574, 187, 88, 378, 216, 621, 499, 419, 922, 485, 494, 476, 255, 114,+ 188, 668, 297, 400, 918, 787, 158, 25, 458, 178, 564, 422, 768, 73, 1011,+ 717, 575, 404, 547, 196, 829, 237, 394, 301, 37, 65, 176, 106, 89, 85,+ 675, 979, 534, 803, 995, 363, 593, 120, 417, 452, 26, 699, 822, 223, 169,+ 416, 235, 609, 773, 211, 607, 208, 302, 852, 965, 603, 357, 761, 247,+ 817, 539, 250, 232, 272, 129, 568, 848, 624, 396, 710, 525, 183, 686, 10,+ 285, 856, 307, 811, 160, 972, 55, 441, 289, 723, 305, 373, 351, 153, 733,+ 409, 506, 975, 838, 573, 970, 988, 913, 471, 205, 337, 49, 594, 777, 549,+ 815, 277, 27, 916, 333, 353, 844, 800, 146, 751, 186, 375, 769, 358, 392,+ 883, 474, 788, 602, 74, 130, 329, 212, 155, 131, 102, 687, 293, 870, 742,+ 726, 427, 217, 834, 904, 29, 127, 869, 407, 338, 832, 470, 482, 810, 399,+ 439, 393, 604, 929, 682, 447, 714, 251, 455, 875, 319, 477, 464, 521,+ 258, 377, 937, 489, 792, 172, 314, 327, 124, 20, 531, 953, 591, 886, 320,+ 696, 71, 859, 578, 175, 587, 707, 663, 283, 179, 795, 989, 702, 940, 371,+ 692, 689, 555, 903, 410, 651, 75, 429, 818, 362, 894, 515, 31, 545, 666,+ 706, 952, 864, 269, 254, 349, 711, 802, 716, 784, 1007, 925, 801, 445,+ 148, 260, 658, 385, 287, 262, 204, 126, 586, 1004, 236, 165, 854, 411,+ 932, 560, 19, 215, 1002, 775, 653, 928, 901, 964, 884, 798, 839, 786,+ 433, 610, 116, 855, 180, 479, 910, 1014, 599, 915, 905, 306, 516, 731,+ 626, 978, 825, 344, 605, 654, 209 ]++-- | This lookup table is a Haskell translation of the reference JavaScript+-- implementation here: https://git.io/fj8FE+gf_1024_log :: Array Int Int+gf_1024_log = Arr.listArray (0, 1023) [+ -1, 0, 99, 363, 198, 726, 462, 132, 297, 495, 825, 528, 561, 693, 231,+ 66, 396, 429, 594, 990, 924, 264, 627, 33, 660, 759, 792, 858, 330, 891,+ 165, 957, 104, 259, 518, 208, 280, 776, 416, 13, 426, 333, 618, 339, 641,+ 52, 388, 140, 666, 852, 529, 560, 678, 213, 26, 832, 681, 309, 70, 194,+ 97, 35, 682, 341, 203, 777, 358, 312, 617, 125, 307, 931, 379, 765, 875,+ 951, 515, 628, 112, 659, 525, 196, 432, 134, 717, 781, 438, 440, 740,+ 780, 151, 408, 487, 169, 239, 293, 467, 21, 672, 622, 557, 571, 881, 433,+ 704, 376, 779, 22, 643, 460, 398, 116, 172, 503, 751, 389, 1004, 18, 576,+ 415, 789, 6, 192, 696, 923, 702, 981, 892, 302, 816, 876, 880, 457, 537,+ 411, 539, 716, 624, 224, 295, 406, 531, 7, 233, 478, 586, 864, 268, 974,+ 338, 27, 392, 614, 839, 727, 879, 211, 250, 758, 507, 830, 129, 369, 384,+ 36, 985, 12, 555, 232, 796, 221, 321, 920, 263, 42, 934, 778, 479, 761,+ 939, 1006, 344, 381, 823, 44, 535, 866, 739, 752, 385, 119, 91, 566, 80,+ 120, 117, 771, 675, 721, 514, 656, 271, 670, 602, 980, 850, 532, 488,+ 803, 1022, 475, 801, 878, 57, 121, 991, 742, 888, 559, 105, 497, 291,+ 215, 795, 236, 167, 692, 520, 272, 661, 229, 391, 814, 340, 184, 798,+ 984, 773, 650, 473, 345, 558, 548, 326, 202, 145, 465, 810, 471, 158,+ 813, 908, 412, 441, 964, 750, 401, 50, 915, 437, 975, 126, 979, 491, 556,+ 577, 636, 685, 510, 963, 638, 367, 815, 310, 723, 349, 323, 857, 394,+ 606, 505, 713, 630, 938, 106, 826, 332, 978, 599, 834, 521, 530, 248,+ 883, 32, 153, 90, 754, 592, 304, 635, 775, 804, 1, 150, 836, 1013, 828,+ 324, 565, 508, 113, 154, 708, 921, 703, 689, 138, 547, 911, 929, 82, 228,+ 443, 468, 480, 483, 922, 135, 877, 61, 578, 111, 860, 654, 15, 331, 851,+ 895, 484, 320, 218, 420, 190, 1019, 143, 362, 634, 141, 965, 10, 838,+ 632, 861, 34, 722, 580, 808, 869, 554, 598, 65, 954, 787, 337, 187, 281,+ 146, 563, 183, 668, 944, 171, 837, 23, 867, 541, 916, 741, 625, 123, 736,+ 186, 357, 665, 977, 179, 156, 219, 220, 216, 67, 870, 902, 774, 98, 820,+ 574, 613, 900, 755, 596, 370, 390, 769, 314, 701, 894, 56, 841, 949, 987,+ 631, 658, 587, 204, 797, 790, 522, 745, 9, 502, 763, 86, 719, 288, 706,+ 887, 728, 952, 311, 336, 446, 1002, 348, 96, 58, 199, 11, 901, 230, 833,+ 188, 352, 351, 973, 3, 906, 335, 301, 266, 244, 791, 564, 619, 909, 371,+ 444, 760, 657, 328, 647, 490, 425, 913, 511, 439, 540, 283, 40, 897, 849,+ 60, 570, 872, 257, 749, 912, 572, 1007, 170, 407, 898, 492, 79, 747, 732,+ 206, 454, 918, 375, 482, 399, 92, 748, 325, 163, 274, 405, 744, 260, 346,+ 707, 626, 595, 118, 842, 136, 279, 684, 584, 101, 500, 422, 149, 956,+ 1014, 493, 536, 705, 51, 914, 225, 409, 55, 822, 590, 448, 655, 205, 676,+ 925, 735, 431, 784, 54, 609, 604, 39, 812, 737, 729, 466, 14, 533, 958,+ 481, 770, 499, 855, 238, 182, 464, 569, 72, 947, 442, 642, 24, 87, 989,+ 688, 88, 47, 762, 623, 709, 455, 817, 526, 637, 258, 84, 845, 738, 768,+ 698, 423, 933, 664, 620, 607, 629, 212, 347, 249, 982, 935, 131, 89, 252,+ 927, 189, 788, 853, 237, 691, 646, 403, 1010, 734, 253, 874, 807, 903,+ 1020, 100, 802, 71, 799, 1003, 633, 355, 276, 300, 649, 64, 306, 161,+ 608, 496, 743, 180, 485, 819, 383, 1016, 226, 308, 393, 648, 107, 19, 37,+ 585, 2, 175, 645, 247, 527, 5, 419, 181, 317, 327, 519, 542, 289, 567,+ 430, 579, 950, 582, 994, 1021, 583, 234, 240, 976, 41, 160, 109, 677,+ 937, 210, 95, 959, 242, 753, 461, 114, 733, 368, 573, 458, 782, 605, 680,+ 544, 299, 73, 652, 905, 477, 690, 93, 824, 882, 277, 946, 361, 17, 945,+ 523, 472, 334, 930, 597, 603, 793, 404, 290, 942, 316, 731, 270, 960,+ 936, 133, 122, 821, 966, 679, 662, 907, 282, 968, 767, 653, 20, 697, 222,+ 164, 835, 30, 285, 886, 456, 436, 640, 286, 1015, 380, 840, 245, 724,+ 137, 593, 173, 130, 715, 85, 885, 551, 246, 449, 103, 366, 372, 714, 313,+ 865, 241, 699, 674, 374, 68, 421, 562, 292, 59, 809, 342, 651, 459, 227,+ 46, 711, 764, 868, 53, 413, 278, 800, 255, 993, 318, 854, 319, 695, 315,+ 469, 166, 489, 969, 730, 1001, 757, 873, 686, 197, 303, 919, 155, 673,+ 940, 712, 25, 999, 63, 863, 972, 967, 785, 152, 296, 512, 402, 377, 45,+ 899, 829, 354, 77, 69, 856, 417, 811, 953, 124, 418, 75, 794, 162, 414,+ 1018, 568, 254, 265, 772, 588, 16, 896, 157, 889, 298, 621, 110, 844,+ 1000, 108, 545, 601, 78, 862, 447, 185, 195, 818, 450, 387, 49, 805, 102,+ 986, 1005, 827, 329, 28, 932, 410, 287, 435, 451, 962, 517, 48, 174, 43,+ 893, 884, 261, 251, 516, 395, 910, 611, 29, 501, 223, 476, 364, 144, 871,+ 998, 687, 928, 115, 453, 513, 176, 94, 168, 667, 955, 353, 434, 382, 400,+ 139, 365, 996, 343, 948, 890, 1012, 663, 610, 718, 538, 1008, 639, 470,+ 848, 543, 1011, 859, 671, 756, 83, 427, 159, 746, 669, 589, 971, 524,+ 356, 995, 904, 256, 201, 988, 62, 397, 81, 720, 917, 209, 549, 943, 486,+ 76, 148, 207, 509, 644, 386, 700, 534, 177, 550, 961, 926, 546, 428, 284,+ 127, 294, 8, 269, 359, 506, 445, 997, 806, 591, 725, 178, 262, 846, 373,+ 831, 504, 305, 843, 553, 378, 1017, 783, 474, 683, 581, 200, 498, 694,+ 191, 217, 847, 941, 424, 235, 38, 74, 616, 786, 147, 4, 273, 214, 142,+ 575, 992, 463, 983, 243, 360, 970, 350, 267, 615, 766, 494, 31, 1009,+ 452, 710, 552, 128, 612, 600, 275, 322, 193 ]++-- | This function is a Haskell translation of the reference JavaScript+-- implementation here: https://git.io/fj8Fu+syndrome :: (Bits a, Num a) => a -> a+syndrome residue = low+ `xor` (low `unsafeShiftL` 10)+ `xor` (low `unsafeShiftL` 20)+ `xor` (if residue `testBit` 5 then 0x31edd3c4 else 0)+ `xor` (if residue `testBit` 6 then 0x335f86a8 else 0)+ `xor` (if residue `testBit` 7 then 0x363b8870 else 0)+ `xor` (if residue `testBit` 8 then 0x3e6390c9 else 0)+ `xor` (if residue `testBit` 9 then 0x2ec72192 else 0)+ `xor` (if residue `testBit` 10 then 0x1046f79d else 0)+ `xor` (if residue `testBit` 11 then 0x208d4e33 else 0)+ `xor` (if residue `testBit` 12 then 0x130ebd6f else 0)+ `xor` (if residue `testBit` 13 then 0x2499fade else 0)+ `xor` (if residue `testBit` 14 then 0x1b27d4b5 else 0)+ `xor` (if residue `testBit` 15 then 0x04be1eb4 else 0)+ `xor` (if residue `testBit` 16 then 0x0968b861 else 0)+ `xor` (if residue `testBit` 17 then 0x1055f0c2 else 0)+ `xor` (if residue `testBit` 18 then 0x20ab4584 else 0)+ `xor` (if residue `testBit` 19 then 0x1342af08 else 0)+ `xor` (if residue `testBit` 20 then 0x24f1f318 else 0)+ `xor` (if residue `testBit` 21 then 0x1be34739 else 0)+ `xor` (if residue `testBit` 22 then 0x35562f7b else 0)+ `xor` (if residue `testBit` 23 then 0x3a3c5bff else 0)+ `xor` (if residue `testBit` 24 then 0x266c96f7 else 0)+ `xor` (if residue `testBit` 25 then 0x25c78b65 else 0)+ `xor` (if residue `testBit` 26 then 0x1b1f13ea else 0)+ `xor` (if residue `testBit` 27 then 0x34baa2f4 else 0)+ `xor` (if residue `testBit` 28 then 0x3b61c0e1 else 0)+ `xor` (if residue `testBit` 29 then 0x265325c2 else 0)+ where+ low = residue .&. 0x1f++-- | For a given Bech32 string residue and Bech32 string length, reports the+-- positions of detectably erroneous characters in the original Bech32 string.+--+-- The reported character positions are zero-based, counting from right to left+-- within the original string, but omitting the separation character (which is+-- not counted).+--+-- Returns the empty list if it is not possible to reliably determine the+-- locations of errors.+--+-- This function is a Haskell translation of the reference JavaScript+-- implementation here: https://git.io/fj8Fz+--+locateErrors :: Int -> Int -> [Int]+locateErrors residue len+ | residue == 0 = []+ | l_s0 /= -1 &&+ l_s1 /= -1 &&+ l_s2 /= -1 && (2 * l_s1 - l_s2 - l_s0 + 2046) `mod` 1023 == 0 =+ let p1 = (l_s1 - l_s0 + 1023) `mod` 1023 in+ if (p1 >= len) then [] else+ let l_e1 = l_s0 + (1023 - 997) * p1 in+ [p1 | l_e1 `mod` 33 <= 0]+ | otherwise =+ case filter (not . null) $ map findError [0 .. len - 1] of+ [] -> []+ es -> join es+ where+ syn = syndrome residue+ s0 = syn .&. 0x3FF+ s1 = (syn `unsafeShiftR` 10) .&. 0x3FF+ s2 = syn `unsafeShiftR` 20+ l_s0 = gf_1024_log Arr.! s0+ l_s1 = gf_1024_log Arr.! s1+ l_s2 = gf_1024_log Arr.! s2++ findError :: Int -> [Int]+ findError p1+ | s2_s1p1 == 0 = []+ | s1_s0p1 == 0 = []+ | p2 >= len = []+ | p1 == p2 = []+ | s1_s0p2 == 0 = []+ | l_e2 `mod` 33 > 0 = []+ | l_e1 `mod` 33 > 0 = []+ | (p1 < p2) = [p1, p2]+ | otherwise = [p2, p1]+ where+ inv_p1_p2 = 1023 -+ (gf_1024_log Arr.! (gf_1024_exp Arr.! p1)) `xor`+ (gf_1024_exp Arr.! p2)+ l_e1 = (gf_1024_log Arr.! s1_s0p2) + inv_p1_p2 + (1023 - 997) * p1+ l_e2 = l_s1_s0p1 + inv_p1_p2 + (1023 - 997) * p2+ l_s1_s0p1 = gf_1024_log Arr.! s1_s0p1+ p2 = ((gf_1024_log Arr.! s2_s1p1) - l_s1_s0p1 + 1023) `mod` 1023+ s1_s0p1 = s1 `xor`+ (if s0 == 0 then 0 else gf_1024_exp Arr.! ((l_s0 + p1) `mod` 1023))+ s1_s0p2 = s1 `xor`+ (if s0 == 0 then 0 else gf_1024_exp Arr.! ((l_s0 + p2) `mod` 1023))+ s2_s1p1 = s2 `xor`+ (if s1 == 0 then 0 else gf_1024_exp Arr.! ((l_s1 + p1) `mod` 1023))++{-------------------------------------------------------------------------------+ Utilities+-------------------------------------------------------------------------------}++guardE :: Bool -> e -> Either e ()+guardE b e = if b then Right () else Left e++-- | Splits the given 'Text' into a prefix and a suffix using the last+-- occurrence of the specified separator character as a splitting point.+-- Evaluates to 'Nothing' if the specified 'Text' does not contain the+-- separator character.+splitAtLastOccurrence :: Char -> Text -> Maybe (Text, Text)+splitAtLastOccurrence c s+ | isNothing (T.find (== c) s) = Nothing+ | otherwise = pure (prefix, suffix)+ where+ (prefixPlusOne, suffix) = T.breakOnEnd (T.pack [c]) s+ prefix = T.dropEnd 1 prefixPlusOne
+ test/Codec/Binary/Bech32Spec.hs view
@@ -0,0 +1,637 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Codec.Binary.Bech32Spec+ ( spec+ ) where++import Prelude++import Codec.Binary.Bech32.Internal+ ( CharPosition (..)+ , DataPart+ , DecodingError (..)+ , HumanReadablePart+ , dataPartFromBytes+ , dataPartFromText+ , dataPartFromWords+ , dataPartIsValid+ , dataPartToWords+ , humanReadableCharMaxBound+ , humanReadableCharMinBound+ , humanReadablePartFromText+ , humanReadablePartToText+ , separatorChar+ )+import Control.DeepSeq+ ( deepseq )+import Control.Monad+ ( forM_, replicateM )+import Data.Bits+ ( xor, (.&.) )+import Data.ByteString+ ( ByteString )+import Data.Char+ ( chr, isUpper, ord, toLower, toUpper )+import Data.Either+ ( fromRight, isRight )+import Data.Either.Extra+ ( eitherToMaybe )+import Data.Functor.Identity+ ( runIdentity )+import Data.List+ ( intercalate )+import Data.Maybe+ ( catMaybes, fromMaybe, isJust )+import Data.Set+ ( Set )+import Data.Text+ ( Text )+import Data.Vector+ ( Vector )+import Data.Word+ ( Word8 )+import Test.Hspec+ ( Spec, describe, expectationFailure, it, shouldBe, shouldSatisfy )+import Test.QuickCheck+ ( Arbitrary (..)+ , Positive (..)+ , arbitraryBoundedEnum+ , choose+ , counterexample+ , cover+ , elements+ , property+ , withMaxSuccess+ , (.&&.)+ , (.||.)+ , (===)+ , (==>)+ )++import qualified Codec.Binary.Bech32.Internal as Bech32+import qualified Data.ByteString as BS+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Vector as V++spec :: Spec+spec = do+ describe "Valid Reference Strings" $+ it "should always decode successfully" $+ forM_ validBech32Strings $ \s ->+ Bech32.decode s `shouldSatisfy` isRight++ describe "Valid Checksums" $ forM_ validChecksums $ \checksum ->+ it (T.unpack checksum) $ case Bech32.decode checksum of+ Left _ ->+ expectationFailure (show checksum)+ Right (resultHRP, resultData) -> do+ -- test that a corrupted checksum fails decoding.+ let (hrp, rest) =+ T.breakOnEnd (T.singleton separatorChar) checksum+ let Just (first, rest') = T.uncons rest+ let checksumCorrupted =+ (hrp `T.snoc` (chr (ord first `xor` 1)))+ `T.append` rest'+ (Bech32.decode checksumCorrupted) `shouldSatisfy` isLeft'+ -- test that re-encoding the decoded checksum results in+ -- the same checksum.+ let checksumEncoded = Bech32.encode resultHRP resultData+ let expectedChecksum = Right $ T.map toLower checksum+ checksumEncoded `shouldBe` expectedChecksum++ describe "Invalid Checksums" $ forM_ invalidChecksums $+ \(checksum, expect) ->+ it (T.unpack checksum) $+ Bech32.decode checksum `shouldBe` (Left expect)++ describe "More Encoding/Decoding Cases" $ do+ it "length > maximum" $ do+ let hrpUnpacked = "ca"+ let hrpLength = length hrpUnpacked+ let (Right hrp) = humanReadablePartFromText (T.pack hrpUnpacked)+ let maxDataLength =+ Bech32.encodedStringMaxLength+ - Bech32.checksumLength - Bech32.separatorLength - hrpLength+ Bech32.encode hrp+ (dataPartFromWords (replicate (maxDataLength + 1)+ $ Bech32.word5 @Word8 1))+ `shouldBe` Left Bech32.EncodedStringTooLong++ it "hrp lowercased" $ do+ let (Right hrp) = humanReadablePartFromText "HRP"+ Bech32.encode hrp mempty `shouldBe` Right "hrp1vhqs52"++ describe "Arbitrary Bech32String" $++ it "Generation always produces a valid string that can be decoded." $+ property $ \v ->+ Bech32.decode (getBech32String v) `shouldBe`+ Right (humanReadablePart v, unencodedDataPart v)++ describe "Arbitrary Bech32Char" $ do++ it "Generation always produces a valid character." $+ property $ withMaxSuccess 10000 $ \c ->+ let char = getBech32Char c in+ cover 30 ( isDataChar char) "is a data character: TRUE" $+ cover 30 (not $ isDataChar char) "is a data character: FALSE" $+ isBech32Char char++ it "Shrinking always produces valid characters." $+ property $ withMaxSuccess 10000 $ \c ->+ all (isBech32Char . getBech32Char) $ shrink c++ it "Shrinking always produces characters with codes that are smaller." $+ property $ withMaxSuccess 10000 $ \c ->+ all (< c) $ shrink (c :: Bech32Char)++ describe "Decoding a corrupted string should fail" $ do++ it "Decoding fails when an adjacent pair of characters is swapped." $+ property $ withMaxSuccess 10000 $ \s -> do+ let originalString = getBech32String s+ index <- choose (0, T.length originalString - 2)+ let prefix = T.take index originalString+ let suffix = T.drop (index + 2) originalString+ let char1 = T.singleton (T.index originalString index)+ let char2 = T.singleton (T.index originalString $ index + 1)+ let corruptedString = prefix <> char2 <> char1 <> suffix+ let description = intercalate "\n"+ [ "index of char #1: " <> show index+ , "index of char #2: " <> show (index + 1)+ , " char #1: " <> show char1+ , " char #2: " <> show char2+ , " original string: " <> show originalString+ , "corrupted string: " <> show corruptedString ]+ return $ counterexample description $+ char1 /= char2 ==>+ (T.length corruptedString === T.length originalString)+ .&&.+ (Bech32.decode corruptedString `shouldSatisfy` isLeft')++ it "Decoding fails when a character is omitted." $+ property $ withMaxSuccess 10000 $ \s -> do+ let originalString = getBech32String s+ index <- choose (0, T.length originalString - 1)+ let char = T.index originalString index+ let prefix = T.take index originalString+ let suffix = T.drop (index + 1) originalString+ let corruptedString = prefix <> suffix+ let description = intercalate "\n"+ [ "index of omitted char: " <> show index+ , " omitted char: " <> show char+ , " original string: " <> show originalString+ , " corrupted string: " <> show corruptedString ]+ return $ counterexample description $+ (T.length corruptedString === T.length originalString - 1)+ .&&.+ (Bech32.decode corruptedString `shouldSatisfy` isLeft')+ .||.+ -- In the case where the tail of a valid Bech32 string is+ -- composed of one or more consecutive 'q' characters+ -- followed by a single 'p' character, omitting any or all+ -- of the 'q' characters will still result in a valid+ -- Bech32 string:+ (T.length suffix > 0+ && T.last suffix == 'p'+ && char == 'q'+ && T.all (== 'q') (T.dropEnd 1 suffix))++ it "Decoding fails when a character is inserted." $+ property $ withMaxSuccess 10000 $ \s c -> do+ let originalString = getBech32String s+ let char = getBech32Char c+ index <- choose (0, T.length originalString)+ let prefix = T.take index originalString+ let suffix = T.drop index originalString+ let corruptedString = prefix <> T.singleton char <> suffix+ let description = intercalate "\n"+ [ "index of inserted char: " <> show index+ , " inserted char: " <> show char+ , " original string: " <> show originalString+ , " corrupted string: " <> show corruptedString ]+ return $+ counterexample description $+ cover 2 (T.null prefix)+ "inserted before the start" $+ cover 2 (T.null suffix)+ "inserted after the end" $+ cover 10 (not (T.null prefix) && not (T.null suffix))+ "inserted into the middle" $+ (T.length corruptedString === T.length originalString + 1)+ .&&.+ (Bech32.decode corruptedString `shouldSatisfy` isLeft')+ .||.+ -- In the case where the last character of a valid Bech32+ -- string is the character 'p', inserting any number of+ -- consecutive 'q' characters immediately before the 'p'+ -- will still result in a valid Bech32 string.+ (T.length suffix > 0+ && T.last suffix == 'p'+ && char == 'q'+ && T.all (== 'q') (T.dropEnd 1 suffix))++ it "Decoding fails when a single character is mutated." $+ withMaxSuccess 10000 $ property $ \s c -> do+ let originalString = getBech32String s+ index <- choose (0, T.length originalString - 1)+ let originalChar = T.index originalString index+ let replacementChar = getBech32Char c+ let prefix = T.take index originalString+ let suffix = T.drop (index + 1) originalString+ let corruptedString =+ prefix <> T.singleton replacementChar <> suffix+ let description = intercalate "\n"+ [ "index of mutated char: " <> show index+ , " original char: " <> show originalChar+ , " replacement char: " <> show replacementChar+ , " original string: " <> show originalString+ , " corrupted string: " <> show corruptedString ]+ let result = Bech32.decode corruptedString+ return $ counterexample description $+ corruptedString /= originalString ==>+ (T.length corruptedString === T.length originalString)+ .&&.+ (result `shouldSatisfy` isLeft')++ it "Decoding fails for an upper-case string with a lower-case \+ \character." $+ withMaxSuccess 10000 $ property $ \s -> do+ let originalString = T.map toUpper $ getBech32String s+ index <- choose (0, T.length originalString - 1)+ let prefix = T.take index originalString+ let suffix = T.drop (index + 1) originalString+ let char = toLower $ T.index originalString index+ let corruptedString = prefix <> T.singleton char <> suffix+ let description = intercalate "\n"+ [ "index of mutated char: " <> show index+ , " original string: " <> show originalString+ , " corrupted string: " <> show corruptedString ]+ return $ counterexample description $+ isMixedCase corruptedString ==>+ (T.length corruptedString === T.length originalString)+ .&&.+ (Bech32.decode corruptedString `shouldBe` Left+ StringToDecodeHasMixedCase)++ it "Decoding fails for a lower-case string with an upper-case \+ \character." $+ withMaxSuccess 10000 $ property $ \s -> do+ let originalString = T.map toLower $ getBech32String s+ index <- choose (0, T.length originalString - 1)+ let prefix = T.take index originalString+ let suffix = T.drop (index + 1) originalString+ let char = toUpper $ T.index originalString index+ let corruptedString = prefix <> T.singleton char <> suffix+ let description = intercalate "\n"+ [ "index of mutated char: " <> show index+ , " original string: " <> show originalString+ , " corrupted string: " <> show corruptedString ]+ return $ counterexample description $+ isMixedCase corruptedString ==>+ (T.length corruptedString === T.length originalString)+ .&&.+ (Bech32.decode corruptedString `shouldBe` Left+ StringToDecodeHasMixedCase)++ describe "Roundtrip (encode . decode)" $ do+ it "Can perform roundtrip for valid data" $ property $ \(hrp, dp) ->+ (eitherToMaybe (Bech32.encode hrp dp)+ >>= eitherToMaybe . Bech32.decode) === Just (hrp, dp)++ describe "Roundtrip (dataPartToBytes . dataPartFromBytes)" $ do+ it "Can perform roundtrip base conversion" $ property $ \bs ->+ (Bech32.dataPartToBytes . Bech32.dataPartFromBytes) bs === Just bs++ describe "Roundtrip (dataPartFromText . dataPartToText)" $ do+ it "Can perform roundtrip conversion" $ property $ \dp ->+ (Bech32.dataPartFromText . Bech32.dataPartToText) dp === Just dp++ describe "Roundtrip (dataPartFromWords . dataPartToWords)" $ do+ it "Can perform roundtrip conversion" $ property $ \dp ->+ (Bech32.dataPartFromWords . Bech32.dataPartToWords) dp === dp++ describe "Roundtrip (dataPartToWords . dataPartFromWords)" $ do+ it "Can perform roundtrip conversion" $ property $ \ws ->+ (Bech32.dataPartToWords . Bech32.dataPartFromWords) ws === ws++ describe "Roundtrip (humanReadablePartFromText . humanReadablePartToText)" $+ it "Can perform roundtrip conversion" $ property $ \hrp ->+ (Bech32.humanReadablePartFromText . Bech32.humanReadablePartToText)+ hrp === Right hrp++ describe "Roundtrip (toBase256 . toBase32)" $ do+ it "Can perform roundtrip base conversion" $ property $ \ws ->+ (Bech32.toBase256 . Bech32.toBase32) ws === Just ws++ describe "Roundtrip (toBase32 . toBase256)" $ do+ it "Can perform roundtrip base conversion" $ property $ \ws ->+ isJust (Bech32.toBase256 ws) ==>+ (Bech32.toBase32 <$> Bech32.toBase256 ws) === Just ws++ describe "Roundtrip (dataCharToWord . dataCharFromWord)" $ do+ it "can perform roundtrip character set conversion" $+ property $ \w ->+ Bech32.dataCharToWord (toLower (Bech32.dataCharFromWord w))+ === Just w++ describe "Constructors produce valid values" $ do++ it "dataPartFromBytes" $+ property $ \bytes -> do+ let value = dataPartFromBytes bytes+ let counterexampleText = mconcat+ [ "input: ", show bytes, "\n"+ , "output: ", show value, "\n" ]+ counterexample counterexampleText $+ dataPartIsValid value++ it "dataPartFromText" $+ property $ \chars -> do+ let value = dataPartFromText (T.pack $ getDataChar <$> chars)+ let counterexampleText = mconcat+ [ "input: ", show chars, "\n"+ , "output: ", show value, "\n" ]+ counterexample counterexampleText $+ fmap dataPartIsValid value === Just True++ it "dataPartFromWords" $+ property $ \ws -> do+ let value = dataPartFromWords ws+ let counterexampleText = mconcat+ [ "input: ", show ws , "\n"+ , "output: ", show value, "\n" ]+ counterexample counterexampleText $+ dataPartIsValid value++ describe "Conversion of word string from one word size to another" $ do++ it "With identical word sizes, conversion is the identity transform" $+ property $ \inputWordsUnmasked -> do+ size <- choose (1, 16)+ let mask (Positive w) = w .&. (2 ^ size - 1)+ let inputWords = mask <$> inputWordsUnmasked+ pure $ inputWords === runIdentity+ (Bech32.convertBits inputWords size size Bech32.yesPadding)++ it "With different word sizes, roundtripping preserves data" $+ property $ \inputWordsUnmasked -> do+ sourceSize <- choose (1, 16)+ targetSize <- choose (1, 16)+ let mask size (Positive w) = w .&. (2 ^ size - 1)+ let inputWords = mask sourceSize <$> inputWordsUnmasked+ let convert s0 s1 inputData =+ runIdentity $+ Bech32.convertBits inputData s0 s1 Bech32.yesPadding+ let outputWords =+ convert targetSize sourceSize $+ convert sourceSize targetSize inputWords+ let outputWordsPrefix = take (length inputWords) outputWords+ let outputWordsSuffix = drop (length inputWords) outputWords+ pure $+ (inputWords === outputWordsPrefix)+ .&&.+ (outputWordsSuffix `shouldSatisfy` all (== 0))++ describe "Pointless test to trigger coverage on derived instances" $ do+ it (show $ humanReadablePartFromText $ T.pack "ca") True++-- Taken from the BIP 0173 specification: https://git.io/fjBIN+validBech32Strings :: [Text]+validBech32Strings =+ [ "A12UEL5L"+ , "a12uel5l"+ , "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcluded\+ \charactersbio1tt5tgs"+ , "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw"+ , "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq\+ \qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j"+ , "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w"+ , "?1ezyfcl"+ , "BC1SW50QA3JX3S"+ , "bc1zw508d6qejxtdg4y5r3zarvaryvg6kdaj"+ , "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t4"+ , "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4"+ , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7"+ , "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy"+ , "bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0\+ \c5xw7k7grplx"+ , "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty"+ , "BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2"+ , "bc1rw5uspcuh"+ , "bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90"+ , "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P"+ , "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du"+ , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv"+ , "bc1gmk9yu"+ ]++validChecksums :: [Text]+validChecksums =+ [ "A12UEL5L"+ , "an83characterlonghumanreadablepartthatcontain\+ \sthenumber1andtheexcludedcharactersbio1tt5tgs"+ , "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw"+ , "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq\+ \qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j"+ , "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w"+ ]++invalidChecksums :: [(Text, Bech32.DecodingError)]+invalidChecksums =+ [ ( " 1nwldj5"+ , Bech32.StringToDecodeContainsInvalidChars [Bech32.CharPosition 0] )+ , ( "\DEL1axkwrx"+ , Bech32.StringToDecodeContainsInvalidChars [Bech32.CharPosition 0] )+ , ( "an84characterslonghumanreadablepartthatcontain\+ \sthenumber1andtheexcludedcharactersbio1569pvx"+ , Bech32.StringToDecodeTooLong)+ , ( "pzry9x0s0muk", Bech32.StringToDecodeMissingSeparatorChar )+ , ( "1pzry9x0s0muk"+ , Bech32.StringToDecodeContainsInvalidChars [Bech32.CharPosition 0] )+ , ( "x1b4n0q5v"+ , Bech32.StringToDecodeContainsInvalidChars [Bech32.CharPosition 2] )+ , ( "x1n4n0q5v"+ , Bech32.StringToDecodeContainsInvalidChars [] )+ , ( "11111111111111111111111111111111111111111111111111111111111111\+ \1111111111111111111111111111"+ , Bech32.StringToDecodeContainsInvalidChars [Bech32.CharPosition 83] )+ , ( "li1dgmt3"+ , Bech32.StringToDecodeTooShort )+ , ( "", Bech32.StringToDecodeTooShort )+ , ( "de1lg7wt\xFF"+ , Bech32.StringToDecodeContainsInvalidChars [Bech32.CharPosition 8] )+ , ( "aBcdef1qpzry9x8gf2tvDw0s3jn54khce6mua7lmqqqXw"+ , Bech32.StringToDecodeHasMixedCase )+ , ( "A1G7SGD8", Bech32.StringToDecodeContainsInvalidChars [] )+ , ( "10a06t8", Bech32.StringToDecodeTooShort )+ , ( "1qzzfhee", Bech32.StringToDecodeContainsInvalidChars [CharPosition 0] )+ , ( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7"+ , Bech32.StringToDecodeHasMixedCase )+ , ( "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5"+ , Bech32.StringToDecodeContainsInvalidChars [CharPosition 41] )+ ]++-- | Represents a character that is permitted to appear within a Bech32 string.+newtype Bech32Char = Bech32Char+ { getBech32Char :: Char }+ deriving newtype (Eq, Ord, Show)++instance Arbitrary Bech32Char where+ arbitrary =+ Bech32Char . (bech32CharVector V.!) <$>+ choose (0, V.length bech32CharVector - 1)+ shrink (Bech32Char c) =+ case sortedVectorElemIndex c bech32CharVector of+ Nothing -> []+ Just ci -> Bech32Char . (bech32CharVector V.!) <$> shrink ci++-- | Returns true iff. the specified character is permitted to appear within+-- a Bech32 string AND is not upper case.+isBech32Char :: Char -> Bool+isBech32Char c = Set.member c bech32CharSet++-- | Returns true iff. the specified character is permitted to appear within+-- the data portion of a Bech32 string AND is not upper case.+isDataChar :: Char -> Bool+isDataChar = isJust . Bech32.dataCharToWord++-- | A vector containing all valid Bech32 characters in ascending sorted order.+-- Upper-case characters are not included.+bech32CharVector :: Vector Char+bech32CharVector = V.fromList $ Set.toAscList bech32CharSet++-- | The set of all valid Bech32 characters.+-- Upper-case characters are not included.+bech32CharSet :: Set Char+bech32CharSet =+ Set.filter (not . isUpper) $+ Set.fromList [humanReadableCharMinBound .. humanReadableCharMaxBound]+ `Set.union` (Set.singleton separatorChar)+ `Set.union` (Set.fromList Bech32.dataCharList)++-- | Find the index of an element in a sorted vector using simple binary search.+sortedVectorElemIndex :: Ord a => a -> Vector a -> Maybe Int+sortedVectorElemIndex a v = search 0 (V.length v - 1)+ where+ search l r+ | l > r = Nothing+ | a == b = Just m+ | a < b = search l (m - 1)+ | a > b = search (m + 1) r+ | otherwise = Nothing+ where+ b = v V.! m+ m = (l + r) `div` 2++newtype DataChar = DataChar+ { getDataChar :: Char+ } deriving (Eq, Ord, Show)++instance Arbitrary DataChar where+ arbitrary = DataChar <$> elements Bech32.dataCharList+ shrink (DataChar c) =+ DataChar . Bech32.dataCharFromWord <$> shrink+ (fromMaybe+ (error "unable to shrink a Bech32 data character.")+ (Bech32.dataCharToWord c))++newtype HumanReadableChar = HumanReadableChar+ { getHumanReadableChar :: Char+ } deriving (Eq, Ord, Show)++instance Arbitrary HumanReadableChar where+ arbitrary = HumanReadableChar <$>+ choose (humanReadableCharMinBound, humanReadableCharMaxBound)++data Bech32String = Bech32String+ { getBech32String :: Text+ , humanReadablePart :: HumanReadablePart+ , unencodedDataPart :: DataPart+ } deriving (Eq, Show)++mkBech32String :: HumanReadablePart -> DataPart -> Bech32String+mkBech32String hrp udp = Bech32String+ { getBech32String =+ fromRight (error "unable to make a valid Bech32 string.") $+ Bech32.encode hrp udp+ , humanReadablePart = hrp+ , unencodedDataPart = udp+ }++instance Arbitrary Bech32String where+ arbitrary = mkBech32String <$> arbitrary <*> arbitrary+ shrink v = do+ let hrpOriginal = humanReadablePart v+ let udpOriginal = unencodedDataPart v+ hrpShrunk <- take 3 $ shrink $ humanReadablePart v+ udpShrunk <- take 3 $ shrink $ unencodedDataPart v+ uncurry mkBech32String <$>+ [ (hrpShrunk, udpShrunk)+ , (hrpShrunk, udpOriginal)+ , (hrpOriginal, udpShrunk) ]++instance Arbitrary DataPart where+ arbitrary = do+ len <- choose (0, 64)+ dataPartFromWords <$> replicateM len arbitrary+ shrink dp+ | null ws = []+ | otherwise = dataPartFromWords <$>+ [ take (length ws `div` 2) ws+ , drop 1 ws+ ]+ where+ ws = dataPartToWords dp++instance Arbitrary HumanReadablePart where+ arbitrary = do+ len <- choose (1, 10)+ chars <- replicateM len arbitrary+ let (Right hrp) = humanReadablePartFromText $ T.pack $+ getHumanReadableChar <$> chars+ return hrp+ shrink hrp+ | T.null chars = []+ | otherwise = catMaybes $ eitherToMaybe . humanReadablePartFromText <$>+ [ T.take (T.length chars `div` 2) chars+ , T.drop 1 chars+ ]+ where+ chars = humanReadablePartToText hrp++instance Arbitrary ByteString where+ shrink bytes | BS.null bytes = []+ shrink bytes =+ [ BS.take (BS.length bytes `div` 2) bytes+ , BS.drop 1 bytes+ ]+ arbitrary = do+ count <- choose (0, 32)+ BS.pack <$> replicateM count arbitrary++instance Arbitrary Bech32.Word5 where+ arbitrary = arbitraryBoundedEnum+ shrink w = Bech32.word5 <$> shrink (Bech32.getWord5 w)++-- | Returns true iff. the given string has both lower-case and upper-case+-- characters.+--+isMixedCase :: Text -> Bool+isMixedCase t =+ T.toUpper t /= t &&+ T.toLower t /= t++-- | Strict `isLeft`, evaluate the left-side and return 'True' if 'Left'.+-- 'False' otherwise.+isLeft' :: Show e => Either e a -> Bool+isLeft' = \case+ Left e -> show e `deepseq` True+ Right _ -> False
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}