zenith/src/Zenith/Zcashd.hs

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