{-# LANGUAGE LambdaCase #-}

module Language.Bitcoin.Script.Descriptors.Syntax (
    OutputDescriptor (..),
    ScriptDescriptor (..),
    KeyDescriptor (..),
    isDefinite,
    keyAtIndex,
    keyDescPubKey,
    keyBytes,
    Origin (..),
    Key (..),
    KeyCollection (..),
    pubKey,
    secKey,
) where

import Data.ByteString (ByteString)
import Data.Word (Word32)
import Haskoin (
    Address,
    DerivPath,
    DerivPathI ((:/), (:|)),
    Fingerprint,
    PubKeyI (..),
    SecKeyI,
    XPubKey (xPubKey),
    derivePubKeyI,
    derivePubPath,
    exportPubKey,
    toSoft,
 )

-- | High level description for a bitcoin output
data OutputDescriptor
    = -- | The output is secured by the given script.
      ScriptPubKey ScriptDescriptor
    | -- | P2SH embed the argument.
      P2SH ScriptDescriptor
    | -- | P2WPKH output for the given compressed pubkey.
      P2WPKH KeyDescriptor
    | -- | P2WSH embed the argument.
      P2WSH ScriptDescriptor
    | -- | P2SH-P2WPKH the given compressed pubkey.
      WrappedWPkh KeyDescriptor
    | -- | P2SH-P2WSH the given script
      WrappedWSh ScriptDescriptor
    | -- | An alias for the collection of pk(KEY) and pkh(KEY). If the key is
      -- compressed, it also includes wpkh(KEY) and sh(wpkh(KEY)).
      Combo KeyDescriptor
    | -- | The script which ADDR expands to.
      Addr Address
    deriving (OutputDescriptor -> OutputDescriptor -> Bool
(OutputDescriptor -> OutputDescriptor -> Bool)
-> (OutputDescriptor -> OutputDescriptor -> Bool)
-> Eq OutputDescriptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputDescriptor -> OutputDescriptor -> Bool
$c/= :: OutputDescriptor -> OutputDescriptor -> Bool
== :: OutputDescriptor -> OutputDescriptor -> Bool
$c== :: OutputDescriptor -> OutputDescriptor -> Bool
Eq, Int -> OutputDescriptor -> ShowS
[OutputDescriptor] -> ShowS
OutputDescriptor -> String
(Int -> OutputDescriptor -> ShowS)
-> (OutputDescriptor -> String)
-> ([OutputDescriptor] -> ShowS)
-> Show OutputDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutputDescriptor] -> ShowS
$cshowList :: [OutputDescriptor] -> ShowS
show :: OutputDescriptor -> String
$cshow :: OutputDescriptor -> String
showsPrec :: Int -> OutputDescriptor -> ShowS
$cshowsPrec :: Int -> OutputDescriptor -> ShowS
Show)

-- | High level description of a bitcoin script
data ScriptDescriptor
    = -- | Require a signature for this key
      Pk KeyDescriptor
    | -- | Require a key matching this hash and a signature for that key
      Pkh KeyDescriptor
    | -- | k-of-n multisig script.
      Multi Int [KeyDescriptor]
    | -- | k-of-n multisig script with keys sorted lexicographically in the resulting script.
      SortedMulti Int [KeyDescriptor]
    | -- | the script whose hex encoding is HEX.
      Raw ByteString
    deriving (ScriptDescriptor -> ScriptDescriptor -> Bool
(ScriptDescriptor -> ScriptDescriptor -> Bool)
-> (ScriptDescriptor -> ScriptDescriptor -> Bool)
-> Eq ScriptDescriptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptDescriptor -> ScriptDescriptor -> Bool
$c/= :: ScriptDescriptor -> ScriptDescriptor -> Bool
== :: ScriptDescriptor -> ScriptDescriptor -> Bool
$c== :: ScriptDescriptor -> ScriptDescriptor -> Bool
Eq, Int -> ScriptDescriptor -> ShowS
[ScriptDescriptor] -> ShowS
ScriptDescriptor -> String
(Int -> ScriptDescriptor -> ShowS)
-> (ScriptDescriptor -> String)
-> ([ScriptDescriptor] -> ShowS)
-> Show ScriptDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptDescriptor] -> ShowS
$cshowList :: [ScriptDescriptor] -> ShowS
show :: ScriptDescriptor -> String
$cshow :: ScriptDescriptor -> String
showsPrec :: Int -> ScriptDescriptor -> ShowS
$cshowsPrec :: Int -> ScriptDescriptor -> ShowS
Show)

