diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/bech32.cabal b/bech32.cabal new file mode 100644 --- /dev/null +++ b/bech32.cabal @@ -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 diff --git a/src/Codec/Binary/Bech32.hs b/src/Codec/Binary/Bech32.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Binary/Bech32.hs @@ -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 diff --git a/src/Codec/Binary/Bech32/Internal.hs b/src/Codec/Binary/Bech32/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Binary/Bech32/Internal.hs @@ -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 diff --git a/test/Codec/Binary/Bech32Spec.hs b/test/Codec/Binary/Bech32Spec.hs new file mode 100644 --- /dev/null +++ b/test/Codec/Binary/Bech32Spec.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}