module Network.Haskoin.Wallet.Client.Commands
( cmdStart
, cmdStop
, cmdNewAcc
, cmdAddKey
, cmdSetGap
, cmdAccount
, cmdRenameAcc
, cmdAccounts
, cmdList
, cmdPubKeys
, cmdUnused
, cmdLabel
, cmdTxs
, cmdAddrTxs
, cmdKeyIndex
, cmdGenAddrs
, cmdSend
, cmdSendMany
, cmdImport
, cmdSign
, cmdBalance
, cmdGetTx
, cmdGetOffline
, cmdSignOffline
, cmdRescan
, cmdDecodeTx
, cmdVersion
, cmdStatus
, cmdBlockInfo
, cmdMonitor
, cmdSync
, cmdKeyPair
, cmdDeleteTx
, cmdPending
, cmdDead
)
where
import Control.Applicative ((<|>))
import Control.Concurrent.Async.Lifted (async, wait)
import Control.Monad (forM_, forever, liftM2,
unless, when)
import qualified Control.Monad.Reader as R (ReaderT, ask, asks)
import Control.Monad.Trans (liftIO)
import Data.Aeson (FromJSON, ToJSON, Value (..),
decode, eitherDecode, object,
toJSON, (.=))
import qualified Data.Aeson as Aeson (encode)
import qualified Data.ByteString.Char8 as B8 (hPutStrLn, putStrLn,
unwords)
import Data.String (fromString)
import Data.List (intercalate, intersperse)
import Data.Maybe (fromMaybe, isJust, isNothing,
listToMaybe, maybeToList)
import Data.Monoid ((<>))
import Data.Restricted (rvalue)
import Data.Serialize (encode)
import Data.String.Conversions (cs)
import Data.Text (Text, pack, splitOn, unpack)
import Data.Word (Word32, Word64)
import qualified Data.Yaml as YAML (encode)
import qualified Data.Time.Format as Time
import Network.Haskoin.Block
import Network.Haskoin.Constants
import Network.Haskoin.Crypto
import Network.Haskoin.Node.STM
import Network.Haskoin.Script
import Network.Haskoin.Transaction
import Network.Haskoin.Util
import Network.Haskoin.Wallet.Server
import Network.Haskoin.Wallet.Settings
import Network.Haskoin.Wallet.Types
import qualified Network.Haskoin.Wallet.Client.PrettyJson as JSON
import qualified System.Console.Haskeline as Haskeline
import System.IO (stderr)
import System.ZMQ4 (KeyFormat (..), Req (..),
Socket, SocketType, Sub (..),
connect, curveKeyPair,
receive, receiveMulti,
restrict, send,
setCurvePublicKey,
setCurveSecretKey,
setCurveServerKey, setLinger,
subscribe, withContext,
withSocket)
import Text.Read (readMaybe)
type Handler = R.ReaderT Config IO
defaultDeriv :: HardPath
defaultDeriv = Deriv :| 0
cmdStart :: Handler ()
cmdStart = do
cfg <- R.ask
liftIO $ runSPVServer cfg
cmdStop :: Handler ()
cmdStop = do
resE <- sendZmq StopServerR
handleResponse (resE :: Either String (WalletResponse (Maybe ()))) (const $ return ())
liftIO $ putStrLn "Process stopped"
getSigningKeys :: String
-> Handler (Maybe XPrvKey)
getSigningKeys name = do
derivM <- R.asks configPath
kM <- masterKey
case kM of
Just _ -> return Nothing
Nothing -> do
keyOrMnemonic <-
liftIO . Haskeline.runInputT
Haskeline.defaultSettings $
Haskeline.getPassword (Just '*')
"Mnemonic or private extended key: "
case keyOrMnemonic of
Just ms -> return $ go (cs ms) derivM
Nothing -> error "No action due to EOF"
where
masterKey = do
resE <- sendZmq $ GetAccountR $ pack name
case resE of
Right (ResponseValid (Just acc)) ->
return $ jsonAccountMaster acc
Right (ResponseError e) -> error $ cs e
Left e -> error e
_ -> error "You find yourself in a strange place"
go "" _ = error "Need key to sign"
go str derivM = case xPrvImport str of
Just k -> case derivM of
Just d -> Just $ derivePath d k
Nothing -> Just k
Nothing -> case mnemonicToSeed "" str of
Right s -> Just (makeXPrvKey s)
Left _ -> error "Could not parse key"
checkExists :: String -> Handler Bool
checkExists name = do
resE <- sendZmq $ GetAccountR $ pack name
case (resE :: Either String (WalletResponse JsonAccount)) of
Right (ResponseValid _) -> return True
Right (ResponseError _) -> return False
Left e -> error e
getKey :: Handler (Maybe Mnemonic, Maybe XPrvKey, Maybe HardPath, Maybe XPubKey)
getKey = do
derivM <- R.asks configPath
i <- liftIO . Haskeline.runInputT Haskeline.defaultSettings $
Haskeline.getPassword (Just '*')
"Type mnemonic, extended key or leave empty to generate: "
case i of
Just s -> go (cs s) derivM
Nothing -> error "No action due to EOF"
where
go "" derivM = return
( Nothing
, Nothing
, derivM <|> Just defaultDeriv
, Nothing
)
go str' derivM = case xPrvImport str' of
Just k -> return
( Nothing
, Just $ maybe k (`derivePath` k) derivM
, derivM
, Nothing
)
Nothing -> case xPubImport str' of
Just p -> return
( Nothing
, Nothing
, derivM
, Just p
)
Nothing -> return
( Just $ cs str'
, Nothing
, derivM <|> Just defaultDeriv
, Nothing
)
cmdNewAcc :: Bool -> String -> [String] -> Handler ()
cmdNewAcc r name ls = do
_ <- return $! typ
e <- checkExists name
when e $ error "Account exists"
(mnemonicM, masterM, derivM, keyM) <- getKey
let newAcc = NewAccount
{ newAccountName = pack name
, newAccountType = typ
, newAccountMnemonic = cs <$> mnemonicM
, newAccountMaster = masterM
, newAccountDeriv = derivM
, newAccountKeys = maybeToList keyM
, newAccountReadOnly = r
}
resE <- sendZmq $ PostAccountsR newAcc
handleResponse resE $ liftIO . putStr . printAccount
where
typ = case ls of
[] -> AccountRegular
[mS, nS] -> fromMaybe (error "Account information incorrect") $ do
m <- readMaybe mS
n <- readMaybe nS
return $ AccountMultisig m n
_ -> error "Number of parametres incorrect"
cmdAddKey :: String -> Handler ()
cmdAddKey name = do
e <- checkExists name
unless e $ error "Account does not exist"
(mnemonicM, masterM, derivM, pubM) <- getKey
let key = case mnemonicM of
Just ms -> case mnemonicToSeed "" (cs ms) of
Right s -> deriveXPubKey $
derivePath (fromMaybe defaultDeriv derivM) $
makeXPrvKey s
Left _ -> error "Could not decode mnemonic sentence"
Nothing -> case masterM of
Just m -> deriveXPubKey $ maybe m (`derivePath` m) derivM
Nothing -> fromMaybe (error "No keys provided") pubM
resE <- sendZmq (PostAccountKeysR (pack name) [key])
handleResponse resE $ liftIO . putStr . printAccount
cmdSetGap :: String -> String -> Handler ()
cmdSetGap name gap = do
resE <- sendZmq (PostAccountGapR (pack name) setGap)
handleResponse resE $ liftIO . putStr . printAccount
where
setGap = SetAccountGap $ read gap
cmdAccount :: String -> Handler ()
cmdAccount name = do
resE <- sendZmq (GetAccountR $ pack name)
handleResponse resE $ liftIO . putStr . printAccount
cmdAccounts :: [String] -> Handler ()
cmdAccounts ls = do
let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
listAction page GetAccountsR $ \ts -> do
let xs = map (liftIO . putStr . printAccount) ts
sequence_ $ intersperse (liftIO $ putStrLn "-") xs
cmdRenameAcc :: String -> String -> Handler ()
cmdRenameAcc oldName newName = do
resE <- sendZmq $ PostAccountRenameR (pack oldName) (pack newName)
handleResponse resE $ liftIO . putStr . printAccount
listAction :: (FromJSON a, ToJSON a)
=> Word32
-> (ListRequest -> WalletRequest)
-> ([a] -> Handler ())
-> Handler ()
listAction page requestBuilder action = do
c <- R.asks configCount
r <- R.asks configReversePaging
case c of
0 -> do
let listReq = ListRequest 0 0 r
resE <- sendZmq (requestBuilder listReq)
handleResponse resE $ \(ListResult a _) -> action a
_ -> do
when (page < 1) $ error "Page cannot be less than 1"
let listReq = ListRequest ((page - 1) * c) c r
resE <- sendZmq (requestBuilder listReq)
handleResponse resE $ \(ListResult a m) -> case m of
0 -> liftIO . putStrLn $ "No elements"
_ -> do
liftIO . putStrLn $
"Page " ++ show page ++ " of " ++ show (pages m c) ++
" (" ++ show m ++ " elements)"
action a
where
pages m c | m `mod` c == 0 = m `div` c
| otherwise = m `div` c + 1
listJsonAddrs :: (JsonAddr -> String)
-> String
-> [String]
-> Handler ()
listJsonAddrs showFunc name ls = do
t <- R.asks configAddrType
m <- R.asks configMinConf
o <- R.asks configOffline
let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
f = GetAddressesR (pack name) t m o
listAction page f $ \as -> forM_ as (liftIO . putStrLn . showFunc)
cmdList :: String -> [String] -> Handler ()
cmdList = listJsonAddrs printAddress
cmdPubKeys :: String -> [String] -> Handler ()
cmdPubKeys = listJsonAddrs printPubKey
cmdUnused :: String -> [String] -> Handler ()
cmdUnused name ls = do
t <- R.asks configAddrType
let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
f = GetAddressesUnusedR (pack name) t
listAction page f $ \as -> forM_ (as :: [JsonAddr]) $
liftIO . putStrLn . printAddress
cmdLabel :: String -> String -> String -> Handler ()
cmdLabel name iStr label = do
t <- R.asks configAddrType
resE <- sendZmq (PutAddressR (pack name) i t addrLabel)
handleResponse resE $ liftIO . putStrLn . printAddress
where
i = read iStr
addrLabel = AddressLabel $ pack label
cmdTxs :: String -> [String] -> Handler ()
cmdTxs name ls = do
let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
r <- R.asks configReversePaging
listAction page (GetTxsR (pack name)) $ \ts -> do
let xs = map (liftIO . putStr . printTx Nothing) ts
xs' = if r then xs else reverse xs
sequence_ $ intersperse (liftIO $ putStrLn "-") xs'
cmdPending :: String -> [String] -> Handler ()
cmdPending name ls = do
let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
r <- R.asks configReversePaging
listAction page (GetPendingR (pack name)) $ \ts -> do
let xs = map (liftIO . putStr . printTx Nothing) ts
xs' = if r then xs else reverse xs
sequence_ $ intersperse (liftIO $ putStrLn "-") xs'
cmdDead :: String -> [String] -> Handler ()
cmdDead name ls = do
let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
r <- R.asks configReversePaging
listAction page (GetDeadR (pack name)) $ \ts -> do
let xs = map (liftIO . putStr . printTx Nothing) ts
xs' = if r then xs else reverse xs
sequence_ $ intersperse (liftIO $ putStrLn "-") xs'
cmdAddrTxs :: String -> String -> [String] -> Handler ()
cmdAddrTxs name i ls = do
t <- R.asks configAddrType
m <- R.asks configMinConf
o <- R.asks configOffline
r <- R.asks configReversePaging
let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
f = GetAddrTxsR (pack name) index t
resE <- sendZmq (GetAddressR (pack name) index t m o)
handleResponse resE $ \JsonAddr{..} -> listAction page f $ \ts -> do
let xs = map (liftIO . putStr . printTx (Just jsonAddrAddress)) ts
xs' = if r then xs else reverse xs
sequence_ $ intersperse (liftIO $ putStrLn "-") xs'
where
index = fromMaybe (error "Could not read index") $ readMaybe i
cmdKeyIndex :: String -> String -> Handler ()
cmdKeyIndex name k = do
t <- R.asks configAddrType
resE <- sendZmq $ GetIndexR (pack name) (fromString k) t
handleResponse resE $ \res -> case res of
[] -> liftIO $ putStrLn "No matching pubkeys found"
lst -> liftIO $ putStrLn $ unlines $
map (\adr -> showLine (jsonAddrIndex adr, jsonAddrKey adr)) lst
where
showLine :: (KeyIndex, Maybe PubKeyC) -> String
showLine (idx,k') = unwords [ show (idx :: KeyIndex), ":", showPubKey k' ]
showPubKey = maybe "<no pubkey available>" (jsonStr2Str . toJSON)
jsonStr2Str (String t) = cs t
jsonStr2Str _ = ""
cmdGenAddrs :: String -> String -> Handler ()
cmdGenAddrs name i = do
t <- R.asks configAddrType
let req = PostAddressesR (pack name) index t
resE <- sendZmq req
handleResponse resE $ \cnt -> liftIO . putStrLn $
unwords [ "Generated", show (cnt :: Int), "addresses" ]
where
index = read i
cmdSend :: String -> String -> String -> Handler ()
cmdSend name addrStr amntStr = cmdSendMany name [addrStr ++ ":" ++ amntStr]
cmdSendMany :: String -> [String] -> Handler ()
cmdSendMany name xs = case rcpsM of
Just rcps -> do
fee <- R.asks configFee
rcptFee <- R.asks configRcptFee
minconf <- R.asks configMinConf
sign <- R.asks configSignTx
masterM <- if sign then getSigningKeys name else return Nothing
let action = CreateTx rcps fee minconf rcptFee sign
resE <- sendZmq (PostTxsR (pack name) masterM action)
handleResponse resE $ liftIO . putStr . printTx Nothing
_ -> error "Could not parse recipient information"
where
g str = map cs $ splitOn ":" (pack str)
f [a,v] = liftM2 (,) (base58ToAddr a) (readMaybe $ cs v)
f _ = Nothing
rcpsM = mapM (f . g) xs
getHexTx :: Handler Tx
getHexTx = do
hexM <- Haskeline.runInputT Haskeline.defaultSettings $
Haskeline.getInputLine ""
let txM = case hexM of
Nothing -> error "No action due to EOF"
Just hex -> decodeToMaybe =<< decodeHex (cs hex)
case txM of
Just tx -> return tx
Nothing -> error "Could not parse transaction"
cmdImport :: String -> Handler ()
cmdImport name = do
tx <- getHexTx
let action = ImportTx tx
resE <- sendZmq (PostTxsR (pack name) Nothing action)
handleResponse resE $ liftIO . putStr . printTx Nothing
cmdSign :: String -> String -> Handler ()
cmdSign name txidStr = case txidM of
Just txid -> do
masterM <- getSigningKeys name
let action = SignTx txid
resE <- sendZmq (PostTxsR (pack name) masterM action)
handleResponse resE $ liftIO . putStr . printTx Nothing
_ -> error "Could not parse txid"
where
txidM = hexToTxHash $ cs txidStr
cmdGetOffline :: String -> String -> Handler ()
cmdGetOffline name tidStr = case tidM of
Just tid -> do
resE <- sendZmq (GetOfflineTxR (pack name) tid)
handleResponse resE $ \(OfflineTxData tx dat) -> do
liftIO $ putStrLn $ unwords
[ "Tx :", cs $ encodeHex $ encode tx ]
liftIO $ putStrLn $ unwords
[ "CoinData:", cs $ encodeHex $ cs $ Aeson.encode dat ]
_ -> error "Could not parse txid"
where
tidM = hexToTxHash $ cs tidStr
cmdSignOffline :: String -> String -> String -> Handler ()
cmdSignOffline name txStr datStr = case (txM, datM) of
(Just tx, Just dat) -> do
masterM <- getSigningKeys name
resE <- sendZmq (PostOfflineTxR (pack name) masterM tx dat)
handleResponse resE $ \(TxCompleteRes tx' c) -> do
liftIO $ putStrLn $ unwords
[ "Tx :", cs $ encodeHex $ encode tx' ]
liftIO $ putStrLn $ unwords
[ "Complete:", if c then "Yes" else "No" ]
_ -> error "Could not decode input data"
where
datM = decode . cs =<< decodeHex (cs datStr)
txM = decodeToMaybe =<< decodeHex (cs txStr)
cmdBalance :: String -> Handler ()
cmdBalance name = do
m <- R.asks configMinConf
o <- R.asks configOffline
resE <- sendZmq (GetBalanceR (pack name) m o)
handleResponse resE $ \bal ->
liftIO $ putStrLn $ unwords [ "Balance:", show (bal :: Word64) ]
cmdGetTx :: String -> String -> Handler ()
cmdGetTx name tidStr = case tidM of
Just tid -> do
resE <- sendZmq (GetTxR (pack name) tid)
handleResponse resE $ liftIO . putStr . printTx Nothing
_ -> error "Could not parse txid"
where
tidM = hexToTxHash $ cs tidStr
cmdRescan :: [String] -> Handler ()
cmdRescan timeLs = do
let timeM = case timeLs of
[] -> Nothing
str:_ -> case readMaybe str of
Nothing -> error "Could not decode time"
Just t -> Just t
resE <- sendZmq (PostNodeR $ NodeActionRescan timeM)
handleResponse resE $ \(RescanRes ts) ->
liftIO $ putStrLn $ unwords [ "Timestamp:", show ts]
cmdDeleteTx :: String -> Handler ()
cmdDeleteTx tidStr = case tidM of
Just tid -> do
resE <- sendZmq (DeleteTxIdR tid)
handleResponse resE $ \() -> return ()
Nothing -> error "Could not parse txid"
where
tidM = hexToTxHash $ cs tidStr
cmdMonitor :: [String] -> Handler ()
cmdMonitor ls = do
cfg@Config{..} <- R.ask
liftIO $ withContext $ \ctx -> withSocket ctx Sub $ \sock -> do
setLinger (restrict (0 :: Int)) sock
setupAuth cfg sock
connect sock configConnectNotif
subscribe sock "[block]"
forM_ ls $ \name -> subscribe sock $ "{" <> cs name <> "}"
forever $ do
[_,m] <- receiveMulti sock
handleNotif configFormat $ eitherDecode $ cs m
cmdSync :: String -> String -> [String] -> Handler ()
cmdSync acc block ls = do
let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
f = case length block of
64 -> GetSyncR (cs acc) $
fromMaybe (error "Could not decode block id") $
hexToBlockHash $ cs block
_ -> GetSyncHeightR (cs acc) $
fromMaybe (error "Could not decode block height") $
readMaybe block
r <- R.asks configReversePaging
listAction page f $ \blocks -> do
let blocks' = if r then reverse blocks else blocks
forM_ (blocks' :: [JsonSyncBlock]) $ liftIO . putStrLn . printSyncBlock
cmdDecodeTx :: Handler ()
cmdDecodeTx = do
tx <- getHexTx
format <- R.asks configFormat
liftIO $ formatStr $ cs $ case format of
OutputJSON -> cs $ jsn tx
_ -> YAML.encode $ val tx
where
val = encodeTxJSON
jsn = JSON.encodePretty . val
cmdVersion :: Handler ()
cmdVersion = liftIO $ do
putStrLn $ unwords [ "network :", cs networkName ]
putStrLn $ unwords [ "user-agent:", cs haskoinUserAgent ]
cmdStatus :: Handler ()
cmdStatus = do
v <- R.asks configVerbose
resE <- sendZmq (PostNodeR NodeActionStatus)
handleResponse resE $ mapM_ (liftIO . putStrLn) . printNodeStatus v
cmdKeyPair :: Handler ()
cmdKeyPair = do
(pub, sec) <- curveKeyPair
liftIO $ do
B8.putStrLn $ B8.unwords [ "public :", rvalue pub ]
B8.putStrLn $ B8.unwords [ "private:", rvalue sec ]
cmdBlockInfo :: [String] -> Handler ()
cmdBlockInfo headers = do
hashL <- if null headers then
(: []) . parseRes <$> sendZmq (PostNodeR NodeActionStatus)
else
return (map fromString headers)
sendZmq (GetBlockInfoR hashL) >>=
\resE -> handleResponse resE (liftIO . printResults)
where
printResults :: [BlockInfo] -> IO ()
printResults = mapM_ $ putStrLn . unlines . printBlockInfo
parseRes :: Either String (WalletResponse NodeStatus) -> BlockHash
parseRes = nodeStatusBestHeader . fromMaybe
(error "No response to NodeActionStatus msg") . parseResponse
handleNotif :: OutputFormat -> Either String Notif -> IO ()
handleNotif _ (Left e) = error e
handleNotif fmt (Right notif) = case fmt of
OutputJSON -> formatStr $ cs $
JSON.encodePretty notif
OutputYAML -> do
putStrLn "---"
formatStr $ cs $ YAML.encode notif
putStrLn "..."
OutputNormal ->
putStrLn $ printNotif notif
parseResponse
:: Either String (WalletResponse a)
-> Maybe a
parseResponse resE = case resE of
Right (ResponseValid resM) -> resM
Right (ResponseError err) -> error $ unpack err
Left err -> error err
handleResponse
:: (FromJSON a, ToJSON a)
=> Either String (WalletResponse a)
-> (a -> Handler ())
-> Handler ()
handleResponse resE handle = case parseResponse resE of
Just a -> formatOutput a =<< R.asks configFormat
Nothing -> return ()
where
formatOutput a format = case format of
OutputJSON -> liftIO . formatStr $ cs $
JSON.encodePretty a
OutputYAML -> liftIO . formatStr $ cs $ YAML.encode a
OutputNormal -> handle a
sendZmq :: (FromJSON a, ToJSON a)
=> WalletRequest
-> Handler (Either String (WalletResponse a))
sendZmq req = do
cfg <- R.ask
let msg = cs $ Aeson.encode req
when (configVerbose cfg) $ liftIO $
B8.hPutStrLn stderr $ "Outgoing JSON: " `mappend` msg
a <- async $ liftIO $ withContext $ \ctx ->
withSocket ctx Req $ \sock -> do
setLinger (restrict (0 :: Int)) sock
setupAuth cfg sock
connect sock (configConnect cfg)
send sock [] (cs $ Aeson.encode req)
eitherDecode . cs <$> receive sock
wait a
setupAuth :: (SocketType t)
=> Config
-> Socket t
-> IO ()
setupAuth cfg sock = do
let clientKeyM = configClientKey cfg
clientKeyPubM = configClientKeyPub cfg
serverKeyPubM = configServerKeyPub cfg
forM_ clientKeyM $ \clientKey -> do
let serverKeyPub = fromMaybe
(error "Server public key not provided")
serverKeyPubM
clientKeyPub = fromMaybe
(error "Client public key not provided")
clientKeyPubM
setCurveServerKey TextFormat serverKeyPub sock
setCurvePublicKey TextFormat clientKeyPub sock
setCurveSecretKey TextFormat clientKey sock
formatStr :: String -> IO ()
formatStr str = forM_ (lines str) putStrLn
encodeTxJSON :: Tx -> Value
encodeTxJSON tx = object
[ "txid" .= (cs $ txHashToHex (txHash tx) :: Text)
, "version" .= txVersion tx
, "inputs" .= map encodeTxInJSON (txIn tx)
, "outputs" .= map encodeTxOutJSON (txOut tx)
, "locktime" .= txLockTime tx
]
encodeTxInJSON :: TxIn -> Value
encodeTxInJSON (TxIn o s i) = object $
[ "outpoint" .= encodeOutPointJSON o
, "sequence" .= i
, "raw-script" .= (cs $ encodeHex s :: Text)
, "script" .= encodeScriptJSON sp
] ++ decoded
where
sp = fromMaybe (Script []) $ decodeToMaybe s
decoded = either (const []) f $ decodeInputBS s
f inp = ["decoded-script" .= encodeScriptInputJSON inp]
encodeTxOutJSON :: TxOut -> Value
encodeTxOutJSON (TxOut v s) = object $
[ "value" .= v
, "raw-script" .= (cs $ encodeHex s :: Text)
, "script" .= encodeScriptJSON sp
] ++ decoded
where
sp = fromMaybe (Script []) $ decodeToMaybe s
decoded = either (const [])
(\out -> ["decoded-script" .= encodeScriptOutputJSON out])
(decodeOutputBS s)
encodeOutPointJSON :: OutPoint -> Value
encodeOutPointJSON (OutPoint h i) = object
[ "txid" .= (cs $ txHashToHex h :: Text)
, "pos" .= i
]
encodeScriptJSON :: Script -> Value
encodeScriptJSON (Script ops) =
toJSON $ map f ops
where
f (OP_PUSHDATA bs _) = String $ pack $ unwords
["OP_PUSHDATA", cs $ encodeHex bs]
f x = String $ pack $ show x
encodeScriptInputJSON :: ScriptInput -> Value
encodeScriptInputJSON si = case si of
RegularInput (SpendPK s) -> object
[ "spendpubkey" .= object [ "sig" .= encodeSigJSON s ] ]
RegularInput (SpendPKHash s p) -> object
[ "spendpubkeyhash" .= object
[ "sig" .= encodeSigJSON s
, "pubkey" .= (cs $ encodeHex (encode p) :: Text)
, "sender-address" .= (cs $ addrToBase58 (pubKeyAddr p) :: Text)
]
]
RegularInput (SpendMulSig sigs) -> object
[ "spendmulsig" .= object [ "sigs" .= map encodeSigJSON sigs ] ]
ScriptHashInput s r -> object
[ "spendscripthash" .= object
[ "scriptinput" .= encodeScriptInputJSON (RegularInput s)
, "redeem" .= encodeScriptOutputJSON r
, "raw-redeem" .= (cs $ encodeHex (encodeOutputBS r) :: Text)
, "sender-address" .= (cs $ addrToBase58 (scriptAddr r) :: Text)
]
]
encodeScriptOutputJSON :: ScriptOutput -> Value
encodeScriptOutputJSON so = case so of
PayPK p -> object
[ "pay2pubkey" .= object
[ "pubkey" .= (cs $ encodeHex (encode p) :: Text) ]
]
PayPKHash a -> object
[ "pay2pubkeyhash" .= object
[ "address-base64" .=
(cs $ encodeHex (encode $ getAddrHash a) :: Text)
, "address-base58" .= (cs $ addrToBase58 a :: Text)
]
]
PayMulSig ks r -> object
[ "pay2mulsig" .= object
[ "required-keys" .= r
, "pubkeys" .= (map (cs . encodeHex . encode) ks :: [Text])
]
]
PayScriptHash a -> object
[ "pay2scripthash" .= object
[ "address-base64" .= (cs $ encodeHex $ encode $ getAddrHash a :: Text)
, "address-base58" .= (cs (addrToBase58 a) :: Text)
]
]
DataCarrier bs -> object
[ "op_return" .= object
[ "data" .= (cs $ encodeHex bs :: Text)
]
]
encodeSigJSON :: TxSignature -> Value
encodeSigJSON ts@(TxSignature _ sh) = object
[ "raw-sig" .= (cs $ encodeHex (encodeSig ts) :: Text)
, "sighash" .= encodeSigHashJSON sh
]
encodeSigHashJSON :: SigHash -> Value
encodeSigHashJSON sh = case sh of
SigAll acp -> object
[ "type" .= String "SigAll"
, "acp" .= acp
]
SigNone acp -> object
[ "type" .= String "SigNone"
, "acp" .= acp
]
SigSingle acp -> object
[ "type" .= String "SigSingle"
, "acp" .= acp
]
SigUnknown acp v -> object
[ "type" .= String "SigUnknown"
, "acp" .= acp
, "value" .= v
]
printAccount :: JsonAccount -> String
printAccount JsonAccount{..} = unlines $
[ "Account : " ++ unpack jsonAccountName
, "Type : " ++ showType
, "Gap : " ++ show jsonAccountGap
]
++
[ "Deriv : " ++ pathToStr d
| d <- maybeToList jsonAccountDerivation
]
++
[ "Mnemonic: " ++ cs ms
| ms <- maybeToList jsonAccountMnemonic
]
++
concat [ printKeys | not (null jsonAccountKeys) ]
where
printKeys =
("Keys : " ++ cs (xPubExport (head jsonAccountKeys))) :
map ((" " ++) . cs . xPubExport) (tail jsonAccountKeys)
showType = case jsonAccountType of
AccountRegular -> if isNothing jsonAccountMaster
then "Read-Only" else "Regular"
AccountMultisig m n -> unwords
[ if isNothing jsonAccountMaster
then "Read-Only Multisig" else "Multisig"
, show m, "of", show n
]
printAddress :: JsonAddr -> String
printAddress JsonAddr{..} = unwords $
[ show jsonAddrIndex, ":", cs (addrToBase58 jsonAddrAddress) ]
++
[ "(" ++ unpack jsonAddrLabel ++ ")" | not (null $ unpack jsonAddrLabel) ]
++ concat
[ [ "[Received: " ++ show (balanceInfoInBalance bal) ++ "]"
, "[Coins: " ++ show (balanceInfoCoins bal) ++ "]"
, "[Spent Coins: " ++ show (balanceInfoSpentCoins bal) ++ "]"
]
| isJust jsonAddrBalance && balanceInfoCoins bal > 0
]
where
bal = fromMaybe (error "Could not get address balance") jsonAddrBalance
printPubKey :: JsonAddr -> String
printPubKey JsonAddr{..} = unwords $
[ show jsonAddrIndex, ":", showPubKey jsonAddrKey ]
++
[ "(" ++ unpack jsonAddrLabel ++ ")" | not (null $ unpack jsonAddrLabel) ]
where
showPubKey = maybe "<no pubkey available>" (jsonStr2Str . toJSON)
jsonStr2Str (String t) = cs t
jsonStr2Str _ = ""
printNotif :: Notif -> String
printNotif (NotifTx tx) = printTx Nothing tx
printNotif (NotifBlock b) = printBlock b
printTx :: Maybe Address -> JsonTx -> String
printTx aM tx@JsonTx{..} = unlines $
[ "Id : " ++ cs (txHashToHex jsonTxHash) ]
++
[ "Value : " ++ printTxType jsonTxType ++ " " ++ show jsonTxValue ]
++
[ "Confidence : " ++ printTxConfidence tx ]
++ concat
[ printAddrInfos "Inputs : " jsonTxInputs
| not (null jsonTxInputs)
]
++ concat
[ printAddrInfos "Outputs : " jsonTxOutputs
| not (null jsonTxOutputs)
]
++ concat
[ printAddrInfos "Change : " jsonTxChange
| not (null jsonTxChange)
]
where
printAddrInfos header xs =
(header ++ f (head xs)) :
map ((" " ++) . f) (tail xs)
f (AddressInfo addr valM local) = unwords $
cs (addrToBase58 addr) :
[ show v | v <- maybeToList valM ]
++
[ "<-" | maybe local (== addr) aM ]
printTxConfidence :: JsonTx -> String
printTxConfidence JsonTx{..} = case jsonTxConfidence of
TxBuilding -> "Building" ++ confirmations
TxPending -> "Pending" ++ confirmations
TxDead -> "Dead" ++ confirmations
TxOffline -> "Offline"
where
confirmations = case jsonTxConfirmations of
Just conf -> " (Confirmations: " ++ show conf ++ ")"
_ -> ""
printTxType :: TxType -> String
printTxType t = case t of
TxIncoming -> "Incoming"
TxOutgoing -> "Outgoing"
TxSelf -> "Self"
printBlock :: JsonBlock -> String
printBlock JsonBlock{..} = unlines
[ "Block Hash : " ++ cs (blockHashToHex jsonBlockHash)
, "Block Height : " ++ show jsonBlockHeight
, "Previous block : " ++ cs (blockHashToHex jsonBlockPrev)
]
printSyncBlock :: JsonSyncBlock -> String
printSyncBlock JsonSyncBlock{..} = unlines
[ "Block Hash : " ++ cs (blockHashToHex jsonSyncBlockHash)
, "Block Height : " ++ show jsonSyncBlockHeight
, "Previous block : " ++ cs (blockHashToHex jsonSyncBlockPrev)
, "Transactions : " ++ show (length jsonSyncBlockTxs)
]
printNodeStatus :: Bool -> NodeStatus -> [String]
printNodeStatus verbose NodeStatus{..} =
[ "Network Height : " ++ show nodeStatusNetworkHeight
, "Best Header : " ++ cs (blockHashToHex nodeStatusBestHeader)
, "Best Header Height: " ++ show nodeStatusBestHeaderHeight
, "Best Block : " ++ cs (blockHashToHex nodeStatusBestBlock)
, "Best Block Height : " ++ show nodeStatusBestBlockHeight
, "Bloom Filter Size : " ++ show nodeStatusBloomSize
] ++
[ "Header Peer : " ++ show h
| h <- maybeToList nodeStatusHeaderPeer, verbose
] ++
[ "Merkle Peer : " ++ show m
| m <- maybeToList nodeStatusMerklePeer, verbose
] ++
[ "Pending Headers : " ++ show nodeStatusHaveHeaders | verbose ] ++
[ "Pending Tickles : " ++ show nodeStatusHaveTickles | verbose ] ++
[ "Pending Txs : " ++ show nodeStatusHaveTxs | verbose ] ++
[ "Pending GetData : " ++ show (map txHashToHex nodeStatusGetData)
| verbose
] ++
[ "Pending Rescan : " ++ show r
| r <- maybeToList nodeStatusRescan, verbose
] ++
[ "Synced Mempool : " ++ show nodeStatusMempool | verbose ] ++
[ "HeaderSync Lock : " ++ show nodeStatusSyncLock | verbose ] ++
[ "Peers: " ] ++
intercalate ["-"] (map (printPeerStatus verbose) nodeStatusPeers)
printPeerStatus :: Bool -> PeerStatus -> [String]
printPeerStatus verbose PeerStatus{..} =
[ " Peer Id : " ++ show peerStatusPeerId
, " Peer Host: " ++ peerHostString peerStatusHost
, " Connected: " ++ if peerStatusConnected then "yes" else "no"
, " Height : " ++ show peerStatusHeight
] ++
[ " Protocol : " ++ show p | p <- maybeToList peerStatusProtocol
] ++
[ " UserAgent: " ++ ua | ua <- maybeToList peerStatusUserAgent
] ++
[ " Avg Ping : " ++ p | p <- maybeToList peerStatusPing
] ++
[ " DoS Score: " ++ show d | d <- maybeToList peerStatusDoSScore
] ++
[ " Merkles : " ++ show peerStatusHaveMerkles | verbose ] ++
[ " Messages : " ++ show peerStatusHaveMessage | verbose ] ++
[ " Nonces : " ++ show peerStatusPingNonces | verbose ] ++
[ " Reconnect: " ++ show t
| t <- maybeToList peerStatusReconnectTimer, verbose
] ++
[ " Logs : " | verbose ] ++
[ " - " ++ msg | msg <- fromMaybe [] peerStatusLog, verbose]
printBlockInfo :: BlockInfo -> [String]
printBlockInfo BlockInfo{..} =
[ "Block Height : " ++ show blockInfoHeight
, "Block Hash : " ++ cs (blockHashToHex blockInfoHash)
, "Block Timestamp : " ++ formatUTCTime blockInfoTimestamp
, "Previous Block : " ++ cs (blockHashToHex blockInfoPrevBlock)
, "Merkle Root : " ++ cs blockInfoMerkleRoot
, "Block Version : " ++ "0x" ++ cs (encodeHex versionData)
, "Block Difficulty : " ++ show (blockDiff blockInfoBits)
, "Chain Work : " ++ show blockInfoChainWork
]
where
blockDiff :: Word32 -> Double
blockDiff target = getTarget (blockBits genesisHeader) / getTarget target
getTarget = fromIntegral . decodeCompact
versionData = integerToBS (fromIntegral blockInfoVersion)
formatUTCTime = Time.formatTime Time.defaultTimeLocale
"%Y-%m-%d %H:%M:%S (UTC)"