{-# LANGUAGE OverloadedStrings #-}

module Language.Bitcoin.Script.Descriptors.Parser (
    ChecksumDescriptor (..),
    ChecksumStatus (..),
    parseDescriptor,
    outputDescriptorParser,
    parseKeyDescriptor,
    keyDescriptorParser,
) where

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

import qualified Data.Text as Text
import Language.Bitcoin.Script.Descriptors.Checksum (
    descriptorChecksum,
    validDescriptorChecksum,
 )
import Language.Bitcoin.Script.Descriptors.Syntax
import Language.Bitcoin.Utils (
    alphanum,
    application,
    argList,
    brackets,
    comma,
    hex,
    maybeFail,
 )

-- | An 'OutputDescriptor' with checksum details
data ChecksumDescriptor = ChecksumDescriptor
    { ChecksumDescriptor -> OutputDescriptor
descriptor :: OutputDescriptor
    -- ^ The output descriptor
    , ChecksumDescriptor -> ChecksumStatus
checksumStatus :: ChecksumStatus
    -- ^ The status of the output descriptor's checksum
    , ChecksumDescriptor -> Text
expectedChecksum :: Text
    -- ^ The expected checksum for the output descriptor
    }
    deriving (ChecksumDescriptor -> ChecksumDescriptor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChecksumDescriptor -> ChecksumDescriptor -> Bool
$c/= :: ChecksumDescriptor -> ChecksumDescriptor -> Bool
== :: ChecksumDescriptor -> ChecksumDescriptor -> Bool
$c== :: ChecksumDescriptor -> ChecksumDescriptor -> Bool
Eq, Int -> ChecksumDescriptor -> ShowS
[ChecksumDescriptor] -> ShowS
ChecksumDescriptor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChecksumDescriptor] -> ShowS
$cshowList :: [ChecksumDescriptor] -> ShowS
show :: ChecksumDescriptor -> String
$cshow :: ChecksumDescriptor -> String
showsPrec :: Int -> ChecksumDescriptor -> ShowS
$cshowsPrec :: Int -> ChecksumDescriptor -> ShowS
Show)

-- | The status of an output descriptor's checksum
data ChecksumStatus
    = -- | Checksum provided is valid
      Valid
    | -- | Checksum provided is invalid
      Invalid
        Text
        -- ^ The invalid checksum
    | -- | Checksum is not provided
      Absent
    deriving (ChecksumStatus -> ChecksumStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChecksumStatus -> ChecksumStatus -> Bool
$c/= :: ChecksumStatus -> ChecksumStatus -> Bool
== :: ChecksumStatus -> ChecksumStatus -> Bool
$c== :: ChecksumStatus -> ChecksumStatus -> Bool
Eq, Int -> ChecksumStatus -> ShowS
[ChecksumStatus] -> ShowS
ChecksumStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChecksumStatus] -> ShowS
$cshowList :: [ChecksumStatus] -> ShowS
show :: ChecksumStatus -> String
$cshow :: ChecksumStatus -> String
showsPrec :: Int -> ChecksumStatus -> ShowS
$cshowsPrec :: Int -> ChecksumStatus -> ShowS
Show)

parseDescriptor :: Network -> Text -> Either String ChecksumDescriptor
parseDescriptor :: Network -> Text -> Either String ChecksumDescriptor
parseDescriptor = forall a. Parser a -> Text -> Either String a
A.parseOnly forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> Parser ChecksumDescriptor
outputDescriptorParser

outputDescriptorParser :: Network -> Parser ChecksumDescriptor
outputDescriptorParser :: Network -> Parser ChecksumDescriptor
outputDescriptorParser Network
net =
    Parser OutputDescriptor -> Parser ChecksumDescriptor
checksumParser forall a b. (a -> b) -> a -> b
$
        Parser OutputDescriptor
spkP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser OutputDescriptor
shP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser OutputDescriptor
wpkhP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser OutputDescriptor
wshP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser OutputDescriptor
shwpkhP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser OutputDescriptor
shwshP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser OutputDescriptor
comboP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser OutputDescriptor
addrP
  where
    sdP :: Parser ScriptDescriptor
sdP = Network -> Parser ScriptDescriptor
scriptDescriptorParser Network
net
    keyP :: Parser KeyDescriptor
