Refactor existing code into modules

This commit is contained in:
Rene Vergara 2024-01-17 12:15:21 -06:00
parent dabd149df2
commit 9a7f191d1b
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
10 changed files with 469 additions and 426 deletions

View file

@ -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/), 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). 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] ## [0.4.0]
### Added ### Added

View file

@ -15,7 +15,9 @@ import System.Console.StructuredCLI
import System.Exit import System.Exit
import System.IO import System.IO
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Zenith import Zenith.Types (ZcashAddress(..), ZcashPool(..), ZcashTx(..))
import Zenith.Utils
import Zenith.Zcashd
prompt :: String -> IO String prompt :: String -> IO String
prompt text = do prompt text = do

View file

@ -1,5 +1,5 @@
name: zenith name: zenith
version: 0.4.0 version: 0.4.1
git: "https://git.vergara.tech/Vergara_Tech/zenith" git: "https://git.vergara.tech/Vergara_Tech/zenith"
license: BOSL license: BOSL
author: "Rene Vergara" author: "Rene Vergara"

1
src/Zenith/DB.hs Normal file
View file

@ -0,0 +1 @@
module Zenith.DB where

275
src/Zenith/Types.hs Normal file
View file

@ -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"

59
src/Zenith/Utils.hs Normal file
View file

@ -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"

View file

