Extended.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE NoFieldSelectors #-}

-- |
-- Module      : Haskoin.Keys.Extended
-- Copyright   : No rights reserved
-- License     : MIT
-- Maintainer  : jprupp@protonmail.ch
-- Stability   : experimental
-- Portability : POSIX
--
-- BIP-32 extended keys.
module Haskoin.Crypto.Keys.Extended
  ( -- * Extended Keys
    XPubKey (..),
    XPrvKey (..),
    ChainCode,
    KeyIndex,
    Fingerprint,
    fingerprintToText,
    textToFingerprint,
    DerivationException (..),
    makeXPrvKey,
    deriveXPubKey,
    prvSubKey,
    pubSubKey,
    hardSubKey,
    xPrvIsHard,
    xPubIsHard,
    xPrvChild,
    xPubChild,
    xPubID,
    xPrvID,
    xPubFP,
    xPrvFP,
    xPubAddr,
    xPubWitnessAddr,
    xPubCompatWitnessAddr,
    xPubExport,
    xPrvExport,
    xPubImport,
    xPrvImport,
    xPrvWif,

    -- ** Helper Functions
    prvSubKeys,
    pubSubKeys,
    hardSubKeys,
    deriveAddr,
    deriveWitnessAddr,
    deriveCompatWitnessAddr,
    deriveAddrs,
    deriveWitnessAddrs,
    deriveCompatWitnessAddrs,
    deriveMSAddr,
    deriveMSAddrs,
    cycleIndex,

    -- ** Derivation Paths
    DerivPathI (Deriv, (:|), (:/)),
    AnyDeriv,
    HardDeriv,
    SoftDeriv,
    HardOrAny,
    AnyOrSoft,
    DerivPath,
    HardPath,
    SoftPath,
    Bip32PathIndex (..),
    derivePath,
    derivePubPath,
    tryDerivePath,
    tryDerivePubPath,
    toHard,
    toSoft,
    toGeneric,
    (++/),
    pathToStr,
    listToPath,
    pathToList,

    -- *** Derivation Path Parser
    XKey (..),
    ParsedPath (..),
    parsePath,
    parseHard,
    parseSoft,
    applyPath,
    derivePathAddr,
    derivePathAddrs,
    derivePathMSAddr,
    derivePathMSAddrs,
    concatBip32Segments,
  )
where

import Control.Applicative
import Control.DeepSeq
import Control.Exception (Exception, throw)
import Control.Monad (foldM, guard, mzero, unless, when, (<=<))
import Crypto.Secp256k1
import Data.Aeson as Aeson
  ( FromJSON,
    ToJSON (..),
    Value (String),
    parseJSON,
    toJSON,
    withText,
  )
import Data.Aeson.Encoding (Encoding, string, text)
import Data.Aeson.Types (Parser)
import Data.Binary (Binary (get, put))
import Data.Bifunctor (first)
import Data.Bits (clearBit, setBit, testBit)
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.Char (isDigit)
import Data.Bytes.Get
  ( MonadGet
      ( getByteString,
        getWord32be,
        getWord8
      ),
    runGetS,
  )
import Data.Bytes.Put
  ( MonadPut
      ( putByteString,
        putWord32be,
        putWord8
      ),
    runPutS,
  )
