base58

Pure Haskell base58, base58check encoding/decoding (docs.ppad.tech/base58).
git clone git://git.ppad.tech/base58.git
Log | Files | Refs | README | LICENSE

Main.hs (4425B)

      1 {-# LANGUAGE LambdaCase #-}
      2 {-# LANGUAGE OverloadedStrings #-}
      3 {-# LANGUAGE RecordWildCards #-}
      4 
      5 module Main where
      6 
      7 import Data.Aeson ((.:))
      8 import qualified Data.Aeson as A
      9 import qualified Data.ByteString as BS
     10 import qualified Data.ByteString.Base16 as B16
     11 import qualified Data.ByteString.Base58 as B58
     12 import qualified Data.ByteString.Base58Check as B58Check
     13 import qualified Data.Text.Encoding as TE
     14 import qualified Data.Text.IO as TIO
     15 import Data.Word (Word8)
     16 import Test.Tasty
     17 import Test.Tasty.HUnit
     18 import qualified Test.Tasty.QuickCheck as Q
     19 
     20 data Valid_Base58Check = Valid_Base58Check {
     21     vc_string  :: !BS.ByteString
     22   , vc_payload :: !BS.ByteString
     23   } deriving Show
     24 
     25 instance A.FromJSON Valid_Base58Check where
     26   parseJSON = A.withObject "Valid_Base58Check" $ \m -> Valid_Base58Check
     27     <$> fmap TE.encodeUtf8 (m .: "string")
     28     <*> fmap (B16.decodeLenient . TE.encodeUtf8) (m .: "payload")
     29 
     30 data Invalid_Base58Check = Invalid_Base58Check {
     31     ic_string  :: !BS.ByteString
     32   } deriving Show
     33 
     34 instance A.FromJSON Invalid_Base58Check where
     35   parseJSON = A.withObject "Invalid_Base58Check" $ \m -> Invalid_Base58Check
     36     <$> fmap TE.encodeUtf8 (m .: "string")
     37 
     38 data Base58Check = Base58Check {
     39     b58c_valid   :: ![Valid_Base58Check]
     40   , b58c_invalid :: ![Invalid_Base58Check]
     41   } deriving Show
     42 
     43 instance A.FromJSON Base58Check where
     44   parseJSON = A.withObject "Base58Check" $ \m -> Base58Check
     45     <$> (m .: "valid")
     46     <*> (m .: "invalid")
     47 
     48 
     49 execute_base58check :: Base58Check -> TestTree
     50 execute_base58check Base58Check {..} = testGroup "base58check" [
     51       testGroup "valid" (fmap execute_valid b58c_valid)
     52     , testGroup "invalid" (fmap execute_invalid b58c_invalid)
     53     ]
     54   where
     55     execute_valid Valid_Base58Check {..} = testCase "valid" $ do -- label
     56       let enc = case BS.uncons vc_payload of
     57             Nothing -> error "faulty"
     58             Just (h, t) -> B58Check.encode h t
     59       assertEqual mempty enc vc_string
     60 
     61     execute_invalid Invalid_Base58Check {..} = testCase "invalid" $ do -- label
     62       let dec = B58Check.decode ic_string
     63           is_just = \case
     64             Nothing -> False
     65             Just _ -> True
     66       assertBool mempty (not (is_just dec))
     67 
     68 data Valid_Base58 = Valid_Base58 {
     69     vb_decodedHex  :: !BS.ByteString
     70   , vb_encoded     :: !BS.ByteString
     71   } deriving Show
     72 
     73 instance A.FromJSON Valid_Base58 where
     74   parseJSON = A.withObject "Valid_Base58" $ \m -> Valid_Base58
     75     <$> fmap (B16.decodeLenient . TE.encodeUtf8) (m .: "decodedHex")
     76     <*> fmap TE.encodeUtf8 (m .: "encoded")
     77 
     78 execute_base58 :: Valid_Base58 -> TestTree -- XX label
     79 execute_base58 Valid_Base58 {..} = testCase "base58" $ do
     80   let enc = B58.encode vb_decodedHex
     81   assertEqual mempty enc vb_encoded
     82 
     83 newtype BS = BS BS.ByteString
     84   deriving (Eq, Show)
     85 
     86 bytes :: Int -> Q.Gen BS.ByteString
     87 bytes k = do
     88   l <- Q.chooseInt (0, k)
     89   v <- Q.vectorOf l Q.arbitrary
     90   pure (BS.pack v)
     91 
     92 data B58C = B58C Word8 BS
     93   deriving (Eq, Show)
     94 
     95 instance Q.Arbitrary BS where
     96   arbitrary = do
     97     b <- bytes 1024
     98     pure (BS b)
     99 
    100 instance Q.Arbitrary B58C where
    101   arbitrary = do
    102     w8 <- Q.arbitrary
    103     bs <- Q.arbitrary
    104     pure (B58C w8 bs)
    105 
    106 base58_decode_inverts_encode :: BS -> Bool
    107 base58_decode_inverts_encode (BS bs) = case B58.decode (B58.encode bs) of
    108   Nothing -> False
    109   Just b  -> b == bs
    110 
    111 base58check_decode_inverts_encode :: B58C -> Bool
    112 base58check_decode_inverts_encode (B58C w8 (BS bs)) =
    113   case B58Check.decode (B58Check.encode w8 bs) of
    114     Nothing -> False
    115     Just (w8', bs') -> w8 == w8' && bs == bs'
    116 
    117 main :: IO ()
    118 main = do
    119   scure_base58 <- TIO.readFile "etc/base58.json"
    120   scure_base58check <- TIO.readFile "etc/base58_check.json"
    121   let per = do
    122         b0 <- A.decodeStrictText scure_base58 :: Maybe [Valid_Base58]
    123         b1 <- A.decodeStrictText scure_base58check :: Maybe Base58Check
    124         pure (b0, b1)
    125   case per of
    126     Nothing -> error "couldn't parse vectors"
    127     Just (b58, b58c) -> defaultMain $ testGroup "ppad-base58" [
    128         testGroup "unit tests" [
    129             testGroup "base58" (fmap execute_base58 b58)
    130           , execute_base58check b58c
    131           ]
    132       , testGroup "property tests" [
    133           Q.testProperty "(base58) decode . encode ~ id" $
    134             Q.withMaxSuccess 250 base58_decode_inverts_encode
    135         , Q.testProperty "(base58check) decode . encode ~ id" $
    136             Q.withMaxSuccess 250 base58check_decode_inverts_encode
    137         ]
    138       ]
    139