data KeyDescriptor = KeyDescriptor
    { KeyDescriptor -> Maybe Origin
origin :: Maybe Origin
    , KeyDescriptor -> Key
keyDef :: Key
    }
    deriving (KeyDescriptor -> KeyDescriptor -> Bool
(KeyDescriptor -> KeyDescriptor -> Bool)
-> (KeyDescriptor -> KeyDescriptor -> Bool) -> Eq KeyDescriptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyDescriptor -> KeyDescriptor -> Bool
$c/= :: KeyDescriptor -> KeyDescriptor -> Bool
== :: KeyDescriptor -> KeyDescriptor -> Bool
$c== :: KeyDescriptor -> KeyDescriptor -> Bool
Eq, Int -> KeyDescriptor -> ShowS
[KeyDescriptor] -> ShowS
KeyDescriptor -> String
(Int -> KeyDescriptor -> ShowS)
-> (KeyDescriptor -> String)
-> ([KeyDescriptor] -> ShowS)
-> Show KeyDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyDescriptor] -> ShowS
$cshowList :: [KeyDescriptor] -> ShowS
show :: KeyDescriptor -> String
$cshow :: KeyDescriptor -> String
showsPrec :: Int -> KeyDescriptor -> ShowS
$cshowsPrec :: Int -> KeyDescriptor -> ShowS
Show)

data Origin = Origin
    { Origin -> Fingerprint
fingerprint :: Fingerprint
    , Origin -> DerivPath
derivation :: DerivPath
    }
    deriving (Origin -> Origin -> Bool
(Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool) -> Eq Origin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Origin -> Origin -> Bool
$c/= :: Origin -> Origin -> Bool
== :: Origin -> Origin -> Bool
$c== :: Origin -> Origin -> Bool
Eq, Eq Origin
Eq Origin
-> (Origin -> Origin -> Ordering)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Origin)
-> (Origin -> Origin -> Origin)
-> Ord Origin
Origin -> Origin -> Bool
Origin -> Origin -> Ordering
Origin -> Origin -> Origin
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Origin -> Origin -> Origin
$cmin :: Origin -> Origin -> Origin
max :: Origin -> Origin -> Origin
$cmax :: Origin -> Origin -> Origin
>= :: Origin -> Origin -> Bool
$c>= :: Origin -> Origin -> Bool
> :: Origin -> Origin -> Bool
$c> :: Origin -> Origin -> Bool
<= :: Origin -> Origin -> Bool
$c<= :: Origin -> Origin -> Bool
< :: Origin -> Origin -> Bool
$c< :: Origin -> Origin -> Bool
compare :: Origin -> Origin -> Ordering
$ccompare :: Origin -> Origin -> Ordering
$cp1Ord :: Eq Origin
Ord, Int -> Origin -> ShowS
[Origin] -> ShowS
Origin -> String
(Int -> Origin -> ShowS)
-> (Origin -> String) -> ([Origin] -> ShowS) -> Show Origin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Origin] -> ShowS
$cshowList :: [Origin] -> ShowS
show :: Origin -> String
$cshow :: Origin -> String
showsPrec :: Int -> Origin -> ShowS
$cshowsPrec :: Int -> Origin -> ShowS
Show)