import Data.Bytes.Serial (Serial (..))
import Data.Either (fromRight)
import Data.Hashable (Hashable)
import Data.List (foldl')
import Data.List.Split (splitOn)
import Data.Maybe (fromMaybe)
import Data.Serialize (Serialize (..))
import Data.Serialize qualified as S
import Data.String (IsString, fromString)
import Data.String.Conversions (cs)
import Data.Text qualified as Text
import Data.Typeable (Typeable)
import Data.Word (Word32, Word8)
import GHC.Generics (Generic)
import Haskoin.Address
import Haskoin.Crypto.Hash
import Haskoin.Crypto.Keys.Common
import Haskoin.Crypto.Keys.Extended.Internal
import Haskoin.Network.Data
import Haskoin.Script.Standard
import Haskoin.Util
import Text.Read as Read
  ( Lexeme (Ident, Number, String),
    Read (readPrec),
    ReadPrec,
    lexP,
    parens,
    pfail,
  )
import Text.Read.Lex (numberToInteger)

-- | A derivation exception is thrown in the very unlikely event that a
-- derivation is invalid.
newtype DerivationException = DerivationException String
  deriving (Eq, Read, Show, Typeable, Generic)
  deriving newtype (NFData)

instance Exception DerivationException

-- | Chain code as specified in BIP-32.
type ChainCode = Hash256

-- | Index of key as specified in BIP-32.
type KeyIndex = Word32

-- | Data type representing an extended BIP32 private key. An extended key
-- is a node in a tree of key derivations. It has a depth in the tree, a
-- parent node and an index to differentiate it from other siblings.
data XPrvKey = XPrvKey
  { -- | depth in the tree
    depth :: !Word8,
    -- | fingerprint of parent
    parent :: !Fingerprint,
    -- | derivation index
    index :: !KeyIndex,
    -- | chain code
    chain :: !ChainCode,
    -- | private key of this node
    key :: !SecKey
  }
  deriving (Generic, Eq, NFData, Hashable)

-- | The chain code and the key are not shown. Together they give every key
-- below this one, so a value that ends up in a log or an error message
-- must not reveal them. There is no 'Read' instance for the same reason:
-- use 'xPrvExport' and 'xPrvImport' to write a key out and read it back.
--
-- The @key@ field is a 'SecKey', whose own 'Show' instance prints the secret
-- in hex. Do not show that field by itself.
instance Show XPrvKey where
  showsPrec d k =
    showParen (d > 10) $
      showString "XPrvKey {depth = "
        . shows k.depth
        . showString ", parent = "
        . shows k.parent
        . showString ", index = "
        . shows k.index
        . showString ", chain = <redacted>, key = <redacted>}"

instance Marshal Network XPrvKey where
  marshalGet net = do
    ver <- getWord32be
    unless (ver == net.xPrvPrefix) $
      fail "Get: Invalid version for extended private key"
    d <- getWord8
    p <- deserialize
    i <- getWord32be
    checkMasterFields d p i
    XPrvKey d p i <$> deserialize <*> getPadPrvKey

  marshalPut net k = do
    putWord32be net.xPrvPrefix
    putWord8 k.depth
    serialize k.parent
    putWord32be k.index
    serialize $ k.chain
    putPadPrvKey k.key

instance MarshalJSON Network XPrvKey where
  marshalValue net = Aeson.String . xPrvExport net

  marshalEncoding net = text . xPrvExport net

  unmarshalValue net =
    withText "XPrvKey" $ \t ->
      case xPrvImport net t of
        Nothing -> fail "could not read xprv"
        Just x -> return x

-- | Data type representing an extended BIP32 public key.
data XPubKey = XPubKey
  { -- | depth in the tree
    depth :: !Word8,
    -- | fingerprint of parent
    parent :: !Fingerprint,
    -- | derivation index
    index :: !KeyIndex,
    -- | chain code
    chain :: !ChainCode,
    -- | public key of this node
    key :: !PubKey
  }
  deriving (Generic, Eq, Show, Read, Hashable, NFData)

instance Marshal (Network, Ctx) XPubKey where
  marshalGet (net, ctx) = do
    ver <- getWord32be
    unless (ver == net.xPubPrefix) $
      fail "Get: Invalid version for extended public key"
    d <- getWord8
    p <- deserialize
    i <- getWord32be
    checkMasterFields d p i
    XPubKey d p i <$> deserialize <*> getCompressedPubKey ctx

  marshalPut (net, ctx) k = do
    putWord32be net.xPubPrefix
    putWord8 k.depth
    serialize k.parent
    putWord32be k.index
    serialize k.chain
    marshalPut ctx $ wrapPubKey True k.key

instance MarshalJSON (Network, Ctx) XPubKey where
  unmarshalValue (net, ctx) =
    withText "XPubKey" $ \t ->
      case xPubImport net ctx t of
        Nothing -> fail "could not read xpub"
        Just x -> return x

  marshalValue (net, ctx) = Aeson.String . xPubExport net ctx

  marshalEncoding (net, ctx) = text . xPubExport net ctx

-- | Read the public key of an extended key. BIP32 serializes it in 33 bytes,
-- the compressed form. The 65-byte form is refused, so that an extended key
-- has one binary form of 78 bytes.
getCompressedPubKey :: (MonadGet m) => Ctx -> m PubKey
getCompressedPubKey ctx = do
  bs <- getByteString 33
  unless (B.head bs `elem` [0x02, 0x03]) $
    fail "Extended key must hold a compressed public key"
  case importPubKey ctx bs of
    Nothing -> fail "Extended key holds an invalid public key"
    Just k -> return k

-- | A key at depth 0 is a master key. BIP32 requires its parent fingerprint
-- and child index to be zero; test vector 5 lists keys that break this rule
-- as invalid.
checkMasterFields :: (MonadGet m) => Word8 -> Fingerprint -> KeyIndex -> m ()
checkMasterFields depth parent index =
  when (depth == 0 && (parent /= Fingerprint 0 || index /= 0)) $
    fail "Extended key at depth 0 must have a zero parent fingerprint and index"

-- | Build a BIP32 compatible extended private key from a seed. This will
-- produce a root node (@depth=0@ and @parent=0@).
--
-- The seed must be 16 to 64 bytes long: BIP32 takes a seed "between 128 and
-- 512 bits", and Bitcoin Core refuses any other length. A shorter seed, such
-- as the empty string left by a failed read of entropy, would give a master
-- key that anyone can compute.
--
-- Throws 'DerivationException' for a seed of another length, and in the
-- vanishingly unlikely case that the seed gives a key outside the curve order,
-- which BIP32 declares invalid.
makeXPrvKey :: ByteString -> XPrvKey
makeXPrvKey bs
  | B.length bs < 16 || B.length bs > 64 =
      throw $
        DerivationException
          "Invalid seed: its length must be between 16 and 64 bytes"
  | otherwise = XPrvKey 0 (Fingerprint 0) 0 c k
  where
    (p, c) = split512 $ hmac512 "Bitcoin seed" bs
    k = fromMaybe err (decodeSecKey (runPutS (serialize p)))
    err = throw $ DerivationException "Invalid seed"

-- | Derive an extended public key from an extended private key. This function
-- will preserve the depth, parent, index and chaincode fields of the extended
-- private keys.
deriveXPubKey :: Ctx -> XPrvKey -> XPubKey
deriveXPubKey ctx (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey ctx k)

-- | Compute a private, soft child key derivation. A private soft derivation
-- will allow the equivalent extended public key to derive the public key for
-- this child. Given a parent key /m/ and a derivation index /i/, this function
-- will compute /m\/i/.
--
-- Soft derivations allow for more flexibility such as read-only wallets.
-- However, care must be taken not the leak both the parent extended public key
-- and one of the extended child private keys as this would compromise the
-- extended parent private key.
prvSubKey ::
  Ctx ->
  -- | extended parent private key
  XPrvKey ->
  -- | child derivation index
  KeyIndex ->
  -- | extended child private key
  XPrvKey
prvSubKey ctx xkey child = orThrow (tryPrvSubKey ctx xkey child)

-- | 'prvSubKey' with its failures as an error value.
tryPrvSubKey :: Ctx -> XPrvKey -> KeyIndex -> Either String XPrvKey
tryPrvSubKey ctx xkey child = do
  unless (child < 0x80000000) $ Left hardIndexError
  depth <- nextDepth xkey.depth
  k <-
    maybeToEither "Invalid prvSubKey derivation" $
      tweakSecKey ctx xkey.key a
  return $ XPrvKey depth (xPrvFP ctx xkey) child c k
  where
    pK = (deriveXPubKey ctx xkey).key
    m = B.append (exportPubKey ctx True pK) (runPutS (serialize child))
    (a, c) = split512 $ hmac512 (runPutS $ serialize xkey.chain) m

-- | Compute a public, soft child key derivation. Given a parent key /M/
-- and a derivation index /i/, this function will compute /M\/i/.
pubSubKey ::
  Ctx ->
  -- | extended parent public key
  XPubKey ->
  -- | child derivation index
  KeyIndex ->
  -- | extended child public key
  XPubKey
pubSubKey ctx xKey child = orThrow (tryPubSubKey ctx xKey child)

-- | 'pubSubKey' with its failures as an error value.
tryPubSubKey :: Ctx -> XPubKey -> KeyIndex -> Either String XPubKey
tryPubSubKey ctx xKey child = do
  unless (child < 0x80000000) $ Left hardIndexError
  depth <- nextDepth xKey.depth
  pK <-
    maybeToEither "Invalid pubSubKey derivation" $
      tweakPubKey ctx xKey.key a
  return $ XPubKey depth (xPubFP ctx xKey) child c pK
  where
    m = B.append (exportPubKey ctx True xKey.key) (runPutS $ serialize child)
    (a, c) = split512 $ hmac512 (runPutS $ serialize xKey.chain) m

-- | Compute a hard child key derivation. Hard derivations can only be computed
-- for private keys. Hard derivations do not allow the parent public key to
-- derive the child public keys. However, they are safer as a breach of the
-- parent public key and child private keys does not lead to a breach of the
-- parent private key. Given a parent key /m/ and a derivation index /i/, this
-- function will compute /m\/i'/.
hardSubKey ::
  Ctx ->
  -- | extended parent private key
  XPrvKey ->
  -- | child derivation index
  KeyIndex ->
  -- | extended child private key
  XPrvKey
hardSubKey ctx xkey child = orThrow (tryHardSubKey ctx xkey child)

-- | 'hardSubKey' with its failures as an error value.
tryHardSubKey :: Ctx -> XPrvKey -> KeyIndex -> Either String XPrvKey
tryHardSubKey ctx xkey child = do
  unless (child < 0x80000000) $ Left hardIndexError
  depth <- nextDepth xkey.depth
  k <-
    maybeToEither "Invalid hardSubKey derivation" $
      tweakSecKey ctx xkey.key a
  return $ XPrvKey depth (xPrvFP ctx xkey) i c k
  where
    i = setBit child 31
    m = B.append (bsPadPrvKey xkey.key) (runPutS $ serialize i)
    (a, c) = split512 $ hmac512 (runPutS $ serialize xkey.chain) m

-- | Turn the failure of a derivation into a 'DerivationException'. Every
-- failure of a derivation function that does not return 'Either' throws that
-- exception, so that a caller can catch them all at once.
orThrow :: Either String a -> a
orThrow = either (throw . DerivationException) id

-- | The error for a child index with the hard bit set. The derivation
-- functions take the index without the bit, below 2^31, and 'hardSubKey'
-- sets the bit itself.
hardIndexError :: String
hardIndexError = "Invalid child derivation index"

-- | The error for a derivation below depth 255.
depthError :: String
depthError = "Maximum derivation depth exceeded"

-- | Depth of a child key. BIP32 stores the depth in one byte, so a key at
-- depth 255 can have no children. Bitcoin Core refuses to derive one
-- (@CExtKey::Derive@ and @CExtPubKey::Derive@ return false), and so does this
-- library.
nextDepth :: Word8 -> Either String Word8
nextDepth 255 = Left depthError
nextDepth d = Right (d + 1)

-- | Returns true if the extended private key was derived through a hard
-- derivation.
xPrvIsHard :: XPrvKey -> Bool
xPrvIsHard k = testBit k.index 31

-- | Returns true if the extended public key was derived through a hard
-- derivation.
xPubIsHard :: XPubKey -> Bool
xPubIsHard k = testBit k.index 31

-- | Returns the derivation index of this extended private key without the hard
-- bit set.
xPrvChild :: XPrvKey -> KeyIndex
xPrvChild k = clearBit k.index 31

-- | Returns the derivation index of this extended public key without the hard
-- bit set.
xPubChild :: XPubKey -> KeyIndex
xPubChild k = clearBit k.index 31

-- | Computes the key identifier of an extended private key.
xPrvID :: Ctx -> XPrvKey -> Hash160
xPrvID ctx = xPubID ctx . deriveXPubKey ctx

-- | Computes the key identifier of an extended public key.
xPubID :: Ctx -> XPubKey -> Hash160
xPubID ctx =
  ripemd160
    . runPutS
    . serialize
    . sha256
    . exportPubKey ctx True
    . (.key)

-- | Computes the key fingerprint of an extended private key.
xPrvFP :: Ctx -> XPrvKey -> Fingerprint
xPrvFP ctx =
  fromRight err
    . runGetS deserialize
    . B.take 4
    . runPutS
    . serialize
    . xPrvID ctx
  where
    err = error "Could not decode xPrvFP"

-- | Computes the key fingerprint of an extended public key.
xPubFP :: Ctx -> XPubKey -> Fingerprint
xPubFP ctx =
  fromRight err
    . runGetS deserialize
    . B.take 4
    . runPutS
    . serialize
    . xPubID ctx
  where
    err = error "Could not decode xPubFP"

-- | Compute a standard P2PKH address for an extended public key.
xPubAddr :: Ctx -> XPubKey -> Address
xPubAddr ctx xkey = pubKeyAddr ctx (wrapPubKey True xkey.key)

-- | Compute a SegWit P2WPKH address for an extended public key. Extended
-- public keys are always compressed, so the address always exists.
xPubWitnessAddr :: Ctx -> XPubKey -> Address
xPubWitnessAddr ctx xkey = p2wpkhAddr (xPubKeyHash ctx xkey)

-- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended
-- public key. Extended public keys are always compressed, so the address
-- always exists.
xPubCompatWitnessAddr :: Ctx -> XPubKey -> Address
xPubCompatWitnessAddr ctx xkey =
  p2shP2wpkhAddr (xPubKeyHash ctx xkey)

-- | HASH160 of the compressed public key of an extended public key.
xPubKeyHash :: Ctx -> XPubKey -> Hash160
xPubKeyHash ctx xkey = addressHash (marshal ctx (wrapPubKey True xkey.key))

-- | Exports an extended private key to the BIP32 key export format ('Base58').
xPrvExport :: Network -> XPrvKey -> Base58
xPrvExport net = encodeBase58Check . marshal net

-- | Exports an extended public key to the BIP32 key export format ('Base58').
xPubExport :: Network -> Ctx -> XPubKey -> Base58
xPubExport net ctx = encodeBase58Check . marshal (net, ctx)

-- | Decodes a BIP32 encoded extended private key. This function will fail if
-- invalid base 58 characters are detected, if the checksum fails, if the
-- payload is not exactly 78 bytes, or if the key fails the checks of BIP32.
xPrvImport :: Network -> Base58 -> Maybe XPrvKey
xPrvImport net =
  eitherToMaybe . unmarshal net <=< decodeExtendedKey

-- | Decodes a BIP32 encoded extended public key. This function will fail if
-- invalid base 58 characters are detected, if the checksum fails, if the
-- payload is not exactly 78 bytes, or if the key fails the checks of BIP32.
xPubImport :: Network -> Ctx -> Base58 -> Maybe XPubKey
xPubImport net ctx =
  eitherToMaybe . unmarshal (net, ctx) <=< decodeExtendedKey

-- | Size in bytes of a serialized extended key, without its checksum.
extendedKeySize :: Int
extendedKeySize = 78

-- | Longest Base58 string an extended key can take. The 82 bytes of key and
-- checksum never need more than 112 digits because 58^112 is larger than
-- 256^82. Longer strings are rejected before decoding, since the time to decode
-- Base58 grows with the square of the length.
maxExtendedKeyLength :: Int
maxExtendedKeyLength = 112

-- | Decode the Base58Check form of an extended key into its 78 bytes. A payload
-- of another size is refused, as Bitcoin Core does, so that trailing bytes or
-- an uncompressed public key cannot slip through.
decodeExtendedKey :: Base58 -> Maybe ByteString
decodeExtendedKey t = do
  guard (Text.length t <= maxExtendedKeyLength)
  bs <- decodeBase58Check t
  guard (B.length bs == extendedKeySize)
  return bs

-- | Export an extended private key to WIF (Wallet Import Format).
xPrvWif :: Network -> XPrvKey -> Base58
xPrvWif net xkey = toWif net (wrapSecKey True xkey.key)

{- Derivation helpers -}

-- | Cyclic list of all private soft child key derivations of a parent key
-- starting from an offset index.
prvSubKeys :: Ctx -> XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)]
prvSubKeys ctx k = map (\i -> (prvSubKey ctx k i, i)) . cycleIndex

