diff --git a/CHANGELOG.md b/CHANGELOG.md index 1f8f2f6..490447a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,12 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.4.1] + +### Fixed + +- Handling of transactions to transparent receivers + ## [0.4.0] ### Added diff --git a/app/Main.hs b/app/Main.hs index 06a532e..906d1af 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -15,7 +15,9 @@ import System.Console.StructuredCLI import System.Exit import System.IO import Text.Read (readMaybe) -import Zenith +import Zenith.Types (ZcashAddress(..), ZcashPool(..), ZcashTx(..)) +import Zenith.Utils +import Zenith.Zcashd prompt :: String -> IO String prompt text = do diff --git a/package.yaml b/package.yaml index 09eaf30..8696224 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: zenith -version: 0.4.0 +version: 0.4.1 git: "https://git.vergara.tech/Vergara_Tech/zenith" license: BOSL author: "Rene Vergara" diff --git a/src/Zenith/DB.hs b/src/Zenith/DB.hs new file mode 100644 index 0000000..5218231 --- /dev/null +++ b/src/Zenith/DB.hs @@ -0,0 +1 @@ +module Zenith.DB where diff --git a/src/Zenith/Types.hs b/src/Zenith/Types.hs new file mode 100644 index 0000000..1ec4408 --- /dev/null +++ b/src/Zenith/Types.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +module Zenith.Types where + +import Data.Aeson +import Data.Aeson.Types (prependFailure, typeMismatch) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as C +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Text.Encoding.Error (lenientDecode) +import GHC.Generics + +-- | A type to model Zcash RPC calls +data RpcCall = RpcCall + { jsonrpc :: T.Text + , id :: T.Text + , method :: T.Text + , params :: [Value] + } deriving (Show, Generic, ToJSON, FromJSON) + +-- | Type for modelling the different address sources for Zcash 5.0.0 +data AddressSource + = LegacyRandom + | Imported + | ImportedWatchOnly + | KeyPool + | LegacySeed + | MnemonicSeed + deriving (Read, Show, Eq, Generic, ToJSON) + +instance FromJSON AddressSource where + parseJSON = + withText "AddressSource" $ \case + "legacy_random" -> return LegacyRandom + "imported" -> return Imported + "imported_watchonly" -> return ImportedWatchOnly + "keypool" -> return KeyPool + "legacy_hdseed" -> return LegacySeed + "mnemonic_seed" -> return MnemonicSeed + _ -> fail "Not a known address source" + +data ZcashPool + = Transparent + | Sprout + | Sapling + | Orchard + deriving (Show, Eq, Generic, ToJSON) + +instance FromJSON ZcashPool where + parseJSON = + withText "ZcashPool" $ \case + "p2pkh" -> return Transparent + "sprout" -> return Sprout + "sapling" -> return Sapling + "orchard" -> return Orchard + _ -> fail "Not a known Zcash pool" + +data ZcashAddress = ZcashAddress + { source :: AddressSource + , pool :: [ZcashPool] + , account :: Maybe Integer + , addy :: T.Text + } deriving (Eq) + +instance Show ZcashAddress where + show (ZcashAddress s p i a) = + T.unpack (T.take 8 a) ++ + "..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p + +-- | A type to model the response of the Zcash RPC +data RpcResponse r = RpcResponse + { err :: Maybe T.Text + , respId :: T.Text + , result :: r + } deriving (Show, Generic, ToJSON) + +instance (FromJSON r) => FromJSON (RpcResponse r) where + parseJSON (Object obj) = do + e <- obj .: "error" + rId <- obj .: "id" + r <- obj .: "result" + pure $ RpcResponse e rId r + parseJSON invalid = + prependFailure + "parsing RpcResponse failed, " + (typeMismatch "Object" invalid) + +newtype NodeVersion = + NodeVersion Integer + deriving (Eq, Show) + +instance FromJSON NodeVersion where + parseJSON = + withObject "NodeVersion" $ \obj -> do + v <- obj .: "version" + pure $ NodeVersion v + +-- | A type to model an address group +data AddressGroup = AddressGroup + { agsource :: !AddressSource + , agtransparent :: ![ZcashAddress] + , agsapling :: ![ZcashAddress] + , agunified :: ![ZcashAddress] + } deriving (Show, Generic) + +instance FromJSON AddressGroup where + parseJSON = + withObject "AddressGroup" $ \obj -> do + s <- obj .: "source" + t <- obj .:? "transparent" + sap <- obj .:? "sapling" + uni <- obj .:? "unified" + sL <- processSapling sap s + tL <- processTransparent t s + uL <- processUnified uni + return $ AddressGroup s tL (concat sL) (concat uL) + where + processTransparent c s1 = + case c of + Nothing -> return [] + Just x -> do + x' <- x .:? "addresses" + return $ maybe [] (map (ZcashAddress s1 [Transparent] Nothing)) x' + processSapling k s2 = + case k of + Nothing -> return [] + Just y -> mapM (processOneSapling s2) y + where processOneSapling sx = + withObject "Sapling" $ \oS -> do + oS' <- oS .: "addresses" + return $ map (ZcashAddress sx [Sapling] Nothing) oS' + processUnified u = + case u of + Nothing -> return [] + Just z -> mapM processOneAccount z + where processOneAccount = + withObject "UAs" $ \uS -> do + acct <- uS .: "account" + uS' <- uS .: "addresses" + mapM (processUAs acct) uS' + where + processUAs a = + withObject "UAs" $ \v -> do + addr <- v .: "address" + p <- v .: "receiver_types" + return $ ZcashAddress MnemonicSeed p a addr + +-- | A type to model a Zcash transaction +data ZcashTx = ZcashTx + { ztxid :: !T.Text + , zamount :: !Double + , zamountZat :: !Integer + , zblockheight :: !Integer + , zblocktime :: !Integer + , zchange :: !Bool + , zconfirmations :: !Integer + , zmemo :: !T.Text + } deriving (Show, Generic) + +instance FromJSON ZcashTx where + parseJSON = + withObject "ZcashTx" $ \obj -> do + t <- obj .: "txid" + a <- obj .: "amount" + aZ <- obj .: "amountZat" + bh <- obj .: "blockheight" + bt <- obj .: "blocktime" + c <- obj .:? "change" + conf <- obj .: "confirmations" + m <- obj .:? "memo" + pure $ + ZcashTx + t + a + aZ + bh + bt + (fromMaybe False c) + conf + (case m of + Nothing -> "" + Just m' -> T.filter (/= '\NUL') $ decodeHexText m') + +instance ToJSON ZcashTx where + toJSON (ZcashTx t a aZ bh bt c conf m) = + object + [ "amount" .= a + , "amountZat" .= aZ + , "txid" .= t + , "blockheight" .= bh + , "blocktime" .= bt + , "change" .= c + , "confirmations" .= conf + , "memo" .= m + ] + +-- | Type for the UA balance +data UABalance = UABalance + { uatransparent :: !Integer + , uasapling :: !Integer + , uaorchard :: !Integer + } deriving (Eq) + +instance Show UABalance where + show (UABalance t s o) = + " T: " ++ show t ++ " S: " ++ show s ++ " O: " ++ show o + +instance FromJSON UABalance where + parseJSON = + withObject "UABalance" $ \obj -> do + p <- obj .: "pools" + t <- p .:? "transparent" + s <- p .:? "sapling" + o <- p .:? "orchard" + vT <- + case t of + Nothing -> return 0 + Just t' -> t' .: "valueZat" + vS <- + case s of + Nothing -> return 0 + Just s' -> s' .: "valueZat" + vO <- + case o of + Nothing -> return 0 + Just o' -> o' .: "valueZat" + pure $ UABalance vT vS vO + +-- | Type for Operation Result +data OpResult = OpResult + { opsuccess :: !T.Text + , opmessage :: !(Maybe T.Text) + , optxid :: !(Maybe T.Text) + } deriving (Show, Eq) + +instance FromJSON OpResult where + parseJSON = + withObject "OpResult" $ \obj -> do + s <- obj .: "status" + r <- obj .:? "result" + e <- obj .:? "error" + t <- + case r of + Nothing -> return Nothing + Just r' -> r' .: "txid" + m <- + case e of + Nothing -> return Nothing + Just m' -> m' .: "message" + pure $ OpResult s m t + +-- * Helper functions +-- | Helper function to turn a hex-encoded memo strings to readable text +decodeHexText :: String -> T.Text +decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h + where + hexRead hexText + | null chunk = [] + | otherwise = + fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText) + where + chunk = take 2 hexText + +-- | Helper function to turn a text into a hex-encoded string +encodeHexText' :: T.Text -> String +encodeHexText' t = + if T.length t > 0 + then C.unpack . B64.encode $ E.encodeUtf8 t + else C.unpack . B64.encode $ E.encodeUtf8 "Sent from Zenith" diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs new file mode 100644 index 0000000..f2b42a4 --- /dev/null +++ b/src/Zenith/Utils.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenith.Utils where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import Data.Char +import Data.Functor (void) +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import qualified Data.Text.IO as TIO +import System.Process (createProcess_, shell) +import Text.Read (readMaybe) +import Text.Regex.Posix +import ZcashHaskell.Orchard (isValidUnifiedAddress) +import ZcashHaskell.Sapling (isValidShieldedAddress) +import Zenith.Types + ( AddressGroup(..) + , AddressSource(..) + , ZcashAddress(..) + , ZcashPool(..) + ) + +-- | Helper function to display small amounts of ZEC +displayZec :: Integer -> String +displayZec s + | s < 100 = show s ++ " zats " + | s < 100000 = show (fromIntegral s / 100) ++ " μZEC " + | s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC " + | otherwise = show (fromIntegral s / 100000000) ++ " ZEC " + +-- | Helper function to extract addresses from AddressGroups +getAddresses :: AddressGroup -> [ZcashAddress] +getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag + +-- | Helper function to validate potential Zcash addresses +validateAddress :: T.Text -> Maybe ZcashPool +validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk) + | tReg = Just Transparent + | sReg && chkS = Just Sapling + | uReg && chk = Just Orchard + | otherwise = Nothing + where + transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String + shieldedRegex = "^zs[a-zA-Z0-9]{76}$" :: String + unifiedRegex = "^u[a-zA-Z0-9]" :: String + tReg = T.unpack txt =~ transparentRegex :: Bool + sReg = T.unpack txt =~ shieldedRegex :: Bool + uReg = T.unpack txt =~ unifiedRegex :: Bool + chk = isJust $ isValidUnifiedAddress $ E.encodeUtf8 txt + chkS = isValidShieldedAddress $ E.encodeUtf8 txt + +-- | Copy an address to the clipboard +copyAddress :: ZcashAddress -> IO () +copyAddress a = + void $ + createProcess_ "toClipboard" $ + shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard" diff --git a/src/Zenith.hs b/src/Zenith/Zcashd.hs similarity index 50% rename from src/Zenith.hs rename to src/Zenith/Zcashd.hs index 08d184f..d82cd1e 100644 --- a/src/Zenith.hs +++ b/src/Zenith/Zcashd.hs @@ -1,24 +1,15 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -module Zenith where +module Zenith.Zcashd where import Control.Concurrent (threadDelay) -import Control.Monad -import Crypto.Hash.BLAKE2.BLAKE2b +import Control.Monad (when) import Data.Aeson -import Data.Aeson.Types import qualified Data.Array as A -import Data.Bits -import qualified Data.ByteString as B +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 LB -import Data.Char -import Data.Functor (void) -import Data.HexString +import qualified Data.ByteString.Lazy as LBS import Data.Maybe import qualified Data.Scientific as Scientific import qualified Data.Text as T @@ -26,318 +17,31 @@ 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 Data.Word -import GHC.Generics import Network.HTTP.Simple -import Network.HTTP.Types -import Numeric import System.Clipboard import System.Exit import System.IO -import System.Process (createProcess_, shell) import Text.Read (readMaybe) import Text.Regex import Text.Regex.Base -import Text.Regex.Posix -import ZcashHaskell.Orchard (isValidUnifiedAddress) -import ZcashHaskell.Sapling (isValidShieldedAddress) +import Zenith.Types + ( AddressGroup + , AddressSource(..) + , NodeVersion(..) + , OpResult(..) + , RpcCall(..) + , RpcResponse(..) + , UABalance(..) + , ZcashAddress(..) + , ZcashPool(..) + , ZcashTx + , encodeHexText' + ) +import Zenith.Utils (displayZec, getAddresses, validateAddress) --- | A type to model Zcash RPC calls -data RpcCall = RpcCall - { jsonrpc :: T.Text - , id :: T.Text - , method :: T.Text - , params :: [Value] - } deriving (Show, Generic, ToJSON, FromJSON) - --- | Type for modelling the different address sources for Zcash 5.0.0 -data AddressSource - = LegacyRandom - | Imported - | ImportedWatchOnly - | KeyPool - | LegacySeed - | MnemonicSeed - deriving (Read, Show, Eq, Generic, ToJSON) - -instance FromJSON AddressSource where - parseJSON = - withText "AddressSource" $ \case - "legacy_random" -> return LegacyRandom - "imported" -> return Imported - "imported_watchonly" -> return ImportedWatchOnly - "keypool" -> return KeyPool - "legacy_hdseed" -> return LegacySeed - "mnemonic_seed" -> return MnemonicSeed - _ -> fail "Not a known address source" - -data ZcashPool - = Transparent - | Sprout - | Sapling - | Orchard - deriving (Show, Eq, Generic, ToJSON) - -instance FromJSON ZcashPool where - parseJSON = - withText "ZcashPool" $ \case - "p2pkh" -> return Transparent - "sprout" -> return Sprout - "sapling" -> return Sapling - "orchard" -> return Orchard - _ -> fail "Not a known Zcash pool" - -data ZcashAddress = ZcashAddress - { source :: AddressSource - , pool :: [ZcashPool] - , account :: Maybe Integer - , addy :: T.Text - } deriving (Eq) - -instance Show ZcashAddress where - show (ZcashAddress s p i a) = - T.unpack (T.take 8 a) ++ - "..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p - --- | A type to model the response of the Zcash RPC -data RpcResponse r = RpcResponse - { err :: Maybe T.Text - , respId :: T.Text - , result :: r - } deriving (Show, Generic, ToJSON) - -instance (FromJSON r) => FromJSON (RpcResponse r) where - parseJSON (Object obj) = do - e <- obj .: "error" - rId <- obj .: "id" - r <- obj .: "result" - pure $ RpcResponse e rId r - parseJSON invalid = - prependFailure - "parsing RpcResponse failed, " - (typeMismatch "Object" invalid) - -newtype NodeVersion = - NodeVersion Integer - deriving (Eq, Show) - -instance FromJSON NodeVersion where - parseJSON = - withObject "NodeVersion" $ \obj -> do - v <- obj .: "version" - pure $ NodeVersion v - --- | A type to model an address group -data AddressGroup = AddressGroup - { agsource :: AddressSource - , agtransparent :: [ZcashAddress] - , agsapling :: [ZcashAddress] - , agunified :: [ZcashAddress] - } deriving (Show, Generic) - -instance FromJSON AddressGroup where - parseJSON = - withObject "AddressGroup" $ \obj -> do - s <- obj .: "source" - t <- obj .:? "transparent" - sap <- obj .:? "sapling" - uni <- obj .:? "unified" - sL <- processSapling sap s - tL <- processTransparent t s - uL <- processUnified uni - return $ AddressGroup s tL (concat sL) (concat uL) - where - processTransparent c s1 = - case c of - Nothing -> return [] - Just x -> do - x' <- x .:? "addresses" - return $ maybe [] (map (ZcashAddress s1 [Transparent] Nothing)) x' - processSapling k s2 = - case k of - Nothing -> return [] - Just y -> mapM (processOneSapling s2) y - where processOneSapling sx = - withObject "Sapling" $ \oS -> do - oS' <- oS .: "addresses" - return $ map (ZcashAddress sx [Sapling] Nothing) oS' - processUnified u = - case u of - Nothing -> return [] - Just z -> mapM processOneAccount z - where processOneAccount = - withObject "UAs" $ \uS -> do - acct <- uS .: "account" - uS' <- uS .: "addresses" - mapM (processUAs acct) uS' - where - processUAs a = - withObject "UAs" $ \v -> do - addr <- v .: "address" - p <- v .: "receiver_types" - return $ ZcashAddress MnemonicSeed p a addr - -displayZec :: Integer -> String -displayZec s - | s < 100 = show s ++ " zats " - | s < 100000 = show (fromIntegral s / 100) ++ " μZEC " - | s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC " - | otherwise = show (fromIntegral s / 100000000) ++ " ZEC " - --- | A type to model a Zcash transaction -data ZcashTx = ZcashTx - { ztxid :: T.Text - , zamount :: Double - , zamountZat :: Integer - , zblockheight :: Integer - , zblocktime :: Integer - , zchange :: Bool - , zconfirmations :: Integer - , zmemo :: T.Text - } deriving (Show, Generic) - -instance FromJSON ZcashTx where - parseJSON = - withObject "ZcashTx" $ \obj -> do - t <- obj .: "txid" - a <- obj .: "amount" - aZ <- obj .: "amountZat" - bh <- obj .: "blockheight" - bt <- obj .: "blocktime" - c <- obj .:? "change" - conf <- obj .: "confirmations" - m <- obj .:? "memo" - pure $ - ZcashTx - t - a - aZ - bh - bt - (fromMaybe False c) - conf - (case m of - Nothing -> "" - Just m' -> T.filter (/= '\NUL') $ decodeHexText m') - -instance ToJSON ZcashTx where - toJSON (ZcashTx t a aZ bh bt c conf m) = - object - [ "amount" .= a - , "amountZat" .= aZ - , "txid" .= t - , "blockheight" .= bh - , "blocktime" .= bt - , "change" .= c - , "confirmations" .= conf - , "memo" .= m - ] - --- | Type for the UA balance -data UABalance = UABalance - { uatransparent :: Integer - , uasapling :: Integer - , uaorchard :: Integer - } deriving (Eq) - -instance Show UABalance where - show (UABalance t s o) = - " T: " ++ show t ++ " S: " ++ show s ++ " O: " ++ show o - -instance FromJSON UABalance where - parseJSON = - withObject "UABalance" $ \obj -> do - p <- obj .: "pools" - t <- p .:? "transparent" - s <- p .:? "sapling" - o <- p .:? "orchard" - vT <- - case t of - Nothing -> return 0 - Just t' -> t' .: "valueZat" - vS <- - case s of - Nothing -> return 0 - Just s' -> s' .: "valueZat" - vO <- - case o of - Nothing -> return 0 - Just o' -> o' .: "valueZat" - pure $ UABalance vT vS vO - --- | Type for Operation Result -data OpResult = OpResult - { opsuccess :: T.Text - , opmessage :: Maybe T.Text - , optxid :: Maybe T.Text - } deriving (Show, Eq) - -instance FromJSON OpResult where - parseJSON = - withObject "OpResult" $ \obj -> do - s <- obj .: "status" - r <- obj .:? "result" - e <- obj .:? "error" - t <- - case r of - Nothing -> return Nothing - Just r' -> r' .: "txid" - m <- - case e of - Nothing -> return Nothing - Just m' -> m' .: "message" - pure $ OpResult s m t - --- | Helper function to turn a hex-encoded memo strings to readable text -decodeHexText :: String -> T.Text -decodeHexText h = E.decodeUtf8With lenientDecode $ B.pack $ hexRead h - where - hexRead hexText - | null chunk = [] - | otherwise = - fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText) - where - chunk = take 2 hexText - --- | Helper function to turn a string into a hex-encoded string -encodeHexText :: String -> String -encodeHexText t = mconcat (map padHex t) - where - padHex x = - if ord x < 16 - then "0" ++ (showHex . ord) x "" - else showHex (ord x) "" - -encodeHexText' :: T.Text -> String -encodeHexText' t = - if T.length t > 0 - then T.unpack . toText . fromBytes $ E.encodeUtf8 t - else T.unpack . toText . fromBytes $ E.encodeUtf8 "Sent from Zenith" - --- | Helper function to extract addresses from AddressGroups -getAddresses :: AddressGroup -> [ZcashAddress] -getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag - --- | Helper function to validate potential Zcash addresses -validateAddress :: T.Text -> Maybe ZcashPool -validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk) - | tReg = Just Transparent - | sReg && chkS = Just Sapling - | uReg && chk = Just Orchard - | otherwise = Nothing - where - transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String - shieldedRegex = "^zs[a-zA-Z0-9]{76}$" :: String - unifiedRegex = "^u[a-zA-Z0-9]" :: String - tReg = T.unpack txt =~ transparentRegex :: Bool - sReg = T.unpack txt =~ shieldedRegex :: Bool - uReg = T.unpack txt =~ unifiedRegex :: Bool - chk = isValidUnifiedAddress $ E.encodeUtf8 txt - chkS = isValidShieldedAddress $ E.encodeUtf8 txt - --- | RPC methods +-- * RPC methods -- | List addresses -listAddresses :: B.ByteString -> B.ByteString -> IO [ZcashAddress] +listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress] listAddresses user pwd = do response <- makeZcashCall user pwd "listaddresses" [] let rpcResp = decode response :: Maybe (RpcResponse [AddressGroup]) @@ -349,7 +53,7 @@ listAddresses user pwd = do return addList -- | Get address balance -getBalance :: B.ByteString -> B.ByteString -> ZcashAddress -> IO [Integer] +getBalance :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [Integer] getBalance user pwd zadd = do let a = account zadd case a of @@ -384,7 +88,7 @@ getBalance user pwd zadd = do [uatransparent ua, uasapling ua, uaorchard ua] -- | List transactions -listTxs :: B.ByteString -> B.ByteString -> ZcashAddress -> IO [ZcashTx] +listTxs :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [ZcashTx] listTxs user pwd zaddy = do response <- makeZcashCall user pwd "z_listreceivedbyaddress" [String $ addy zaddy] @@ -396,8 +100,8 @@ listTxs user pwd zaddy = do -- | Send Tx sendTx :: - B.ByteString - -> B.ByteString + BS.ByteString + -> BS.ByteString -> ZcashAddress -> T.Text -> Double @@ -450,80 +154,24 @@ sendTx user pwd fromAddy toAddy amount memo = do else putStrLn "Error: Source address is view-only." else putStrLn "Error: Insufficient balance in source address." --- | Make a Zcash RPC call -makeZcashCall :: - B.ByteString - -> B.ByteString - -> T.Text - -> [Data.Aeson.Value] - -> IO LB.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 (result x) - 401 -> fail "Incorrect full node credentials" - 200 -> return body - _ -> fail "Unknown error" - --- | Display an address -displayZcashAddress :: - B.ByteString -> B.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 "" - --- | Copy an address to the clipboard -copyAddress :: ZcashAddress -> IO () -copyAddress a = - void $ - createProcess_ "toClipboard" $ - shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard" - --- | Verify operation result -checkOpResult :: B.ByteString -> B.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]) +-- | 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 res -> do - let r = result res - 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) + Just myResp -> do + let r = result myResp + 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 :: B.ByteString -> B.ByteString -> IO Bool +checkAccounts :: BS.ByteString -> BS.ByteString -> IO Bool checkAccounts user pwd = do response <- makeZcashCall user pwd "z_listaccounts" [] let rpcResp = decode response :: Maybe (RpcResponse [Object]) @@ -534,7 +182,7 @@ checkAccounts user pwd = do return $ not (null r) -- | Add account to node -createAccount :: B.ByteString -> B.ByteString -> IO () +createAccount :: BS.ByteString -> BS.ByteString -> IO () createAccount user pwd = do response <- makeZcashCall user pwd "z_getnewaccount" [] let rpcResp = decode response :: Maybe (RpcResponse Object) @@ -545,7 +193,7 @@ createAccount user pwd = do putStrLn " Account created!" -- | Create new Unified Address -createUnifiedAddress :: B.ByteString -> B.ByteString -> Bool -> Bool -> IO () +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] @@ -573,25 +221,62 @@ createUnifiedAddress user pwd tRec sRec = do (V.fromList [Data.Aeson.String "sapling", Data.Aeson.String "orchard"]) | otherwise = Data.Aeson.Array (V.fromList [Data.Aeson.String "orchard"]) --- | Check Zcash full node server -checkServer :: B.ByteString -> B.ByteString -> IO () -checkServer user pwd = do - resp <- makeZcashCall user pwd "getinfo" [] - let rpcResp = decode resp :: Maybe (RpcResponse NodeVersion) +-- | 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 myResp -> do - let r = result myResp - 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 + Just res -> do + let r = result res + 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 (result x) + 401 -> fail "Incorrect full node credentials" + 200 -> return body + _ -> fail "Unknown error" -- | Read ZIP-321 URI sendWithUri :: - B.ByteString -> B.ByteString -> ZcashAddress -> String -> Bool -> IO () + 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 @@ -631,3 +316,15 @@ sendWithUri user pwd fromAddy uri repTo = do 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 "" diff --git a/stack.yaml b/stack.yaml index e202242..fa604ae 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.6 +resolver: lts-21.22 # User packages to be built. # Various formats can be used as shown in the example below. @@ -44,7 +44,7 @@ packages: # extra-deps: [] extra-deps: - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + commit: 0858b805d066d0ce91dcc05594d929e63a99484e - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - git: https://github.com/reach-sh/haskell-hexstring.git diff --git a/stack.yaml.lock b/stack.yaml.lock index f92b46d..ce8c103 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,15 +5,15 @@ packages: - completed: - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + commit: 0858b805d066d0ce91dcc05594d929e63a99484e git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git name: zcash-haskell pantry-tree: - sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21 - size: 1126 - version: 0.1.0 + sha256: 1f36dc81c65790bb090acc7b5337a149fe82dfeeea278c89033245cd85c462fc + size: 1430 + version: 0.4.1 original: - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 + commit: 0858b805d066d0ce91dcc05594d929e63a99484e git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - completed: commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 @@ -56,22 +56,22 @@ packages: original: hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 - completed: - hackage: generically-0.1.1@sha256:aa00d9a77b7fb90c08f935699758ed9de55975021b1e979c6a4a4b5b49a940a9,1133 + hackage: generically-0.1.1@sha256:378ec049bc2853b8011df116647fbd34bb9f00edce9840e4957f98abc097597c,1169 pantry-tree: - sha256: ec19e6d2aecfbe7a59e789526b9d7ab5c8ba853f017248d0203ee69a9769adb7 + sha256: 9f30503d1fe709f3849c5dd8b9751697a8db4d66105d7ba9c3b98bf4e36bb232 size: 233 original: hackage: generically-0.1.1 - completed: - hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826 + hackage: vector-algorithms-0.9.0.1@sha256:222b01a4c0b9e13d73d04fba7c65930df16d1647acc07d84c47ef0356fa33dba,3880 pantry-tree: - sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0 + sha256: f2442ae23235b332dcd8b593bb20bfae02890ec891330c060ac4a410a5f1d64d size: 1510 original: hackage: vector-algorithms-0.9.0.1 snapshots: - completed: - sha256: 2e7d4a730d8eb5373b2d383fac84efcf7c81e3b7a5fce71b4c2e19a1768f25a6 - size: 640239 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml - original: lts-21.6 + sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea + size: 640060 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml + original: lts-21.22 diff --git a/zenith.cabal b/zenith.cabal index a2a59ee..ba62cc3 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: zenith -version: 0.4.0 +version: 0.4.1 synopsis: Haskell CLI for Zcash Full Node description: Please see the README on repo at author: Rene Vergara @@ -25,7 +25,10 @@ source-repository head library exposed-modules: - Zenith + Zenith.DB + Zenith.Types + Zenith.Utils + Zenith.Zcashd other-modules: Paths_zenith hs-source-dirs: