zenith/src/Zenith/GUI.hs

1414 lines
49 KiB
Haskell
Raw Normal View History

2024-05-23 21:20:43 +00:00
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module Zenith.GUI where
2024-06-06 10:43:24 +00:00
import Codec.Picture
import Codec.Picture.Types (pixelFold, promoteImage)
import Codec.QRCode
import Codec.QRCode.JuicyPixels
2024-07-04 12:37:41 +00:00
import Control.Concurrent (threadDelay)
2024-05-23 21:20:43 +00:00
import Control.Exception (throwIO, try)
2024-07-04 12:37:41 +00:00
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runFileLoggingT, runNoLoggingT)
2024-07-04 12:37:41 +00:00
import Data.Aeson
2024-06-06 10:43:24 +00:00
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
2024-06-27 14:19:26 +00:00
import Data.HexString (toText)
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
2024-05-23 21:20:43 +00:00
import qualified Data.Text as T
2024-06-06 10:43:24 +00:00
import qualified Data.Text.Encoding as E
2024-06-03 14:15:53 +00:00
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Database.Esqueleto.Experimental (ConnectionPool)
2024-05-23 21:20:43 +00:00
import Database.Persist
import Lens.Micro ((&), (+~), (.~), (?~), (^.), set)
import Lens.Micro.TH
import Monomer
2024-05-27 12:37:34 +00:00
import qualified Monomer.Lens as L
2024-07-12 16:30:12 +00:00
import System.Directory (getHomeDirectory)
import System.FilePath ((</>))
2024-06-07 19:44:15 +00:00
import System.Hclip
2024-07-04 12:37:41 +00:00
import Text.Printf
2024-06-27 14:19:26 +00:00
import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText)
import TextShow hiding (toText)
import ZcashHaskell.Keys (generateWalletSeedPhrase)
2024-06-06 10:43:24 +00:00
import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress)
import ZcashHaskell.Transparent (encodeTransparentReceiver)
2024-05-23 21:20:43 +00:00
import ZcashHaskell.Types
2024-07-04 12:37:41 +00:00
( BlockResponse(..)
, Phrase(..)
2024-06-19 20:37:56 +00:00
, Scope(..)
, ToBytes(..)
, UnifiedAddress(..)
2024-06-06 10:43:24 +00:00
, ZcashNet(..)
2024-05-23 21:20:43 +00:00
, ZebraGetBlockChainInfo(..)
, ZebraGetInfo(..)
)
2024-07-04 12:37:41 +00:00
import ZcashHaskell.Utils (getBlockTime, makeZebraCall)
2024-05-23 21:20:43 +00:00
import Zenith.Core
import Zenith.DB
2024-05-27 12:37:34 +00:00
import Zenith.GUI.Theme
2024-07-10 15:52:04 +00:00
import Zenith.Scanner (processTx, updateConfs)
2024-06-19 20:37:56 +00:00
import Zenith.Types hiding (ZcashAddress(..))
import Zenith.Utils
( displayAmount
, isRecipientValid
, jsonNumber
, parseAddress
, showAddress
, validBarValue
)
2024-05-23 21:20:43 +00:00
data AppEvent
= AppInit
| ShowMsg !T.Text
2024-06-17 20:47:56 +00:00
| ShowError !T.Text
2024-06-27 14:19:26 +00:00
| ShowModal !T.Text
| CloseMsg
| WalletClicked
| AccountClicked
2024-06-14 21:06:55 +00:00
| MenuClicked
| NewClicked
2024-06-24 15:34:46 +00:00
| NewAddress !(Maybe (Entity ZcashAccount))
| NewAccount !(Maybe (Entity ZcashWallet))
2024-06-14 21:06:55 +00:00
| NewWallet
| SetPool !ZcashPool
| SwitchQr !(Maybe QrCode)
| SwitchAddr !Int
2024-06-12 19:11:58 +00:00
| SwitchAcc !Int
2024-06-14 21:06:55 +00:00
| SwitchWal !Int
2024-07-08 20:17:53 +00:00
| UpdateBalance !(Integer, Integer)
2024-06-07 19:44:15 +00:00
| CopyAddr !(Maybe (Entity WalletAddress))
| LoadTxs ![Entity UserTx]
2024-06-12 19:11:58 +00:00
| LoadAddrs ![Entity WalletAddress]
2024-06-14 21:06:55 +00:00
| LoadAccs ![Entity ZcashAccount]
2024-06-27 14:19:26 +00:00
| LoadWallets ![Entity ZcashWallet]
2024-06-17 19:27:00 +00:00
| ConfirmCancel
2024-06-24 15:34:46 +00:00
| SaveAddress !(Maybe (Entity ZcashAccount))
| SaveAccount !(Maybe (Entity ZcashWallet))
2024-06-17 20:47:56 +00:00
| SaveWallet
2024-06-19 20:37:56 +00:00
| CloseSeed
| CloseTxId
2024-06-19 20:37:56 +00:00
| ShowSeed
| CopySeed !T.Text
2024-06-27 14:19:26 +00:00
| CopyTx !T.Text
| CloseTx
| ShowTx !Int
2024-07-04 12:37:41 +00:00
| TickUp
| SyncVal !Float
| SendTx
| ShowSend
| CancelSend
| CheckRecipient !T.Text
| CheckAmount !Float
| ShowTxId !T.Text
deriving (Eq, Show)
2024-05-23 21:20:43 +00:00
data AppModel = AppModel
2024-05-27 12:37:34 +00:00
{ _configuration :: !Config
, _network :: !ZcashNet
2024-05-23 21:20:43 +00:00
, _wallets :: ![Entity ZcashWallet]
2024-05-27 12:37:34 +00:00
, _selWallet :: !Int
, _accounts :: ![Entity ZcashAccount]
, _selAcc :: !Int
, _addresses :: ![Entity WalletAddress]
, _selAddr :: !Int
, _transactions :: ![Entity UserTx]
, _setTx :: !Int
2024-05-23 21:20:43 +00:00
, _msg :: !(Maybe T.Text)
2024-05-27 12:37:34 +00:00
, _zebraOn :: !Bool
, _balance :: !Integer
, _unconfBalance :: !(Maybe Integer)
2024-06-06 10:43:24 +00:00
, _selPool :: !ZcashPool
, _qrCodeWidget :: !(Maybe QrCode)
2024-06-12 19:11:58 +00:00
, _accPopup :: !Bool
2024-06-14 21:06:55 +00:00
, _walPopup :: !Bool
, _menuPopup :: !Bool
, _newPopup :: !Bool
2024-06-17 19:27:00 +00:00
, _mainInput :: !T.Text
, _confirmTitle :: !(Maybe T.Text)
, _confirmAccept :: !T.Text
, _confirmCancel :: !T.Text
, _confirmEvent :: !AppEvent
2024-06-17 20:47:56 +00:00
, _inError :: !Bool
2024-06-19 20:37:56 +00:00
, _showSeed :: !Bool
2024-06-27 14:19:26 +00:00
, _modalMsg :: !(Maybe T.Text)
, _showTx :: !(Maybe Int)
2024-07-04 12:37:41 +00:00
, _timer :: !Int
, _barValue :: !Float
, _openSend :: !Bool
, _sendRecipient :: !T.Text
, _sendAmount :: !Float
, _sendMemo :: !T.Text
, _recipientValid :: !Bool
, _amountValid :: !Bool
, _showId :: !(Maybe T.Text)
2024-07-12 16:30:12 +00:00
, _home :: !FilePath
2024-05-23 21:20:43 +00:00
} deriving (Eq, Show)
makeLenses ''AppModel
2024-05-27 12:37:34 +00:00
remixArrowRightWideLine :: T.Text
remixArrowRightWideLine = toGlyph 0xF496
remixHourglassFill :: T.Text
remixHourglassFill = toGlyph 0xF338
remixIcon :: T.Text -> WidgetNode s e
remixIcon i = label i `styleBasic` [textFont "Remix", textMiddle]
2024-05-23 21:20:43 +00:00
buildUI ::
WidgetEnv AppModel AppEvent -> AppModel -> WidgetNode AppModel AppEvent
buildUI wenv model = widgetTree
where
2024-06-03 14:15:53 +00:00
btnColor = rgbHex "#ff5722" --rgbHex "#1818B2"
2024-05-27 12:37:34 +00:00
btnHiLite = rgbHex "#207DE8"
currentWallet =
if null (model ^. wallets)
then Nothing
else Just ((model ^. wallets) !! (model ^. selWallet))
currentAccount =
if null (model ^. accounts)
then Nothing
else Just ((model ^. accounts) !! (model ^. selAcc))
2024-06-06 10:43:24 +00:00
currentAddress =
if null (model ^. addresses)
then Nothing
else Just ((model ^. addresses) !! (model ^. selAddr))
2024-05-23 21:20:43 +00:00
widgetTree =
2024-06-17 19:27:00 +00:00
zstack
[ mainWindow
, confirmOverlay `nodeVisible` isJust (model ^. confirmTitle)
2024-06-19 20:37:56 +00:00
, seedOverlay `nodeVisible` model ^. showSeed
2024-06-27 14:19:26 +00:00
, txOverlay `nodeVisible` isJust (model ^. showTx)
2024-07-04 12:37:41 +00:00
, sendTxOverlay `nodeVisible` model ^. openSend
, txIdOverlay `nodeVisible` isJust (model ^. showId)
2024-06-27 15:05:41 +00:00
, msgOverlay `nodeVisible` isJust (model ^. msg)
2024-06-27 14:19:26 +00:00
, modalOverlay `nodeVisible` isJust (model ^. modalMsg)
2024-06-17 19:27:00 +00:00
]
2024-05-27 12:37:34 +00:00
mainWindow =
vstack
[ windowHeader
, spacer
, balanceBox
, filler
, mainPane
, filler
, windowFooter
]
windowHeader =
hstack
2024-06-14 21:06:55 +00:00
[ vstack
[ box_
[onClick MenuClicked, alignMiddle]
(remixIcon remixMenuFill `styleBasic`
[textSize 16, textColor white]) `styleBasic`
[cursorHand, height 25, padding 3] `styleHover`
[bgColor btnHiLite]
, popup menuPopup menuBox
]
, vstack
[ box_ [onClick WalletClicked, alignMiddle] walletButton `styleBasic`
[cursorHand, height 25, padding 3] `styleHover`
[bgColor btnHiLite]
, popup walPopup walListPopup
]
2024-06-12 19:11:58 +00:00
, vstack
[ box_ [onClick AccountClicked, alignMiddle] accountButton `styleBasic`
[cursorHand, height 25, padding 3] `styleHover`
[bgColor btnHiLite]
, popup accPopup accListPopup
]
2024-05-27 12:37:34 +00:00
, filler
2024-06-03 14:15:53 +00:00
, remixIcon remixErrorWarningFill `styleBasic` [textColor white]
, label "Testnet" `styleBasic` [textColor white] `nodeVisible`
(model ^. network == TestNet)
2024-05-27 12:37:34 +00:00
] `styleBasic`
[bgColor btnColor]
2024-06-14 21:06:55 +00:00
menuBox =
box_
[alignMiddle]
(vstack
[ box_
[alignLeft]
(vstack
[ box_
[alignLeft, onClick NewClicked]
(hstack
[ label "New"
, filler
, widgetIf (not $ model ^. newPopup) $
remixIcon remixMenuUnfoldFill
, widgetIf (model ^. newPopup) $
remixIcon remixMenuFoldFill
])
, widgetIf (model ^. newPopup) $ animSlideIn newBox
]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
2024-06-19 20:37:56 +00:00
, box_ [alignLeft, onClick ShowSeed] (label "Backup Wallet") `styleBasic`
2024-06-14 21:06:55 +00:00
[bgColor white, borderB 1 gray, padding 3]
]) `styleBasic`
[bgColor btnColor, padding 3]
newBox =
box_
[alignMiddle]
(vstack
[ box_
2024-06-24 15:34:46 +00:00
[alignLeft, onClick $ NewAddress currentAccount]
2024-06-14 21:06:55 +00:00
(hstack [label "Address", filler]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
, box_
2024-06-24 15:34:46 +00:00
[alignLeft, onClick $ NewAccount currentWallet]
2024-06-14 21:06:55 +00:00
(hstack [label "Account", filler]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
, box_
[alignLeft, onClick NewWallet]
(hstack [label "Wallet", filler]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
])
2024-05-27 12:37:34 +00:00
walletButton =
hstack
[ label "Wallet: " `styleBasic` [textFont "Bold", textColor white]
, label (maybe "None" (zcashWalletName . entityVal) currentWallet) `styleBasic`
[textFont "Regular", textColor white]
, remixIcon remixArrowRightWideLine `styleBasic` [textColor white]
]
2024-06-14 21:06:55 +00:00
walListPopup =
box_ [alignMiddle] dispWalList `styleBasic` [bgColor btnColor, padding 3]
dispWalList = vstack (zipWith walRow [0 ..] (model ^. wallets))
walRow :: Int -> Entity ZcashWallet -> WidgetNode AppModel AppEvent
walRow idx wal =
box_
[onClick $ SwitchWal idx, alignCenter]
(label (zcashWalletName (entityVal wal))) `styleBasic`
[ padding 1
, borderB 1 gray
, bgColor white
, width 80
, styleIf (model ^. selWallet == idx) (borderL 2 btnHiLite)
, styleIf (model ^. selWallet == idx) (borderR 2 btnHiLite)
]
2024-05-27 12:37:34 +00:00
accountButton =
hstack
[ label "Account: " `styleBasic` [textFont "Bold", textColor white]
, label (maybe "None" (zcashAccountName . entityVal) currentAccount) `styleBasic`
[textFont "Regular", textColor white]
, remixIcon remixArrowRightWideLine `styleBasic` [textColor white]
]
2024-06-12 19:11:58 +00:00
accListPopup =
box_ [alignMiddle] dispAccList `styleBasic` [bgColor btnColor, padding 3]
dispAccList = vstack (zipWith accRow [0 ..] (model ^. accounts))
accRow :: Int -> Entity ZcashAccount -> WidgetNode AppModel AppEvent
accRow idx wAcc =
box_
[onClick $ SwitchAcc idx, alignLeft]
(label (zcashAccountName (entityVal wAcc))) `styleBasic`
[ padding 1
, borderB 1 gray
, bgColor white
2024-06-14 21:06:55 +00:00
, width 80
2024-06-12 19:11:58 +00:00
, styleIf (model ^. selAcc == idx) (borderL 2 btnHiLite)
, styleIf (model ^. selAcc == idx) (borderR 2 btnHiLite)
]
2024-06-19 20:37:56 +00:00
mainPane =
box_ [alignMiddle] $
hstack
2024-07-04 12:37:41 +00:00
[ addressBox
, vstack
2024-07-08 20:17:53 +00:00
[ mainButton "Send" ShowSend `styleBasic` [textFont "Bold"]
2024-07-04 12:37:41 +00:00
, txBox `nodeVisible` not (null $ model ^. transactions)
]
]
2024-05-27 12:37:34 +00:00
balanceBox =
2024-06-03 14:15:53 +00:00
hstack
[ filler
, boxShadow $
box_
[alignMiddle]
(vstack
2024-07-08 20:17:53 +00:00
[ hstack
[ filler
, animFadeIn
(label
(displayAmount (model ^. network) $ model ^. balance) `styleBasic`
[textSize 20])
, filler
]
2024-06-03 14:15:53 +00:00
, hstack
[ filler
, remixIcon remixHourglassFill `styleBasic` [textSize 8]
, label
(maybe "0" (displayAmount (model ^. network)) $
model ^. unconfBalance) `styleBasic`
2024-07-08 20:17:53 +00:00
[textSize 8]
2024-06-03 14:15:53 +00:00
, filler
2024-07-08 20:17:53 +00:00
] `nodeVisible`
isJust (model ^. unconfBalance)
2024-06-03 14:15:53 +00:00
]) `styleBasic`
[bgColor white, radius 5, border 1 btnColor]
, filler
]
2024-05-27 12:37:34 +00:00
addressBox =
2024-06-06 10:43:24 +00:00
vstack
2024-06-07 19:44:15 +00:00
[ boxShadow $
box_
2024-06-06 10:43:24 +00:00
[alignMiddle]
(vstack
[ label "Addresses" `styleBasic`
[textFont "Bold", textColor white, bgColor btnColor]
, vscroll (vstack (zipWith addrRow [0 ..] (model ^. addresses))) `nodeKey`
"addrScroll"
]) `styleBasic`
[padding 3, radius 2, bgColor white]
, addrQRCode
2024-06-06 10:43:24 +00:00
]
addrQRCode :: WidgetNode AppModel AppEvent
addrQRCode =
box_
[alignMiddle]
(hstack
[ filler
2024-06-07 19:44:15 +00:00
, boxShadow $
hstack
[ vstack
[ tooltip "Unified" $
box_
[onClick (SetPool Orchard)]
(remixIcon remixShieldCheckFill `styleBasic`
[ textSize 14
, padding 4
, styleIf
(model ^. selPool == Orchard)
(bgColor btnColor)
, styleIf
(model ^. selPool == Orchard)
(textColor white)
])
, filler
, tooltip "Legacy Shielded" $
box_
[onClick (SetPool Sapling)]
(remixIcon remixShieldLine `styleBasic`
[ textSize 14
, padding 4
, styleIf
(model ^. selPool == Sapling)
(bgColor btnColor)
, styleIf
(model ^. selPool == Sapling)
(textColor white)
])
, filler
, tooltip "Transparent" $
box_
[onClick (SetPool Transparent)]
(remixIcon remixEyeLine `styleBasic`
[ textSize 14
, padding 4
, styleIf
(model ^. selPool == Transparent)
(bgColor btnColor)
, styleIf
(model ^. selPool == Transparent)
(textColor white)
])
] `styleBasic`
[bgColor white]
, vstack
[ filler
, tooltip "Copy" $
box_
[onClick $ CopyAddr currentAddress]
(hstack
[ label
(case model ^. selPool of
Orchard -> "Unified"
Sapling -> "Legacy Shielded"
Transparent -> "Transparent"
Sprout -> "Unknown") `styleBasic`
[textColor white]
, remixIcon remixFileCopyFill `styleBasic`
[textSize 14, padding 4, textColor white]
]) `styleBasic`
[cursorHand]
, box_
[alignMiddle]
(case model ^. qrCodeWidget of
Just qr ->
imageMem_
(qrCodeName qr)
(qrCodeBytes qr)
(Size
(fromIntegral $ qrCodeHeight qr)
(fromIntegral $ qrCodeWidth qr))
[fitWidth]
Nothing ->
2024-07-12 16:30:12 +00:00
image_
(T.pack $
(model ^. home) </>
"Zenith/assets/1F928_color.png")
[fitEither]) `styleBasic`
2024-06-07 19:44:15 +00:00
[bgColor white, height 100, width 100]
, filler
] `styleBasic`
[bgColor btnColor, border 2 btnColor]
] `styleBasic`
2024-06-07 19:44:15 +00:00
[radius 3, border 1 btnColor]
, filler
2024-06-07 19:44:15 +00:00
])
2024-05-27 12:37:34 +00:00
addrRow :: Int -> Entity WalletAddress -> WidgetNode AppModel AppEvent
addrRow idx wAddr =
box_
[onClick $ SwitchAddr idx, alignLeft]
2024-05-27 12:37:34 +00:00
(label
(walletAddressName (entityVal wAddr) <>
2024-06-03 14:15:53 +00:00
": " <> showAddress (walletAddressUAddress $ entityVal wAddr))) `styleBasic`
[ padding 1
, borderB 1 gray
, styleIf (model ^. selAddr == idx) (borderL 2 btnHiLite)
, styleIf (model ^. selAddr == idx) (borderR 2 btnHiLite)
]
2024-05-27 12:37:34 +00:00
txBox =
2024-06-03 14:15:53 +00:00
boxShadow $
2024-05-27 12:37:34 +00:00
box_
[alignMiddle]
(vstack
2024-06-03 14:15:53 +00:00
[ label "Transactions" `styleBasic`
[textFont "Bold", bgColor btnColor, textColor white]
, vscroll (vstack (zipWith txRow [0 ..] (model ^. transactions))) `nodeKey`
"txScroll"
]) `styleBasic`
[radius 2, padding 3, bgColor white]
txRow :: Int -> Entity UserTx -> WidgetNode AppModel AppEvent
txRow idx tx =
box_
2024-06-27 14:19:26 +00:00
[onClick $ ShowTx idx]
2024-06-03 14:15:53 +00:00
(hstack
[ label
(T.pack $
show
(posixSecondsToUTCTime
(fromIntegral (userTxTime $ entityVal tx))))
, filler
, widgetIf
(T.length (userTxMemo $ entityVal tx) > 1)
(remixIcon remixDiscussFill)
, if 0 >= userTxAmount (entityVal tx)
then remixIcon remixArrowRightUpFill `styleBasic` [textColor red]
else remixIcon remixArrowRightDownFill `styleBasic`
[textColor green]
, label $
displayAmount (model ^. network) $
fromIntegral $ userTxAmount (entityVal tx)
2024-05-27 12:37:34 +00:00
]) `styleBasic`
2024-06-03 14:15:53 +00:00
[padding 2, borderB 1 gray]
2024-05-27 12:37:34 +00:00
windowFooter =
hstack
[ label
("Last block sync: " <>
maybe "N/A" (showt . zcashWalletLastSync . entityVal) currentWallet) `styleBasic`
[padding 3, textSize 8]
2024-07-04 12:37:41 +00:00
, spacer
, label (showt $ model ^. timer) `styleBasic` [padding 3, textSize 8]
2024-05-27 12:37:34 +00:00
, filler
2024-07-12 16:30:12 +00:00
, image_
(T.pack $ (model ^. home) </> "Zenith/assets/1F993.png")
[fitHeight] `styleBasic`
2024-05-27 12:37:34 +00:00
[height 24, width 24] `nodeVisible`
(model ^. zebraOn)
, label
("Connected on " <>
c_zebraHost (model ^. configuration) <>
":" <> showt (c_zebraPort $ model ^. configuration)) `styleBasic`
[padding 3, textSize 8] `nodeVisible`
(model ^. zebraOn)
, label "Disconnected" `styleBasic` [padding 3, textSize 8] `nodeVisible`
not (model ^. zebraOn)
2024-05-23 21:20:43 +00:00
]
msgOverlay =
alert CloseMsg $
2024-06-17 20:47:56 +00:00
hstack
[ filler
2024-06-19 20:37:56 +00:00
, remixIcon remixErrorWarningFill `styleBasic`
[textSize 32, textColor btnColor] `nodeVisible`
2024-06-17 20:47:56 +00:00
(model ^. inError)
2024-06-19 20:37:56 +00:00
, spacer
2024-06-17 20:47:56 +00:00
, label $ fromMaybe "" (model ^. msg)
, filler
]
2024-06-17 19:27:00 +00:00
confirmOverlay =
confirm_
(model ^. confirmEvent)
ConfirmCancel
[ titleCaption $ fromMaybe "" $ model ^. confirmTitle
, acceptCaption $ model ^. confirmAccept
, cancelCaption $ model ^. confirmCancel
]
(hstack [label "Name:", filler, textField_ mainInput [maxLength 25]])
2024-07-04 12:37:41 +00:00
sendTxOverlay =
box
2024-07-04 12:37:41 +00:00
(vstack
[ filler
2024-07-04 12:37:41 +00:00
, hstack
[ filler
, box_
[]
(vstack
[ box_
[alignMiddle]
(label "Send Zcash" `styleBasic`
[textFont "Bold", textSize 12])
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, hstack
[ label "To:" `styleBasic` [width 50]
, spacer
, textField_ sendRecipient [onChange CheckRecipient] `styleBasic`
[ width 150
, styleIf
(not $ model ^. recipientValid)
(textColor red)
]
]
, hstack
[ label "Amount:" `styleBasic` [width 50]
, spacer
, numericField_
sendAmount
[ decimals 8
, minValue 0.0
, maxValue
(fromIntegral (model ^. balance) / 100000000.0)
, validInput amountValid
, onChange CheckAmount
] `styleBasic`
[ width 150
, styleIf
(not $ model ^. amountValid)
(textColor red)
]
]
, hstack
[ label "Memo:" `styleBasic` [width 50]
, spacer
, textArea sendMemo `styleBasic`
[width 150, height 40]
]
, spacer
, box_
[alignMiddle]
(hstack
[ spacer
, button "Cancel" CancelSend
, spacer
, mainButton "Send" SendTx `nodeEnabled`
(model ^. amountValid && model ^. recipientValid)
, spacer
])
]) `styleBasic`
[radius 4, border 2 btnColor, bgColor white, padding 4]
2024-07-04 12:37:41 +00:00
, filler
]
, filler
]) `styleBasic`
[bgColor (white & L.a .~ 0.5)]
2024-06-19 20:37:56 +00:00
seedOverlay =
alert CloseSeed $
vstack
[ box_
[]
(label "Seed Phrase" `styleBasic`
[textFont "Bold", textSize 12, textColor white]) `styleBasic`
[bgColor btnColor, radius 2, padding 3]
, spacer
, textAreaV_
(maybe
"None"
(E.decodeUtf8Lenient .
getBytes . getPhrase . zcashWalletSeedPhrase . entityVal)
currentWallet)
(const CloseSeed)
[readOnly, maxLines 2] `styleBasic`
[textSize 8]
, spacer
, hstack
[ filler
, box_
[ onClick $
CopySeed $
maybe
"None"
(E.decodeUtf8Lenient .
getBytes . getPhrase . zcashWalletSeedPhrase . entityVal)
currentWallet
]
(hstack
[ label "Copy" `styleBasic` [textColor white]
, remixIcon remixFileCopyLine `styleBasic` [textColor white]
]) `styleBasic`
[cursorHand, bgColor btnColor, radius 2, padding 3]
, filler
]
]
2024-06-27 14:19:26 +00:00
modalOverlay =
box
(label (fromMaybe "?" $ model ^. modalMsg) `styleBasic`
[textSize 12, textFont "Bold"]) `styleBasic`
[bgColor (white & L.a .~ 0.5)]
txOverlay =
case model ^. showTx of
Nothing -> alert CloseTx $ label "N/A"
Just i ->
alert CloseTx $
vstack
[ box_
[alignLeft]
(hstack
[ label "Date " `styleBasic` [width 60, textFont "Bold"]
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, label
(T.pack $
show $
posixSecondsToUTCTime $
fromIntegral $
userTxTime $ entityVal $ (model ^. transactions) !! i)
]) `styleBasic`
[padding 2, bgColor white, width 280, borderB 1 gray]
, box_
[alignLeft]
(hstack
[ label "Tx ID " `styleBasic` [width 60, textFont "Bold"]
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, label_
(txtWrap $
toText $
getHex $
userTxHex $ entityVal $ (model ^. transactions) !! i)
[multiline]
2024-06-27 15:05:41 +00:00
, spacer
2024-06-27 14:19:26 +00:00
, box_
2024-06-27 15:05:41 +00:00
[ onClick $
CopyTx $
toText $
getHex $
userTxHex $ entityVal $ (model ^. transactions) !! i
]
2024-06-27 14:19:26 +00:00
(remixIcon remixFileCopyFill `styleBasic`
[textColor white]) `styleBasic`
2024-06-27 15:05:41 +00:00
[cursorHand, bgColor btnColor, radius 2, padding 2]
2024-06-27 14:19:26 +00:00
]) `styleBasic`
[padding 2, bgColor white, width 280, borderB 1 gray]
, box_
[alignLeft]
(hstack
[ label "Amount" `styleBasic` [width 60, textFont "Bold"]
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, label $
displayAmount (model ^. network) $
fromIntegral $
userTxAmount $ entityVal $ (model ^. transactions) !! i
]) `styleBasic`
[padding 2, bgColor white, width 280, borderB 1 gray]
, box_
[alignLeft]
(hstack
[ label "Memo " `styleBasic` [width 60, textFont "Bold"]
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, label_
(txtWrap $
userTxMemo $ entityVal $ (model ^. transactions) !! i)
[multiline]
]) `styleBasic`
[padding 2, bgColor white, width 280, borderB 1 gray]
]
txIdOverlay =
case model ^. showId of
Nothing -> alert CloseTxId $ label "N/A"
Just t ->
alert CloseTxId $
box_
[alignLeft]
(vstack
[ box_ [alignMiddle] $
label "Transaction Sent!" `styleBasic` [textFont "Bold"]
, spacer
, hstack
[ label "Tx ID " `styleBasic` [width 60, textFont "Bold"]
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, label_ (txtWrap t) [multiline]
, spacer
, box_
[onClick $ CopyTx t]
(remixIcon remixFileCopyFill `styleBasic`
[textColor white]) `styleBasic`
[cursorHand, bgColor btnColor, radius 2, padding 2]
]
]) `styleBasic`
[padding 2, bgColor white, width 280, borderB 1 gray, borderT 1 gray]
2024-05-23 21:20:43 +00:00
generateQRCodes :: Config -> IO ()
generateQRCodes config = do
let dbFilePath = c_dbPath config
pool <- runNoLoggingT $ initPool dbFilePath
addrs <- getExternalAddresses pool
mapM_ (checkExistingQrs pool) addrs
where
checkExistingQrs :: ConnectionPool -> Entity WalletAddress -> IO ()
checkExistingQrs pool wAddr = do
s <- getQrCodes pool (entityKey wAddr)
if not (null s)
then return ()
else do
generateOneQr pool Orchard wAddr
generateOneQr pool Sapling wAddr
generateOneQr pool Transparent wAddr
generateOneQr ::
ConnectionPool -> ZcashPool -> Entity WalletAddress -> IO ()
generateOneQr p zp wAddr =
case encodeText (defaultQRCodeOptions L) Utf8WithoutECI =<<
dispAddr zp (entityVal wAddr) of
Just qr -> do
_ <-
runNoLoggingT $
saveQrCode p $
QrCode
(entityKey wAddr)
zp
(qrCodeData qr)
(qrCodeH qr)
(qrCodeW qr)
(walletAddressName (entityVal wAddr) <> T.pack (show zp))
return ()
Nothing -> return ()
qrCodeImg :: QRImage -> Image PixelRGBA8
qrCodeImg qr = promoteImage (toImage 4 2 qr)
qrCodeH :: QRImage -> Int
qrCodeH qr = fromIntegral $ imageHeight $ qrCodeImg qr
qrCodeW :: QRImage -> Int
qrCodeW qr = fromIntegral $ imageWidth $ qrCodeImg qr
qrCodeData :: QRImage -> BS.ByteString
qrCodeData qr =
BS.pack $
pixelFold
(\bs _ _ (PixelRGBA8 i j k l) -> bs <> [i, j, k, l])
[]
(qrCodeImg qr)
dispAddr :: ZcashPool -> WalletAddress -> Maybe T.Text
dispAddr zp w =
case zp of
Transparent ->
T.append "zcash:" .
encodeTransparentReceiver
(maybe
TestNet
ua_net
((isValidUnifiedAddress .
E.encodeUtf8 . getUA . walletAddressUAddress)
w)) <$>
(t_rec =<<
(isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress)
w)
Sapling ->
T.append "zcash:" <$>
(getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress) w
Orchard -> Just $ (T.append "zcash:" . getUA . walletAddressUAddress) w
Sprout -> Nothing
2024-05-23 21:20:43 +00:00
handleEvent ::
WidgetEnv AppModel AppEvent
-> WidgetNode AppModel AppEvent
-> AppModel
-> AppEvent
-> [AppEventResponse AppModel AppEvent]
handleEvent wenv node model evt =
case evt of
2024-07-04 12:37:41 +00:00
AppInit ->
[Event NewWallet | isNothing currentWallet] <> [Producer timeTicker]
2024-06-14 21:06:55 +00:00
ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False]
2024-06-17 20:47:56 +00:00
ShowError t ->
[ Model $
model & msg ?~ t & menuPopup .~ False & inError .~ True & modalMsg .~
Nothing
]
2024-06-27 14:19:26 +00:00
ShowModal t -> [Model $ model & modalMsg ?~ t]
2024-06-14 21:06:55 +00:00
WalletClicked -> [Model $ model & walPopup .~ True]
2024-06-12 19:11:58 +00:00
AccountClicked -> [Model $ model & accPopup .~ True]
2024-06-14 21:06:55 +00:00
MenuClicked -> [Model $ model & menuPopup .~ True]
NewClicked -> [Model $ model & newPopup .~ not (model ^. newPopup)]
2024-06-24 15:34:46 +00:00
NewAddress acc ->
2024-06-17 19:27:00 +00:00
[ Model $
model & confirmTitle ?~ "New Address" & confirmAccept .~ "Create" &
confirmCancel .~
2024-06-17 20:47:56 +00:00
"Cancel" &
confirmEvent .~
2024-06-24 15:34:46 +00:00
SaveAddress acc &
2024-06-17 20:47:56 +00:00
menuPopup .~
False
]
2024-06-24 15:34:46 +00:00
NewAccount wal ->
2024-06-17 20:47:56 +00:00
[ Model $
model & confirmTitle ?~ "New Account" & confirmAccept .~ "Create" &
confirmCancel .~
"Cancel" &
confirmEvent .~
2024-06-24 15:34:46 +00:00
SaveAccount wal &
2024-06-17 20:47:56 +00:00
menuPopup .~
False
]
NewWallet ->
[ Model $
model & confirmTitle ?~ "New Wallet" & confirmAccept .~ "Create" &
confirmCancel .~
"Cancel" &
confirmEvent .~
SaveWallet &
menuPopup .~
False
2024-06-17 19:27:00 +00:00
]
ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""]
2024-06-19 20:37:56 +00:00
ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False]
2024-07-04 12:37:41 +00:00
ShowSend -> [Model $ model & openSend .~ True]
SendTx ->
case currentAccount of
2024-07-10 18:48:54 +00:00
Nothing -> [Event $ ShowError "No account available", Event CancelSend]
Just acc ->
case currentWallet of
2024-07-10 18:48:54 +00:00
Nothing ->
[Event $ ShowError "No wallet available", Event CancelSend]
Just wal ->
[ Producer $
sendTransaction
(model ^. configuration)
(model ^. network)
(entityKey acc)
(zcashWalletLastSync $ entityVal wal)
(model ^. sendAmount)
(model ^. sendRecipient)
(model ^. sendMemo)
2024-07-10 18:48:54 +00:00
, Event CancelSend
]
2024-07-04 12:37:41 +00:00
CancelSend ->
[ Model $
model & openSend .~ False & sendRecipient .~ "" & sendAmount .~ 0.0 &
sendMemo .~
""
]
2024-06-24 15:34:46 +00:00
SaveAddress acc ->
2024-06-19 20:37:56 +00:00
if T.length (model ^. mainInput) > 1
2024-06-24 15:34:46 +00:00
then [ Task $ addNewAddress (model ^. mainInput) External acc
2024-06-27 14:19:26 +00:00
, Event $ ShowModal "Generating QR codes..."
2024-06-24 15:34:46 +00:00
, Event ConfirmCancel
]
else [Event $ ShowError "Invalid input", Event ConfirmCancel]
SaveAccount wal ->
if T.length (model ^. mainInput) > 1
then [ Task $ addNewAccount (model ^. mainInput) wal
2024-06-19 20:37:56 +00:00
, Event ConfirmCancel
]
else [Event $ ShowError "Invalid input", Event ConfirmCancel]
2024-06-17 20:47:56 +00:00
SaveWallet ->
2024-06-27 14:19:26 +00:00
if T.length (model ^. mainInput) > 1
then [Task addNewWallet, Event ConfirmCancel]
else [Event $ ShowError "Invalid input"]
SetPool p ->
2024-06-27 14:19:26 +00:00
[ Model $ model & selPool .~ p & modalMsg .~ Nothing
, Task $
SwitchQr <$> do
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
case currentAddress of
Nothing -> return Nothing
Just wAddr -> getQrCode dbPool p $ entityKey wAddr
2024-06-07 19:44:15 +00:00
, Task $
LoadTxs <$> do
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
case currentAddress of
Nothing -> return []
Just wAddr -> getUserTx dbPool $ entityKey wAddr
]
SwitchQr q -> [Model $ model & qrCodeWidget .~ q]
SwitchAddr i -> [Model $ model & selAddr .~ i, Event $ SetPool Orchard]
2024-06-12 19:11:58 +00:00
SwitchAcc i ->
[ Model $ model & selAcc .~ i
, Task $
LoadAddrs <$> do
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
case selectAccount i of
Nothing -> return []
Just acc -> runNoLoggingT $ getAddresses dbPool $ entityKey acc
2024-07-08 20:17:53 +00:00
, Task $
UpdateBalance <$> do
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
case selectAccount i of
Nothing -> return (0, 0)
Just acc -> do
b <- getBalance dbPool $ entityKey acc
u <- getUnconfirmedBalance dbPool $ entityKey acc
return (b, u)
2024-06-12 19:11:58 +00:00
, Event $ SetPool Orchard
]
2024-06-14 21:06:55 +00:00
SwitchWal i ->
[ Model $ model & selWallet .~ i & selAcc .~ 0 & selAddr .~ 0
, Task $
LoadAccs <$> do
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
case selectWallet i of
Nothing -> return []
Just wal -> runNoLoggingT $ getAccounts dbPool $ entityKey wal
]
2024-07-08 20:17:53 +00:00
UpdateBalance (b, u) ->
[ Model $
model & balance .~ b & unconfBalance .~
(if u == 0
then Nothing
else Just u)
]
2024-06-07 19:44:15 +00:00
CopyAddr a ->
2024-06-27 14:19:26 +00:00
[ setClipboardData ClipboardEmpty
, setClipboardData $
2024-06-07 19:44:15 +00:00
ClipboardText $
case model ^. selPool of
Orchard -> maybe "None" (getUA . walletAddressUAddress . entityVal) a
Sapling ->
fromMaybe "None" $
(getSaplingFromUA .
E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<<
a
Sprout -> "None"
Transparent ->
maybe "None" (encodeTransparentReceiver (model ^. network)) $
t_rec =<<
(isValidUnifiedAddress .
E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<<
a
, Event $ ShowMsg "Copied address!"
]
2024-06-19 20:37:56 +00:00
CopySeed s ->
2024-06-27 14:19:26 +00:00
[ setClipboardData ClipboardEmpty
, setClipboardData $ ClipboardText s
2024-06-19 20:37:56 +00:00
, Event $ ShowMsg "Copied seed phrase!"
]
2024-06-27 14:19:26 +00:00
CopyTx t ->
[ setClipboardData ClipboardEmpty
, setClipboardData $ ClipboardText t
, Event $ ShowMsg "Copied transaction ID!"
]
2024-06-07 19:44:15 +00:00
LoadTxs t -> [Model $ model & transactions .~ t]
2024-06-24 15:34:46 +00:00
LoadAddrs a ->
if not (null a)
2024-06-27 14:19:26 +00:00
then [ Model $ model & addresses .~ a
, Event $ SwitchAddr $ model ^. selAddr
, Event $ SetPool Orchard
]
2024-06-24 15:34:46 +00:00
else [Event $ NewAddress currentAccount]
LoadAccs a ->
if not (null a)
then [Model $ model & accounts .~ a, Event $ SwitchAcc 0]
else [Event $ NewAccount currentWallet]
2024-06-27 14:19:26 +00:00
LoadWallets a ->
if not (null a)
2024-07-04 12:37:41 +00:00
then [ Model $ model & wallets .~ a
, Event $ SwitchWal $ model ^. selWallet
]
2024-06-27 14:19:26 +00:00
else [Event NewWallet]
2024-06-17 20:47:56 +00:00
CloseMsg -> [Model $ model & msg .~ Nothing & inError .~ False]
2024-06-19 20:37:56 +00:00
CloseSeed -> [Model $ model & showSeed .~ False]
2024-06-27 14:19:26 +00:00
CloseTx -> [Model $ model & showTx .~ Nothing]
CloseTxId -> [Model $ model & showId .~ Nothing]
2024-06-27 14:19:26 +00:00
ShowTx i -> [Model $ model & showTx ?~ i]
2024-07-04 12:37:41 +00:00
TickUp ->
if (model ^. timer) < 90
then [Model $ model & timer .~ (1 + model ^. timer)]
else if (model ^. barValue) == 1.0
then [ Model $ model & timer .~ 0 & barValue .~ 0.0
, Producer $
scanZebra
(c_dbPath $ model ^. configuration)
(c_zebraHost $ model ^. configuration)
(c_zebraPort $ model ^. configuration)
]
else [Model $ model & timer .~ 0]
SyncVal i ->
if (i + model ^. barValue) >= 0.999
then [ Model $ model & barValue .~ 1.0 & modalMsg .~ Nothing
, Task $ do
case currentWallet of
Nothing -> return $ ShowError "No wallet available"
Just cW -> do
syncWallet (model ^. configuration) cW
2024-07-23 18:46:37 +00:00
pool <-
runNoLoggingT $
initPool $ c_dbPath $ model ^. configuration
wL <- getWallets pool (model ^. network)
return $ LoadWallets wL
2024-07-04 12:37:41 +00:00
]
else [ Model $
model & barValue .~ validBarValue (i + model ^. barValue) &
modalMsg ?~
("Wallet Sync: " <>
T.pack (printf "%.2f%%" (model ^. barValue * 100)))
]
CheckRecipient a -> [Model $ model & recipientValid .~ isRecipientValid a]
CheckAmount i ->
2024-07-04 12:37:41 +00:00
[ Model $
model & amountValid .~
(i < (fromIntegral (model ^. balance) / 100000000.0))
2024-07-04 12:37:41 +00:00
]
ShowTxId tx -> [Model $ model & showId ?~ tx & modalMsg .~ Nothing]
where
currentWallet =
if null (model ^. wallets)
then Nothing
else Just ((model ^. wallets) !! (model ^. selWallet))
2024-06-14 21:06:55 +00:00
selectWallet i =
if null (model ^. wallets)
then Nothing
else Just ((model ^. wallets) !! i)
currentAccount =
if null (model ^. accounts)
then Nothing
else Just ((model ^. accounts) !! (model ^. selAcc))
2024-06-12 19:11:58 +00:00
selectAccount i =
if null (model ^. accounts)
then Nothing
else Just ((model ^. accounts) !! i)
currentAddress =
if null (model ^. addresses)
then Nothing
else Just ((model ^. addresses) !! (model ^. selAddr))
2024-06-19 20:37:56 +00:00
addNewAddress ::
T.Text -> Scope -> Maybe (Entity ZcashAccount) -> IO AppEvent
addNewAddress n scope acc = do
case acc of
Nothing -> return $ ShowError "No account available"
Just a -> do
pool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
maxAddr <- getMaxAddress pool (entityKey a) scope
uA <-
try $ createWalletAddress n (maxAddr + 1) (model ^. network) scope a :: IO
(Either IOError WalletAddress)
case uA of
Left e -> return $ ShowError $ "Error: " <> T.pack (show e)
Right uA' -> do
nAddr <- saveAddress pool uA'
case nAddr of
Nothing -> return $ ShowError $ "Address already exists: " <> n
Just _x -> do
generateQRCodes $ model ^. configuration
addrL <- runNoLoggingT $ getAddresses pool $ entityKey a
return $ LoadAddrs addrL
2024-06-24 15:34:46 +00:00
addNewAccount :: T.Text -> Maybe (Entity ZcashWallet) -> IO AppEvent
addNewAccount n w = do
case w of
Nothing -> return $ ShowError "No wallet available"
Just w' -> do
pool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
accIx <- getMaxAccount pool $ entityKey w'
newAcc <-
try $ createZcashAccount n (accIx + 1) w' :: IO
(Either IOError ZcashAccount)
case newAcc of
Left e -> return $ ShowError "Failed to create account"
Right newAcc' -> do
r <- saveAccount pool newAcc'
case r of
Nothing -> return $ ShowError "Account already exists"
Just _x -> do
aList <- runNoLoggingT $ getAccounts pool (entityKey w')
return $ LoadAccs aList
2024-06-27 14:19:26 +00:00
addNewWallet :: IO AppEvent
addNewWallet = do
sP <- generateWalletSeedPhrase
pool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
bc <-
try $
checkBlockChain
(c_zebraHost $ model ^. configuration)
(c_zebraPort $ model ^. configuration) :: IO
(Either IOError ZebraGetBlockChainInfo)
case bc of
Left e1 -> return $ ShowError $ T.pack $ show e1
Right chainInfo -> do
r <-
saveWallet pool $
ZcashWallet
(model ^. mainInput)
(ZcashNetDB (model ^. network))
(PhraseDB sP)
(zgb_blocks chainInfo)
0
case r of
Nothing -> return $ ShowError "Wallet already exists"
Just _ -> do
wL <- getWallets pool (model ^. network)
return $ LoadWallets wL
2024-07-04 12:37:41 +00:00
scanZebra :: T.Text -> T.Text -> Int -> (AppEvent -> IO ()) -> IO ()
scanZebra dbPath zHost zPort sendMsg = do
_ <- liftIO $ initDb dbPath
bStatus <- liftIO $ checkBlockChain zHost zPort
pool <- runNoLoggingT $ initPool dbPath
b <- liftIO $ getMinBirthdayHeight pool
dbBlock <- runNoLoggingT $ getMaxBlock pool
let sb = max dbBlock b
2024-07-10 15:52:04 +00:00
confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
case confUp of
Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions")
Right _ -> do
if sb > zgb_blocks bStatus || sb < 1
then sendMsg (ShowError "Invalid starting block for scan")
else do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
if not (null bList)
then do
let step = (1.0 :: Float) / fromIntegral (length bList)
mapM_ (processBlock pool step) bList
else sendMsg (SyncVal 1.0)
2024-07-04 12:37:41 +00:00
where
processBlock :: ConnectionPool -> Float -> Int -> IO ()
processBlock pool step bl = do
r <-
liftIO $
makeZebraCall
zHost
zPort
"getblock"
[Data.Aeson.String $ showt bl, jsonNumber 1]
case r of
Left e1 -> sendMsg (ShowError $ showt e1)
Right blk -> do
r2 <-
liftIO $
makeZebraCall
zHost
zPort
"getblock"
[Data.Aeson.String $ showt bl, jsonNumber 0]
case r2 of
Left e2 -> sendMsg (ShowError $ showt e2)
Right hb -> do
let blockTime = getBlockTime hb
mapM_ (runNoLoggingT . processTx zHost zPort blockTime pool) $
bl_txs $ addTime blk blockTime
sendMsg (SyncVal step)
addTime :: BlockResponse -> Int -> BlockResponse
addTime bl t =
BlockResponse
(bl_confirmations bl)
(bl_height bl)
(fromIntegral t)
(bl_txs bl)
sendTransaction ::
Config
-> ZcashNet
-> ZcashAccountId
-> Int
-> Float
-> T.Text
-> T.Text
-> (AppEvent -> IO ())
-> IO ()
sendTransaction config znet accId bl amt ua memo sendMsg = do
sendMsg $ ShowModal "Preparing transaction..."
case parseAddress ua znet of
Nothing -> sendMsg $ ShowError "Incorrect address"
Just outUA -> do
let dbPath = c_dbPath config
let zHost = c_zebraHost config
let zPort = c_zebraPort config
pool <- runNoLoggingT $ initPool dbPath
res <-
runFileLoggingT "zenith.log" $
prepareTx pool zHost zPort znet accId bl amt outUA memo
case res of
Left e -> sendMsg $ ShowError $ T.pack $ show e
Right rawTx -> do
sendMsg $ ShowModal "Transaction ready, sending to Zebra..."
resp <-
makeZebraCall
zHost
zPort
"sendrawtransaction"
[Data.Aeson.String $ toText rawTx]
case resp of
Left e1 -> sendMsg $ ShowError $ "Zebra error: " <> showt e1
Right txId -> sendMsg $ ShowTxId txId
2024-07-04 12:37:41 +00:00
timeTicker :: (AppEvent -> IO ()) -> IO ()
timeTicker sendMsg = do
sendMsg TickUp
threadDelay $ 1000 * 1000
timeTicker sendMsg
2024-06-27 14:19:26 +00:00
txtWrap :: T.Text -> T.Text
txtWrap = wrapText (WrapSettings False True NoFill FillAfterFirst) 32
2024-05-23 21:20:43 +00:00
runZenithGUI :: Config -> IO ()
runZenithGUI config = do
2024-07-12 16:30:12 +00:00
homeDir <- try getHomeDirectory :: IO (Either IOError FilePath)
case homeDir of
Left e -> print e
Right hD -> do
let host = c_zebraHost config
let port = c_zebraPort config
let dbFilePath = c_dbPath config
pool <- runNoLoggingT $ initPool dbFilePath
w <- try $ checkZebra host port :: IO (Either IOError ZebraGetInfo)
case w of
Right zebra -> do
bc <-
try $ checkBlockChain host port :: IO
(Either IOError ZebraGetBlockChainInfo)
case bc of
Left e1 -> throwIO e1
Right chainInfo -> do
initDb dbFilePath
generateQRCodes config
walList <- getWallets pool $ zgb_net chainInfo
accList <-
if not (null walList)
then runNoLoggingT $
getAccounts pool $ entityKey $ head walList
else return []
addrList <-
if not (null accList)
then runNoLoggingT $
getAddresses pool $ entityKey $ head accList
else return []
txList <-
if not (null addrList)
then getUserTx pool $ entityKey $ head addrList
else return []
qr <-
if not (null addrList)
then getQrCode pool Orchard $ entityKey $ head addrList
else return Nothing
bal <-
if not (null accList)
then getBalance pool $ entityKey $ head accList
else return 0
unconfBal <-
if not (null accList)
then getUnconfirmedBalance pool $ entityKey $ head accList
else return 0
let model =
AppModel
config
(zgb_net chainInfo)
walList
0
accList
0
addrList
0
txList
0
Nothing
True
bal
(if unconfBal == 0
then Nothing
else Just unconfBal)
Orchard
qr
False
False
False
False
""
Nothing
""
""
(SaveAddress $
if not (null accList)
then Just (head accList)
else Nothing)
False
False
Nothing
Nothing
0
1.0
False
""
0.0
""
False
False
Nothing
hD
startApp model handleEvent buildUI (params hD)
Left e -> do
2024-05-23 21:20:43 +00:00
initDb dbFilePath
2024-05-27 12:37:34 +00:00
let model =
AppModel
config
2024-07-12 16:30:12 +00:00
TestNet
[]
2024-05-27 12:37:34 +00:00
0
2024-07-12 16:30:12 +00:00
[]
2024-05-27 12:37:34 +00:00
0
2024-07-12 16:30:12 +00:00
[]
2024-05-27 12:37:34 +00:00
0
2024-07-12 16:30:12 +00:00
[]
2024-05-27 12:37:34 +00:00
0
2024-07-12 16:30:12 +00:00
(Just $
"Couldn't connect to Zebra on " <>
host <> ":" <> showt port <> ". Check your configuration.")
False
314259000
(Just 30000)
Orchard
2024-07-12 16:30:12 +00:00
Nothing
2024-06-12 19:11:58 +00:00
False
2024-06-14 21:06:55 +00:00
False
False
False
2024-06-17 19:27:00 +00:00
""
Nothing
""
""
2024-07-12 16:30:12 +00:00
(SaveAddress Nothing)
2024-06-17 20:47:56 +00:00
False
2024-06-19 20:37:56 +00:00
False
2024-06-27 14:19:26 +00:00
Nothing
Nothing
2024-07-04 12:37:41 +00:00
0
1.0
False
""
0.0
""
False
False
Nothing
2024-07-12 16:30:12 +00:00
hD
startApp model handleEvent buildUI (params hD)
2024-05-23 21:20:43 +00:00
where
2024-07-12 16:30:12 +00:00
params hd =
2024-05-23 21:20:43 +00:00
[ appWindowTitle "Zenith - Zcash Full Node Wallet"
2024-06-07 19:44:15 +00:00
, appWindowState $ MainWindowNormal (1000, 700)
2024-05-27 12:37:34 +00:00
, appTheme zenithTheme
2024-07-12 16:30:12 +00:00
, appFontDef
"Regular"
(T.pack $
hd </>
"Zenith/assets/Atkinson-Hyperlegible-Regular-102.ttf" --"./assets/DejaVuSansMono.ttf"
)
, appFontDef
"Bold"
(T.pack $ hd </> "Zenith/assets/Atkinson-Hyperlegible-Bold-102.ttf")
, appFontDef
"Italic"
(T.pack $ hd </> "Zenith/assets/Atkinson-Hyperlegible-Italic-102.ttf")
, appFontDef "Remix" (T.pack $ hd </> "Zenith/assets/remixicon.ttf")
2024-05-27 12:37:34 +00:00
, appDisableAutoScale True
, appScaleFactor 2.0
2024-05-23 21:20:43 +00:00
, appInitEvent AppInit
]