-- | Cyclic list of all public soft child key derivations of a parent key
-- starting from an offset index.
pubSubKeys :: Ctx -> XPubKey -> KeyIndex -> [(XPubKey, KeyIndex)]
pubSubKeys ctx k = map (\i -> (pubSubKey ctx k i, i)) . cycleIndex

-- | Cyclic list of all hard child key derivations of a parent key starting
-- from an offset index.
hardSubKeys :: Ctx -> XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)]
hardSubKeys ctx k = map (\i -> (hardSubKey ctx k i, i)) . cycleIndex

-- | Derive a standard address from an extended public key and an index.
deriveAddr :: Ctx -> XPubKey -> KeyIndex -> (Address, PubKey)
deriveAddr ctx k i =
  (xPubAddr ctx key, key.key)
  where
    key = pubSubKey ctx k i

-- | Derive a SegWit P2WPKH address from an extended public key and an index.
deriveWitnessAddr :: Ctx -> XPubKey -> KeyIndex -> (Address, PubKey)
deriveWitnessAddr ctx k i =
  (xPubWitnessAddr ctx key, key.key)
  where
    key = pubSubKey ctx k i

-- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended
-- public key and an index.
deriveCompatWitnessAddr :: Ctx -> XPubKey -> KeyIndex -> (Address, PubKey)
deriveCompatWitnessAddr ctx k i =
  (xPubCompatWitnessAddr ctx key, key.key)
  where
    key = pubSubKey ctx k i

