{-# LANGUAGE OverloadedStrings #-}

module Language.Bitcoin.Script.Descriptors.Parser (
    parseDescriptor,
    descriptorParser,
    parseKeyDescriptor,
    keyDescriptorParser,
) where

import Control.Applicative (optional, (<|>))
import Data.Attoparsec.Text (Parser)
import qualified Data.Attoparsec.Text as A
import Data.Bool (bool)
import qualified Data.ByteString as BS
import Data.Maybe (isJust)
import Data.Text (Text, pack)
import Haskoin.Address (textToAddr)
import Haskoin.Constants (Network)
import Haskoin.Keys (
    DerivPath,
    DerivPathI (..),
    fromWif,
    importPubKey,
    wrapPubKey,
    xPubImport,
 )

import Language.Bitcoin.Script.Descriptors.Syntax
import Language.Bitcoin.Utils (
    alphanum,
    application,
    argList,
    brackets,
    comma,
    hex,
    maybeFail,
 )

parseDescriptor :: Network -> Text -> Either String ScriptDescriptor
parseDescriptor :: Network -> Text -> Either String ScriptDescriptor
parseDescriptor net :: Network
net = Parser ScriptDescriptor -> Text -> Either String ScriptDescriptor
forall a. Parser a -> Text -> Either String a
A.parseOnly (Parser ScriptDescriptor -> Text -> Either String ScriptDescriptor)
-> Parser ScriptDescriptor
-> Text
-> Either String ScriptDescriptor
forall a b. (a -> b) -> a -> b
$ Network -> Parser ScriptDescriptor
descriptorParser Network
net

descriptorParser :: Network -> Parser ScriptDescriptor
descriptorParser :: Network -> Parser ScriptDescriptor
descriptorParser net :: Network
net =
    Parser ScriptDescriptor
shP Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
wshP Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
pkP Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
pkhP Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
wpkhP Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
comboP Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
rawP Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
addrP
        Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
multiP
        Parser ScriptDescriptor
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
sortedMultiP
  where
    dp :: Parser ScriptDescriptor
dp = Network -> Parser ScriptDescriptor
descriptorParser Network
net
    kp :: Parser KeyDescriptor
kp = Network -> Parser KeyDescriptor
keyDescriptorParser Network
net

    shP :: Parser ScriptDescriptor
shP = ScriptDescriptor -> ScriptDescriptor
Sh (ScriptDescriptor -> ScriptDescriptor)
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall a. Text -> Parser a -> Parser a
application "sh" Parser ScriptDescriptor
dp
    wshP :: Parser ScriptDescriptor
wshP = ScriptDescriptor -> ScriptDescriptor
Wsh (ScriptDescriptor -> ScriptDescriptor)
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall a. Text -> Parser a -> Parser a
application "wsh" Parser ScriptDescriptor
dp
    pkP :: Parser ScriptDescriptor
pkP = KeyDescriptor -> ScriptDescriptor
Pk (KeyDescriptor -> ScriptDescriptor)
-> Parser KeyDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser KeyDescriptor -> Parser KeyDescriptor
forall a. Text -> Parser a -> Parser a
application "pk" Parser KeyDescriptor
kp
    pkhP :: Parser ScriptDescriptor
pkhP = KeyDescriptor -> ScriptDescriptor
Pkh (KeyDescriptor -> ScriptDescriptor)
-> Parser KeyDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser KeyDescriptor -> Parser KeyDescriptor
forall a. Text -> Parser a -> Parser a
application "pkh" Parser KeyDescriptor
kp
    wpkhP :: Parser ScriptDescriptor
wpkhP = KeyDescriptor -> ScriptDescriptor
Wpkh (KeyDescriptor -> ScriptDescriptor)
-> Parser KeyDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser KeyDescriptor -> Parser KeyDescriptor
forall a. Text -> Parser a -> Parser a
application "wpkh" Parser KeyDescriptor
kp
    comboP :: Parser ScriptDescriptor
comboP = KeyDescriptor -> ScriptDescriptor
Combo (KeyDescriptor -> ScriptDescriptor)
-> Parser KeyDescriptor -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser KeyDescriptor -> Parser KeyDescriptor
forall a. Text -> Parser a -> Parser a
application "combo" Parser KeyDescriptor
kp
    rawP :: Parser ScriptDescriptor
rawP = ByteString -> ScriptDescriptor
Raw (ByteString -> ScriptDescriptor)
-> Parser Text ByteString -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text ByteString -> Parser Text ByteString
forall a. Text -> Parser a -> Parser a
application "raw" Parser Text ByteString
hex

    addrP :: Parser ScriptDescriptor
addrP =
        Text -> Parser String -> Parser String
forall a. Text -> Parser a -> Parser a
application "addr" (Parser Text Char -> Parser Text Char -> Parser String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
A.manyTill Parser Text Char
A.anyChar (Parser Text Char -> Parser String)
-> Parser Text Char -> Parser String
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
A.char ')')
            Parser String
-> (String -> Parser ScriptDescriptor) -> Parser ScriptDescriptor
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> (Address -> ScriptDescriptor)
-> Maybe Address
-> Parser ScriptDescriptor
forall a b. String -> (a -> b) -> Maybe a -> Parser b
maybeFail "descriptorParser: unable to parse address" Address -> ScriptDescriptor
Addr (Maybe Address -> Parser ScriptDescriptor)
-> (String -> Maybe Address) -> String -> Parser ScriptDescriptor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> Text -> Maybe Address
textToAddr Network
net (Text -> Maybe Address)
-> (String -> Text) -> String -> Maybe Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack

    multiP :: Parser ScriptDescriptor
multiP = Text -> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall a. Text -> Parser a -> Parser a
application "multi" (Parser ScriptDescriptor -> Parser ScriptDescriptor)
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall a b. (a -> b) -> a -> b
$ Int -> [KeyDescriptor] -> ScriptDescriptor
Multi (Int -> [KeyDescriptor] -> ScriptDescriptor)
-> Parser Text Int
-> Parser Text ([KeyDescriptor] -> ScriptDescriptor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
forall a. Integral a => Parser a
A.decimal Parser Text ([KeyDescriptor] -> ScriptDescriptor)
-> Parser Text [KeyDescriptor] -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text [KeyDescriptor] -> Parser Text [KeyDescriptor]
forall a. Parser a -> Parser a
comma Parser Text [KeyDescriptor]
keyList
    sortedMultiP :: Parser ScriptDescriptor
sortedMultiP = Text -> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall a. Text -> Parser a -> Parser a
application "sortedmulti" (Parser ScriptDescriptor -> Parser ScriptDescriptor)
-> Parser ScriptDescriptor -> Parser ScriptDescriptor
forall a b. (a -> b) -> a -> b
$ Int -> [KeyDescriptor] -> ScriptDescriptor
SortedMulti (Int -> [KeyDescriptor] -> ScriptDescriptor)
-> Parser Text Int
-> Parser Text ([KeyDescriptor] -> ScriptDescriptor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
forall a. Integral a => Parser a
A.decimal Parser Text ([KeyDescriptor] -> ScriptDescriptor)
-> Parser Text [KeyDescriptor] -> Parser ScriptDescriptor
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text [KeyDescriptor] -> Parser Text [KeyDescriptor]
forall a. Parser a -> Parser a
comma Parser Text [KeyDescriptor]
keyList

    keyList :: Parser Text [KeyDescriptor]
keyList = Parser KeyDescriptor -> Parser Text [KeyDescriptor]
forall a. Parser a -> Parser [a]
argList Parser KeyDescriptor
kp

parseKeyDescriptor :: Network -> Text -> Either String KeyDescriptor
parseKeyDescriptor :: Network -> Text -> Either String KeyDescriptor
parseKeyDescriptor net :: Network
net = Parser KeyDescriptor -> Text -> Either String KeyDescriptor
forall a. Parser a -> Text -> Either String a
A.parseOnly (Parser KeyDescriptor -> Text -> Either String KeyDescriptor)
-> Parser KeyDescriptor -> Text -> Either String KeyDescriptor
forall a b. (a -> b) -> a -> b
$ Network -> Parser KeyDescriptor
keyDescriptorParser Network
net

keyDescriptorParser :: Network -> Parser KeyDescriptor
keyDescriptorParser :: Network -> Parser KeyDescriptor
keyDescriptorParser net :: Network
net = Maybe Origin -> Key -> KeyDescriptor
KeyDescriptor (Maybe Origin -> Key -> KeyDescriptor)
-> Parser Text (Maybe Origin) -> Parser Text (Key -> KeyDescriptor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Maybe Origin)
originP Parser Text (Key -> KeyDescriptor)
-> Parser Text Key -> Parser KeyDescriptor
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Key
keyP
  where
    originP :: Parser Text (Maybe Origin)
originP = Parser Text Origin -> Parser Text (Maybe Origin)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text Origin -> Parser Text (Maybe Origin))
-> (Parser Text Origin -> Parser Text Origin)
-> Parser Text Origin
-> Parser Text (Maybe Origin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Text Origin -> Parser Text Origin
forall a. Parser a -> Parser a
brackets (Parser Text Origin -> Parser Text (Maybe Origin))
-> Parser Text Origin -> Parser Text (Maybe Origin)
forall a b. (a -> b) -> a -> b
$ Fingerprint -> DerivPath -> Origin
Origin (Fingerprint -> DerivPath -> Origin)
-> Parser Text Fingerprint -> Parser Text (DerivPath -> Origin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Fingerprint
forall a. (Integral a, Bits a) => Parser a
A.hexadecimal Parser Text (DerivPath -> Origin)
-> Parser Text DerivPath -> Parser Text Origin
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text DerivPath
pathP

    keyP :: Parser Text Key
keyP = Parser Text Key
pubP Parser Text Key -> Parser Text Key -> Parser Text Key
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Key
wifP Parser Text Key -> Parser Text Key -> Parser Text Key
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> XPubKey -> DerivPath -> KeyCollection -> Key
XPub (XPubKey -> DerivPath -> KeyCollection -> Key)
-> Parser Text XPubKey
-> Parser Text (DerivPath -> KeyCollection -> Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text XPubKey
xpubP Parser Text (DerivPath -> KeyCollection -> Key)
-> Parser Text DerivPath -> Parser Text (KeyCollection -> Key)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text DerivPath
pathP Parser Text (KeyCollection -> Key)
-> Parser Text KeyCollection -> Parser Text Key
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text KeyCollection
famP

    pubP :: Parser Text Key
pubP = do
        ByteString
bs <- Parser Text ByteString
hex
        String -> (PubKey -> Key) -> Maybe PubKey -> Parser Text Key
forall a b. String -> (a -> b) -> Maybe a -> Parser b
maybeFail "Unable to parse pubkey" (ByteString -> PubKey -> Key
toPubKey ByteString
bs) (Maybe PubKey -> Parser Text Key)
-> Maybe PubKey -> Parser Text Key
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe PubKey
importPubKey ByteString
bs

    toPubKey :: ByteString -> PubKey -> Key
toPubKey bs :: ByteString
bs = PubKeyI -> Key
Pubkey (PubKeyI -> Key) -> (PubKey -> PubKeyI) -> PubKey -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PubKey -> PubKeyI
wrapPubKey (ByteString -> Bool
isCompressed ByteString
bs)
    isCompressed :: ByteString -> Bool
isCompressed bs :: ByteString
bs = ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 33

    wifP :: Parser Text Key
wifP = Parser Text Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many1' Parser Text Char
alphanum Parser String -> (String -> Parser Text Key) -> Parser Text Key
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> (SecKeyI -> Key) -> Maybe SecKeyI -> Parser Text Key
forall a b. String -> (a -> b) -> Maybe a -> Parser b
maybeFail "Unable to parse WIF secret key" SecKeyI -> Key
SecretKey (Maybe SecKeyI -> Parser Text Key)
-> (String -> Maybe SecKeyI) -> String -> Parser Text Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> Text -> Maybe SecKeyI
fromWif Network
net (Text -> Maybe SecKeyI)
-> (String -> Text) -> String -> Maybe SecKeyI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
    xpubP :: Parser Text XPubKey
xpubP = Parser Text Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many1' Parser Text Char
alphanum Parser String
-> (String -> Parser Text XPubKey) -> Parser Text XPubKey
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> (XPubKey -> XPubKey) -> Maybe XPubKey -> Parser Text XPubKey
forall a b. String -> (a -> b) -> Maybe a -> Parser b
maybeFail "Unable to parse xpub" XPubKey -> XPubKey
forall a. a -> a
id (Maybe XPubKey -> Parser Text XPubKey)
-> (String -> Maybe XPubKey) -> String -> Parser Text XPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> Text -> Maybe XPubKey
xPubImport Network
net (Text -> Maybe XPubKey)
-> (String -> Text) -> String -> Maybe XPubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack

    famP :: Parser Text KeyCollection
famP = (KeyCollection
HardKeys KeyCollection -> Parser Text Text -> Parser Text KeyCollection
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text Text
A.string "/*'") Parser Text KeyCollection
-> Parser Text KeyCollection -> Parser Text KeyCollection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (KeyCollection
SoftKeys KeyCollection -> Parser Text Text -> Parser Text KeyCollection
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text Text
A.string "/*") Parser Text KeyCollection
-> Parser Text KeyCollection -> Parser Text KeyCollection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> KeyCollection -> Parser Text KeyCollection
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyCollection
Single

pathP :: Parser DerivPath
pathP :: Parser Text DerivPath
pathP = DerivPath -> Parser Text DerivPath
forall t.
(AnyOrSoft t, HardOrAny t) =>
DerivPathI t -> Parser Text (DerivPathI t)
go DerivPath
forall t. DerivPathI t
Deriv
  where
    go :: DerivPathI t -> Parser Text (DerivPathI t)
go d :: DerivPathI t
d = Parser Text (DerivPathI t)
-> (DerivPathI t -> Parser Text (DerivPathI t))
-> Maybe (DerivPathI t)
-> Parser Text (DerivPathI t)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DerivPathI t -> Parser Text (DerivPathI t)
forall (m :: * -> *) a. Monad m => a -> m a
return DerivPathI t
d) DerivPathI t -> Parser Text (DerivPathI t)
go (Maybe (DerivPathI t) -> Parser Text (DerivPathI t))
-> Parser Text (Maybe (DerivPathI t)) -> Parser Text (DerivPathI t)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Text (DerivPathI t) -> Parser Text (Maybe (DerivPathI t))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (DerivPathI t -> Parser Text (DerivPathI t)
forall t.
(AnyOrSoft t, HardOrAny t) =>
DerivPathI t -> Parser Text (DerivPathI t)
componentP DerivPathI t
d)

    componentP :: DerivPathI t -> Parser Text (DerivPathI t)
componentP d :: DerivPathI t
d = do
        Char
_ <- Char -> Parser Text Char
A.char '/'
        Fingerprint
n <- Parser Text Fingerprint
forall a. Integral a => Parser a
A.decimal
        Bool
isHard <- Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Char -> Bool)
-> Parser Text (Maybe Char) -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
A.char '\'' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
A.char 'h')
        DerivPathI t -> Parser Text (DerivPathI t)
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivPathI t -> Parser Text (DerivPathI t))
-> DerivPathI t -> Parser Text (DerivPathI t)
forall a b. (a -> b) -> a -> b
$ (Fingerprint -> DerivPathI t)
-> (Fingerprint -> DerivPathI t)
-> Bool
-> Fingerprint
-> DerivPathI t
forall a. a -> a -> Bool -> a
bool (DerivPathI t
d DerivPathI t -> Fingerprint -> DerivPathI t
forall t.
AnyOrSoft t =>
DerivPathI t -> Fingerprint -> DerivPathI t
:/) (DerivPathI t
d DerivPathI t -> Fingerprint -> DerivPathI t
forall t.
HardOrAny t =>
DerivPathI t -> Fingerprint -> DerivPathI t
:|) Bool
isHard Fingerprint
n