{-# 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,
)
data ChecksumDescriptor = ChecksumDescriptor
{ ChecksumDescriptor -> OutputDescriptor
descriptor :: OutputDescriptor
, ChecksumDescriptor -> ChecksumStatus
checksumStatus :: ChecksumStatus
, ChecksumDescriptor -> Text
expectedChecksum :: Text
}
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)
data ChecksumStatus
=
Valid
|
Invalid
Text
|
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