diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,13 @@ +Copyright © 2013, Stephen Paul Weber + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/Data/Base58Address.hs b/Data/Base58Address.hs new file mode 100644 --- /dev/null +++ b/Data/Base58Address.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +--module Data.Base58Address (BitcoinAddress, RippleAddress) where +module Data.Base58Address where + +import Control.Arrow ((***)) +import Data.Word +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString as BS + +import Data.Base58Address.BaseConvert +import Data.Base58Address.Alphabet + +#ifdef TESTS +import Test.QuickCheck + +instance Arbitrary Base58Address where + arbitrary = do + ver <- arbitrary + adr <- arbitrary `suchThat` (>0) + return $ Base58Address ver adr + +instance Arbitrary BitcoinAddress where + arbitrary = do + adr <- arbitrary + return $ BitcoinAddress adr + +instance Arbitrary RippleAddress where + arbitrary = do + adr <- arbitrary + return $ RippleAddress adr +#endif + +newtype BitcoinAddress = BitcoinAddress Base58Address + deriving (Ord, Eq) + +bitcoinAlphabet :: Alphabet +bitcoinAlphabet = read "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" + +instance Show BitcoinAddress where + show (BitcoinAddress adr) = showB58 bitcoinAlphabet adr + +instance Read BitcoinAddress where + readsPrec _ s = case decodeB58 bitcoinAlphabet s of + Just x -> [(BitcoinAddress x,"")] + Nothing -> [] + +newtype RippleAddress = RippleAddress Base58Address + deriving (Ord, Eq) + +rippleAlphabet :: Alphabet +rippleAlphabet = read "rpshnaf39wBUDNEGHJKLM4PQRST7VWXYZ2bcdeCg65jkm8oFqi1tuvAxyz" + +instance Show RippleAddress where + show (RippleAddress adr) = showB58 rippleAlphabet adr + +instance Read RippleAddress where + readsPrec _ s = case decodeB58 rippleAlphabet s of + Just x -> [(RippleAddress x,"")] + Nothing -> [] + +data Base58Address = Base58Address !Word8 !Integer + deriving (Ord, Eq) + +showB58 :: Alphabet -> Base58Address -> String +showB58 alphabet (Base58Address version addr) = prefix ++ + toString alphabet 58 (fromBase 256 (bytes' ++ mkChk bytes') :: Integer) + where + prefix | version == 0 = toString alphabet 58 0 + | otherwise = "" + bytes' = version : replicate (20 - length bytes) 0 ++ bytes + bytes = toBase 256 addr + +decodeB58 :: Alphabet -> String -> Maybe Base58Address +decodeB58 alphabet s = do + (chk,bytes) <- fmap (splitChk . toBase 256) + (toIntegral alphabet 58 s :: Maybe Integer) + let bytes' = replicate (21 - length bytes) 0 ++ bytes + if mkChk bytes' /= chk then Nothing else + Just $! Base58Address (head bytes') (fromBase 256 (tail bytes')) + +splitChk :: [a] -> ([a], [a]) +splitChk = (reverse *** reverse) . splitAt 4 . reverse + +mkChk :: [Word8] -> [Word8] +mkChk = BS.unpack . BS.take 4 . SHA256.hash . SHA256.hash . BS.pack diff --git a/Data/Base58Address/Alphabet.hs b/Data/Base58Address/Alphabet.hs new file mode 100644 --- /dev/null +++ b/Data/Base58Address/Alphabet.hs @@ -0,0 +1,34 @@ +module Data.Base58Address.Alphabet where + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Base58Address.BaseConvert + +data Alphabet = Alphabet !(IntMap Char) !(Map Char Int) + deriving (Eq) + +instance Show Alphabet where + show (Alphabet a _) = map snd $ IntMap.toAscList a + +instance Read Alphabet where + readsPrec _ alphabet = [( + Alphabet + (IntMap.fromAscList $ zip [0..] alphabet) + (Map.fromList $ zip alphabet [0..]), + "")] + +toAlphaDigit :: Alphabet -> Int -> Maybe Char +toAlphaDigit (Alphabet letters _) i = IntMap.lookup i letters + +toString :: (Integral a) => Alphabet -> a -> a -> String +toString a b v = let Just x = mapM (toAlphaDigit a) (toBase b v) in x + +fromAlphaDigit :: Alphabet -> Char -> Maybe Int +fromAlphaDigit (Alphabet _ indices) v = Map.lookup v indices + +toIntegral :: (Integral a) => Alphabet -> a -> String -> Maybe a +toIntegral a b = fmap (fromBase b) . + mapM (fmap toInteger . fromAlphaDigit a) diff --git a/Data/Base58Address/BaseConvert.hs b/Data/Base58Address/BaseConvert.hs new file mode 100644 --- /dev/null +++ b/Data/Base58Address/BaseConvert.hs @@ -0,0 +1,14 @@ +module Data.Base58Address.BaseConvert (toBase, fromBase) where + +import Data.Sequence (unfoldl) +import Data.Foldable (toList) + +toBase :: (Integral a, Integral b) => a -> a -> [b] +toBase _ 0 = [0] +toBase b v + | v < 0 = error "Data.Base58Address.BaseConvert.toBase v < 0" + | otherwise = map fromIntegral $ toList $ + unfoldl (\n -> if n == 0 then Nothing else Just $! (n `divMod` b)) v + +fromBase :: (Integral a, Integral b) => b -> [a] -> b +fromBase b = foldl (\n k -> n * b + fromIntegral k) 0 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,2 @@ +Datatypes with show and read instances that match the spec for Bitcoin +and Ripple addresses. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/base58address.cabal b/base58address.cabal new file mode 100644 --- /dev/null +++ b/base58address.cabal @@ -0,0 +1,54 @@ +name: base58address +version: 0.1 +cabal-version: >= 1.8 +license: OtherLicense +license-file: COPYING +category: Web +copyright: © 2013 Stephen Paul Weber +author: Stephen Paul Weber +maintainer: Stephen Paul Weber +stability: experimental +tested-with: GHC == 7.4.1 +synopsis: Parsing and serialization for Base58 addresses (Bitcoin and Ripple) +homepage: https://github.com/singpolyma/base58address +bug-reports: https://github.com/singpolyma/base58address/issues +build-type: Simple +description: + Datatypes with show and read instances that match the spec for Bitcoin + and Ripple addresses. + +extra-source-files: + README + +library + exposed-modules: + Data.Base58Address + + other-modules: + Data.Base58Address.BaseConvert + Data.Base58Address.Alphabet + + build-depends: + base == 4.*, + containers, + bytestring, + cryptohash + +test-suite tests + type: exitcode-stdio-1.0 + main-is: tests/suite.hs + + cpp-options: -DTESTS + + build-depends: + base == 4.*, + containers, + bytestring, + cryptohash, + QuickCheck >= 2.4.1.1, + test-framework, + test-framework-quickcheck2 + +source-repository head + type: git + location: git://github.com/singpolyma/base58address.git diff --git a/tests/suite.hs b/tests/suite.hs new file mode 100644 --- /dev/null +++ b/tests/suite.hs @@ -0,0 +1,30 @@ +module Main (main) where + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.QuickCheck2 + +import Data.Base58Address + +prop_read_show_bitcoin :: BitcoinAddress -> Bool +prop_read_show_bitcoin adr = (read $! str) == adr + where + str = show $! adr + {-# NOINLINE str #-} + +prop_read_show_ripple :: RippleAddress -> Bool +prop_read_show_ripple adr = (read $! str) == adr + where + str = show $! adr + {-# NOINLINE str #-} + +tests :: [Test] +tests = + [ + testGroup "Encode/decode loop" [ + testProperty "BitcoinAddress" prop_read_show_bitcoin, + testProperty "RippleAddress" prop_read_show_ripple + ] + ] + +main :: IO () +main = defaultMain tests