From 01307da3627188e09e1181592e6d4ed6af0c9216 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:19:30 +0000 Subject: [PATCH 01/10] Introduce type `Bech32Char` and associated `Arbitrary` instance. This type represents the set of all characters permitted to appear within a Bech32 string, including: * characters that can appear within the human-readable part. * the separator character. * characters that can appear within the data part. --- lib/bech32/bech32.cabal | 2 + lib/bech32/test/Codec/Binary/Bech32Spec.hs | 80 +++++++++++++++++++++- 2 files changed, 81 insertions(+), 1 deletion(-) diff --git a/lib/bech32/bech32.cabal b/lib/bech32/bech32.cabal index 270ed912fbd..0df9f81a507 100644 --- a/lib/bech32/bech32.cabal +++ b/lib/bech32/bech32.cabal @@ -58,11 +58,13 @@ test-suite bech32-test build-depends: base , bech32 + , containers , extra , hspec , bytestring , QuickCheck , text + , vector main-is: Main.hs other-modules: diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index 9fd4cf01e00..ffad5241991 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -32,7 +34,7 @@ import Data.Bits import Data.ByteString ( ByteString ) import Data.Char - ( chr, ord, toLower, toUpper ) + ( chr, isUpper, ord, toLower, toUpper ) import Data.Either ( fromRight, isLeft, isRight ) import Data.Either.Extra @@ -43,8 +45,12 @@ 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 @@ -55,6 +61,7 @@ import Test.QuickCheck , arbitraryBoundedEnum , choose , counterexample + , cover , elements , property , withMaxSuccess @@ -66,7 +73,9 @@ import Test.QuickCheck 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 @@ -123,6 +132,23 @@ spec = do Bech32.decode (getValidBech32String 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 let chooseWithinDataPart originalString = do let sepIx = maybe @@ -457,6 +483,58 @@ invalidChecksums = , 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) From e8d31c71ca86a63798497227b3d11d18cba46c17 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:23:23 +0000 Subject: [PATCH 02/10] Use the correct index range for the Bech32 character swap test. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index ffad5241991..67393771f7f 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -160,7 +160,7 @@ spec = do it "Decoding fails when an adjacent pair of characters is swapped." $ property $ withMaxSuccess 10000 $ \s -> do let originalString = getValidBech32String s - index <- chooseWithinDataPart originalString + 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) From 269513e1612629075008a8584e0559ec7ee37545 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:24:39 +0000 Subject: [PATCH 03/10] Use the correct index range for the Bech32 character omission test. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index 67393771f7f..fcb457c7704 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -182,7 +182,7 @@ spec = do it "Decoding fails when a character is omitted." $ property $ withMaxSuccess 10000 $ \s -> do let originalString = getValidBech32String s - index <- chooseWithinDataPart originalString + 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 From ab7a337d2d4f70c7f41e55662cb75b2f1db7fe23 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:25:55 +0000 Subject: [PATCH 04/10] Use the correct index range for the Bech32 character insertion test. Make sure that we have coverage for: 1. Insertions before the start of the string. 2. Insertions in the middle of the string. 3. Insertions after the end of the string. Additionally, choose from the full range of Bech32 characters, and not just those allowed in the data part of the string. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index fcb457c7704..011c6590164 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -210,8 +210,8 @@ spec = do it "Decoding fails when a character is inserted." $ property $ withMaxSuccess 10000 $ \s c -> do let originalString = getValidBech32String s - let char = getDataChar c - index <- chooseWithinDataPart originalString + 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 @@ -220,7 +220,14 @@ spec = do , " inserted char: " <> show char , " original string: " <> show originalString , " corrupted string: " <> show corruptedString ] - return $ counterexample description $ + 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) From 0f8654daa407a5f5579f2a1dd68b0a763f856e46 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:28:18 +0000 Subject: [PATCH 05/10] Use the correct index range for the Bech32 character mutation test. Additionally, choose from the full range of Bech32 characters, and not just those allowed in the data part of the string. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index 011c6590164..e8146459877 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -244,9 +244,9 @@ spec = do it "Decoding fails when a single character is mutated." $ withMaxSuccess 10000 $ property $ \s c -> do let originalString = getValidBech32String s - index <- chooseWithinDataPart originalString + index <- choose (0, T.length originalString - 1) let originalChar = T.index originalString index - let replacementChar = getDataChar c + let replacementChar = getBech32Char c let prefix = T.take index originalString let suffix = T.drop (index + 1) originalString let corruptedString = @@ -262,15 +262,7 @@ spec = do corruptedString /= originalString ==> (T.length corruptedString === T.length originalString) .&&. - (result `shouldBe` Left - StringToDecodeMissingSeparatorChar) - .||. - (result `shouldBe` Left - (StringToDecodeContainsInvalidChars [])) - .||. - (result `shouldBe` Left - (StringToDecodeContainsInvalidChars - [CharPosition index])) + (result `shouldSatisfy` isLeft) it "Decoding fails for an upper-case string with a lower-case \ \character." $ From 6dd43273e2186a3ceab6275b6cad007bb18660bc Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:30:09 +0000 Subject: [PATCH 06/10] Use the correct index range for the Bech32 mixed-case test. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index e8146459877..b9a6f20b565 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -268,7 +268,7 @@ spec = do \character." $ withMaxSuccess 10000 $ property $ \s -> do let originalString = T.map toUpper $ getValidBech32String s - index <- chooseWithinDataPart originalString + 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 @@ -288,7 +288,7 @@ spec = do \character." $ withMaxSuccess 10000 $ property $ \s -> do let originalString = T.map toLower $ getValidBech32String s - index <- chooseWithinDataPart originalString + 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 From e90abf8c1d8052f3a52b67dd9d3053b04fe013c7 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:30:50 +0000 Subject: [PATCH 07/10] Make constructor more readable for `Bech32String`. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index b9a6f20b565..86447d93be4 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -561,11 +561,13 @@ data ValidBech32String = ValidBech32String } deriving (Eq, Show) mkValidBech32String :: HumanReadablePart -> DataPart -> ValidBech32String -mkValidBech32String hrp udp = - ValidBech32String - (fromRight (error "unable to make a valid Bech32 string.") $ - Bech32.encode hrp udp) - hrp udp +mkValidBech32String hrp udp = ValidBech32String + { getValidBech32String = + fromRight (error "unable to make a valid Bech32 string.") $ + Bech32.encode hrp udp + , humanReadablePart = hrp + , unencodedDataPart = udp + } instance Arbitrary ValidBech32String where arbitrary = mkValidBech32String <$> arbitrary <*> arbitrary From 1a2c5e257aced12eab7b7fd3c29822759db3de26 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:31:32 +0000 Subject: [PATCH 08/10] Remove unused function `chooseWithinDataPart`. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index 86447d93be4..0d5a30fe7b7 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -150,12 +150,6 @@ spec = do all (< c) $ shrink (c :: Bech32Char) describe "Decoding a corrupted string should fail" $ do - let chooseWithinDataPart originalString = do - let sepIx = maybe - (error "couldn't find separator in valid bech32 string") - (\ix -> T.length originalString - ix - 1) - (T.findIndex (== '1') (T.reverse originalString)) - choose (sepIx + 1, T.length originalString - 2) it "Decoding fails when an adjacent pair of characters is swapped." $ property $ withMaxSuccess 10000 $ \s -> do From 907f607afd9b4186dd074c4ba22e0e846d65eb98 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 07:32:55 +0000 Subject: [PATCH 09/10] Rename `ValidBech32String` to `Bech32String` for readability. This name is consistent with `Bech32Char`. Also rename related functions. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 32 +++++++++++----------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index 0d5a30fe7b7..305d865b935 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -125,11 +125,11 @@ spec = do let (Right hrp) = humanReadablePartFromText "HRP" Bech32.encode hrp mempty `shouldBe` Right "hrp1vhqs52" - describe "Arbitrary ValidBech32String" $ + describe "Arbitrary Bech32String" $ it "Generation always produces a valid string that can be decoded." $ property $ \v -> - Bech32.decode (getValidBech32String v) `shouldBe` + Bech32.decode (getBech32String v) `shouldBe` Right (humanReadablePart v, unencodedDataPart v) describe "Arbitrary Bech32Char" $ do @@ -153,7 +153,7 @@ spec = do it "Decoding fails when an adjacent pair of characters is swapped." $ property $ withMaxSuccess 10000 $ \s -> do - let originalString = getValidBech32String s + let originalString = getBech32String s index <- choose (0, T.length originalString - 2) let prefix = T.take index originalString let suffix = T.drop (index + 2) originalString @@ -175,7 +175,7 @@ spec = do it "Decoding fails when a character is omitted." $ property $ withMaxSuccess 10000 $ \s -> do - let originalString = getValidBech32String s + let originalString = getBech32String s index <- choose (0, T.length originalString - 1) let char = T.index originalString index let prefix = T.take index originalString @@ -203,7 +203,7 @@ spec = do it "Decoding fails when a character is inserted." $ property $ withMaxSuccess 10000 $ \s c -> do - let originalString = getValidBech32String s + let originalString = getBech32String s let char = getBech32Char c index <- choose (0, T.length originalString) let prefix = T.take index originalString @@ -237,7 +237,7 @@ spec = do it "Decoding fails when a single character is mutated." $ withMaxSuccess 10000 $ property $ \s c -> do - let originalString = getValidBech32String s + let originalString = getBech32String s index <- choose (0, T.length originalString - 1) let originalChar = T.index originalString index let replacementChar = getBech32Char c @@ -261,7 +261,7 @@ spec = do it "Decoding fails for an upper-case string with a lower-case \ \character." $ withMaxSuccess 10000 $ property $ \s -> do - let originalString = T.map toUpper $ getValidBech32String s + 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 @@ -281,7 +281,7 @@ spec = do it "Decoding fails for a lower-case string with an upper-case \ \character." $ withMaxSuccess 10000 $ property $ \s -> do - let originalString = T.map toLower $ getValidBech32String s + 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 @@ -548,29 +548,29 @@ instance Arbitrary HumanReadableChar where arbitrary = HumanReadableChar <$> choose (humanReadableCharMinBound, humanReadableCharMaxBound) -data ValidBech32String = ValidBech32String - { getValidBech32String :: Text +data Bech32String = Bech32String + { getBech32String :: Text , humanReadablePart :: HumanReadablePart , unencodedDataPart :: DataPart } deriving (Eq, Show) -mkValidBech32String :: HumanReadablePart -> DataPart -> ValidBech32String -mkValidBech32String hrp udp = ValidBech32String - { getValidBech32String = +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 ValidBech32String where - arbitrary = mkValidBech32String <$> arbitrary <*> arbitrary +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 mkValidBech32String <$> + uncurry mkBech32String <$> [ (hrpShrunk, udpShrunk) , (hrpShrunk, udpOriginal) , (hrpOriginal, udpShrunk) ] From 15fbefbef226f612675061fe84ba1286b8259470 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 29 May 2019 08:24:25 +0000 Subject: [PATCH 10/10] Strengthen the precondition for the Bech32 mixed-case mutation test. It's possible to change the case of a given character of a Bech32 string and yet not produce a mixed-case string. In such cases, we can't expect that the `decode` function will fail with a `StringToDecodeHasMixedCase` error. To prevent the test failing, we change the precondition to actually check that the string is in mixed case. --- lib/bech32/test/Codec/Binary/Bech32Spec.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index 9fd4cf01e00..f7d7078d79d 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -253,7 +253,7 @@ spec = do , " original string: " <> show originalString , " corrupted string: " <> show corruptedString ] return $ counterexample description $ - corruptedString /= originalString ==> + isMixedCase corruptedString ==> (T.length corruptedString === T.length originalString) .&&. (Bech32.decode corruptedString `shouldBe` Left @@ -273,7 +273,7 @@ spec = do , " original string: " <> show originalString , " corrupted string: " <> show corruptedString ] return $ counterexample description $ - corruptedString /= originalString ==> + isMixedCase corruptedString ==> (T.length corruptedString === T.length originalString) .&&. (Bech32.decode corruptedString `shouldBe` Left @@ -544,3 +544,11 @@ instance Arbitrary ByteString where 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