-- | Cyclic list of all addresses derived from a public key starting from an
-- offset index.
deriveAddrs :: Ctx -> XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)]
deriveAddrs ctx k =
  map f . cycleIndex
  where
    f i = let (a, key) = deriveAddr ctx k i in (a, key, i)

-- | Cyclic list of all SegWit P2WPKH addresses derived from a public key
-- starting from an offset index.
deriveWitnessAddrs ::
  Ctx -> XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)]
deriveWitnessAddrs ctx k =
  map f . cycleIndex
  where
    f i = let (a, key) = deriveWitnessAddr ctx k i in (a, key, i)

-- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses
-- derived from a public key starting from an offset index.
deriveCompatWitnessAddrs ::
  Ctx -> XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)]
deriveCompatWitnessAddrs ctx k =
  map f . cycleIndex
  where
    f i = let (a, key) = deriveCompatWitnessAddr ctx k i in (a, key, i)

-- | Derive a pay-to-script-hash multisig address from a list of public keys,
-- the number of required signatures /m/ and a derivation index. The
-- derivation type is a public, soft derivation, and the keys of the redeem
-- script are sorted as BIP 67 defines.
--
-- Fails when /m/ is not between 1 and the number of keys, and when there are
-- more than 15 keys. The redeem script of 16 compressed keys is 547 bytes
-- (3 + 16 × 34), and a pay-to-script-hash redeem script can have at most 520
-- ('maxRedeemScriptSize'), so coins sent to such an address could never be
-- spent. For 16 to 20 keys, build a pay-to-witness-script-hash address from
-- the redeem script with 'payToWitnessScriptAddress'.
deriveMSAddr ::
  Ctx -> [XPubKey] -> Int -> KeyIndex -> Either String (Address, RedeemScript)