@ -1,24 +1,15 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Zenith where module Zenith.Zcashd where
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Monad import Control.Monad (when)
import Crypto.Hash.BLAKE2.BLAKE2b
import Data.Aeson import Data.Aeson
import Data.Aeson.Types
import qualified Data.Array as A import qualified Data.Array as A
import Data.Bits import qualified Data.ByteString as BS
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LBS
import Data.Char
import Data.Functor (void)
import Data.HexString
import Data.Maybe import Data.Maybe
import qualified Data.Scientific as Scientific import qualified Data.Scientific as Scientific
import qualified Data.Text as T import qualified Data.Text as T
@ -26,318 +17,31 @@ import qualified Data.Text.Encoding as E
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.IO as TIO import qualified Data.Text.IO as TIO
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Word
import GHC.Generics
import Network.HTTP.Simple import Network.HTTP.Simple
import Network.HTTP.Types
import Numeric
import System.Clipboard import System.Clipboard
import System.Exit import System.Exit
import System.IO import System.IO
import System.Process (createProcess_, shell)
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Text.Regex import Text.Regex
import Text.Regex.Base import Text.Regex.Base
import Text.Regex.Posix import Zenith.Types
import ZcashHaskell.Orchard (isValidUnifiedAddress) ( AddressGroup
import ZcashHaskell.Sapling (isValidShieldedAddress) , AddressSource(..)
, NodeVersion(..)
, OpResult(..)
, RpcCall(..)
, RpcResponse(..)
, UABalance(..)
, ZcashAddress(..)
, ZcashPool(..)
, ZcashTx
, encodeHexText'
)
import Zenith.Utils (displayZec, getAddresses, validateAddress)
-- | A type to model Zcash RPC calls -- * RPC methods
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
-- | List addresses -- | List addresses
listAddresses :: B.ByteString -> B.ByteString -> IO [ZcashAddress] listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
listAddresses user pwd = do listAddresses user pwd = do
response <- makeZcashCall user pwd "listaddresses" [] response <- makeZcashCall user pwd "listaddresses" []
let rpcResp = decode response :: Maybe (RpcResponse [AddressGroup]) let rpcResp = decode response :: Maybe (RpcResponse [AddressGroup])
@ -349,7 +53,7 @@ listAddresses user pwd = do
return addList return addList
-- | Get address balance -- | Get address balance
getBalance :: B.ByteString -> B.ByteString -> ZcashAddress -> IO [Integer] getBalance :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [Integer]
getBalance user pwd zadd = do getBalance user pwd zadd = do
let a = account zadd let a = account zadd
case a of case a of
@ -384,7 +88,7 @@ getBalance user pwd zadd = do
[uatransparent ua, uasapling ua, uaorchard ua] [uatransparent ua, uasapling ua, uaorchard ua]
-- | List transactions -- | List transactions
listTxs :: B.ByteString -> B.ByteString -> ZcashAddress -> IO [ZcashTx] listTxs :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [ZcashTx]
listTxs user pwd zaddy = do listTxs user pwd zaddy = do
response <- response <-
makeZcashCall user pwd "z_listreceivedbyaddress" [String $ addy zaddy] makeZcashCall user pwd "z_listreceivedbyaddress" [String $ addy zaddy]
@ -396,8 +100,8 @@ listTxs user pwd zaddy = do
-- | Send Tx -- | Send Tx
sendTx :: sendTx ::
B.ByteString BS.ByteString
-> B.ByteString -> BS.ByteString
-> ZcashAddress -> ZcashAddress
-> T.Text -> T.Text
-> Double -> Double
@ -450,80 +154,24 @@ sendTx user pwd fromAddy toAddy amount memo = do
else putStrLn "Error: Source address is view-only." else putStrLn "Error: Source address is view-only."
else putStrLn "Error: Insufficient balance in source address." else putStrLn "Error: Insufficient balance in source address."
-- | Make a Zcash RPC call -- | Check Zcash full node server
makeZcashCall :: checkServer :: BS.ByteString -> BS.ByteString -> IO ()
B.ByteString checkServer user pwd = do
-> B.ByteString resp <- makeZcashCall user pwd "getinfo" []
-> T.Text let rpcResp = decode resp :: Maybe (RpcResponse NodeVersion)
-> [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])
case rpcResp of case rpcResp of
Nothing -> fail "Couldn't parse node response" Nothing -> fail "Couldn't parse node response"
Just res -> do Just myResp -> do
let r = result res let r = result myResp
mapM_ showResult r if isNodeValid r
where then putStrLn $ "Connected to Zcash Full Node (" <> show r <> ") :)"
showResult t = else do
case opsuccess t of putStrLn "Deprecated Zcash Full Node version found. Exiting"
"success" -> exitFailure
putStrLn $ " Success! Tx ID: " ++ maybe "" T.unpack (optxid t) where isNodeValid (NodeVersion i) = i >= 5000000
"executing" -> do
putStr "."
hFlush stdout
threadDelay 1000000 >> checkOpResult user pwd opid
_ -> putStrLn $ " Failed :( " ++ maybe "" T.unpack (opmessage t)
-- | Check for accounts -- | Check for accounts
checkAccounts :: B.ByteString -> B.ByteString -> IO Bool checkAccounts :: BS.ByteString -> BS.ByteString -> IO Bool
checkAccounts user pwd = do checkAccounts user pwd = do
response <- makeZcashCall user pwd "z_listaccounts" [] response <- makeZcashCall user pwd "z_listaccounts" []
let rpcResp = decode response :: Maybe (RpcResponse [Object]) let rpcResp = decode response :: Maybe (RpcResponse [Object])
@ -534,7 +182,7 @@ checkAccounts user pwd = do
return $ not (null r) return $ not (null r)
-- | Add account to node -- | Add account to node
createAccount :: B.ByteString -> B.ByteString -> IO () createAccount :: BS.ByteString -> BS.ByteString -> IO ()
createAccount user pwd = do createAccount user pwd = do
response <- makeZcashCall user pwd "z_getnewaccount" [] response <- makeZcashCall user pwd "z_getnewaccount" []
let rpcResp = decode response :: Maybe (RpcResponse Object) let rpcResp = decode response :: Maybe (RpcResponse Object)
@ -545,7 +193,7 @@ createAccount user pwd = do
putStrLn " Account created!" putStrLn " Account created!"
-- | Create new Unified Address -- | 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 createUnifiedAddress user pwd tRec sRec = do
let recs = getReceivers tRec sRec let recs = getReceivers tRec sRec
let pd = [Data.Aeson.Number $ Scientific.scientific 0 1, recs] 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"]) (V.fromList [Data.Aeson.String "sapling", Data.Aeson.String "orchard"])
| otherwise = Data.Aeson.Array (V.fromList [Data.Aeson.String "orchard"]) | otherwise = Data.Aeson.Array (V.fromList [Data.Aeson.String "orchard"])
-- | Check Zcash full node server -- | Verify operation result
checkServer :: B.ByteString -> B.ByteString -> IO () checkOpResult :: BS.ByteString -> BS.ByteString -> T.Text -> IO ()
checkServer user pwd = do checkOpResult user pwd opid = do
resp <- makeZcashCall user pwd "getinfo" [] response <-
let rpcResp = decode resp :: Maybe (RpcResponse NodeVersion) makeZcashCall
user
pwd
"z_getoperationstatus"
[Data.Aeson.Array (V.fromList [Data.Aeson.String opid])]
let rpcResp = decode response :: Maybe (RpcResponse [OpResult])
case rpcResp of case rpcResp of
Nothing -> fail "Couldn't parse node response" Nothing -> fail "Couldn't parse node response"
Just myResp -> do Just res -> do
let r = result myResp let r = result res
if isNodeValid r mapM_ showResult r
then putStrLn $ "Connected to Zcash Full Node (" <> show r <> ") :)" where
else do showResult t =
putStrLn "Deprecated Zcash Full Node version found. Exiting" case opsuccess t of
exitFailure "success" ->
where isNodeValid (NodeVersion i) = i >= 5000000 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 -- | Read ZIP-321 URI
sendWithUri :: sendWithUri ::
B.ByteString -> B.ByteString -> ZcashAddress -> String -> Bool -> IO () BS.ByteString -> BS.ByteString -> ZcashAddress -> String -> Bool -> IO ()
sendWithUri user pwd fromAddy uri repTo = do sendWithUri user pwd fromAddy uri repTo = do
let uriRegex = mkRegex "^zcash:(\\w+)\\?amount=(.*)\\&memo=(.*)$" let uriRegex = mkRegex "^zcash:(\\w+)\\?amount=(.*)\\&memo=(.*)$"
if matchTest uriRegex uri if matchTest uriRegex uri
@ -631,3 +316,15 @@ sendWithUri user pwd fromAddy uri repTo = do
T.concat [decodedMemo, "\nReply-To:\n", addy fromAddy] T.concat [decodedMemo, "\nReply-To:\n", addy fromAddy]
else Just decodedMemo) else Just decodedMemo)
else putStrLn "URI is not compliant with ZIP-321" 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 ""

