{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
module BIP32
(
encodeXPrv
, encodeXPub
, decodeXPrv
, decodeXPub
, decode
, encodeXPrvRaw
, encodeXPubRaw
, decodeXPrvRaw
, decodeXPubRaw
, decodeRaw
, XPrv(..)
, xprvToXPub
, I.Prv
, I.prv
, I.unPrv
, I.prvToPub
, XPub(..)
, I.Pub
, I.pub
, I.unPub
, Chain
, chain
, unChain
, Index(..)
, indexIsHardened
, subXPubXPub
, subXPrvXPrv
, subXPrvXPub
, subPubPub
, subPrvPrv
, subPrvPub
, Depth(..)
, Fingerprint(..)
, fingerprint
, Version(..)
, version_xprv
, version_xpub
, version_tprv
, version_tpub
, version_Ltpv
, version_Ltub
, version_ttpv
, version_ttub
) where
import Control.Applicative
import Control.Monad
import Data.Bits
import qualified Data.Binary.Get as Bin
import qualified Data.ByteString as B
import qualified Data.ByteString.Base58 as B58
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import Data.Word
#ifdef ghcjs_HOST_OS
import qualified BIP32.GHCJS as I
#else
import qualified BIP32.GHC as I
#endif
data XPrv = XPrv !Version !Depth !Fingerprint !Index !Chain !I.Prv
deriving (Eq, Show)
xprvToXPub :: Version -> XPrv -> XPub
xprvToXPub v (XPrv _ d f i c prv) = XPub v d f i c (I.prvToPub prv)
data XPub = XPub !Version !Depth !Fingerprint !Index !Chain !I.Pub
deriving (Eq, Show)
newtype Key = Key B.ByteString
keyPub :: I.Pub -> Key
{-# INLINE keyPub #-}
keyPub = Key . I.unPub
keyPrv :: I.Prv -> Key
{-# INLINE keyPrv #-}
keyPrv = Key . B.cons 0 . I.unPrv
newtype Version = Version { unVersion :: Word32 }
deriving (Eq, Show)
version_xprv :: Version
version_xprv = Version 0x0488ade4
{-# INLINE version_xprv #-}
version_xpub :: Version
version_xpub = Version 0x0488b21e
{-# INLINE version_xpub #-}
version_tprv :: Version
version_tprv = Version 0x04358394
{-# INLINE version_tprv #-}
version_tpub :: Version
version_tpub = Version 0x043587cf
{-# INLINE version_tpub #-}
version_Ltpv :: Version
version_Ltpv = Version 0x019d9cfe
{-# INLINE version_Ltpv #-}
version_Ltub :: Version
version_Ltub = Version 0x019da462
{-# INLINE version_Ltub #-}
version_ttpv :: Version
version_ttpv = Version 0x0436ef7d
{-# INLINE version_ttpv #-}
version_ttub :: Version
version_ttub = Version 0x0436f6e1
{-# INLINE version_ttub #-}
newtype Depth = Depth { unDepth :: Word8 }
deriving (Eq, Show)
depthNext :: Depth -> Maybe Depth
{-# INLINE depthNext #-}
depthNext (Depth w) = do
guard (w /= 0xFF)
pure (Depth (w + 1))
newtype Fingerprint = Fingerprint { unFingerprint :: Word32 }
deriving (Eq, Show)
fingerprint :: I.Pub -> Fingerprint
{-# INLINE fingerprint #-}
fingerprint = fingerprint' . keyId
fingerprint' :: KeyId -> Fingerprint
{-# INLINE fingerprint' #-}
fingerprint' (KeyId x) =
let b = B.take 4 x :: B.ByteString
in Fingerprint $! unsafeShiftL (fromIntegral (B.index b 0)) 24 .|.
unsafeShiftL (fromIntegral (B.index b 1)) 16 .|.
unsafeShiftL (fromIntegral (B.index b 2)) 8 .|.
fromIntegral (B.index b 3)
newtype KeyId = KeyId B.ByteString
keyId :: I.Pub -> KeyId
{-# INLINE keyId #-}
keyId = KeyId . I.ripemd160 . I.sha256 . I.unPub
newtype Chain = Chain B.ByteString
deriving (Eq)
instance Show Chain where
showsPrec n (Chain b) = showParen (n > 10) $
showString "Chain " .
showsPrec 0 (BB.toLazyByteString (BB.byteStringHex b))
chain :: B.ByteString -> Maybe Chain
{-# INLINE chain #-}
chain x = do
guard (B.length x == 32)
Just (Chain x)
unChain :: Chain -> B.ByteString
{-# INLINE unChain #-}
unChain (Chain x) = x
newtype Index = Index Word32
deriving (Eq, Ord, Show)
indexIsHardened :: Index -> Bool
{-# INLINE indexIsHardened #-}
indexIsHardened (Index w) = w >= 0x80000000
subXPrvXPrv :: XPrv -> Index -> Maybe XPrv
subXPrvXPrv (XPrv v d0 _ _ ch0 prv0) i1 = do
d1 <- depthNext d0
(ch1, prv1) <- subPrvPrv ch0 prv0 i1
let f1 = fingerprint (I.prvToPub prv0)
pure $ XPrv v d1 f1 i1 ch1 prv1
subXPubXPub :: XPub -> Index -> Maybe XPub
subXPubXPub (XPub v d0 _ _ ch0 pub0) i1 = do
d1 <- depthNext d0
(ch1, pub1) <- subPubPub ch0 pub0 i1
let f1 = fingerprint pub0
pure $ XPub v d1 f1 i1 ch1 pub1
subXPrvXPub :: Version -> XPrv -> Index -> Maybe XPub
subXPrvXPub v xprv i1 = xprvToXPub v <$> subXPrvXPrv xprv i1
subPrvPrv :: Chain -> I.Prv -> Index -> Maybe (Chain, I.Prv)
subPrvPrv (Chain ch0) prv0 i1@(Index i1w) = do
let pub0 = I.prvToPub prv0
x = I.hmacSHA512 ch0 $ mconcat $ if indexIsHardened i1
then [B.singleton 0, I.unPrv prv0, word32BE i1w]
else [I.unPub pub0, word32BE i1w]
(xl, xr) = B.splitAt 32 x
prv1 <- I.addPrvTweak prv0 =<< I.tweak xl
ch1 <- chain xr
pure (ch1, prv1)
subPubPub :: Chain -> I.Pub -> Index -> Maybe (Chain, I.Pub)
subPubPub (Chain ch0) pub0 i1@(Index i1w) = do
guard (not (indexIsHardened i1))
let x = I.hmacSHA512 ch0 (I.unPub pub0 <> word32BE i1w)
(xl, xr) = B.splitAt 32 x
pub1 <- I.addPubTweak pub0 =<< I.tweak xl
ch1 <- chain xr
pure (ch1, pub1)
subPrvPub :: Chain -> I.Prv -> Index -> Maybe (Chain, I.Pub)
subPrvPub ch0 prv0 i1 = fmap I.prvToPub <$> subPrvPrv ch0 prv0 i1
encodeXPub :: XPub -> B.ByteString
{-# INLINE encodeXPub #-}
encodeXPub a = base58EncodeWithChecksum (encodeXPubRaw a)
encodeXPrv :: XPrv -> B.ByteString
{-# INLINE encodeXPrv #-}
encodeXPrv a = base58EncodeWithChecksum (encodeXPrvRaw a)
base58EncodeWithChecksum :: B.ByteString -> B.ByteString
{-# INLINE base58EncodeWithChecksum #-}
base58EncodeWithChecksum a =
B58.encodeBase58 B58.bitcoinAlphabet (a <> checksum32 a)
encodeXPubRaw :: XPub -> B.ByteString
{-# INLINE encodeXPubRaw #-}
encodeXPubRaw (XPub v d f i c p) = encodeRaw v d f i c (keyPub p)
encodeXPrvRaw :: XPrv -> B.ByteString
{-# INLINE encodeXPrvRaw #-}
encodeXPrvRaw (XPrv v d f i c p) = encodeRaw v d f i c (keyPrv p)
encodeRaw
:: Version -> Depth -> Fingerprint -> Index -> Chain -> Key -> B.ByteString
encodeRaw (Version v) (Depth d) (Fingerprint f) (Index i) (Chain c) (Key k) =
BL.toStrict $ BB.toLazyByteString $
BB.word32BE v <>
BB.word8 d <>
BB.word32BE f <>
BB.word32BE i <>
BB.byteString c <>
BB.byteString k
decodeXPub :: B.ByteString -> Maybe XPub
{-# INLINE decodeXPub #-}
decodeXPub = decodeXPubRaw <=< base58DecodeWithChecksum
decodeXPrv :: B.ByteString -> Maybe XPrv
{-# INLINE decodeXPrv #-}
decodeXPrv = decodeXPrvRaw <=< base58DecodeWithChecksum
decode :: B.ByteString -> Maybe (Either XPub XPrv)
{-# INLINE decode #-}
decode = decodeRaw <=< base58DecodeWithChecksum
base58DecodeWithChecksum :: B.ByteString -> Maybe B.ByteString
{-# INLINE base58DecodeWithChecksum #-}
base58DecodeWithChecksum = \a -> do
b <- B58.decodeBase58 B58.bitcoinAlphabet a
guard (B.length b == 78 + 4)
let (raw, ch) = B.splitAt 78 b
guard (ch == checksum32 raw)
pure raw
decodeXPubRaw :: B.ByteString -> Maybe XPub
{-# INLINE decodeXPubRaw #-}
decodeXPubRaw = either Just (\_ -> Nothing) <=< decodeRaw
decodeXPrvRaw :: B.ByteString -> Maybe XPrv
{-# INLINE decodeXPrvRaw #-}
decodeXPrvRaw = either (\_ -> Nothing) Just <=< decodeRaw
decodeRaw :: B.ByteString -> Maybe (Either XPub XPrv)
decodeRaw = \b -> do
guard (B.length b == 78)
case Bin.runGetOrFail getX (BL.fromStrict b) of
Right (lo, 78, ex) | BL.null lo -> Just ex
_ -> Nothing
getX :: Bin.Get (Either XPub XPrv)
getX = do
v <- Version <$> Bin.getWord32be
d <- Depth <$> Bin.getWord8
f <- Fingerprint <$> Bin.getWord32be
i <- Index <$> Bin.getWord32be
c <- Chain <$> Bin.getByteString 32
ek <- fmap Left getPub <|> fmap Right getPrv
pure $ case ek of
Left k -> Left (XPub v d f i c k)
Right k -> Right (XPrv v d f i c k)
getPrv :: Bin.Get I.Prv
getPrv = do
0 <- Bin.getWord8
a <- Bin.getByteString 32
case I.prv a of
Just b -> pure b
Nothing -> fail "Bad private key"
getPub :: Bin.Get I.Pub
getPub = do
a <- Bin.getByteString 33
case I.pub a of
Just b -> pure b
Nothing -> fail "Bad public key"
word32BE :: Word32 -> B.ByteString
{-# INLINE word32BE #-}
word32BE = BL.toStrict . BB.toLazyByteString . BB.word32BE
checksum32 :: B.ByteString -> B.ByteString
{-# INLINE checksum32 #-}
checksum32 = B.take 4 . I.sha256 . I.sha256