deriveMSAddr ctx keys m i = do
  addr <- payToScriptAddress ctx rdm
  return (addr, rdm)
  where
    rdm = sortMulSig ctx $ PayMulSig k m
    k = map (wrapPubKey True . (.key) . flip (pubSubKey ctx) i) keys

-- | Cyclic list of all multisig addresses derived from a list of public keys,
-- a number of required signatures /m/ and starting from an offset index. The
-- derivation type is a public, soft derivation. Fails as 'deriveMSAddr' does.
deriveMSAddrs ::
  Ctx ->
  [XPubKey] ->
  Int ->
  KeyIndex ->
  Either String [(Address, RedeemScript, KeyIndex)]
deriveMSAddrs ctx keys m start = do
  -- Whether an address can be made depends on the number of keys and on m,
  -- not on the index. One check therefore covers the whole list, which stays
  -- lazy and endless.
  _ <- deriveMSAddr ctx keys m start
  return
    [ (a, rdm, i)
      | i <- cycleIndex start,
        Right (a, rdm) <- [deriveMSAddr ctx keys m i]
    ]

-- | Helper function to go through derivation indices. Throws
-- 'DerivationException' for an index with the hard bit set.
cycleIndex :: KeyIndex -> [KeyIndex]
cycleIndex i
  | i == 0 = cycle [0 .. 0x7fffffff]
  | i < 0x80000000 = cycle $ [i .. 0x7fffffff] ++ [0 .. (i - 1)]
  | otherwise = throw $ DerivationException $ "cycleIndex: invalid index " ++ show i

{- Derivation Paths -}

-- | Phantom type signaling a hardened derivation path that can only be computed
-- from private extended key.
data HardDeriv deriving (Generic, NFData)

-- | Phantom type signaling no knowledge about derivation path: can be hardened or not.
data AnyDeriv deriving (Generic, NFData)

-- | Phantom type signaling derivation path including only non-hardened paths
-- that can be computed from an extended public key.
data SoftDeriv deriving (Generic, NFData)

-- | Hardened derivation path. Can be computed from extended private key only.
type HardPath = DerivPathI HardDeriv

-- | Any derivation path.
type DerivPath = DerivPathI AnyDeriv

-- | Non-hardened derivation path can be computed from extended public key.
type SoftPath = DerivPathI SoftDeriv

-- | Helper class to perform validations on a hardened derivation path.
class HardOrAny a

instance HardOrAny HardDeriv

instance HardOrAny AnyDeriv

-- | Helper class to perform validations on a non-hardened derivation path.
class AnyOrSoft a

instance AnyOrSoft AnyDeriv

instance AnyOrSoft SoftDeriv

