{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Haskoin.Keys.Extended
(
XPubKey(..)
, XPrvKey(..)
, ChainCode
, KeyIndex
, DerivationException(..)
, makeXPrvKey
, deriveXPubKey
, prvSubKey
, pubSubKey
, hardSubKey
, xPrvIsHard
, xPubIsHard
, xPrvChild
, xPubChild
, xPubID
, xPrvID
, xPubFP
, xPrvFP
, xPubAddr
, xPubExport
, xPrvExport
, xPubImport
, xPrvImport
, xPrvWif
, putXPrvKey
, putXPubKey
, getXPrvKey
, getXPubKey
, xPubFromJSON
, xPrvFromJSON
, prvSubKeys
, pubSubKeys
, hardSubKeys
, deriveAddr
, deriveAddrs
, deriveMSAddr
, deriveMSAddrs
, cycleIndex
, DerivPathI(..)
, AnyDeriv, HardDeriv, SoftDeriv
, HardOrAny
, AnyOrSoft
, DerivPath
, HardPath
, SoftPath
, Bip32PathIndex (..)
, derivePath
, derivePubPath
, toHard
, toSoft
, toGeneric
, (++/)
, pathToStr
, listToPath
, pathToList
, XKey(..)
, ParsedPath(..)
, parsePath
, parseHard
, parseSoft
, applyPath
, derivePathAddr
, derivePathAddrs
, derivePathMSAddr
, derivePathMSAddrs
, concatBip32Segments
) where
import Control.Applicative
import Control.DeepSeq (NFData, rnf)
import Control.Exception (Exception, throw)
import Control.Monad (guard, mzero, unless, (<=<))
import Crypto.Secp256k1
import Data.Aeson as A (FromJSON, ToJSON,
Value (String), parseJSON,
toJSON, withText)
import Data.Aeson.Types (Parser)
import Data.Bits (clearBit, setBit, testBit)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Either (fromRight)
import Data.List (foldl')
import Data.List.Split (splitOn)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Serialize as S (Serialize, decode, encode,
get, put)
import Data.Serialize.Get (Get, getWord32be, getWord8,
runGet)
import Data.Serialize.Put (Putter, putWord32be, putWord8,
runPut)
import Data.String (IsString, fromString)
import Data.String.Conversions (cs)
import Data.Typeable (Typeable)
import Data.Word (Word32, Word8)
import Network.Haskoin.Address
import Network.Haskoin.Address.Base58
import Network.Haskoin.Constants
import Network.Haskoin.Crypto.Hash
import Network.Haskoin.Keys.Common
import Network.Haskoin.Script
import Network.Haskoin.Util
import Text.Read as R
import Text.Read.Lex
newtype DerivationException = DerivationException String
deriving (Eq, Read, Show, Typeable)
instance Exception DerivationException
type ChainCode = Hash256
type KeyIndex = Word32
data XPrvKey = XPrvKey
{ xPrvDepth :: !Word8
, xPrvParent :: !Word32
, xPrvIndex :: !KeyIndex
, xPrvChain :: !ChainCode
, xPrvKey :: !SecKey
, xPrvNet :: !Network
} deriving (Eq)
instance Ord XPrvKey where
compare k1 k2 = xPrvExport k1 `compare` xPrvExport k2
instance Show XPrvKey where
showsPrec _ = shows . xPrvExport
instance Read XPrvKey where
readPrec = do
R.String str <- lexP
let bs = cs str
f k n = k <|> xPrvImport n bs
maybe pfail return $ foldl' f Nothing allNets
instance NFData XPrvKey where
rnf (XPrvKey d p i c k n) =
rnf d `seq`
rnf p `seq` rnf i `seq` rnf c `seq` k `seq` rnf n `seq` ()
instance ToJSON XPrvKey where
toJSON = A.String . xPrvExport
data XPubKey = XPubKey
{ xPubDepth :: !Word8
, xPubParent :: !Word32
, xPubIndex :: !KeyIndex
, xPubChain :: !ChainCode
, xPubKey :: !PubKey
, xPubNet :: !Network
} deriving (Eq)
instance Ord XPubKey where
compare k1 k2 = xPubExport k1 `compare` xPubExport k2
instance Show XPubKey where
showsPrec _ = shows . xPubExport
instance Read XPubKey where
readPrec = do
R.String str <- lexP
let bs = cs str
f k n = k <|> xPubImport n bs
maybe pfail return $ foldl' f Nothing allNets
instance NFData XPubKey where
rnf (XPubKey d p i c k n) =
rnf d `seq`
rnf p `seq` rnf i `seq` rnf c `seq` k `seq` rnf n `seq` ()
instance ToJSON XPubKey where
toJSON = A.String . xPubExport
xPubFromJSON :: Network -> Value -> Parser XPubKey
xPubFromJSON net =
withText "xpub" $ \t ->
case xPubImport net t of
Nothing -> fail "could not read xpub"
Just x -> return x
xPrvFromJSON :: Network -> Value -> Parser XPrvKey
xPrvFromJSON net =
withText "xprv" $ \t ->
case xPrvImport net t of
Nothing -> fail "could not read xprv"
Just x -> return x
makeXPrvKey :: Network -> ByteString -> XPrvKey
makeXPrvKey net bs =
XPrvKey 0 0 0 c k net
where
(p, c) = split512 $ hmac512 "Bitcoin seed" bs
k = fromMaybe err (secKey (encode p))
err = throw $ DerivationException "Invalid seed"
deriveXPubKey :: XPrvKey -> XPubKey
deriveXPubKey (XPrvKey d p i c k n) = XPubKey d p i c (derivePubKey k) n
prvSubKey :: XPrvKey
-> KeyIndex
-> XPrvKey
prvSubKey xkey child
| child >= 0 && child < 0x80000000 =
XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k (xPrvNet xkey)
| otherwise = error "Invalid child derivation index"
where
pK = xPubKey $ deriveXPubKey xkey
m = B.append (exportPubKey True pK) (encode child)
(a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) m
k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a
err = throw $ DerivationException "Invalid prvSubKey derivation"
pubSubKey :: XPubKey
-> KeyIndex
-> XPubKey
pubSubKey xKey child
| child >= 0 && child < 0x80000000 =
XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK (xPubNet xKey)
| otherwise = error "Invalid child derivation index"
where
m = B.append (exportPubKey True (xPubKey xKey)) (encode child)
(a, c) = split512 $ hmac512 (encode $ xPubChain xKey) m
pK = fromMaybe err $ tweakPubKey (xPubKey xKey) a
err = throw $ DerivationException "Invalid pubSubKey derivation"
hardSubKey :: XPrvKey
-> KeyIndex
-> XPrvKey
hardSubKey xkey child
| child >= 0 && child < 0x80000000 =
XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k (xPrvNet xkey)
| otherwise = error "Invalid child derivation index"
where
i = setBit child 31
m = B.append (bsPadPrvKey $ xPrvKey xkey) (encode i)
(a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) m
k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a
err = throw $ DerivationException "Invalid hardSubKey derivation"
xPrvIsHard :: XPrvKey -> Bool
xPrvIsHard k = testBit (xPrvIndex k) 31
xPubIsHard :: XPubKey -> Bool
xPubIsHard k = testBit (xPubIndex k) 31
xPrvChild :: XPrvKey -> KeyIndex
xPrvChild k = clearBit (xPrvIndex k) 31
xPubChild :: XPubKey -> KeyIndex
xPubChild k = clearBit (xPubIndex k) 31
xPrvID :: XPrvKey -> Hash160
xPrvID = xPubID . deriveXPubKey
xPubID :: XPubKey -> Hash160
xPubID = ripemd160 . encode . sha256 . exportPubKey True . xPubKey
xPrvFP :: XPrvKey -> Word32
xPrvFP =
fromRight err . decode . B.take 4 . encode . xPrvID
where
err = error "Could not decode xPrvFP"
xPubFP :: XPubKey -> Word32
xPubFP =
fromRight err . decode . B.take 4 . encode . xPubID
where
err = error "Could not decode xPubFP"
xPubAddr :: XPubKey -> Address
xPubAddr xkey = pubKeyAddr (xPubNet xkey) (wrapPubKey True (xPubKey xkey))
xPrvExport :: XPrvKey -> Base58
xPrvExport = encodeBase58Check . runPut . putXPrvKey
xPubExport :: XPubKey -> Base58
xPubExport = encodeBase58Check . runPut . putXPubKey
xPrvImport :: Network -> Base58 -> Maybe XPrvKey
xPrvImport net = eitherToMaybe . runGet (getXPrvKey net) <=< decodeBase58Check
xPubImport :: Network -> Base58 -> Maybe XPubKey
xPubImport net = eitherToMaybe . runGet (getXPubKey net) <=< decodeBase58Check
xPrvWif :: XPrvKey -> Base58
xPrvWif xkey = toWif (xPrvNet xkey) (wrapSecKey True (xPrvKey xkey))
getXPrvKey :: Network -> Get XPrvKey
getXPrvKey net = do
ver <- getWord32be
unless (ver == getExtSecretPrefix net) $ fail
"Get: Invalid version for extended private key"
XPrvKey <$> getWord8
<*> getWord32be
<*> getWord32be
<*> S.get
<*> getPadPrvKey
<*> pure net
putXPrvKey :: Putter XPrvKey
putXPrvKey k = do
putWord32be $ getExtSecretPrefix (xPrvNet k)
putWord8 $ xPrvDepth k
putWord32be $ xPrvParent k
putWord32be $ xPrvIndex k
put $ xPrvChain k
putPadPrvKey $ xPrvKey k
getXPubKey :: Network -> Get XPubKey
getXPubKey net = do
ver <- getWord32be
unless (ver == getExtPubKeyPrefix net) $ fail
"Get: Invalid version for extended public key"
XPubKey <$> getWord8
<*> getWord32be
<*> getWord32be
<*> S.get
<*> (pubKeyPoint <$> S.get)
<*> pure net
putXPubKey :: Putter XPubKey
putXPubKey k = do
putWord32be $ getExtPubKeyPrefix (xPubNet k)
putWord8 $ xPubDepth k
putWord32be $ xPubParent k
putWord32be $ xPubIndex k
put $ xPubChain k
put $ wrapPubKey True (xPubKey k)
prvSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)]
prvSubKeys k = map (\i -> (prvSubKey k i, i)) . cycleIndex
pubSubKeys :: XPubKey -> KeyIndex -> [(XPubKey, KeyIndex)]
pubSubKeys k = map (\i -> (pubSubKey k i, i)) . cycleIndex
hardSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)]
hardSubKeys k = map (\i -> (hardSubKey k i, i)) . cycleIndex
deriveAddr :: XPubKey -> KeyIndex -> (Address, PubKey)
deriveAddr k i =
(xPubAddr key, xPubKey key)
where
key = pubSubKey k i
deriveAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)]
deriveAddrs k =
map f . cycleIndex
where
f i = let (a, key) = deriveAddr k i in (a, key, i)
deriveMSAddr :: Network -> [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript)
deriveMSAddr net keys m i
| all ((== net) . xPubNet) keys = (payToScriptAddress net rdm, rdm)
| otherwise = error "Some extended public keys on the wrong network"
where
rdm = sortMulSig $ PayMulSig k m
k = map (wrapPubKey True . xPubKey . flip pubSubKey i) keys
deriveMSAddrs :: Network -> [XPubKey] -> Int -> KeyIndex
-> [(Address, RedeemScript, KeyIndex)]
deriveMSAddrs net keys m = map f . cycleIndex
where
f i =
let (a, rdm) = deriveMSAddr net keys m i
in (a, rdm, i)
cycleIndex :: KeyIndex -> [KeyIndex]
cycleIndex i
| i == 0 = cycle [0..0x7fffffff]
| i < 0x80000000 = cycle $ [i..0x7fffffff] ++ [0..(i-1)]
| otherwise = error $ "cycleIndex: invalid index " ++ show i
data HardDeriv
data AnyDeriv
data SoftDeriv
type HardPath = DerivPathI HardDeriv
type DerivPath = DerivPathI AnyDeriv
type SoftPath = DerivPathI SoftDeriv
class HardOrAny a
instance HardOrAny HardDeriv
instance HardOrAny AnyDeriv
class AnyOrSoft a
instance AnyOrSoft AnyDeriv
instance AnyOrSoft SoftDeriv
data DerivPathI t where
(:|) :: HardOrAny t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t
(:/) :: AnyOrSoft t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t
Deriv :: DerivPathI t
instance NFData (DerivPathI t) where
rnf p = case p of
next :| i -> rnf i `seq` rnf next
next :/ i -> rnf i `seq` rnf next
Deriv -> ()
instance Eq (DerivPathI t) where
(nextA :| iA) == (nextB :| iB) = iA == iB && nextA == nextB
(nextA :/ iA) == (nextB :/ iB) = iA == iB && nextA == nextB
Deriv == Deriv = True
_ == _ = False
instance Serialize DerivPath where
get = listToPath <$> S.get
put = put . pathToList
pathToList :: DerivPathI t -> [KeyIndex]
pathToList =
reverse . go
where
go (next :| i) = setBit i 31 : go next
go (next :/ i) = i : go next
go _ = []
listToPath :: [KeyIndex] -> DerivPath
listToPath =
go . reverse
where
go (i:is)
| testBit i 31 = go is :| clearBit i 31
| otherwise = go is :/ i
go [] = Deriv
pathToStr :: DerivPathI t -> String
pathToStr p =
case p of
next :| i -> concat [ pathToStr next, "/", show i, "'" ]
next :/ i -> concat [ pathToStr next, "/", show i ]
Deriv -> ""
toHard :: DerivPathI t -> Maybe HardPath
toHard p = case p of
next :| i -> (:| i) <$> toHard next
Deriv -> Just Deriv
_ -> Nothing
toSoft :: DerivPathI t -> Maybe SoftPath
toSoft p = case p of
next :/ i -> (:/ i) <$> toSoft next
Deriv -> Just Deriv
_ -> Nothing
toGeneric :: DerivPathI t -> DerivPath
toGeneric p = case p of
next :/ i -> toGeneric next :/ i
next :| i -> toGeneric next :| i
Deriv -> Deriv
(++/) :: DerivPathI t1 -> DerivPathI t2 -> DerivPath
(++/) p1 p2 =
go id (toGeneric p2) $ toGeneric p1
where
go f p = case p of
next :/ i -> go (f . (:/ i)) $ toGeneric next
next :| i -> go (f . (:| i)) $ toGeneric next
_ -> f
derivePath :: DerivPathI t -> XPrvKey -> XPrvKey
derivePath = go id
where
go f p = case p of
next :| i -> go (f . flip hardSubKey i) next
next :/ i -> go (f . flip prvSubKey i) next
_ -> f
derivePubPath :: SoftPath -> XPubKey -> XPubKey
derivePubPath = go id
where
go f p = case p of
next :/ i -> go (f . flip pubSubKey i) next
_ -> f
instance Show DerivPath where
showsPrec d p = showParen (d > 10) $
showString "DerivPath " . shows (pathToStr p)
instance Read DerivPath where
readPrec = parens $ do
R.Ident "DerivPath" <- lexP
R.String str <- lexP
maybe pfail return $ getParsedPath <$> parsePath str
instance Show HardPath where
showsPrec d p = showParen (d > 10) $
showString "HardPath " . shows (pathToStr p)
instance Read HardPath where
readPrec = parens $ do
R.Ident "HardPath" <- lexP
R.String str <- lexP
maybe pfail return $ parseHard str
instance Show SoftPath where
showsPrec d p = showParen (d > 10) $
showString "SoftPath " . shows (pathToStr p)
instance Read SoftPath where
readPrec = parens $ do
R.Ident "SoftPath" <- lexP
R.String str <- lexP
maybe pfail return $ parseSoft str
instance IsString ParsedPath where
fromString =
fromMaybe e . parsePath
where
e = error "Could not parse derivation path"
instance IsString DerivPath where
fromString =
getParsedPath . fromMaybe e . parsePath
where
e = error "Could not parse derivation path"
instance IsString HardPath where
fromString =
fromMaybe e . parseHard
where
e = error "Could not parse hard derivation path"
instance IsString SoftPath where
fromString =
fromMaybe e . parseSoft
where
e = error "Could not parse soft derivation path"
instance FromJSON ParsedPath where
parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of
Just p -> return p
_ -> mzero
instance FromJSON DerivPath where
parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of
Just p -> return $ getParsedPath p
_ -> mzero
instance FromJSON HardPath where
parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of
Just p -> return p
_ -> mzero
instance FromJSON SoftPath where
parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of
Just p -> return p
_ -> mzero
instance ToJSON (DerivPathI t) where
toJSON = A.String . cs . pathToStr
instance ToJSON ParsedPath where
toJSON (ParsedPrv p) = A.String . cs . ("m" ++) . pathToStr $ p
toJSON (ParsedPub p) = A.String . cs . ("M" ++) . pathToStr $ p
toJSON (ParsedEmpty p) = A.String . cs . ("" ++) . pathToStr $ p
data ParsedPath = ParsedPrv { getParsedPath :: !DerivPath }
| ParsedPub { getParsedPath :: !DerivPath }
| ParsedEmpty { getParsedPath :: !DerivPath }
deriving Eq
instance Show ParsedPath where
showsPrec d p = showParen (d > 10) $ showString "ParsedPath " . shows f
where
f =
case p of
ParsedPrv d' -> "m" <> pathToStr d'
ParsedPub d' -> "M" <> pathToStr d'
ParsedEmpty d' -> pathToStr d'
instance Read ParsedPath where
readPrec = parens $ do
R.Ident "ParsedPath" <- lexP
R.String str <- lexP
maybe pfail return $ parsePath str
parsePath :: String -> Maybe ParsedPath
parsePath str = do
res <- concatBip32Segments <$> mapM parseBip32PathIndex xs
case x of
"m" -> Just $ ParsedPrv res
"M" -> Just $ ParsedPub res
"" -> Just $ ParsedEmpty res
_ -> Nothing
where
(x : xs) = splitOn "/" str
concatBip32Segments :: [Bip32PathIndex] -> DerivPath
concatBip32Segments = foldl' appendBip32Segment Deriv
appendBip32Segment :: DerivPath -> Bip32PathIndex -> DerivPath
appendBip32Segment d (Bip32SoftIndex i) = d :/ i
appendBip32Segment d (Bip32HardIndex i) = d :| i
parseBip32PathIndex :: String -> Maybe Bip32PathIndex
parseBip32PathIndex segment = case reads segment of
[(i, "" )] -> guard (is31Bit i) >> return (Bip32SoftIndex i)
[(i, "'")] -> guard (is31Bit i) >> return (Bip32HardIndex i)
_ -> Nothing
data Bip32PathIndex = Bip32HardIndex KeyIndex
| Bip32SoftIndex KeyIndex
deriving Eq
instance Show Bip32PathIndex where
showsPrec d (Bip32HardIndex i) = showParen (d > 10) $
showString "Bip32HardIndex " . shows i
showsPrec d (Bip32SoftIndex i) = showParen (d > 10) $
showString "Bip32SoftIndex " . shows i
instance Read Bip32PathIndex where
readPrec = h <|> s
where
h =
parens $ do
R.Ident "Bip32HardIndex" <- lexP
R.Number n <- lexP
maybe pfail return $
Bip32HardIndex . fromIntegral <$> numberToInteger n
s =
parens $ do
R.Ident "Bip32SoftIndex" <- lexP
R.Number n <- lexP
maybe pfail return $
Bip32SoftIndex . fromIntegral <$> numberToInteger n
is31Bit :: (Integral a) => a -> Bool
is31Bit i = i >= 0 && i < 0x80000000
parseHard :: String -> Maybe HardPath
parseHard = toHard . getParsedPath <=< parsePath
parseSoft :: String -> Maybe SoftPath
parseSoft = toSoft . getParsedPath <=< parsePath
data XKey
= XPrv { getXKeyPrv :: !XPrvKey
, getXKeyNet :: !Network }
| XPub { getXKeyPub :: !XPubKey
, getXKeyNet :: !Network }
deriving (Eq, Show)
applyPath :: ParsedPath -> XKey -> Either String XKey
applyPath path key =
case (path, key) of
(ParsedPrv _, XPrv k n) -> return $ XPrv (derivPrvF k) n
(ParsedPrv _, XPub {}) -> Left "applyPath: Invalid public key"
(ParsedPub _, XPrv k n) -> return $ XPub (deriveXPubKey (derivPrvF k)) n
(ParsedPub _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n
(ParsedEmpty _, XPrv k n) -> return $ XPrv (derivPrvF k) n
(ParsedEmpty _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n
where
derivPrvF = goPrv id $ getParsedPath path
derivPubFE = goPubE id $ getParsedPath path
goPrv f p =
case p of
next :| i -> goPrv (f . flip hardSubKey i) next
next :/ i -> goPrv (f . flip prvSubKey i) next
Deriv -> f
goPubE f p =
case p of
next :/ i -> goPubE (f . flip pubSubKey i) next
Deriv -> Right f
_ -> Left "applyPath: Invalid hard derivation"
derivePathAddr :: XPubKey -> SoftPath -> KeyIndex -> (Address, PubKey)
derivePathAddr key path = deriveAddr (derivePubPath path key)
derivePathAddrs ::
XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKey, KeyIndex)]
derivePathAddrs key path = deriveAddrs (derivePubPath path key)
derivePathMSAddr ::
Network
-> [XPubKey]
-> SoftPath
-> Int
-> KeyIndex
-> (Address, RedeemScript)
derivePathMSAddr net keys path =
deriveMSAddr net $ map (derivePubPath path) keys
derivePathMSAddrs ::
Network
-> [XPubKey]
-> SoftPath
-> Int
-> KeyIndex
-> [(Address, RedeemScript, KeyIndex)]
derivePathMSAddrs net keys path =
deriveMSAddrs net $ map (derivePubPath path) keys
getPadPrvKey :: Get SecKey
getPadPrvKey = do
pad <- getWord8
unless (pad == 0x00) $ fail "Private key must be padded with 0x00"
secKeyGet
putPadPrvKey :: Putter SecKey
putPadPrvKey p = putWord8 0x00 >> secKeyPut p
bsPadPrvKey :: SecKey -> ByteString
bsPadPrvKey = runPut . putPadPrvKey