data Key
    = -- | DER-hex encoded secp256k1 public key
      Pubkey PubKeyI
    | -- | (de)serialized as WIF
      SecretKey SecKeyI
    | XPub XPubKey DerivPath KeyCollection
    deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show)

-- | Simple explicit public key with no origin information
pubKey :: PubKeyI -> KeyDescriptor
pubKey :: PubKeyI -> KeyDescriptor
pubKey = Maybe Origin -> Key -> KeyDescriptor
KeyDescriptor Maybe Origin
forall a. Maybe a
Nothing (Key -> KeyDescriptor)
-> (PubKeyI -> Key) -> PubKeyI -> KeyDescriptor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyI -> Key
Pubkey

-- | Simple explicit secret key with no origin information
secKey :: SecKeyI -> KeyDescriptor
secKey :: SecKeyI -> KeyDescriptor
secKey = Maybe Origin -> Key -> KeyDescriptor
KeyDescriptor Maybe Origin
forall a. Maybe a
Nothing (Key -> KeyDescriptor)
-> (SecKeyI -> Key) -> SecKeyI -> KeyDescriptor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecKeyI -> Key
SecretKey

-- | For key families, get the key at the given index.  Otherwise, return the input key.
keyAtIndex :: Word32 -> Key -> Key
keyAtIndex :: Fingerprint -> Key -> Key
keyAtIndex Fingerprint
ix = \case
    XPub XPubKey
xpub DerivPath
path KeyCollection
HardKeys -> XPubKey -> DerivPath -> KeyCollection -> Key
XPub XPubKey
xpub (DerivPath
path DerivPath -> Fingerprint -> DerivPath
forall t.
HardOrAny t =>
DerivPathI t -> Fingerprint -> DerivPathI t
:| Fingerprint
ix) KeyCollection
Single
    XPub XPubKey
xpub DerivPath
path KeyCollection
SoftKeys -> XPubKey -> DerivPath -> KeyCollection -> Key
XPub XPubKey
xpub (DerivPath
path DerivPath -> Fingerprint -> DerivPath
forall t.
AnyOrSoft t =>
DerivPathI t -> Fingerprint -> DerivPathI t
:/ Fingerprint
ix) KeyCollection
Single
    Key
key -> Key
key

-- | Represent whether the key corresponds to a collection (and how) or a single key.
data KeyCollection
    = Single
    | -- | immediate hardened children
      HardKeys
    | -- | immediate non-hardened children
      SoftKeys
    deriving (KeyCollection -> KeyCollection -> Bool
(KeyCollection -> KeyCollection -> Bool)
-> (KeyCollection -> KeyCollection -> Bool) -> Eq KeyCollection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyCollection -> KeyCollection -> Bool
$c/= :: KeyCollection -> KeyCollection -> Bool
== :: KeyCollection -> KeyCollection -> Bool
$c== :: KeyCollection -> KeyCollection -> Bool
Eq, Eq KeyCollection
Eq KeyCollection
-> (KeyCollection -> KeyCollection -> Ordering)
-> (KeyCollection -> KeyCollection -> Bool)
-> (KeyCollection -> KeyCollection -> Bool)
-> (KeyCollection -> KeyCollection -> Bool)
-> (KeyCollection -> KeyCollection -> Bool)
-> (KeyCollection -> KeyCollection -> KeyCollection)
-> (KeyCollection -> KeyCollection -> KeyCollection)
-> Ord KeyCollection
KeyCollection -> KeyCollection -> Bool
KeyCollection -> KeyCollection -> Ordering
KeyCollection -> KeyCollection -> KeyCollection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KeyCollection -> KeyCollection -> KeyCollection
$cmin :: KeyCollection -> KeyCollection -> KeyCollection
max :: KeyCollection -> KeyCollection -> KeyCollection
$cmax :: KeyCollection -> KeyCollection -> KeyCollection
>= :: KeyCollection -> KeyCollection -> Bool
$c>= :: KeyCollection -> KeyCollection -> Bool
> :: KeyCollection -> KeyCollection -> Bool
$c> :: KeyCollection -> KeyCollection -> Bool
<= :: KeyCollection -> KeyCollection -> Bool
$c<= :: KeyCollection -> KeyCollection -> Bool
< :: KeyCollection -> KeyCollection -> Bool
$c< :: KeyCollection -> KeyCollection -> Bool
compare :: KeyCollection -> KeyCollection -> Ordering
$ccompare :: KeyCollection -> KeyCollection -> Ordering
$cp1Ord :: Eq KeyCollection
Ord, Int -> KeyCollection -> ShowS
[KeyCollection] -> ShowS
KeyCollection -> String
(Int -> KeyCollection -> ShowS)
-> (KeyCollection -> String)
-> ([KeyCollection] -> ShowS)
-> Show KeyCollection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyCollection] -> ShowS
$cshowList :: [KeyCollection] -> ShowS
show :: KeyCollection -> String
$cshow :: KeyCollection -> String
showsPrec :: Int -> KeyCollection -> ShowS
$cshowsPrec :: Int -> KeyCollection -> ShowS
Show)