-- | Data type representing a derivation path. Two constructors are provided
-- for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be
-- expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type
-- classes are used to constrain the valid values for the phantom type /t/. If
-- you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'.
-- Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv'
-- if you only have soft derivations.
--
-- Using this type is as easy as writing the required derivation like in these
-- example:
--
-- > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath
-- > Deriv :| 0 :| 1 :| 2 :: HardPath
-- > Deriv :| 0 :/ 1 :/ 2 :: DerivPath
--
-- The index of a step is below 2^31, for a hardened step as well: '(:|)'
-- stands for the hard bit. Building a step with a larger index throws
-- 'DerivationException'. A path can therefore not hold an index that its
-- text and binary forms cannot write.
data DerivPathI t where
  HardStep :: (HardOrAny t) => !(DerivPathI t) -> !KeyIndex -> DerivPathI t
  SoftStep :: (AnyOrSoft t) => !(DerivPathI t) -> !KeyIndex -> DerivPathI t
  Deriv :: DerivPathI t

-- | A hardened step. The index is given without the hard bit.
pattern (:|) :: () => (HardOrAny t) => DerivPathI t -> KeyIndex -> DerivPathI t
pattern next :| i <- HardStep next i
  where
    next :| i = HardStep next (checkedIndex i)

-- | A soft step.
pattern (:/) :: () => (AnyOrSoft t) => DerivPathI t -> KeyIndex -> DerivPathI t
pattern next :/ i <- SoftStep next i
  where
    next :/ i = SoftStep next (checkedIndex i)

