diff --git a/lib/bech32/bech32.cabal b/lib/bech32/bech32.cabal index 6b540acf292..98e08c958a5 100644 --- a/lib/bech32/bech32.cabal +++ b/lib/bech32/bech32.cabal @@ -32,6 +32,7 @@ library array , base , bytestring + , extra hs-source-dirs: src exposed-modules: @@ -56,6 +57,7 @@ test-suite bech32-test array , base , bech32 + , extra , hspec , bytestring , QuickCheck diff --git a/lib/bech32/src/Codec/Binary/Bech32/Internal.hs b/lib/bech32/src/Codec/Binary/Bech32/Internal.hs index 0c492d9cfd8..37fc6673c46 100644 --- a/lib/bech32/src/Codec/Binary/Bech32/Internal.hs +++ b/lib/bech32/src/Codec/Binary/Bech32/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -19,16 +20,22 @@ module Codec.Binary.Bech32.Internal ( -- * Encoding & Decoding encode + , EncodingError (..) , decode , checksumLength - , maxEncodedStringLength + , separatorLength + , encodedStringMaxLength + , encodedStringMinLength -- * Human-Readable Parts , HumanReadablePart + , HumanReadablePartError (..) , mkHumanReadablePart , humanReadablePartToBytes , humanReadableCharsetMinBound , humanReadableCharsetMaxBound + , humanReadablePartMinLength + , humanReadablePartMaxLength -- * Bit Manipulation , convertBits @@ -52,18 +59,24 @@ import Control.Monad ( guard ) import Data.Array ( Array ) +import Data.Bifunctor + ( first ) import Data.Bits ( Bits, testBit, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.) ) import Data.ByteString ( ByteString ) import Data.Char - ( toLower, toUpper ) + ( ord, toLower, toUpper ) +import Data.Either.Extra + ( maybeToEither ) import Data.Foldable ( foldl' ) import Data.Functor.Identity ( Identity, runIdentity ) import Data.Ix ( Ix (..) ) +import Data.Maybe + ( isJust ) import Data.Word ( Word8 ) @@ -78,15 +91,30 @@ import qualified Data.ByteString.Char8 as B8 newtype HumanReadablePart = HumanReadablePart ByteString deriving (Show, Eq) -mkHumanReadablePart :: ByteString -> Maybe HumanReadablePart -mkHumanReadablePart hrp = do - guard $ not (BS.null hrp) && BS.all valid hrp - return (HumanReadablePart hrp) +mkHumanReadablePart + :: ByteString -> Either HumanReadablePartError HumanReadablePart +mkHumanReadablePart hrp + | BS.length hrp < humanReadablePartMinLength = + Left HumanReadablePartTooShort + | BS.length hrp > humanReadablePartMaxLength = + Left HumanReadablePartTooLong + | BS.length invalidPortion > 0 = + Left $ HumanReadablePartContainsInvalidChar $ CharPosition $ + BS.length validPortion + | otherwise = + Right $ HumanReadablePart hrp where + (validPortion, invalidPortion) = BS.break (not . valid) hrp valid c = c >= humanReadableCharsetMinBound && c <= humanReadableCharsetMaxBound +data HumanReadablePartError + = HumanReadablePartTooShort + | HumanReadablePartTooLong + | HumanReadablePartContainsInvalidChar CharPosition + deriving (Eq, Show) + humanReadableCharsetMinBound :: Word8 humanReadableCharsetMinBound = 33 @@ -96,43 +124,105 @@ humanReadableCharsetMaxBound = 126 humanReadablePartToBytes :: HumanReadablePart -> ByteString humanReadablePartToBytes (HumanReadablePart bytes) = bytes +humanReadablePartMinLength :: Int +humanReadablePartMinLength = 1 + +humanReadablePartMaxLength :: Int +humanReadablePartMaxLength = 83 + {------------------------------------------------------------------------------- Encoding & Decoding -------------------------------------------------------------------------------} -encode :: HumanReadablePart -> ByteString -> Maybe ByteString +encode :: HumanReadablePart -> ByteString -> Either EncodingError ByteString encode hrp@(HumanReadablePart hrpBytes) payload = do let payload5 = toBase32 (BS.unpack payload) let payload' = payload5 ++ bech32CreateChecksum hrp payload5 let rest = map (charset Arr.!) payload' let output = B8.map toLower hrpBytes <> B8.pack "1" <> B8.pack rest - guard (BS.length output <= maxEncodedStringLength) + guardE (BS.length output <= encodedStringMaxLength) EncodedStringTooLong return output -decode :: ByteString -> Maybe (HumanReadablePart, ByteString) +data EncodingError = EncodedStringTooLong + deriving (Eq, Show) + +decode :: ByteString -> Either DecodingError (HumanReadablePart, ByteString) decode bech32 = do - guard $ BS.length bech32 <= maxEncodedStringLength - guard $ B8.map toUpper bech32 == bech32 || B8.map toLower bech32 == bech32 - let (hrp, dat) = B8.breakEnd (== '1') $ B8.map toLower bech32 - guard $ BS.length dat >= checksumLength - hrp' <- B8.stripSuffix (B8.pack "1") hrp >>= mkHumanReadablePart - dat' <- mapM charsetMap $ B8.unpack dat - guard $ bech32VerifyChecksum hrp' dat' - result <- toBase256 (take (BS.length dat - checksumLength) dat') - return (hrp', BS.pack result) + (hrpUnparsed , dcpUnparsed) <- + maybeToEither StringToDecodeMissingSeparatorChar $ + splitAtLastOccurrence separatorChar $ B8.map toLower bech32 + hrp <- first hrpError $ mkHumanReadablePart hrpUnparsed + dcp <- first + (\(CharPosition p) -> StringToDecodeContainsInvalidChar $ + CharPosition $ p + BS.length hrpUnparsed + separatorLength) + (parseDataPart $ B8.unpack dcpUnparsed) + guardE (BS.length bech32 <= encodedStringMaxLength) + StringToDecodeTooLong + guardE (BS.length bech32 >= encodedStringMinLength) + StringToDecodeTooShort + guardE (B8.map toUpper bech32 == bech32 || B8.map toLower bech32 == bech32) + StringToDecodeHasMixedCase + guardE (length dcp >= checksumLength) + StringToDecodeTooShort + guardE (bech32VerifyChecksum hrp dcp) + StringToDecodeContainsInvalidChars + dp <- maybeToEither StringToDecodeContainsInvalidChars $ + toBase256 (take (length dcp - checksumLength) dcp) + return (hrp, BS.pack dp) + where + parseDataPart :: String -> Either CharPosition [Word5] + parseDataPart dpUnparsed = + case mapM charsetMap dpUnparsed of + Just dp -> pure dp + Nothing -> Left $ CharPosition $ length $ + takeWhile isJust (charsetMap <$> dpUnparsed) + hrpError = \case + HumanReadablePartTooLong -> + StringToDecodeContainsInvalidChar $ CharPosition + humanReadablePartMaxLength + HumanReadablePartTooShort -> + StringToDecodeContainsInvalidChar $ CharPosition $ + humanReadablePartMinLength - 1 + HumanReadablePartContainsInvalidChar p -> + StringToDecodeContainsInvalidChar p + +data DecodingError + = StringToDecodeTooLong + | StringToDecodeTooShort + | StringToDecodeHasMixedCase + | StringToDecodeMissingSeparatorChar + | StringToDecodeContainsInvalidChar CharPosition + | StringToDecodeContainsInvalidChars + deriving (Eq, Show) + +-- | The separator character. This character appears immediately after the +-- human-readable part and before the data part. +separatorChar :: Word8 +separatorChar = fromIntegral $ ord '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. -maxEncodedStringLength :: Int -maxEncodedStringLength = 90 +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 Set Manipulation + Character Manipulation -------------------------------------------------------------------------------} charset :: Array Word5 Char @@ -153,6 +243,10 @@ charsetMap c Arr.// (map swap (Arr.assocs charset)) +-- | The zero-based position of a character in a string, counting from the left. +newtype CharPosition = CharPosition Int + deriving (Eq, Show) + {------------------------------------------------------------------------------- Bit Manipulation -------------------------------------------------------------------------------} @@ -251,3 +345,17 @@ toBase256 :: [Word5] -> Maybe [Word8] toBase256 dat = map fromIntegral <$> convertBits (map fromWord5 dat) 5 8 noPadding +{------------------------------------------------------------------------------- + Utilities +-------------------------------------------------------------------------------} + +guardE :: Bool -> e -> Either e () +guardE b e = if b then Right () else Left e + +-- | Splits the given 'ByteString' into a prefix and a suffix using the last +-- occurrence of the specified separator character as a splitting point. +-- Evaluates to 'Nothing' if the 'ByteString` does not contain the separator +-- character. +splitAtLastOccurrence :: Word8 -> ByteString -> Maybe (ByteString, ByteString) +splitAtLastOccurrence w s = + (\i -> (BS.take i s, BS.drop (i + 1) s)) <$> BS.elemIndexEnd w s diff --git a/lib/bech32/test/Codec/Binary/Bech32Spec.hs b/lib/bech32/test/Codec/Binary/Bech32Spec.hs index 569fc9f492b..9ad89616e73 100644 --- a/lib/bech32/test/Codec/Binary/Bech32Spec.hs +++ b/lib/bech32/test/Codec/Binary/Bech32Spec.hs @@ -19,10 +19,14 @@ import Data.ByteString ( ByteString ) import Data.Char ( toLower, toUpper ) +import Data.Either + ( isLeft ) +import Data.Either.Extra + ( eitherToMaybe ) import Data.Functor.Identity ( runIdentity ) import Data.Maybe - ( catMaybes, isJust, isNothing ) + ( catMaybes, isJust ) import Data.Word ( Word8 ) import Test.Hspec @@ -48,45 +52,45 @@ spec :: Spec spec = do describe "Valid Checksums" $ forM_ validChecksums $ \checksum -> it (B8.unpack checksum) $ case Bech32.decode checksum of - Nothing -> + Left _ -> expectationFailure (show checksum) - Just (resultHRP, resultData) -> do + Right (resultHRP, resultData) -> do -- test that a corrupted checksum fails decoding. let (hrp, rest) = B8.breakEnd (== '1') checksum let Just (first, rest') = BS.uncons rest let checksumCorrupted = (hrp `BS.snoc` (first `xor` 1)) `BS.append` rest' - (Bech32.decode checksumCorrupted) `shouldSatisfy` isNothing + (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 = Just $ B8.map toLower checksum + let expectedChecksum = Right $ B8.map toLower checksum checksumEncoded `shouldBe` expectedChecksum describe "Invalid Checksums" $ forM_ invalidChecksums $ \checksum -> it (B8.unpack checksum) $ - Bech32.decode checksum `shouldSatisfy` isNothing + Bech32.decode checksum `shouldSatisfy` isLeft describe "More Encoding/Decoding Cases" $ do it "length > maximum" $ do let hrpUnpacked = "ca" let hrpLength = length hrpUnpacked - let (Just hrp) = mkHumanReadablePart (B8.pack hrpUnpacked) - let separatorLength = 1 + let (Right hrp) = mkHumanReadablePart (B8.pack hrpUnpacked) let maxDataLength = - Bech32.maxEncodedStringLength - - Bech32.checksumLength - separatorLength - hrpLength + Bech32.encodedStringMaxLength + - Bech32.checksumLength - Bech32.separatorLength - hrpLength Bech32.encode hrp (BS.pack (replicate (maxDataLength + 1) 1)) - `shouldSatisfy` isNothing + `shouldBe` Left Bech32.EncodedStringTooLong it "hrp lowercased" $ do - let (Just hrp) = mkHumanReadablePart (B8.pack "HRP") + let (Right hrp) = mkHumanReadablePart (B8.pack "HRP") Bech32.encode hrp mempty - `shouldBe` Just (B8.pack "hrp1g9xj8m") + `shouldBe` Right (B8.pack "hrp1g9xj8m") describe "Roundtrip (encode . decode)" $ do it "Can perform roundtrip for valid data" $ property $ \(hrp, bytes) -> - (Bech32.encode hrp bytes >>= Bech32.decode) === Just (hrp, bytes) + (eitherToMaybe (Bech32.encode hrp bytes) + >>= eitherToMaybe . Bech32.decode) === Just (hrp, bytes) describe "Roundtrip (toBase256 . toBase32)" $ do it "Can perform roundtrip base conversion" $ property $ \ws -> @@ -164,15 +168,15 @@ invalidChecksums = map B8.pack ] instance Arbitrary HumanReadablePart where - shrink hrp = catMaybes - (mkHumanReadablePart <$> shrink (humanReadablePartToBytes hrp)) + shrink hrp = catMaybes $ eitherToMaybe . + mkHumanReadablePart <$> shrink (humanReadablePartToBytes hrp) arbitrary = do let range = ( Bech32.humanReadableCharsetMinBound , Bech32.humanReadableCharsetMaxBound ) bytes <- choose (1, 10) >>= \n -> vectorOf n (choose range) - let (Just hrp) = mkHumanReadablePart (B8.map toLower $ BS.pack bytes) + let (Right hrp) = mkHumanReadablePart (B8.map toLower $ BS.pack bytes) return hrp instance Arbitrary ByteString where