zenith/src/Zenith/GUI.hs

739 lines
25 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-05-23 21:20:43 +00:00
import Control.Exception (throwIO, try)
import Control.Monad.Logger (runNoLoggingT)
2024-06-06 10:43:24 +00:00
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
2024-05-23 21:20:43 +00:00
import Data.Maybe (fromMaybe, isJust)
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-06-07 19:44:15 +00:00
import System.Hclip
2024-05-23 21:20:43 +00:00
import TextShow
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-06-06 10:43:24 +00:00
( UnifiedAddress(..)
, ZcashNet(..)
2024-05-23 21:20:43 +00:00
, ZebraGetBlockChainInfo(..)
, ZebraGetInfo(..)
)
import Zenith.Core
import Zenith.DB
2024-05-27 12:37:34 +00:00
import Zenith.GUI.Theme
import Zenith.Types hiding (ZcashAddress)
import Zenith.Utils (displayAmount, showAddress)
2024-05-23 21:20:43 +00:00
data AppEvent
= AppInit
| ShowMsg !T.Text
| CloseMsg
| WalletClicked
| AccountClicked
2024-06-14 21:06:55 +00:00
| MenuClicked
| NewClicked
| NewAddress
| NewAccount
| 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-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-17 19:27:00 +00:00
| ConfirmCancel
| SaveAddress
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-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)
, msgOverlay `nodeVisible` isJust (model ^. msg)
]
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]
, box_ [alignLeft] (label "Backup Wallet") `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
]) `styleBasic`
[bgColor btnColor, padding 3]
newBox =
box_
[alignMiddle]
(vstack
[ box_
[alignLeft, onClick NewAddress]
(hstack [label "Address", filler]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
, box_
[alignLeft, onClick NewAccount]
(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-05-27 12:37:34 +00:00
mainPane = box_ [alignMiddle] $ hstack [addressBox, txBox]
balanceBox =
2024-06-03 14:15:53 +00:00
hstack
[ filler
, boxShadow $
box_
[alignMiddle]
(vstack
[ animFadeIn
(label (displayAmount (model ^. network) $ model ^. balance) `styleBasic`
[textSize 20])
, hstack
[ filler
, remixIcon remixHourglassFill `styleBasic` [textSize 8]
, label
(maybe "0" (displayAmount (model ^. network)) $
model ^. unconfBalance) `styleBasic`
[textSize 8] `nodeVisible`
isJust (model ^. unconfBalance)
, filler
]
]) `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 ->
image_ "./assets/2620_color.png" [fitEither]) `styleBasic`
[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_
[onClick $ ShowMsg ("You clicked transaction " <> showt idx)]
(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]
, filler
, image_ "./assets/1F993.png" [fitHeight] `styleBasic`
[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 $
hstack [filler, 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-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
AppInit -> []
2024-06-14 21:06:55 +00:00
ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False]
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-17 19:27:00 +00:00
NewAddress ->
[ Model $
model & confirmTitle ?~ "New Address" & confirmAccept .~ "Create" &
confirmCancel .~
"Cancel"
]
2024-06-14 21:06:55 +00:00
NewAccount -> [Event $ ShowMsg "You clicked new account"]
NewWallet -> [Event $ ShowMsg "You clicked new wallet"]
2024-06-17 19:27:00 +00:00
ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""]
SaveAddress ->
[Event $ ShowMsg $ "You saved address: " <> model ^. mainInput]
SetPool p ->
[ Model $ model & selPool .~ p
, 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
, 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-06-07 19:44:15 +00:00
CopyAddr a ->
[ setClipboardData $
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!"
]
LoadTxs t -> [Model $ model & transactions .~ t]
2024-06-12 19:11:58 +00:00
LoadAddrs a -> [Model $ model & addresses .~ a, Event $ SetPool Orchard]
2024-06-14 21:06:55 +00:00
LoadAccs a -> [Model $ model & accounts .~ a, Event $ SwitchAcc 0]
2024-05-23 21:20:43 +00:00
CloseMsg -> [Model $ model & msg .~ 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-05-23 21:20:43 +00:00
runZenithGUI :: Config -> IO ()
runZenithGUI config = 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
2024-05-23 21:20:43 +00:00
walList <- getWallets pool $ zgb_net chainInfo
2024-05-27 12:37:34 +00:00
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
2024-05-27 12:37:34 +00:00
let model =
AppModel
config
(zgb_net chainInfo)
walList
0
accList
0
addrList
0
txList
0
Nothing
True
314259000
(Just 300000)
Orchard
qr
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
""
""
SaveAddress
2024-05-23 21:20:43 +00:00
startApp model handleEvent buildUI params
2024-05-27 12:37:34 +00:00
Left e -> do
initDb dbFilePath
let model =
AppModel
config
TestNet
[]
0
[]
0
[]
0
[]
0
(Just $
"Couldn't connect to Zebra on " <>
host <> ":" <> showt port <> ". Check your configuration.")
False
314259000
(Just 30000)
2024-06-06 10:43:24 +00:00
Orchard
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
""
""
SaveAddress
2024-05-27 12:37:34 +00:00
startApp model handleEvent buildUI params
2024-05-23 21:20:43 +00:00
where
params =
[ 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
, appFontDef "Regular" "./assets/Atkinson-Hyperlegible-Regular-102.ttf" --"./assets/DejaVuSansMono.ttf"
, appFontDef "Bold" "./assets/Atkinson-Hyperlegible-Bold-102.ttf"
, appFontDef "Italic" "./assets/Atkinson-Hyperlegible-Italic-102.ttf"
, appFontDef "Remix" "./assets/remixicon.ttf"
, appDisableAutoScale True
, appScaleFactor 2.0
2024-05-23 21:20:43 +00:00
, appInitEvent AppInit
]