zenith/src/Zenith/GUI.hs

312 lines
10 KiB
Haskell
Raw Normal View History

2024-05-23 21:20:43 +00:00
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module Zenith.GUI where
import Control.Exception (throwIO, try)
import Control.Monad.Logger (runNoLoggingT)
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
2024-06-03 14:15:53 +00:00
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
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-05-23 21:20:43 +00:00
import TextShow
import ZcashHaskell.Types
( ZcashNet(..)
, 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 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-05-23 21:20:43 +00:00
} deriving (Eq, Show)
makeLenses ''AppModel
data AppEvent
= AppInit
| ShowMsg !T.Text
| CloseMsg
2024-05-27 12:37:34 +00:00
| WalletClicked
| AccountClicked
2024-05-23 21:20:43 +00:00
deriving (Eq, Show)
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-05-23 21:20:43 +00:00
widgetTree =
2024-05-27 12:37:34 +00:00
zstack [mainWindow, msgOverlay `nodeVisible` isJust (model ^. msg)]
mainWindow =
vstack
[ windowHeader
, spacer
, balanceBox
, filler
, mainPane
, filler
, windowFooter
]
windowHeader =
hstack
[ box_ [onClick WalletClicked, alignMiddle] walletButton `styleBasic`
[cursorHand, height 25, padding 3] `styleHover`
[bgColor btnHiLite]
, box_ [onClick AccountClicked, alignMiddle] accountButton `styleBasic`
[cursorHand, height 25, padding 3] `styleHover`
[bgColor btnHiLite]
, 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]
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]
]
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]
]
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-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 "Addresses" `styleBasic`
[textFont "Bold", textColor white, bgColor btnColor]
2024-05-27 12:37:34 +00:00
, vscroll (vstack (zipWith addrRow [0 ..] (model ^. addresses))) `nodeKey`
"addrScroll"
]) `styleBasic`
2024-06-03 14:15:53 +00:00
[padding 3, radius 2, bgColor white]
2024-05-27 12:37:34 +00:00
addrRow :: Int -> Entity WalletAddress -> WidgetNode AppModel AppEvent
addrRow idx wAddr =
box_
2024-06-03 14:15:53 +00:00
[onClick $ ShowMsg ("You clicked address " <> showt 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]
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]
handleEvent ::
WidgetEnv AppModel AppEvent
-> WidgetNode AppModel AppEvent
-> AppModel
-> AppEvent
-> [AppEventResponse AppModel AppEvent]
handleEvent wenv node model evt =
case evt of
AppInit -> []
ShowMsg t -> [Model $ model & msg ?~ t]
2024-05-27 12:37:34 +00:00
WalletClicked -> [Model $ model & msg ?~ "You clicked Wallet!"]
AccountClicked -> [Model $ model & msg ?~ "You clicked Account!"]
2024-05-23 21:20:43 +00:00
CloseMsg -> [Model $ model & msg .~ Nothing]
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
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 []
let model =
AppModel
config
(zgb_net chainInfo)
walList
0
accList
0
addrList
0
txList
0
Nothing
True
314259000
(Just 300000)
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)
startApp model handleEvent buildUI params
2024-05-23 21:20:43 +00:00
where
params =
[ appWindowTitle "Zenith - Zcash Full Node Wallet"
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
]