module Network.Haskoin.Crypto.ExtendedKeys
( XPubKey(..)
, XPrvKey(..)
, ChainCode
, makeXPrvKey
, deriveXPubKey
, prvSubKey
, pubSubKey
, primeSubKey
, prvSubKeys
, pubSubKeys
, primeSubKeys
, mulSigSubKey
, mulSigSubKeys
, xPrvIsPrime
, xPubIsPrime
, xPrvChild
, xPubChild
, xPubID
, xPrvID
, xPubFP
, xPrvFP
, xPubAddr
, xPubExport
, xPrvExport
, xPubImport
, xPrvImport
, xPrvWIF
, cycleIndex
, cycleIndex'
, addPubKeys
, addPrvKeys
) where
import Control.DeepSeq (NFData, rnf)
import Control.Monad (mzero, guard, unless, when, liftM2)
import Data.Aeson (Value(String), FromJSON, ToJSON, parseJSON, toJSON, withText)
import Data.Binary (Binary, get, put)
import Data.Binary.Get (Get, getWord8, getWord32be)
import Data.Binary.Put (Put, runPut, putWord8, putWord32be)
import Data.Word (Word8, Word32)
import Data.Bits (shiftR, setBit, testBit, clearBit)
import Data.Maybe (mapMaybe)
import qualified Data.Text as T (pack, unpack)
import qualified Data.ByteString as BS (ByteString, append)
import Network.Haskoin.Util
import Network.Haskoin.Constants
import Network.Haskoin.Crypto.Keys
import Network.Haskoin.Crypto.Hash
import Network.Haskoin.Crypto.Base58
import Network.Haskoin.Crypto.BigWord
import Network.Haskoin.Crypto.Curve
import Network.Haskoin.Crypto.Point
type ChainCode = Word256
data XPrvKey = XPrvKey
{ xPrvDepth :: !Word8
, xPrvParent :: !Word32
, xPrvIndex :: !Word32
, xPrvChain :: !ChainCode
, xPrvKey :: !PrvKey
} deriving (Eq, Show, Read)
instance NFData XPrvKey where
rnf (XPrvKey d p i c k) =
rnf d `seq` rnf p `seq` rnf i `seq` rnf c `seq` rnf k
instance ToJSON XPrvKey where
toJSON = String . T.pack . xPrvExport
instance FromJSON XPrvKey where
parseJSON = withText "xprvkey" $ \t ->
maybe mzero return $ xPrvImport (T.unpack t)
data XPubKey = XPubKey
{ xPubDepth :: !Word8
, xPubParent :: !Word32
, xPubIndex :: !Word32
, xPubChain :: !ChainCode
, xPubKey :: !PubKey
} deriving (Eq, Show, Read)
instance NFData XPubKey where
rnf (XPubKey d p i c k) =
rnf d `seq` rnf p `seq` rnf i `seq` rnf c `seq` rnf k
instance ToJSON XPubKey where
toJSON = String . T.pack . xPubExport
instance FromJSON XPubKey where
parseJSON = withText "xpubkey" $ \t ->
maybe mzero return $ xPubImport (T.unpack t)
makeXPrvKey :: BS.ByteString -> Maybe XPrvKey
makeXPrvKey bs = do
pk' <- makePrvKey $ fromIntegral pk
return $ XPrvKey 0 0 0 c pk'
where (pk,c) = split512 $ hmac512 (stringToBS "Bitcoin seed") bs
deriveXPubKey :: XPrvKey -> XPubKey
deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k)
prvSubKey :: XPrvKey
-> Word32
-> Maybe XPrvKey
prvSubKey xkey child = guardIndex child >> do
k <- addPrvKeys (xPrvKey xkey) a
return $ XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k
where pK = xPubKey $ deriveXPubKey xkey
msg = BS.append (encode' pK) (encode' child)
(a,c) = split512 $ hmac512 (encode' $ xPrvChain xkey) msg
pubSubKey :: XPubKey
-> Word32
-> Maybe XPubKey
pubSubKey xKey child = guardIndex child >> do
pK <- addPubKeys (xPubKey xKey) a
return $ XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK
where msg = BS.append (encode' $ xPubKey xKey) (encode' child)
(a,c) = split512 $ hmac512 (encode' $ xPubChain xKey) msg
primeSubKey :: XPrvKey
-> Word32
-> Maybe XPrvKey
primeSubKey xkey child = guardIndex child >> do
k <- addPrvKeys (xPrvKey xkey) a
return $ XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k
where i = setBit child 31
msg = BS.append (bsPadPrvKey $ xPrvKey xkey) (encode' i)
(a,c) = split512 $ hmac512 (encode' $ xPrvChain xkey) msg
addPrvKeys :: PrvKey -> Word256 -> Maybe PrvKey
addPrvKeys key i
| isPrvKeyU key = error "Add: HDW only supports compressed formats"
| toInteger i < curveN =
let r = (prvKeyFieldN key) + (fromIntegral i :: FieldN)
in makePrvKey $ toInteger r
| otherwise = Nothing
addPubKeys :: PubKey -> Word256 -> Maybe PubKey
addPubKeys pub i
| isPubKeyU pub = error "Add: HDW only supports compressed formats"
| toInteger i < curveN =
let pt1 = mulPoint (fromIntegral i :: FieldN) curveG
pt2 = addPoint (pubKeyPoint pub) pt1
in if isInfPoint pt2 then Nothing
else Just $ PubKey pt2
| otherwise = Nothing
prvSubKeys :: XPrvKey -> Word32 -> [(XPrvKey,Word32)]
prvSubKeys k i = mapMaybe f $ cycleIndex i
where f j = liftM2 (,) (prvSubKey k j) (return j)
pubSubKeys :: XPubKey -> Word32 -> [(XPubKey,Word32)]
pubSubKeys k i = mapMaybe f $ cycleIndex i
where f j = liftM2 (,) (pubSubKey k j) (return j)
primeSubKeys :: XPrvKey -> Word32 -> [(XPrvKey,Word32)]
primeSubKeys k i = mapMaybe f $ cycleIndex i
where f j = liftM2 (,) (primeSubKey k j) (return j)
mulSigSubKey :: [XPubKey]
-> Word32
-> Maybe [XPubKey]
mulSigSubKey pubs i = mapM (flip pubSubKey i) pubs
mulSigSubKeys :: [XPubKey] -> Word32 -> [([XPubKey],Word32)]
mulSigSubKeys pubs i = mapMaybe f $ cycleIndex i
where f j = liftM2 (,) (mulSigSubKey pubs j) (return j)
cycleIndex :: Word32 -> [Word32]
cycleIndex i
| i == 0 = cycle [0..0x7fffffff]
| i < 0x80000000 = cycle $ [i..0x7fffffff] ++ [0..(i1)]
| otherwise = error $ "cycleIndex: invalid index " ++ (show i)
cycleIndex' :: Word32 -> [Word32]
cycleIndex' i
| i == 0 = cycle $ 0 : [0x7fffffff,0x7ffffffe..1]
| i == 0x7fffffff = cycle [0x7fffffff,0x7ffffffe..0]
| i == 0x7ffffffe = cycle $ [0x7ffffffe,0x7ffffffd..0] ++ [0x7fffffff]
| i < 0x80000000 = cycle $ [i,(i1)..0] ++ [0x7fffffff,0x7ffffffe..(i+1)]
| otherwise = error $ "cycleIndex: invalid index " ++ (show i)
guardIndex :: Word32 -> Maybe ()
guardIndex child = guard $ child >= 0 && child < 0x80000000
xPrvIsPrime :: XPrvKey -> Bool
xPrvIsPrime k = testBit (xPrvIndex k) 31
xPubIsPrime :: XPubKey -> Bool
xPubIsPrime k = testBit (xPubIndex k) 31
xPrvChild :: XPrvKey -> Word32
xPrvChild k = clearBit (xPrvIndex k) 31
xPubChild :: XPubKey -> Word32
xPubChild k = clearBit (xPubIndex k) 31
xPrvID :: XPrvKey -> Word160
xPrvID = xPubID . deriveXPubKey
xPubID :: XPubKey -> Word160
xPubID = hash160 . hash256BS . encode' . xPubKey
xPrvFP :: XPrvKey -> Word32
xPrvFP = fromIntegral . (`shiftR` 128) . xPrvID
xPubFP :: XPubKey -> Word32
xPubFP = fromIntegral . (`shiftR` 128) . xPubID
xPubAddr :: XPubKey -> Address
xPubAddr = pubKeyAddr . xPubKey
xPrvExport :: XPrvKey -> String
xPrvExport = bsToString . encodeBase58Check . encode'
xPubExport :: XPubKey -> String
xPubExport = bsToString . encodeBase58Check . encode'
xPrvImport :: String -> Maybe XPrvKey
xPrvImport str = decodeToMaybe =<< (decodeBase58Check $ stringToBS str)
xPubImport :: String -> Maybe XPubKey
xPubImport str = decodeToMaybe =<< (decodeBase58Check $ stringToBS str)
xPrvWIF :: XPrvKey -> String
xPrvWIF = toWIF . xPrvKey
instance Binary XPrvKey where
get = do
ver <- getWord32be
unless (ver == extSecretPrefix) $ fail $
"Get: Invalid version for extended private key"
dep <- getWord8
par <- getWord32be
idx <- getWord32be
chn <- get
prv <- getPadPrvKey
return $ XPrvKey dep par idx chn prv
put k = do
putWord32be extSecretPrefix
putWord8 $ xPrvDepth k
putWord32be $ xPrvParent k
putWord32be $ xPrvIndex k
put $ xPrvChain k
putPadPrvKey $ xPrvKey k
instance Binary XPubKey where
get = do
ver <- getWord32be
unless (ver == extPubKeyPrefix) $ fail $
"Get: Invalid version for extended public key"
dep <- getWord8
par <- getWord32be
idx <- getWord32be
chn <- get
pub <- get
when (isPubKeyU pub) $ fail $
"Invalid public key. Only compressed format is supported"
return $ XPubKey dep par idx chn pub
put k = do
putWord32be extPubKeyPrefix
putWord8 $ xPubDepth k
putWord32be $ xPubParent k
putWord32be $ xPubIndex k
put $ xPubChain k
when (isPubKeyU (xPubKey k)) $ fail $
"Only compressed public keys are supported"
put $ xPubKey k
getPadPrvKey :: Get PrvKey
getPadPrvKey = do
pad <- getWord8
unless (pad == 0x00) $ fail $
"Private key must be padded with 0x00"
getPrvKey
putPadPrvKey :: PrvKey -> Put
putPadPrvKey p = putWord8 0x00 >> putPrvKey p
bsPadPrvKey :: PrvKey -> BS.ByteString
bsPadPrvKey = toStrictBS . runPut . putPadPrvKey