diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,10 @@ # Changelog +- 0.2.4 (2026-10-10) + * Decoding now validates and converts input in a single pass, and is + somewhat faster on longer inputs. + * Expands the test suite with decoding vectors and invalid inputs. + - 0.2.3 (2026-01-10) * Bumps the ppad-sha256 dependency. diff --git a/lib/Data/ByteString/Base58.hs b/lib/Data/ByteString/Base58.hs --- a/lib/Data/ByteString/Base58.hs +++ b/lib/Data/ByteString/Base58.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -- | -- Module: Data.ByteString.Base58 @@ -15,7 +14,6 @@ , decode ) where -import Control.Monad (guard) import qualified Data.Bits as B import Data.Bits ((.|.)) import qualified Data.ByteString as BS @@ -56,37 +54,20 @@ -- Nothing decode :: BS.ByteString -> Maybe BS.ByteString decode bs = do - guard (verify_base58 bs) + n <- roll_base58 bs let ls = leading_zeros bs - pure $ ls <> unroll_base256 (roll_base58 bs) - -verify_base58 :: BS.ByteString -> Bool -verify_base58 bs = case BS.uncons bs of - Nothing -> True - Just (h, t) - | BS.elem h base58_charset -> verify_base58 t - | otherwise -> False + pure $ ls <> unroll_base256 n base58_charset :: BS.ByteString base58_charset = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" -- produce leading ones from leading zeros leading_ones :: BS.ByteString -> BS.ByteString -leading_ones = go mempty where - go acc bs = case BS.uncons bs of - Nothing -> acc - Just (h, t) - | h == 0 -> go (BS.cons 0x31 acc) t - | otherwise -> acc +leading_ones bs = BS.replicate (BS.length (BS.takeWhile (== 0x00) bs)) 0x31 -- produce leading zeros from leading ones leading_zeros :: BS.ByteString -> BS.ByteString -leading_zeros = go mempty where - go acc bs = case BS.uncons bs of - Nothing -> acc - Just (h, t) - | h == 0x31 -> go (BS.cons 0x00 acc) t - | otherwise -> acc +leading_zeros bs = BS.replicate (BS.length (BS.takeWhile (== 0x31) bs)) 0x00 -- to base256 unroll_base256 :: Integer -> BS.ByteString @@ -111,11 +92,13 @@ let (b, c) = quotRem a 58 in (BU.unsafeIndex base58_charset (fi c), b) --- from base58 -roll_base58 :: BS.ByteString -> Integer -roll_base58 bs = BS.foldl' alg 0 bs where - alg !b !a = case word6 a of - Just w -> b * 58 + fi w - Nothing -> - error "ppad-base58 (roll_base58): internal error" +-- from base58, failing on any non-base58 character +roll_base58 :: BS.ByteString -> Maybe Integer +roll_base58 bs = go 0 0 where + l = BS.length bs + go !acc !i + | i == l = Just acc + | otherwise = case word6 (BU.unsafeIndex bs i) of + Nothing -> Nothing + Just w -> go (acc * 58 + fi w) (i + 1) diff --git a/lib/Data/ByteString/Base58Check.hs b/lib/Data/ByteString/Base58Check.hs --- a/lib/Data/ByteString/Base58Check.hs +++ b/lib/Data/ByteString/Base58Check.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - -- | -- Module: Data.ByteString.Base58Check -- Copyright: (c) 2024 Jared Tobin @@ -42,7 +40,8 @@ decode mb = do bs <- B58.decode mb let len = BS.length bs - (pay, kek) = BS.splitAt (len - 4) bs + guard (len >= 4) + let (pay, kek) = BS.splitAt (len - 4) bs man = BS.take 4 (SHA256.hash (SHA256.hash pay)) guard (kek == man) pure pay diff --git a/ppad-base58.cabal b/ppad-base58.cabal --- a/ppad-base58.cabal +++ b/ppad-base58.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-base58 -version: 0.2.3 +version: 0.2.4 synopsis: base58 and base58check encoding/decoding. license: MIT license-file: LICENSE @@ -35,7 +35,7 @@ build-depends: base >= 4.9 && < 5 , bytestring >= 0.9 && < 0.13 - , ppad-sha256 > 0.3 && < 0.4 + , ppad-sha256 >= 0.3 && < 0.4 test-suite base58-tests type: exitcode-stdio-1.0 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -6,7 +5,9 @@ import Data.Aeson ((.:)) import qualified Data.Aeson as A +import qualified Data.Aeson.Types as AT import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Base58 as B58 import qualified Data.ByteString.Base58Check as B58Check @@ -21,15 +22,15 @@ , vc_payload :: !BS.ByteString } deriving Show -decodeLenient :: BS.ByteString -> BS.ByteString -decodeLenient bs = case B16.decode bs of - Nothing -> error "boom" - Just v -> v +hex :: BS.ByteString -> AT.Parser BS.ByteString +hex bs = case B16.decode bs of + Nothing -> fail "invalid hex" + Just v -> pure v instance A.FromJSON Valid_Base58Check where parseJSON = A.withObject "Valid_Base58Check" $ \m -> Valid_Base58Check <$> fmap TE.encodeUtf8 (m .: "string") - <*> fmap (decodeLenient . TE.encodeUtf8) (m .: "payload") + <*> (hex . TE.encodeUtf8 =<< (m .: "payload")) data Invalid_Base58Check = Invalid_Base58Check { ic_string :: !BS.ByteString @@ -56,16 +57,16 @@ , testGroup "invalid" (fmap execute_invalid b58c_invalid) ] where - execute_valid Valid_Base58Check {..} = testCase "valid" $ do -- label - let enc = B58Check.encode vc_payload - assertEqual mempty enc vc_string + execute_valid Valid_Base58Check {..} = testGroup (label vc_string) [ + testCase "encode" $ + assertEqual mempty vc_string (B58Check.encode vc_payload) + , testCase "decode" $ + assertEqual mempty (Just vc_payload) (B58Check.decode vc_string) + ] - execute_invalid Invalid_Base58Check {..} = testCase "invalid" $ do -- label - let dec = B58Check.decode ic_string - is_just = \case - Nothing -> False - Just _ -> True - assertBool mempty (not (is_just dec)) + execute_invalid Invalid_Base58Check {..} = + testCase (label ic_string) $ + assertEqual mempty Nothing (B58Check.decode ic_string) data Valid_Base58 = Valid_Base58 { vb_decodedHex :: !BS.ByteString @@ -74,14 +75,60 @@ instance A.FromJSON Valid_Base58 where parseJSON = A.withObject "Valid_Base58" $ \m -> Valid_Base58 - <$> fmap (decodeLenient . TE.encodeUtf8) (m .: "decodedHex") + <$> (hex . TE.encodeUtf8 =<< (m .: "decodedHex")) <*> fmap TE.encodeUtf8 (m .: "encoded") -execute_base58 :: Valid_Base58 -> TestTree -- XX label -execute_base58 Valid_Base58 {..} = testCase "base58" $ do - let enc = B58.encode vb_decodedHex - assertEqual mempty enc vb_encoded +execute_base58 :: Valid_Base58 -> TestTree +execute_base58 Valid_Base58 {..} = testGroup (label vb_encoded) [ + testCase "encode" $ + assertEqual mempty vb_encoded (B58.encode vb_decodedHex) + , testCase "decode" $ + assertEqual mempty (Just vb_decodedHex) (B58.decode vb_encoded) + ] +-- test label for an encoded string +label :: BS.ByteString -> String +label bs + | BS.null bs = "(empty)" + | otherwise = show (B8.unpack bs) + +-- strings containing non-base58 characters +invalid_base58 :: [BS.ByteString] +invalid_base58 = [ + "0" + , "O" + , "I" + , "l" + , " " + , "\NUL" + , "+" + , "/" + , "\xff" + , "\xc3\xa9" + , "StV1DL0CwTryKyV" + , "StV1DLOCwTryKyV" + , "StV1DLICwTryKyV" + , "StV1DLlCwTryKyV" + , " StV1DL6CwTryKyV" + , "StV1DL6CwTryKyV " + , "StV1DL6CwTryKyV\n" + , "11110" + , "111l" + , "11 1" + ] + +execute_invalid_base58 :: BS.ByteString -> TestTree +execute_invalid_base58 bs = testCase (label bs) $ + assertEqual mempty Nothing (B58.decode bs) + +-- strings that base58-decode to fewer than four bytes +short_base58check :: [BS.ByteString] +short_base58check = ["", "1", "11", "111", "2g", "a3gV"] + +execute_short_base58check :: BS.ByteString -> TestTree +execute_short_base58check bs = testCase (label bs) $ + assertEqual mempty Nothing (B58Check.decode bs) + newtype BS = BS BS.ByteString deriving (Eq, Show) @@ -96,6 +143,32 @@ b <- bytes 1024 pure (BS b) +-- arbitrary strings over the base58 alphabet, plus some invalid +-- characters +newtype B58Str = B58Str BS.ByteString + deriving (Eq, Show) + +instance Q.Arbitrary B58Str where + arbitrary = do + l <- Q.chooseInt (0, 64) + v <- Q.vectorOf l $ Q.frequency [ + (16, Q.elements alphabet) + , (1, Q.elements (BS.unpack "0OIl +/\NUL\xff")) + ] + pure (B58Str (BS.pack v)) + where + alphabet = BS.unpack + "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" + +-- decoding succeeds exactly on strings over the alphabet, and every +-- such string is canonical +base58_decode_canonical :: B58Str -> Bool +base58_decode_canonical (B58Str bs) = case B58.decode bs of + Nothing -> BS.any (`BS.notElem` alphabet) bs + Just d -> B58.encode d == bs + where + alphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" + base58_decode_inverts_encode :: BS -> Bool base58_decode_inverts_encode (BS bs) = case B58.decode (B58.encode bs) of Nothing -> False @@ -120,11 +193,17 @@ Just (b58, b58c) -> defaultMain $ testGroup "ppad-base58" [ testGroup "unit tests" [ testGroup "base58" (fmap execute_base58 b58) + , testGroup "base58 (invalid)" + (fmap execute_invalid_base58 invalid_base58) , execute_base58check b58c + , testGroup "base58check (short)" + (fmap execute_short_base58check short_base58check) ] , testGroup "property tests" [ Q.testProperty "(base58) decode . encode ~ id" $ Q.withMaxSuccess 250 base58_decode_inverts_encode + , Q.testProperty "(base58) decode succeeds iff canonical" $ + Q.withMaxSuccess 1000 base58_decode_canonical , Q.testProperty "(base58check) decode . encode ~ id" $ Q.withMaxSuccess 250 base58check_decode_inverts_encode ]