{-# COMPLETE (:|), (:/), Deriv #-}

-- | The index of a path step, which must be below 2^31.
checkedIndex :: KeyIndex -> KeyIndex
checkedIndex i
  | i < 0x80000000 = i
  | otherwise = throw (DerivationException hardIndexError)

instance NFData (DerivPathI t) where
  rnf (a :| b) = rnf a `seq` rnf b
  rnf (a :/ b) = rnf a `seq` rnf b
  rnf 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 Ord (DerivPathI t) where
  -- Same hardness on each side
  (nextA :| iA) `compare` (nextB :| iB) =
    if nextA == nextB then iA `compare` iB else nextA `compare` nextB
  (nextA :/ iA) `compare` (nextB :/ iB) =
    if nextA == nextB then iA `compare` iB else nextA `compare` nextB
  -- Different hardness: a soft path sorts before a hard one, as it does when
  -- comparing the index lists of 'pathToList', where the hard bit is set.
  (nextA :/ _iA) `compare` (nextB :| _iB) =
    if nextA == nextB then LT else nextA `compare` nextB
  (nextA :| _iA) `compare` (nextB :/ _iB) =
    if nextA == nextB then GT else nextA `compare` nextB
  Deriv `compare` Deriv = EQ
  Deriv `compare` _ = LT
  _ `compare` Deriv = GT

instance Serial DerivPath where
  deserialize = listToPath <$> getList getWord32be
  serialize = putList putWord32be . pathToList

instance Serialize DerivPath where
  put = serialize
  get = deserialize

instance Binary DerivPath where
  put = serialize
  get = deserialize

instance Serial HardPath where
  deserialize =
    maybe
      (fail "Could not decode hard path")
      return
      . toHard
      . listToPath
      =<< getList getWord32be
  serialize = putList putWord32be . pathToList

instance Serialize HardPath where
  put = serialize
  get = deserialize

instance Binary HardPath where
  put = serialize
  get = deserialize

instance Serial SoftPath where
  deserialize =
    maybe
      (fail "Could not decode soft path")
      return
      . toSoft
      . listToPath
      =<< getList getWord32be
  serialize = putList putWord32be . pathToList

instance Serialize SoftPath where
  put = serialize
  get = deserialize

instance Binary SoftPath where
  put = serialize
  get = deserialize

-- | Get a list of derivation indices from a derivation path.
pathToList :: DerivPathI t -> [KeyIndex]
pathToList =
  reverse . go
  where
    go (next :| i) = setBit i 31 : go next
    go (next :/ i) = i : go next
    go _ = []

-- | Convert a list of derivation indices to a derivation path.
listToPath :: [KeyIndex] -> DerivPath
listToPath =
  go . reverse
  where
    go (i : is)
      | testBit i 31 = go is :| clearBit i 31
      | otherwise = go is :/ i
    go [] = Deriv

-- | Convert a derivation path to a human-readable string.
pathToStr :: DerivPathI t -> String
pathToStr p =
  case p of
    next :| i -> concat [pathToStr next, "/", show i, "'"]
    next :/ i -> concat [pathToStr next, "/", show i]
    Deriv -> ""

-- | Turn a derivation path into a hard derivation path. Will fail if the path
-- contains soft derivations.
toHard :: DerivPathI t -> Maybe HardPath
toHard p = case p of
  next :| i -> (:| i) <$> toHard next
  Deriv -> Just Deriv
  _ -> Nothing

-- | Turn a derivation path into a soft derivation path. Will fail if the path
-- has hard derivations.
toSoft :: DerivPathI t -> Maybe SoftPath
toSoft p = case p of
  next :/ i -> (:/ i) <$> toSoft next
  Deriv -> Just Deriv
  _ -> Nothing

-- | Make a derivation path generic.
toGeneric :: DerivPathI t -> DerivPath
toGeneric p = case p of
  next :/ i -> toGeneric next :/ i
  next :| i -> toGeneric next :| i
  Deriv -> Deriv

-- | Append two derivation paths together. The result will be a mixed
-- derivation path.
(++/) :: 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

-- | Derive a private key from a derivation path. Throws
-- 'DerivationException' when the path cannot be followed, for example when it
-- leads below depth 255. Use 'tryDerivePath' for a path that comes from
-- outside, such as the path of a PSBT record.
derivePath :: Ctx -> DerivPathI t -> XPrvKey -> XPrvKey
derivePath ctx path = orThrow . tryDerivePath ctx path

-- | Derive a public key from a soft derivation path. Throws
-- 'DerivationException' when the path cannot be followed. Use
-- 'tryDerivePubPath' for a path that comes from outside.
derivePubPath :: Ctx -> SoftPath -> XPubKey -> XPubKey
derivePubPath ctx path = orThrow . tryDerivePubPath ctx path

-- | Derive a private key from a derivation path, with an error value when the
-- path cannot be followed. BIP32 stores the depth of a key in one byte, so a
-- path that leads below depth 255 has no key. That is checked before any key
-- is derived, so a path that is far too long costs nothing.
tryDerivePath :: Ctx -> DerivPathI t -> XPrvKey -> Either String XPrvKey
tryDerivePath ctx path key = do
  checkPathDepth key.depth steps
  foldM step key steps
  where
    steps = pathSteps path
    step k (hard, i)
      | hard = tryHardSubKey ctx k i
      | otherwise = tryPrvSubKey ctx k i

-- | Derive a public key from a soft derivation path, with an error value when
-- the path cannot be followed. See 'tryDerivePath'.
tryDerivePubPath :: Ctx -> SoftPath -> XPubKey -> Either String XPubKey
tryDerivePubPath ctx path key = do
  checkPathDepth key.depth steps
  foldM (tryPubSubKey ctx) key (map snd steps)
  where
    steps = pathSteps path

-- | The steps of a path from the key down. Each step says whether it is
-- hardened, and gives its index without the hard bit.
pathSteps :: DerivPathI t -> [(Bool, KeyIndex)]
pathSteps =
  reverse . go
  where
    go (next :| i) = (True, i) : go next
    go (next :/ i) = (False, i) : go next
    go Deriv = []

-- | Fail when a key at this depth has no descendant that many steps below.
checkPathDepth :: Word8 -> [a] -> Either String ()
checkPathDepth depth steps
  | length steps > 255 - fromIntegral depth = Left depthError
  | otherwise = Right ()

instance Show DerivPath where
  showsPrec d p =
    showParen (d > 10) $
      showString "DerivPath " . shows (pathToStr p)

instance Read DerivPath where
  readPrec = parens $ do
    Ident "DerivPath" <- lexP
    Read.String str <- lexP
    maybe pfail (return . (.get)) (parsePath str)

instance Show HardPath where
  showsPrec d p =
    showParen (d > 10) $
      showString "HardPath " . shows (pathToStr p)

instance Read HardPath where
  readPrec = parens $ do
    Ident "HardPath" <- lexP
    Read.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
    Ident "SoftPath" <- lexP
    Read.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 =
    (.get) . 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 p.get
    _ -> 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 = Aeson.String . cs . pathToStr
  toEncoding = string . pathToStr

instance ToJSON ParsedPath where
  toJSON (ParsedPrv p) = Aeson.String . cs . ("m" ++) . pathToStr $ p
  toJSON (ParsedPub p) = Aeson.String . cs . ("M" ++) . pathToStr $ p
  toJSON (ParsedEmpty p) = Aeson.String . cs . ("" ++) . pathToStr $ p
  toEncoding (ParsedPrv p) = text . cs . ("m" ++) . pathToStr $ p
  toEncoding (ParsedPub p) = text . cs . ("M" ++) . pathToStr $ p
  toEncoding (ParsedEmpty p) = text . cs . ("" ++) . pathToStr $ p

{- Parsing derivation paths of the form m/1/2'/3 or M/1/2'/3 -}

-- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or
-- /M\/1\/2'\/3/.
data ParsedPath
  = ParsedPrv {get :: !DerivPath}
  | ParsedPub {get :: !DerivPath}
  | ParsedEmpty {get :: !DerivPath}
  deriving (Eq, Generic, NFData)

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
    Ident "ParsedPath" <- lexP
    Read.String str <- lexP
    maybe pfail return $ parsePath str

-- | Parse derivation path string for extended key.
-- Forms: /m\/0'\/2/, /M\/2\/3\/4/.
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

-- | Concatenate derivation path indices into a derivation path.
concatBip32Segments :: [Bip32PathIndex] -> DerivPath
concatBip32Segments = foldl' appendBip32Segment Deriv

-- | Append an extra derivation path index element into an existing path.
appendBip32Segment :: DerivPath -> Bip32PathIndex -> DerivPath
appendBip32Segment d (Bip32SoftIndex i) = d :/ i
appendBip32Segment d (Bip32HardIndex i) = d :| i

-- | Parse a BIP32 derivation path index element from a string. The element is
-- a decimal number below 2^31, followed by @'@, @h@ or @H@ for a hardened
-- index. BIP32 itself writes a hardened index with a subscript H, as in
-- @m\/0H\/1@. Bitcoin Core and the descriptors of BIP380 take @'@ and @h@
-- only, so write one of those two for text that other software reads.
-- 'pathToStr' writes @'@. The number is read as an 'Integer' so that a value
-- too large for 32 bits cannot wrap around.
parseBip32PathIndex :: String -> Maybe Bip32PathIndex
parseBip32PathIndex segment =
  case span isDigit segment of
    ("", _) -> Nothing
    (digits, "") -> Bip32SoftIndex <$> parseIndex digits
    (digits, [marker])
      | marker `elem` hardMarkers -> Bip32HardIndex <$> parseIndex digits
    _ -> Nothing
  where
    hardMarkers = "'hH" :: String
    parseIndex digits = do
      let n = read digits :: Integer
      guard (is31Bit n)
      return (fromInteger n)

-- | Type for BIP32 path index element.
data Bip32PathIndex
  = Bip32HardIndex KeyIndex
  | Bip32SoftIndex KeyIndex
  deriving (Eq, Generic, NFData)

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
          Ident "Bip32HardIndex" <- lexP
          Number n <- lexP
          maybe pfail (fmap Bip32HardIndex . readIndex) (numberToInteger n)
      s =
        parens $ do
          Ident "Bip32SoftIndex" <- lexP
          Number n <- lexP
          maybe pfail (fmap Bip32SoftIndex . readIndex) (numberToInteger n)

-- | Read a derivation index that was lexed as a number, refusing values that
-- do not fit in 31 bits instead of wrapping them around.
readIndex :: Integer -> ReadPrec KeyIndex
readIndex i
  | is31Bit i = return (fromInteger i)
  | otherwise = pfail

-- | Test whether the number could be a valid BIP32 derivation index.
is31Bit :: (Integral a) => a -> Bool
is31Bit i = i >= 0 && i < 0x80000000

-- | Helper function to parse a hard path.
parseHard :: String -> Maybe HardPath
parseHard = toHard . (.get) <=< parsePath

-- | Helper function to parse a soft path.
parseSoft :: String -> Maybe SoftPath
parseSoft = toSoft . (.get) <=< parsePath

-- | Data type representing a private or public key with its respective network.
data XKey
  = XPrv
      { xprv :: !XPrvKey,
        net :: !Network
      }
  | XPub
      { xpub :: !XPubKey,
        net :: !Network
      }
  deriving (Show, Eq, Generic, NFData)

-- | Apply a parsed path to an extended key to derive the new key defined in the
-- path. If the path starts with /m/, a private key will be returned and if the
-- path starts with /M/, a public key will be returned. Private derivations on a
-- public key, public derivations with a hard segment, and a path that leads
-- below depth 255 return an error value. The function does not throw.
applyPath :: Ctx -> ParsedPath -> XKey -> Either String XKey
applyPath ctx path key =
  first ("applyPath: " <>) $
    case (path, key) of
      (ParsedPrv _, XPrv k n) -> (`XPrv` n) <$> derivePrv k
      (ParsedPrv _, XPub {}) -> Left "Invalid public key"
      (ParsedPub _, XPrv k n) -> (`XPub` n) . deriveXPubKey ctx <$> derivePrv k
      (ParsedPub _, XPub k n) -> (`XPub` n) <$> derivePub k
      -- For empty parsed paths, we take a hint from the provided key
      (ParsedEmpty _, XPrv k n) -> (`XPrv` n) <$> derivePrv k
      (ParsedEmpty _, XPub k n) -> (`XPub` n) <$> derivePub k
  where
    derivePrv = tryDerivePath ctx path.get
    derivePub k = do
      soft <- maybeToEither "Invalid hard derivation" (toSoft path.get)
      tryDerivePubPath ctx soft k

{- Helpers for derivation paths and addresses -}

-- | Derive an address from a given parent path.
derivePathAddr :: Ctx -> XPubKey -> SoftPath -> KeyIndex -> (Address, PubKey)
derivePathAddr ctx key path = deriveAddr ctx (derivePubPath ctx path key)

-- | Cyclic list of all addresses derived from a given parent path and starting
-- from the given offset index.
derivePathAddrs ::
  Ctx -> XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKey, KeyIndex)]
