344 lines
12 KiB
Haskell
344 lines
12 KiB
Haskell
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
|
||
|
|
module Zenith.Zcashd where
|
||
|
|
|
||
|
|
import Control.Concurrent (threadDelay)
|
||
|
|
import Control.Monad (when)
|
||
|
|
import Data.Aeson
|
||
|
|
import qualified Data.Array as A
|
||
|
|
import qualified Data.ByteString as BS
|
||
|
|
import qualified Data.ByteString.Base64 as B64
|
||
|
|
import qualified Data.ByteString.Char8 as C
|
||
|
|
import qualified Data.ByteString.Lazy as LBS
|
||
|
|
import Data.Maybe
|
||
|
|
import qualified Data.Scientific as Scientific
|
||
|
|
import qualified Data.Text as T
|
||
|
|
import qualified Data.Text.Encoding as E
|
||
|
|
import Data.Text.Encoding.Error (lenientDecode)
|
||
|
|
import qualified Data.Text.IO as TIO
|
||
|
|
import qualified Data.Vector as V
|
||
|
|
import Network.HTTP.Simple
|
||
|
|
import System.Clipboard
|
||
|
|
import System.Exit
|
||
|
|
import System.IO
|
||
|
|
import Text.Read (readMaybe)
|
||
|
|
import Text.Regex
|
||
|
|
import Text.Regex.Base
|
||
|
|
import ZcashHaskell.Types (RpcCall(..), RpcResponse(..))
|
||
|
|
import Zenith.Types
|
||
|
|
( AddressGroup
|
||
|
|
, AddressSource(..)
|
||
|
|
, NodeVersion(..)
|
||
|
|
, OpResult(..)
|
||
|
|
, UABalance(..)
|
||
|
|
, ZcashAddress(..)
|
||
|
|
, ZcashPool(..)
|
||
|
|
, ZcashTx
|
||
|
|
, encodeHexText'
|
||
|
|
)
|
||
|
|
import Zenith.Utils (displayZec, getAddresses, validateAddress)
|
||
|
|
|
||
|
|
-- * RPC methods
|
||
|
|
-- | List addresses
|
||
|
|
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
|
||
|
|
listAddresses user pwd = do
|
||
|
|
response <- makeZcashCall user pwd "listaddresses" []
|
||
|
|
let rpcResp = decode response :: Maybe (RpcResponse [AddressGroup])
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
let addys = result res
|
||
|
|
case addys of
|
||
|
|
Nothing -> fail "Empty response"
|
||
|
|
Just addys' -> do
|
||
|
|
let addList = concatMap getAddresses addys'
|
||
|
|
return addList
|
||
|
|
|
||
|
|
-- | Get address balance
|
||
|
|
getBalance :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [Integer]
|
||
|
|
getBalance user pwd zadd = do
|
||
|
|
let a = account zadd
|
||
|
|
case a of
|
||
|
|
Nothing -> do
|
||
|
|
response <-
|
||
|
|
makeZcashCall
|
||
|
|
user
|
||
|
|
pwd
|
||
|
|
"z_getbalance"
|
||
|
|
[ String (addy zadd)
|
||
|
|
, Number (Scientific.scientific 1 0)
|
||
|
|
, Data.Aeson.Bool True
|
||
|
|
]
|
||
|
|
let rpcResp = decode response :: Maybe (RpcResponse Integer)
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
case result res of
|
||
|
|
Nothing -> return []
|
||
|
|
Just r -> return [r]
|
||
|
|
Just acct -> do
|
||
|
|
response <-
|
||
|
|
makeZcashCall
|
||
|
|
user
|
||
|
|
pwd
|
||
|
|
"z_getbalanceforaccount"
|
||
|
|
[Number (Scientific.scientific acct 0)]
|
||
|
|
let rpcResp = decode response :: Maybe (RpcResponse UABalance)
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
case result res of
|
||
|
|
Nothing -> return [0, 0, 0]
|
||
|
|
Just r -> return $ readUABalance r
|
||
|
|
where readUABalance ua =
|
||
|
|
[uatransparent ua, uasapling ua, uaorchard ua]
|
||
|
|
|
||
|
|
-- | List transactions
|
||
|
|
listTxs :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [ZcashTx]
|
||
|
|
listTxs user pwd zaddy = do
|
||
|
|
response <-
|
||
|
|
makeZcashCall user pwd "z_listreceivedbyaddress" [String $ addy zaddy]
|
||
|
|
let rpcResp = decode response :: Maybe (RpcResponse [ZcashTx])
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "listTxs: Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
case result res of
|
||
|
|
Nothing -> fail "listTxs: Empty response"
|
||
|
|
Just res' -> return res'
|
||
|
|
|
||
|
|
-- | Send Tx
|
||
|
|
sendTx ::
|
||
|
|
BS.ByteString
|
||
|
|
-> BS.ByteString
|
||
|
|
-> ZcashAddress
|
||
|
|
-> T.Text
|
||
|
|
-> Double
|
||
|
|
-> Maybe T.Text
|
||
|
|
-> IO ()
|
||
|
|
sendTx user pwd fromAddy toAddy amount memo = do
|
||
|
|
bal <- getBalance user pwd fromAddy
|
||
|
|
let valAdd = validateAddress toAddy
|
||
|
|
if sum bal - floor (amount * 100000000) >= 1000
|
||
|
|
then do
|
||
|
|
if source fromAddy /= ImportedWatchOnly
|
||
|
|
then do
|
||
|
|
let privacyPolicy
|
||
|
|
| valAdd == Just Transparent = "AllowRevealedRecipients"
|
||
|
|
| isNothing (account fromAddy) &&
|
||
|
|
elem Transparent (pool fromAddy) = "AllowRevealedSenders"
|
||
|
|
| otherwise = "AllowRevealedAmounts"
|
||
|
|
let pd =
|
||
|
|
case memo of
|
||
|
|
Nothing ->
|
||
|
|
[ Data.Aeson.String (addy fromAddy)
|
||
|
|
, Data.Aeson.Array
|
||
|
|
(V.fromList
|
||
|
|
[object ["address" .= toAddy, "amount" .= amount]])
|
||
|
|
, Data.Aeson.Number $ Scientific.scientific 1 1
|
||
|
|
, Data.Aeson.Null
|
||
|
|
, Data.Aeson.String privacyPolicy
|
||
|
|
]
|
||
|
|
Just memo' ->
|
||
|
|
[ Data.Aeson.String (addy fromAddy)
|
||
|
|
, Data.Aeson.Array
|
||
|
|
(V.fromList
|
||
|
|
[ object
|
||
|
|
[ "address" .= toAddy
|
||
|
|
, "amount" .= amount
|
||
|
|
, "memo" .= encodeHexText' memo'
|
||
|
|
]
|
||
|
|
])
|
||
|
|
, Data.Aeson.Number $ Scientific.scientific 1 1
|
||
|
|
, Data.Aeson.Null
|
||
|
|
, Data.Aeson.String privacyPolicy
|
||
|
|
]
|
||
|
|
response <- makeZcashCall user pwd "z_sendmany" pd
|
||
|
|
let rpcResp = decode response :: Maybe (RpcResponse T.Text)
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
putStr " Sending."
|
||
|
|
checkOpResult user pwd (fromMaybe "" $ result res)
|
||
|
|
else putStrLn "Error: Source address is view-only."
|
||
|
|
else putStrLn "Error: Insufficient balance in source address."
|
||
|
|
|
||
|
|
-- | Check Zcash full node server
|
||
|
|
checkServer :: BS.ByteString -> BS.ByteString -> IO ()
|
||
|
|
checkServer user pwd = do
|
||
|
|
resp <- makeZcashCall user pwd "getinfo" []
|
||
|
|
let rpcResp = decode resp :: Maybe (RpcResponse NodeVersion)
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just myResp -> do
|
||
|
|
let r = result myResp
|
||
|
|
case r of
|
||
|
|
Nothing -> fail "Empty node response"
|
||
|
|
Just r' -> do
|
||
|
|
if isNodeValid r'
|
||
|
|
then putStrLn $ "Connected to Zcash Full Node (" <> show r <> ") :)"
|
||
|
|
else do
|
||
|
|
putStrLn "Deprecated Zcash Full Node version found. Exiting"
|
||
|
|
exitFailure
|
||
|
|
where isNodeValid (NodeVersion i) = i >= 5000000
|
||
|
|
|
||
|
|
-- | Check for accounts
|
||
|
|
checkAccounts :: BS.ByteString -> BS.ByteString -> IO Bool
|
||
|
|
checkAccounts user pwd = do
|
||
|
|
response <- makeZcashCall user pwd "z_listaccounts" []
|
||
|
|
let rpcResp = decode response :: Maybe (RpcResponse [Object])
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
let r = result res
|
||
|
|
return $ not (null r)
|
||
|
|
|
||
|
|
-- | Add account to node
|
||
|
|
createAccount :: BS.ByteString -> BS.ByteString -> IO ()
|
||
|
|
createAccount user pwd = do
|
||
|
|
response <- makeZcashCall user pwd "z_getnewaccount" []
|
||
|
|
let rpcResp = decode response :: Maybe (RpcResponse Object)
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
let r = result res
|
||
|
|
putStrLn " Account created!"
|
||
|
|
|
||
|
|
-- | Create new Unified Address
|
||
|
|
createUnifiedAddress :: BS.ByteString -> BS.ByteString -> Bool -> Bool -> IO ()
|
||
|
|
createUnifiedAddress user pwd tRec sRec = do
|
||
|
|
let recs = getReceivers tRec sRec
|
||
|
|
let pd = [Data.Aeson.Number $ Scientific.scientific 0 1, recs]
|
||
|
|
newResp <- makeZcashCall user pwd "z_getaddressforaccount" pd
|
||
|
|
let rpcResp = decode newResp :: Maybe (RpcResponse Object)
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
let r = result res
|
||
|
|
putStrLn " New UA created!"
|
||
|
|
where
|
||
|
|
getReceivers t s
|
||
|
|
| t && s =
|
||
|
|
Data.Aeson.Array
|
||
|
|
(V.fromList
|
||
|
|
[ Data.Aeson.String "p2pkh"
|
||
|
|
, Data.Aeson.String "sapling"
|
||
|
|
, Data.Aeson.String "orchard"
|
||
|
|
])
|
||
|
|
| t =
|
||
|
|
Data.Aeson.Array
|
||
|
|
(V.fromList [Data.Aeson.String "p2pkh", Data.Aeson.String "orchard"])
|
||
|
|
| s =
|
||
|
|
Data.Aeson.Array
|
||
|
|
(V.fromList [Data.Aeson.String "sapling", Data.Aeson.String "orchard"])
|
||
|
|
| otherwise = Data.Aeson.Array (V.fromList [Data.Aeson.String "orchard"])
|
||
|
|
|
||
|
|
-- | Verify operation result
|
||
|
|
checkOpResult :: BS.ByteString -> BS.ByteString -> T.Text -> IO ()
|
||
|
|
checkOpResult user pwd opid = do
|
||
|
|
response <-
|
||
|
|
makeZcashCall
|
||
|
|
user
|
||
|
|
pwd
|
||
|
|
"z_getoperationstatus"
|
||
|
|
[Data.Aeson.Array (V.fromList [Data.Aeson.String opid])]
|
||
|
|
let rpcResp = decode response :: Maybe (RpcResponse [OpResult])
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail "Couldn't parse node response"
|
||
|
|
Just res -> do
|
||
|
|
let r = result res
|
||
|
|
case r of
|
||
|
|
Nothing -> fail "Empty node response"
|
||
|
|
Just r' -> mapM_ showResult r'
|
||
|
|
where
|
||
|
|
showResult t =
|
||
|
|
case opsuccess t of
|
||
|
|
"success" ->
|
||
|
|
putStrLn $ " Success! Tx ID: " ++ maybe "" T.unpack (optxid t)
|
||
|
|
"executing" -> do
|
||
|
|
putStr "."
|
||
|
|
hFlush stdout
|
||
|
|
threadDelay 1000000 >> checkOpResult user pwd opid
|
||
|
|
_ -> putStrLn $ " Failed :( " ++ maybe "" T.unpack (opmessage t)
|
||
|
|
|
||
|
|
-- | Make a Zcash RPC call
|
||
|
|
makeZcashCall ::
|
||
|
|
BS.ByteString
|
||
|
|
-> BS.ByteString
|
||
|
|
-> T.Text
|
||
|
|
-> [Data.Aeson.Value]
|
||
|
|
-> IO LBS.ByteString
|
||
|
|
makeZcashCall username password m p = do
|
||
|
|
let payload = RpcCall "1.0" "test" m p
|
||
|
|
let myRequest =
|
||
|
|
setRequestBodyJSON payload $
|
||
|
|
setRequestPort 8232 $
|
||
|
|
setRequestBasicAuth username password $
|
||
|
|
setRequestMethod "POST" defaultRequest
|
||
|
|
response <- httpLBS myRequest
|
||
|
|
let respStatus = getResponseStatusCode response
|
||
|
|
let body = getResponseBody response
|
||
|
|
case respStatus of
|
||
|
|
500 -> do
|
||
|
|
let rpcResp = decode body :: Maybe (RpcResponse String)
|
||
|
|
case rpcResp of
|
||
|
|
Nothing -> fail $ "Unknown server error " ++ show response
|
||
|
|
Just x -> fail (fromMaybe "" $ result x)
|
||
|
|
401 -> fail "Incorrect full node credentials"
|
||
|
|
200 -> return body
|
||
|
|
_ -> fail "Unknown error"
|
||
|
|
|
||
|
|
-- | Read ZIP-321 URI
|
||
|
|
sendWithUri ::
|
||
|
|
BS.ByteString -> BS.ByteString -> ZcashAddress -> String -> Bool -> IO ()
|
||
|
|
sendWithUri user pwd fromAddy uri repTo = do
|
||
|
|
let uriRegex = mkRegex "^zcash:(\\w+)\\?amount=(.*)\\&memo=(.*)$"
|
||
|
|
if matchTest uriRegex uri
|
||
|
|
then do
|
||
|
|
let reg = matchAllText uriRegex uri
|
||
|
|
let parsedAddress = fst $ head reg A.! 1
|
||
|
|
let parsedAmount = fst $ head reg A.! 2
|
||
|
|
let parsedEncodedMemo = fst $ head reg A.! 3
|
||
|
|
let addType = validateAddress $ T.pack parsedAddress
|
||
|
|
case addType of
|
||
|
|
Nothing -> putStrLn " Invalid address"
|
||
|
|
Just Transparent -> do
|
||
|
|
putStrLn $ " Address is valid: " ++ parsedAddress
|
||
|
|
case (readMaybe parsedAmount :: Maybe Double) of
|
||
|
|
Nothing -> putStrLn " Invalid amount."
|
||
|
|
Just amt -> do
|
||
|
|
putStrLn $ " Valid ZEC amount: " ++ show amt
|
||
|
|
sendTx user pwd fromAddy (T.pack parsedAddress) amt Nothing
|
||
|
|
Just _ -> do
|
||
|
|
putStrLn $ " Address is valid: " ++ parsedAddress
|
||
|
|
case (readMaybe parsedAmount :: Maybe Double) of
|
||
|
|
Nothing -> putStrLn " Invalid amount."
|
||
|
|
Just amt -> do
|
||
|
|
putStrLn $ " Valid ZEC amount: " ++ show amt
|
||
|
|
let decodedMemo =
|
||
|
|
E.decodeUtf8With lenientDecode $
|
||
|
|
B64.decodeLenient $ C.pack parsedEncodedMemo
|
||
|
|
TIO.putStrLn $ " Memo: " <> decodedMemo
|
||
|
|
sendTx
|
||
|
|
user
|
||
|
|
pwd
|
||
|
|
fromAddy
|
||
|
|
(T.pack parsedAddress)
|
||
|
|
amt
|
||
|
|
(if repTo
|
||
|
|
then Just $
|
||
|
|
T.concat [decodedMemo, "\nReply-To:\n", addy fromAddy]
|
||
|
|
else Just decodedMemo)
|
||
|
|
else putStrLn "URI is not compliant with ZIP-321"
|
||
|
|
|
||
|
|
-- | Display an address
|
||
|
|
displayZcashAddress ::
|
||
|
|
BS.ByteString -> BS.ByteString -> (Int, ZcashAddress) -> IO ()
|
||
|
|
displayZcashAddress user pwd (idx, zaddy) = do
|
||
|
|
zats <- getBalance user pwd zaddy
|
||
|
|
putStr $ show idx ++ ": "
|
||
|
|
putStr $ show zaddy
|
||
|
|
when (source zaddy == ImportedWatchOnly) (putStr "[VK]")
|
||
|
|
putStr " Balance: "
|
||
|
|
mapM_ (putStr . displayZec) zats
|
||
|
|
putStrLn ""
|