module Data.Base58String ( Base58String
, b58String
, fromBinary
, toBinary
, fromBytes
, toBytes
, toText
, fromText ) where
import Control.Applicative (pure, (<$>))
import Control.Monad (liftM)
import Data.Bits (shiftL, shiftR, (.|.))
import Data.Char (chr, ord)
import Data.List (unfoldr)
import Data.Maybe (fromJust, fromMaybe, isJust,
listToMaybe)
import Data.String (fromString)
import Data.Word (Word8)
import Numeric (readInt, showIntAtBase)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Binary as B (Binary, decode, encode)
data Base58String =
Base58String BS.ByteString
deriving ( Show, Eq, Ord )
b58String :: BS.ByteString
-> BS.ByteString
-> Base58String
b58String table bs =
if BS.all (isValidBase58 table) bs
then Base58String bs
else error ("Not a valid base58 string: " ++ show bs)
fromBinary :: B.Binary a
=> BS.ByteString
-> a
-> Base58String
fromBinary table = (b58String table) . (b58Encode table) . BSL.toStrict . B.encode
toBinary :: B.Binary a
=> BS.ByteString
-> Base58String
-> a
toBinary table (Base58String bs) = B.decode . BSL.fromStrict . fromMaybe (error "not a valid base58 input") $ b58Decode table bs
fromBytes :: BS.ByteString
-> BS.ByteString
-> Base58String
fromBytes table = (b58String table) . (b58Encode table)
toBytes :: BS.ByteString
-> Base58String
-> BS.ByteString
toBytes table (Base58String bs) = fromMaybe (error "not a valid base58 input") $ b58Decode table bs
toText :: Base58String -> T.Text
toText (Base58String bs) = TE.decodeUtf8 bs
fromText :: BS.ByteString
-> T.Text
-> Base58String
fromText table = (b58String table) . TE.encodeUtf8
isValidBase58 :: BS.ByteString -> Word8 -> Bool
isValidBase58 table c =
BS.elem c table
b58 :: BS.ByteString -> Word8 -> Word8
b58 table i = BS.index table (fromIntegral i)
b58' :: BS.ByteString -> Word8 -> Maybe Word8
b58' table w = fromIntegral <$> BS.elemIndex w table
b58EncodeInt :: BS.ByteString
-> Integer
-> BS.ByteString
b58EncodeInt table i =
fromString $ showIntAtBase (58 :: Integer) f (fromIntegral i) ""
where
f = chr . fromIntegral . (b58 table) . fromIntegral
b58DecodeInt :: BS.ByteString
-> BS.ByteString
-> Maybe Integer
b58DecodeInt table s = case go of
Just (r,[]) -> Just r
_ -> Nothing
where
c = (b58' table) . fromIntegral . ord
p = isJust . c
f = fromIntegral . fromJust . c
go = listToMaybe $ readInt 58 p f (BS8.unpack s)
b58Encode :: BS.ByteString
-> BS.ByteString
-> BS.ByteString
b58Encode table input = BS.append l r
where
(z,b) = BS.span (== 0) input
l = BS.map (b58 table) z
r | BS.null b = BS.empty
| otherwise = b58EncodeInt table $ bsToInteger b
b58Decode :: BS.ByteString
-> BS.ByteString
-> Maybe BS.ByteString
b58Decode table input = liftM (BS.append prefix) r
where
(z,b) = BS.span (== (b58 table) 0) input
prefix = BS.map (fromJust . (b58' table)) z
r | BS.null b = Just BS.empty
| otherwise = integerToBS <$> (b58DecodeInt table) b
bsToInteger :: BS.ByteString -> Integer
bsToInteger = foldr f 0 . reverse . BS.unpack
where
f w n = toInteger w .|. shiftL n 8
integerToBS :: Integer -> BS.ByteString
integerToBS 0 = BS.pack [0]
integerToBS i
| i > 0 = BS.pack $ reverse $ unfoldr f i
| otherwise = error "integerToBS not defined for negative values"
where
f 0 = Nothing
f x = Just (fromInteger x :: Word8, x `shiftR` 8)