packages feed

ppad-base58 0.2.3 → 0.2.4

raw patch · 5 files changed

+121/−55 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGELOG view
@@ -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.
lib/Data/ByteString/Base58.hs view
@@ -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)
lib/Data/ByteString/Base58Check.hs view
@@ -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
ppad-base58.cabal view
@@ -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
test/Main.hs view
@@ -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         ]