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 (4232B)

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