derivePathAddrs ctx key path = deriveAddrs ctx (derivePubPath ctx path key)

-- | Derive a multisig address from a given parent path. The number of required
-- signatures (m in m of n) is also needed. Fails as 'deriveMSAddr' does.
derivePathMSAddr ::
  Ctx ->
  [XPubKey] ->
  SoftPath ->
  Int ->
  KeyIndex ->
  Either String (Address, RedeemScript)
derivePathMSAddr ctx keys path =
  deriveMSAddr ctx $ map (derivePubPath ctx path) keys

-- | Cyclic list of all multisig addresses derived from a given parent path and
-- starting from the given offset index. The number of required signatures
-- (m in m of n) is also needed. Fails as 'deriveMSAddr' does.
derivePathMSAddrs ::
  Ctx ->
  [XPubKey] ->
  SoftPath ->
  Int ->
  KeyIndex ->
  Either String [(Address, RedeemScript, KeyIndex)]
derivePathMSAddrs ctx keys path =
  deriveMSAddrs ctx $ map (derivePubPath ctx path) keys

{- Utilities for extended keys -}

-- | De-serialize HDW-specific private key.
getPadPrvKey :: (MonadGet m) => m SecKey
getPadPrvKey = do
  pad <- getWord8
  unless (pad == 0x00) $ fail "Private key must be padded with 0x00"
  bs <- getByteString 32
  case decodeSecKey bs of
    Nothing -> fail "Secret key is zero or not below the curve order"
    Just x -> return x

-- | Serialize HDW-specific private key.
putPadPrvKey :: (MonadPut m) => SecKey -> m ()
putPadPrvKey p = putWord8 0x00 >> putByteString p.get

bsPadPrvKey :: SecKey -> ByteString
bsPadPrvKey = runPutS . putPadPrvKey