Milestone 2: Graphic User Interface #93

Merged
pitmutt merged 38 commits from milestone2 into master 2024-07-17 14:28:52 +00:00
4 changed files with 227 additions and 10 deletions
Showing only changes of commit a8d1333600 - Show all commits

View file

@ -25,7 +25,7 @@ import Brick.Forms
import qualified Brick.Main as M
import qualified Brick.Types as BT
import Brick.Types (Widget)
import Brick.Util (bg, clamp, fg, on, style)
import Brick.Util (bg, fg, on, style)
import qualified Brick.Widgets.Border as B
import Brick.Widgets.Border.Style (unicode, unicodeBold)
import qualified Brick.Widgets.Center as C
@ -97,7 +97,13 @@ import Zenith.Types
, UnifiedAddressDB(..)
, ZcashNetDB(..)
)
import Zenith.Utils (displayTaz, displayZec, jsonNumber, showAddress)
import Zenith.Utils
( displayTaz
, displayZec
, jsonNumber
, showAddress
, validBarValue
)
data Name
= WList
@ -589,9 +595,6 @@ barDoneAttr = A.attrName "done"
barToDoAttr :: A.AttrName
barToDoAttr = A.attrName "remaining"
validBarValue :: Float -> Float
validBarValue = clamp 0 1
scanZebra :: T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> IO ()
scanZebra dbP zHost zPort b eChan = do
_ <- liftIO $ initDb dbP

View file

@ -7,8 +7,11 @@ import Codec.Picture
import Codec.Picture.Types (pixelFold, promoteImage)
import Codec.QRCode
import Codec.QRCode.JuicyPixels
import Control.Concurrent (threadDelay)
import Control.Exception (throwIO, try)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runNoLoggingT)
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.HexString (toText)
@ -23,13 +26,15 @@ import Lens.Micro.TH
import Monomer
import qualified Monomer.Lens as L
import System.Hclip
import Text.Printf
import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText)
import TextShow hiding (toText)
import ZcashHaskell.Keys (generateWalletSeedPhrase)
import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress)
import ZcashHaskell.Transparent (encodeTransparentReceiver)
import ZcashHaskell.Types
( Phrase(..)
( BlockResponse(..)
, Phrase(..)
, Scope(..)
, ToBytes(..)
, UnifiedAddress(..)
@ -37,11 +42,13 @@ import ZcashHaskell.Types
, ZebraGetBlockChainInfo(..)
, ZebraGetInfo(..)
)
import ZcashHaskell.Utils (getBlockTime, makeZebraCall)
import Zenith.Core
import Zenith.DB
import Zenith.GUI.Theme
import Zenith.Scanner (processTx)
import Zenith.Types hiding (ZcashAddress(..))
import Zenith.Utils (displayAmount, showAddress)
import Zenith.Utils (displayAmount, jsonNumber, showAddress, validBarValue)
data AppEvent
= AppInit
@ -76,6 +83,13 @@ data AppEvent
| CopyTx !T.Text
| CloseTx
| ShowTx !Int
| TickUp
| SyncVal !Float
| SendTx
| ShowSend
| CancelSend
| CheckRecipient
| CheckAmount
deriving (Eq, Show)
data AppModel = AppModel
@ -108,6 +122,14 @@ data AppModel = AppModel
, _showSeed :: !Bool
, _modalMsg :: !(Maybe T.Text)
, _showTx :: !(Maybe Int)
, _timer :: !Int
, _barValue :: !Float
, _openSend :: !Bool
, _sendRecipient :: !T.Text
, _sendAmount :: !Float
, _sendMemo :: !T.Text
, _recipientValid :: !Bool
, _amountValid :: !Bool
} deriving (Eq, Show)
makeLenses ''AppModel
@ -145,6 +167,7 @@ buildUI wenv model = widgetTree
, confirmOverlay `nodeVisible` isJust (model ^. confirmTitle)
, seedOverlay `nodeVisible` model ^. showSeed
, txOverlay `nodeVisible` isJust (model ^. showTx)
, sendTxOverlay `nodeVisible` model ^. openSend
, msgOverlay `nodeVisible` isJust (model ^. msg)
, modalOverlay `nodeVisible` isJust (model ^. modalMsg)
]
@ -275,7 +298,12 @@ buildUI wenv model = widgetTree
mainPane =
box_ [alignMiddle] $
hstack
[addressBox, txBox `nodeVisible` not (null $ model ^. transactions)]
[ addressBox
, vstack
[ mainButton "Send" ShowSend
, txBox `nodeVisible` not (null $ model ^. transactions)
]
]
balanceBox =
hstack
[ filler
@ -456,6 +484,8 @@ buildUI wenv model = widgetTree
("Last block sync: " <>
maybe "N/A" (showt . zcashWalletLastSync . entityVal) currentWallet) `styleBasic`
[padding 3, textSize 8]
, spacer
, label (showt $ model ^. timer) `styleBasic` [padding 3, textSize 8]
, filler
, image_ "./assets/1F993.png" [fitHeight] `styleBasic`
[height 24, width 24] `nodeVisible`
@ -489,6 +519,31 @@ buildUI wenv model = widgetTree
, cancelCaption $ model ^. confirmCancel
]
(hstack [label "Name:", filler, textField_ mainInput [maxLength 25]])
sendTxOverlay =
confirm_
SendTx
CancelSend
[ titleCaption "Send Transaction"
, acceptCaption "Send"
, cancelCaption "Cancel"
]
(vstack
[ hstack
[ label "To:" `styleBasic` [width 50]
, filler
, textField_ sendRecipient []
]
, hstack
[ label "Amount:" `styleBasic` [width 50]
, filler
, numericField_ sendAmount [minValue 0.0, decimals 8]
]
, hstack
[ label "Memo:" `styleBasic` [width 50]
, filler
, textArea sendMemo
]
])
seedOverlay =
alert CloseSeed $
vstack
@ -679,7 +734,8 @@ handleEvent ::
-> [AppEventResponse AppModel AppEvent]
handleEvent wenv node model evt =
case evt of
AppInit -> [Event NewWallet | isNothing currentWallet]
AppInit ->
[Event NewWallet | isNothing currentWallet] <> [Producer timeTicker]
ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False]
ShowError t ->
[Model $ model & msg ?~ t & menuPopup .~ False & inError .~ True]
@ -720,6 +776,14 @@ handleEvent wenv node model evt =
]
ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""]
ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False]
ShowSend -> [Model $ model & openSend .~ True]
SendTx -> []
CancelSend ->
[ Model $
model & openSend .~ False & sendRecipient .~ "" & sendAmount .~ 0.0 &
sendMemo .~
""
]
SaveAddress acc ->
if T.length (model ^. mainInput) > 1
then [ Task $ addNewAddress (model ^. mainInput) External acc
@ -817,12 +881,53 @@ handleEvent wenv node model evt =
else [Event $ NewAccount currentWallet]
LoadWallets a ->
if not (null a)
then [Model $ model & wallets .~ a, Event $ SwitchWal 0]
then [ Model $ model & wallets .~ a
, Event $ SwitchWal $ model ^. selWallet
]
else [Event NewWallet]
CloseMsg -> [Model $ model & msg .~ Nothing & inError .~ False]
CloseSeed -> [Model $ model & showSeed .~ False]
CloseTx -> [Model $ model & showTx .~ Nothing]
ShowTx i -> [Model $ model & showTx ?~ i]
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
return $ SwitchAddr (model ^. selAddr)
, Task $ do
pool <-
runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
wL <- getWallets pool (model ^. network)
return $ LoadWallets wL
]
else [ Model $
model & barValue .~ validBarValue (i + model ^. barValue) &
modalMsg ?~
("Wallet Sync: " <>
T.pack (printf "%.2f%%" (model ^. barValue * 100)))
]
CheckRecipient -> []
CheckAmount ->
[ Model $
model & amountValid .~
((model ^. sendAmount) < (fromIntegral (model ^. balance) / 100000000.0))
]
where
currentWallet =
if null (model ^. wallets)
@ -911,6 +1016,64 @@ handleEvent wenv node model evt =
wL <- getWallets pool (model ^. network)
return $ LoadWallets wL
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
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)
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)
timeTicker :: (AppEvent -> IO ()) -> IO ()
timeTicker sendMsg = do
sendMsg TickUp
threadDelay $ 1000 * 1000
timeTicker sendMsg
txtWrap :: T.Text -> T.Text
txtWrap = wrapText (WrapSettings False True NoFill FillAfterFirst) 32
@ -982,6 +1145,14 @@ runZenithGUI config = do
False
Nothing
Nothing
0
1.0
False
""
0.0
""
False
False
startApp model handleEvent buildUI params
Left e -> do
initDb dbFilePath
@ -1018,6 +1189,14 @@ runZenithGUI config = do
False
Nothing
Nothing
0
1.0
False
""
0.0
""
False
False
startApp model handleEvent buildUI params
where
params =

