zenith/src/Zenith/Zcashd.hs

344 lines
12 KiB
Haskell
Raw Normal View History

{-# 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 ""