diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index 8460d009b3a..aed64dac2a2 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -5,6 +5,8 @@ module Codec.Binary.Bech32Spec ( spec + , ValidBech32Char (..) + , ValidBech32String (..) ) where import Prelude @@ -20,13 +22,13 @@ import Data.ByteString import Data.Char ( toLower, toUpper ) import Data.Either - ( isLeft ) + ( isLeft, isRight, fromRight ) import Data.Either.Extra ( eitherToMaybe ) import Data.Functor.Identity ( runIdentity ) import Data.Maybe - ( catMaybes, isJust ) + ( catMaybes, fromMaybe, isJust ) import Data.Word ( Word8 ) import Test.Hspec @@ -35,6 +37,7 @@ import Test.QuickCheck ( Arbitrary (..) , Positive (..) , choose + , counterexample , elements , property , vectorOf @@ -87,6 +90,110 @@ spec = do Bech32.encode hrp mempty `shouldBe` Right (B8.pack "hrp1g9xj8m") + describe "Arbitrary ValidBech32String" $ + + it "Generation always produces a valid string that can be decoded." $ + property $ \v -> + Bech32.decode (getValidBech32String v) `shouldBe` + Right (humanReadablePart v, unencodedDataPart v) + + describe "Decoding a corrupted string should fail" $ do + + it "Decoding fails when an adjacent pair of characters is swapped." $ + property $ \s -> do + let validString = getValidBech32String s + index <- choose (0, BS.length validString - 2) + let prefix = BS.take index validString + let suffix = BS.drop (index + 2) validString + let char0 = BS.singleton (BS.index validString index) + let char1 = BS.singleton (BS.index validString $ index + 1) + let recombinedString = prefix <> char1 <> char0 <> suffix + return $ + (BS.length recombinedString === BS.length validString) + .&&. + (Bech32.decode recombinedString `shouldSatisfy` + (if char0 == char1 then isRight else isLeft)) + + it "Decoding fails when a character is omitted." $ + property $ \s -> do + let validString = getValidBech32String s + index <- choose (0, BS.length validString - 1) + let prefix = BS.take index validString + let suffix = BS.drop (index + 1) validString + let recombinedString = prefix <> suffix + return $ + (BS.length recombinedString === BS.length validString - 1) + .&&. + (Bech32.decode recombinedString `shouldSatisfy` isLeft) + + it "Decoding fails when a character is inserted." $ + property $ \s c -> do + let validString = getValidBech32String s + let validChar = getValidBech32Char c + index <- choose (0, BS.length validString - 1) + let prefix = BS.take index validString + let suffix = BS.drop index validString + let recombinedString = + prefix <> B8.singleton validChar <> suffix + return $ + (BS.length recombinedString === BS.length validString + 1) + .&&. + (Bech32.decode recombinedString `shouldSatisfy` isLeft) + + it "Decoding fails when a single character is mutated." $ + property $ \s c -> do + let validString = getValidBech32String s + let validChar = getValidBech32Char c + let separatorIndex = BS.length $ + Bech32.humanReadablePartToBytes $ humanReadablePart s + index <- choose (0, BS.length validString - 1) + let prefix = BS.take index validString + let suffix = BS.drop (index + 1) validString + let recombinedString = + prefix <> B8.singleton validChar <> suffix + return $ + index /= separatorIndex ==> + recombinedString /= validString ==> + (BS.length recombinedString === BS.length validString) + .&&. + (Bech32.decode recombinedString `shouldSatisfy` isLeft) + + it "Decoding fails for an upper-case string with a lower-case \ + \character." $ + property $ \s -> do + let validString = getValidBech32String s + index <- choose (0, BS.length validString - 1) + let prefix = B8.map toUpper $ BS.take index validString + let suffix = B8.map toUpper $ BS.drop (index + 1) validString + let char = B8.singleton $ toLower $ B8.index validString index + let recombinedString = prefix <> char <> suffix + return $ counterexample + (show validString <> " : " <> show recombinedString) $ + (BS.length recombinedString === BS.length validString) + .&&. + (Bech32.decode recombinedString `shouldSatisfy` + (if B8.map toUpper validString == recombinedString + then isRight + else isLeft)) + + it "Decoding fails for a lower-case string with an upper-case \ + \character." $ + property $ \s -> do + let validString = getValidBech32String s + index <- choose (0, BS.length validString - 1) + let prefix = B8.map toLower $ BS.take index validString + let suffix = B8.map toLower $ BS.drop (index + 1) validString + let char = B8.singleton $ toUpper $ B8.index validString index + let recombinedString = prefix <> char <> suffix + return $ counterexample + (show validString <> " : " <> show recombinedString) $ + (BS.length recombinedString === BS.length validString) + .&&. + (Bech32.decode recombinedString `shouldSatisfy` + (if B8.map toLower validString == recombinedString + then isRight + else isLeft)) + describe "Roundtrip (encode . decode)" $ do it "Can perform roundtrip for valid data" $ property $ \(hrp, bytes) -> (eitherToMaybe (Bech32.encode hrp bytes) @@ -169,6 +276,43 @@ invalidChecksums = map B8.pack , "de1lg7wt\xFF" ] +newtype ValidBech32Char = ValidBech32Char + { getValidBech32Char :: Char + } deriving (Eq, Ord, Show) + +instance Arbitrary ValidBech32Char where + arbitrary = ValidBech32Char <$> elements Bech32.charset + shrink (ValidBech32Char c) = + ValidBech32Char . (Bech32.word5ToChar Arr.!) <$> shrink + (fromMaybe + (error "unable to shrink a Bech32 character.") + (Bech32.charToWord5 c)) + +data ValidBech32String = ValidBech32String + { getValidBech32String :: ByteString + , humanReadablePart :: HumanReadablePart + , unencodedDataPart :: ByteString + } deriving (Eq, Show) + +mkValidBech32String :: HumanReadablePart -> ByteString -> ValidBech32String +mkValidBech32String hrp udp = + ValidBech32String + (fromRight (error "unable to make a valid Bech32 string.") $ + Bech32.encode hrp udp) + hrp udp + +instance Arbitrary ValidBech32String where + arbitrary = mkValidBech32String <$> 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 <$> + [ (hrpShrunk, udpShrunk) + , (hrpShrunk, udpOriginal) + , (hrpOriginal, udpShrunk) ] + instance Arbitrary HumanReadablePart where shrink hrp = catMaybes $ eitherToMaybe . mkHumanReadablePart <$> shrink (humanReadablePartToBytes hrp)