-- | Produce a key literal if possible
keyBytes :: KeyDescriptor -> Maybe ByteString
keyBytes :: KeyDescriptor -> Maybe ByteString
keyBytes = (PubKeyI -> ByteString) -> Maybe PubKeyI -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PubKeyI -> ByteString
toBytes (Maybe PubKeyI -> Maybe ByteString)
-> (KeyDescriptor -> Maybe PubKeyI)
-> KeyDescriptor
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyDescriptor -> Maybe PubKeyI
keyDescPubKey
  where
    toBytes :: PubKeyI -> ByteString
toBytes (PubKeyI PubKey
pk Bool
c) = Bool -> PubKey -> ByteString
exportPubKey Bool
c PubKey
pk

-- | Produce a pubkey if possible
keyDescPubKey :: KeyDescriptor -> Maybe PubKeyI
keyDescPubKey :: KeyDescriptor -> Maybe PubKeyI
keyDescPubKey (KeyDescriptor Maybe Origin
_ Key
k) = case Key
k of
    Pubkey PubKeyI
pk -> PubKeyI -> Maybe PubKeyI
forall a. a -> Maybe a
Just PubKeyI
pk
    SecretKey SecKeyI
sk -> PubKeyI -> Maybe PubKeyI
forall a. a -> Maybe a
Just (PubKeyI -> Maybe PubKeyI) -> PubKeyI -> Maybe PubKeyI
forall a b. (a -> b) -> a -> b
$ SecKeyI -> PubKeyI
derivePubKeyI SecKeyI
sk
    XPub XPubKey
xpub DerivPath
path KeyCollection
Single -> (PubKey -> Bool -> PubKeyI
`PubKeyI` Bool
True) (PubKey -> PubKeyI) -> (SoftPath -> PubKey) -> SoftPath -> PubKeyI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPubKey -> PubKey
xPubKey (XPubKey -> PubKey) -> (SoftPath -> XPubKey) -> SoftPath -> PubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SoftPath -> XPubKey -> XPubKey
`derivePubPath` XPubKey
xpub) (SoftPath -> PubKeyI) -> Maybe SoftPath -> Maybe PubKeyI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DerivPath -> Maybe SoftPath
forall t. DerivPathI t -> Maybe SoftPath
toSoft DerivPath
path
    Key
_ -> Maybe PubKeyI
forall a. Maybe a
Nothing

-- | Test whether the key descriptor corresponds to a single key
isDefinite :: KeyDescriptor -> Bool
isDefinite :: KeyDescriptor -> Bool
isDefinite (KeyDescriptor Maybe Origin
_ Key
k) = case Key
k of
    XPub XPubKey
_ DerivPath
_ KeyCollection
HardKeys -> Bool
False
    XPub XPubKey
_ DerivPath
_ KeyCollection
SoftKeys -> Bool
False
    Key
_ -> Bool
True