View file

@ -78,6 +78,36 @@ zenithTheme =
baseTextStyle &
L.focusHover .
L.textFieldStyle . L.text ?~
baseTextStyle &
L.basic .
L.numericFieldStyle . L.text ?~
baseTextStyle &
L.hover .
L.numericFieldStyle . L.text ?~
baseTextStyle &
L.focus .
L.numericFieldStyle . L.text ?~
baseTextStyle &
L.active .
L.numericFieldStyle . L.text ?~
baseTextStyle &
L.focusHover .
L.numericFieldStyle . L.text ?~
baseTextStyle &
L.basic .
L.textAreaStyle . L.text ?~
baseTextStyle &
L.hover .
L.textAreaStyle . L.text ?~
baseTextStyle &
L.focus .
L.textAreaStyle . L.text ?~
baseTextStyle &
L.active .
L.textAreaStyle . L.text ?~
baseTextStyle &
L.focusHover .
L.textAreaStyle . L.text ?~
baseTextStyle
zenithThemeColors :: BaseThemeColors

View file

@ -5,6 +5,7 @@ module Zenith.Utils where
import Data.Aeson
import Data.Functor (void)
import Data.Maybe
import Data.Ord (clamp)
import Data.Scientific (Scientific(..), scientific)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
@ -79,3 +80,7 @@ copyAddress a =
void $
createProcess_ "toClipboard" $
shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard"
-- | Bound a value to the 0..1 range, used for progress reporting on UIs
validBarValue :: Float -> Float
validBarValue = clamp (0, 1)