Milestone 2: Graphic User Interface #93

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

BIN
assets/1F928_color.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 10 KiB

View file

@ -11,7 +11,8 @@ import Control.Exception (throwIO, try)
import Control.Monad.Logger (runNoLoggingT) import Control.Monad.Logger (runNoLoggingT)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.Maybe (fromMaybe, isJust) import Data.HexString (toText)
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
@ -22,7 +23,9 @@ import Lens.Micro.TH
import Monomer import Monomer
import qualified Monomer.Lens as L import qualified Monomer.Lens as L
import System.Hclip import System.Hclip
import TextShow import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText)
import TextShow hiding (toText)
import ZcashHaskell.Keys (generateWalletSeedPhrase)
import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress)
import ZcashHaskell.Transparent (encodeTransparentReceiver) import ZcashHaskell.Transparent (encodeTransparentReceiver)
import ZcashHaskell.Types import ZcashHaskell.Types
@ -44,6 +47,7 @@ data AppEvent
= AppInit = AppInit
| ShowMsg !T.Text | ShowMsg !T.Text
| ShowError !T.Text | ShowError !T.Text
| ShowModal !T.Text
| CloseMsg | CloseMsg
| WalletClicked | WalletClicked
| AccountClicked | AccountClicked
@ -61,6 +65,7 @@ data AppEvent
| LoadTxs ![Entity UserTx] | LoadTxs ![Entity UserTx]
| LoadAddrs ![Entity WalletAddress] | LoadAddrs ![Entity WalletAddress]
| LoadAccs ![Entity ZcashAccount] | LoadAccs ![Entity ZcashAccount]
| LoadWallets ![Entity ZcashWallet]
| ConfirmCancel | ConfirmCancel
| SaveAddress !(Maybe (Entity ZcashAccount)) | SaveAddress !(Maybe (Entity ZcashAccount))
| SaveAccount !(Maybe (Entity ZcashWallet)) | SaveAccount !(Maybe (Entity ZcashWallet))
@ -68,6 +73,9 @@ data AppEvent
| CloseSeed | CloseSeed
| ShowSeed | ShowSeed
| CopySeed !T.Text | CopySeed !T.Text
| CopyTx !T.Text
| CloseTx
| ShowTx !Int
deriving (Eq, Show) deriving (Eq, Show)
data AppModel = AppModel data AppModel = AppModel
@ -98,6 +106,8 @@ data AppModel = AppModel
, _confirmEvent :: !AppEvent , _confirmEvent :: !AppEvent
, _inError :: !Bool , _inError :: !Bool
, _showSeed :: !Bool , _showSeed :: !Bool
, _modalMsg :: !(Maybe T.Text)
, _showTx :: !(Maybe Int)
} deriving (Eq, Show) } deriving (Eq, Show)
makeLenses ''AppModel makeLenses ''AppModel
@ -135,6 +145,8 @@ buildUI wenv model = widgetTree
, confirmOverlay `nodeVisible` isJust (model ^. confirmTitle) , confirmOverlay `nodeVisible` isJust (model ^. confirmTitle)
, seedOverlay `nodeVisible` model ^. showSeed , seedOverlay `nodeVisible` model ^. showSeed
, msgOverlay `nodeVisible` isJust (model ^. msg) , msgOverlay `nodeVisible` isJust (model ^. msg)
, txOverlay `nodeVisible` isJust (model ^. showTx)
, modalOverlay `nodeVisible` isJust (model ^. modalMsg)
] ]
mainWindow = mainWindow =
vstack vstack
@ -383,7 +395,7 @@ buildUI wenv model = widgetTree
(fromIntegral $ qrCodeWidth qr)) (fromIntegral $ qrCodeWidth qr))
[fitWidth] [fitWidth]
Nothing -> Nothing ->
image_ "./assets/2620_color.png" [fitEither]) `styleBasic` image_ "./assets/1F928_color.png" [fitEither]) `styleBasic`
[bgColor white, height 100, width 100] [bgColor white, height 100, width 100]
, filler , filler
] `styleBasic` ] `styleBasic`
@ -418,7 +430,7 @@ buildUI wenv model = widgetTree
txRow :: Int -> Entity UserTx -> WidgetNode AppModel AppEvent txRow :: Int -> Entity UserTx -> WidgetNode AppModel AppEvent
txRow idx tx = txRow idx tx =
box_ box_
[onClick $ ShowMsg ("You clicked transaction " <> showt idx)] [onClick $ ShowTx idx]
(hstack (hstack
[ label [ label
(T.pack $ (T.pack $
@ -515,6 +527,75 @@ buildUI wenv model = widgetTree
, filler , filler
] ]
] ]
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]
, box_
[]
(remixIcon remixFileCopyFill `styleBasic`
[textColor white]) `styleBasic`
[bgColor btnColor, radius 2]
]) `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]
]
generateQRCodes :: Config -> IO () generateQRCodes :: Config -> IO ()
generateQRCodes config = do generateQRCodes config = do
@ -592,10 +673,11 @@ handleEvent ::
-> [AppEventResponse AppModel AppEvent] -> [AppEventResponse AppModel AppEvent]
handleEvent wenv node model evt = handleEvent wenv node model evt =
case evt of case evt of
AppInit -> [] AppInit -> [Event NewWallet | isNothing currentWallet]
ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False] ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False]
ShowError t -> ShowError t ->
[Model $ model & msg ?~ t & menuPopup .~ False & inError .~ True] [Model $ model & msg ?~ t & menuPopup .~ False & inError .~ True]
ShowModal t -> [Model $ model & modalMsg ?~ t]
WalletClicked -> [Model $ model & walPopup .~ True] WalletClicked -> [Model $ model & walPopup .~ True]
AccountClicked -> [Model $ model & accPopup .~ True] AccountClicked -> [Model $ model & accPopup .~ True]
MenuClicked -> [Model $ model & menuPopup .~ True] MenuClicked -> [Model $ model & menuPopup .~ True]
@ -635,6 +717,7 @@ handleEvent wenv node model evt =
SaveAddress acc -> SaveAddress acc ->
if T.length (model ^. mainInput) > 1 if T.length (model ^. mainInput) > 1
then [ Task $ addNewAddress (model ^. mainInput) External acc then [ Task $ addNewAddress (model ^. mainInput) External acc
, Event $ ShowModal "Generating QR codes..."
, Event ConfirmCancel , Event ConfirmCancel
] ]
else [Event $ ShowError "Invalid input", Event ConfirmCancel] else [Event $ ShowError "Invalid input", Event ConfirmCancel]
@ -645,13 +728,11 @@ handleEvent wenv node model evt =
] ]
else [Event $ ShowError "Invalid input", Event ConfirmCancel] else [Event $ ShowError "Invalid input", Event ConfirmCancel]
SaveWallet -> SaveWallet ->
[ if T.length (model ^. mainInput) > 1 if T.length (model ^. mainInput) > 1
then Event $ ShowMsg $ "You saved wallet: " <> model ^. mainInput then [Task addNewWallet, Event ConfirmCancel]
else Event $ ShowError "Invalid input" else [Event $ ShowError "Invalid input"]
, Event ConfirmCancel
]
SetPool p -> SetPool p ->
[ Model $ model & selPool .~ p [ Model $ model & selPool .~ p & modalMsg .~ Nothing
, Task $ , Task $
SwitchQr <$> do SwitchQr <$> do
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
@ -687,7 +768,8 @@ handleEvent wenv node model evt =
Just wal -> runNoLoggingT $ getAccounts dbPool $ entityKey wal Just wal -> runNoLoggingT $ getAccounts dbPool $ entityKey wal
] ]
CopyAddr a -> CopyAddr a ->
[ setClipboardData $ [ setClipboardData ClipboardEmpty
, setClipboardData $
ClipboardText $ ClipboardText $
case model ^. selPool of case model ^. selPool of
Orchard -> maybe "None" (getUA . walletAddressUAddress . entityVal) a Orchard -> maybe "None" (getUA . walletAddressUAddress . entityVal) a
@ -706,20 +788,35 @@ handleEvent wenv node model evt =
, Event $ ShowMsg "Copied address!" , Event $ ShowMsg "Copied address!"
] ]
CopySeed s -> CopySeed s ->
[ setClipboardData $ ClipboardText s [ setClipboardData ClipboardEmpty
, setClipboardData $ ClipboardText s
, Event $ ShowMsg "Copied seed phrase!" , Event $ ShowMsg "Copied seed phrase!"
] ]
CopyTx t ->
[ setClipboardData ClipboardEmpty
, setClipboardData $ ClipboardText t
, Event $ ShowMsg "Copied transaction ID!"
]
LoadTxs t -> [Model $ model & transactions .~ t] LoadTxs t -> [Model $ model & transactions .~ t]
LoadAddrs a -> LoadAddrs a ->
if not (null a) if not (null a)
then [Model $ model & addresses .~ a, Event $ SetPool Orchard] then [ Model $ model & addresses .~ a
, Event $ SwitchAddr $ model ^. selAddr
, Event $ SetPool Orchard
]
else [Event $ NewAddress currentAccount] else [Event $ NewAddress currentAccount]
LoadAccs a -> LoadAccs a ->
if not (null a) if not (null a)
then [Model $ model & accounts .~ a, Event $ SwitchAcc 0] then [Model $ model & accounts .~ a, Event $ SwitchAcc 0]
else [Event $ NewAccount currentWallet] else [Event $ NewAccount currentWallet]
LoadWallets a ->
if not (null a)
then [Model $ model & wallets .~ a, Event $ SwitchWal 0]
else [Event NewWallet]
CloseMsg -> [Model $ model & msg .~ Nothing & inError .~ False] CloseMsg -> [Model $ model & msg .~ Nothing & inError .~ False]
CloseSeed -> [Model $ model & showSeed .~ False] CloseSeed -> [Model $ model & showSeed .~ False]
CloseTx -> [Model $ model & showTx .~ Nothing]
ShowTx i -> [Model $ model & showTx ?~ i]
where where
currentWallet = currentWallet =
if null (model ^. wallets) if null (model ^. wallets)
@ -781,6 +878,35 @@ handleEvent wenv node model evt =
Just _x -> do Just _x -> do
aList <- runNoLoggingT $ getAccounts pool (entityKey w') aList <- runNoLoggingT $ getAccounts pool (entityKey w')
return $ LoadAccs aList return $ LoadAccs aList
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
txtWrap :: T.Text -> T.Text
txtWrap = wrapText (WrapSettings False True NoFill FillAfterFirst) 32
runZenithGUI :: Config -> IO () runZenithGUI :: Config -> IO ()
runZenithGUI config = do runZenithGUI config = do
@ -848,6 +974,8 @@ runZenithGUI config = do
else Nothing) else Nothing)
False False
False False
Nothing
Nothing
startApp model handleEvent buildUI params startApp model handleEvent buildUI params
Left e -> do Left e -> do
initDb dbFilePath initDb dbFilePath
@ -882,6 +1010,8 @@ runZenithGUI config = do
(SaveAddress Nothing) (SaveAddress Nothing)
False False
False False
Nothing
Nothing
startApp model handleEvent buildUI params startApp model handleEvent buildUI params
where where
params = params =