keyP = Network -> Parser KeyDescriptor
keyDescriptorParser Network
net

    spkP :: Parser OutputDescriptor
spkP = ScriptDescriptor -> OutputDescriptor
ScriptPubKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ScriptDescriptor
sdP
    shP :: Parser OutputDescriptor
shP = ScriptDescriptor -> OutputDescriptor
P2SH forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
application Text
"sh" Parser ScriptDescriptor
sdP
    wshP :: Parser OutputDescriptor
wshP = ScriptDescriptor -> OutputDescriptor
P2WSH forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
application Text
"wsh" Parser ScriptDescriptor
sdP
    wpkhP :: Parser OutputDescriptor
wpkhP = KeyDescriptor -> OutputDescriptor
P2WPKH forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
application Text
"wpkh" Parser KeyDescriptor
keyP
    shwpkhP :: Parser OutputDescriptor
shwpkhP = KeyDescriptor -> OutputDescriptor
WrappedWPkh forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Text -> Parser a -> Parser a
application Text
"sh" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> Parser a -> Parser a
application Text
"wpkh") Parser KeyDescriptor
keyP
    shwshP :: Parser OutputDescriptor
shwshP = ScriptDescriptor -> OutputDescriptor
WrappedWSh forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Text -> Parser a -> Parser a
application Text
"sh" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> Parser a -> Parser a
application Text
"wsh") Parser ScriptDescriptor
sdP
    comboP :: Parser OutputDescriptor
comboP = KeyDescriptor -> OutputDescriptor
Combo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
application Text
"combo" Parser KeyDescriptor
keyP

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

scriptDescriptorParser :: Network -> Parser ScriptDescriptor
scriptDescriptorParser :: Network -> Parser ScriptDescriptor
scriptDescriptorParser Network
net = Parser ScriptDescriptor
pkP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
pkhP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
rawP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
multiP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ScriptDescriptor
sortedMultiP
  where
    kp :: Parser KeyDescriptor
kp = Network -> Parser KeyDescriptor
keyDescriptorParser Network
net

    rawP :: Parser ScriptDescriptor
rawP = ByteString -> ScriptDescriptor
Raw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
application Text
"raw" Parser ByteString
hex
    pkP :: Parser ScriptDescriptor
pkP = KeyDescriptor -> ScriptDescriptor
Pk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
application Text
"pk" Parser KeyDescriptor
kp
    pkhP :: Parser ScriptDescriptor
pkhP = KeyDescriptor -> ScriptDescriptor
Pkh forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
application Text
"pkh" Parser KeyDescriptor
kp

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

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

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

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

    fingerprintP :: Parser Text Fingerprint
fingerprintP =
        Int -> Parser Text
A.take Int
8
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Fingerprint
textToFingerprint

    keyP :: Parser Text Key
keyP = Parser Text Key
pubP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Key
wifP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> XPubKey -> DerivPath -> KeyCollection -> Key
XPub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text XPubKey
xpubP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser DerivPath
pathP 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 ByteString
hex
        forall a b. String -> (a -> b) -> Maybe a -> Parser b
maybeFail String
"Unable to parse pubkey" (ByteString -> PubKey -> Key
toPubKey ByteString
bs) forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe PubKey
importPubKey ByteString
bs

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

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

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

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

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

checksumParser :: Parser OutputDescriptor -> Parser ChecksumDescriptor
checksumParser :: Parser OutputDescriptor -> Parser ChecksumDescriptor
checksumParser Parser OutputDescriptor
p = do
    (Text
input, OutputDescriptor
desc) <- forall a. Parser a -> Parser (Text, a)
match Parser OutputDescriptor
p
    Text
actual <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ do
        Char
_ <- Char -> Parser Char
char Char
'#'
        String -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
8 Parser Char
alphanum
    let status :: ChecksumStatus
status = case Text
actual of
            Text
"" -> ChecksumStatus
Absent
            Text
_
                | Text
input Text -> Text -> Bool
`validDescriptorChecksum` Text
actual -> ChecksumStatus
Valid
                | Bool
otherwise -> Text -> ChecksumStatus
Invalid Text
actual
        expected :: Text
expected = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
descriptorChecksum Text
input
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OutputDescriptor -> ChecksumStatus -> Text -> ChecksumDescriptor
ChecksumDescriptor OutputDescriptor
desc ChecksumStatus
status Text
expected