View file

@ -17,7 +17,7 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-21.6 resolver: lts-21.22
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.
@ -44,7 +44,7 @@ packages:
# extra-deps: [] # extra-deps: []
extra-deps: extra-deps:
- git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - 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 - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
- git: https://github.com/reach-sh/haskell-hexstring.git - git: https://github.com/reach-sh/haskell-hexstring.git

View file

@ -5,15 +5,15 @@
packages: packages:
- completed: - completed:
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 commit: 0858b805d066d0ce91dcc05594d929e63a99484e
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
name: zcash-haskell name: zcash-haskell
pantry-tree: pantry-tree:
sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21 sha256: 1f36dc81c65790bb090acc7b5337a149fe82dfeeea278c89033245cd85c462fc
size: 1126 size: 1430
version: 0.1.0 version: 0.4.1
original: original:
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 commit: 0858b805d066d0ce91dcc05594d929e63a99484e
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
- completed: - completed:
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
@ -56,22 +56,22 @@ packages:
original: original:
hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
- completed: - completed:
hackage: generically-0.1.1@sha256:aa00d9a77b7fb90c08f935699758ed9de55975021b1e979c6a4a4b5b49a940a9,1133 hackage: generically-0.1.1@sha256:378ec049bc2853b8011df116647fbd34bb9f00edce9840e4957f98abc097597c,1169
pantry-tree: pantry-tree:
sha256: ec19e6d2aecfbe7a59e789526b9d7ab5c8ba853f017248d0203ee69a9769adb7 sha256: 9f30503d1fe709f3849c5dd8b9751697a8db4d66105d7ba9c3b98bf4e36bb232
size: 233 size: 233
original: original:
hackage: generically-0.1.1 hackage: generically-0.1.1
- completed: - completed:
hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826 hackage: vector-algorithms-0.9.0.1@sha256:222b01a4c0b9e13d73d04fba7c65930df16d1647acc07d84c47ef0356fa33dba,3880
pantry-tree: pantry-tree:
sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0 sha256: f2442ae23235b332dcd8b593bb20bfae02890ec891330c060ac4a410a5f1d64d
size: 1510 size: 1510
original: original:
hackage: vector-algorithms-0.9.0.1 hackage: vector-algorithms-0.9.0.1
snapshots: snapshots:
- completed: - completed:
sha256: 2e7d4a730d8eb5373b2d383fac84efcf7c81e3b7a5fce71b4c2e19a1768f25a6 sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea
size: 640239 size: 640060
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml
original: lts-21.6 original: lts-21.22

View file

@ -1,11 +1,11 @@
cabal-version: 1.12 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 -- see: https://github.com/sol/hpack
name: zenith name: zenith
version: 0.4.0 version: 0.4.1
synopsis: Haskell CLI for Zcash Full Node synopsis: Haskell CLI for Zcash Full Node
description: Please see the README on repo at <https://git.vergara.tech/Vergara_Tech/zenith#readme> description: Please see the README on repo at <https://git.vergara.tech/Vergara_Tech/zenith#readme>
author: Rene Vergara author: Rene Vergara
@ -25,7 +25,10 @@ source-repository head
library library
exposed-modules: exposed-modules:
Zenith Zenith.DB
Zenith.Types
Zenith.Utils
Zenith.Zcashd
other-modules: other-modules:
Paths_zenith Paths_zenith
hs-source-dirs: hs-source-dirs: