Vergara_Tech
/
zenith
2
0
Fork 0
Code Issues 38 Pull Requests Packages Projects Releases 5 Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
CHANGELOG.md
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/),
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

4
app/Main.hs
View File

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

2
package.yaml
View File

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

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"

509
src/Zenith.hs → src/Zenith/Zcashd.hs
View File

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

4
stack.yaml
View File

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

26
stack.yaml.lock
View File

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

9
zenith.cabal
View File

@ -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 <https://git.vergara.tech/Vergara_Tech/zenith#readme>
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: