{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Haskoin.Keys.Extended
(
XPubKey(..)
, XPrvKey(..)
, ChainCode
, KeyIndex
, Fingerprint
, DerivationException(..)
, makeXPrvKey
, deriveXPubKey
, prvSubKey
, pubSubKey
, hardSubKey
, xPrvIsHard
, xPubIsHard
, xPrvChild
, xPubChild
, xPubID
, xPrvID
, xPubFP
, xPrvFP
, xPubAddr
, xPubExport
, xPubToJSON
, xPubFromJSON
, xPrvExport
, xPrvToJSON
, xPrvFromJSON
, xPubImport
, xPrvImport
, xPrvWif
, putXPrvKey
, putXPubKey
, getXPrvKey
, getXPubKey
, 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.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 GHC.Generics (Generic)
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
type Fingerprint = Word32
data XPrvKey = XPrvKey
{ xPrvDepth :: !Word8
, xPrvParent :: !Fingerprint
, xPrvIndex :: !KeyIndex
, xPrvChain :: !ChainCode
, xPrvKey :: !SecKey
} deriving (Generic, Eq, Show, Read)
xPrvToJSON :: Network -> XPrvKey -> Value
xPrvToJSON net = A.String . xPrvExport net
data XPubKey = XPubKey
{ xPubDepth :: !Word8
, xPubParent :: !Fingerprint
, xPubIndex :: !KeyIndex
, xPubChain :: !ChainCode
, xPubKey :: !PubKey
} deriving (Generic, Eq, Show, Read)
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
xPubToJSON :: Network -> XPubKey -> Value
xPubToJSON net = A.String . xPubExport net
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 :: ByteString -> XPrvKey
makeXPrvKey bs =
XPrvKey 0 0 0 c k
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) = XPubKey d p i c (derivePubKey k)
prvSubKey :: XPrvKey
-> KeyIndex
-> XPrvKey
prvSubKey xkey child
| child >= 0 && child < 0x80000000 =
XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k
| 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
| 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
| 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 -> Fingerprint
xPrvFP =
fromRight err . decode . B.take 4 . encode . xPrvID
where
err = error "Could not decode xPrvFP"
xPubFP :: XPubKey -> Fingerprint
xPubFP =
fromRight err . decode . B.take 4 . encode . xPubID
where
err = error "Could not decode xPubFP"
xPubAddr :: XPubKey -> Address
xPubAddr xkey = pubKeyAddr (wrapPubKey True (xPubKey xkey))
xPrvExport :: Network -> XPrvKey -> Base58
xPrvExport net = encodeBase58Check . runPut . putXPrvKey net
xPubExport :: Network -> XPubKey -> Base58
xPubExport net = encodeBase58Check . runPut . putXPubKey net
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 :: Network -> XPrvKey -> Base58
xPrvWif net xkey = toWif net (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
putXPrvKey :: Network -> Putter XPrvKey
putXPrvKey net k = do
putWord32be $ getExtSecretPrefix net
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)
putXPubKey :: Network -> Putter XPubKey
putXPubKey net k = do
putWord32be $ getExtPubKeyPrefix net
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 :: [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript)
deriveMSAddr keys m i = (payToScriptAddress rdm, rdm)
where
rdm = sortMulSig $ PayMulSig k m
k = map (wrapPubKey True . xPubKey . flip pubSubKey i) keys
deriveMSAddrs :: [XPubKey] -> Int -> KeyIndex
-> [(Address, RedeemScript, KeyIndex)]
deriveMSAddrs keys m = map f . cycleIndex
where
f i =
let (a, rdm) = deriveMSAddr 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 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 ::
[XPubKey]
-> SoftPath
-> Int
-> KeyIndex
-> (Address, RedeemScript)
derivePathMSAddr keys path =
deriveMSAddr $ map (derivePubPath path) keys
derivePathMSAddrs ::
[XPubKey]
-> SoftPath
-> Int
-> KeyIndex
-> [(Address, RedeemScript, KeyIndex)]
derivePathMSAddrs keys path =
deriveMSAddrs $ 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