Add TX display
This commit is contained in:
parent
b9ab1623b3
commit
7956a2ec22
GPG key ID:
65122AD495A7F5B2
2 changed files with 144 additions and 14 deletions
BIN
assets/1F928_color.png
Normal file
BIN
assets/1F928_color.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 10 KiB |
|
|
@ -11,7 +11,8 @@ import Control.Exception (throwIO, try)
|
|||
import Control.Monad.Logger (runNoLoggingT)
|
||||
import qualified Data.ByteString as BS
|
||||
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.Encoding as E
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
|
|
@ -22,7 +23,9 @@ import Lens.Micro.TH
|
|||
import Monomer
|
||||
import qualified Monomer.Lens as L
|
||||
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.Transparent (encodeTransparentReceiver)
|
||||
import ZcashHaskell.Types
|
||||
|
|
@ -44,6 +47,7 @@ data AppEvent
|
|||
= AppInit
|
||||
| ShowMsg !T.Text
|
||||
| ShowError !T.Text
|
||||
| ShowModal !T.Text
|
||||
| CloseMsg
|
||||
| WalletClicked
|
||||
| AccountClicked
|
||||
|
|
@ -61,6 +65,7 @@ data AppEvent
|
|||
| LoadTxs ![Entity UserTx]
|
||||
| LoadAddrs ![Entity WalletAddress]
|
||||
| LoadAccs ![Entity ZcashAccount]
|
||||
| LoadWallets ![Entity ZcashWallet]
|
||||
| ConfirmCancel
|
||||
| SaveAddress !(Maybe (Entity ZcashAccount))
|
||||
| SaveAccount !(Maybe (Entity ZcashWallet))
|
||||
|
|
@ -68,6 +73,9 @@ data AppEvent
|
|||
| CloseSeed
|
||||
| ShowSeed
|
||||
| CopySeed !T.Text
|
||||
| CopyTx !T.Text
|
||||
| CloseTx
|
||||
| ShowTx !Int
|
||||
deriving (Eq, Show)
|
||||
|
||||
data AppModel = AppModel
|
||||
|
|
@ -98,6 +106,8 @@ data AppModel = AppModel
|
|||
, _confirmEvent :: !AppEvent
|
||||
, _inError :: !Bool
|
||||
, _showSeed :: !Bool
|
||||
, _modalMsg :: !(Maybe T.Text)
|
||||
, _showTx :: !(Maybe Int)
|
||||
} deriving (Eq, Show)
|
||||
|
||||
makeLenses ''AppModel
|
||||
|
|
@ -135,6 +145,8 @@ buildUI wenv model = widgetTree
|
|||
, confirmOverlay `nodeVisible` isJust (model ^. confirmTitle)
|
||||
, seedOverlay `nodeVisible` model ^. showSeed
|
||||
, msgOverlay `nodeVisible` isJust (model ^. msg)
|
||||
, txOverlay `nodeVisible` isJust (model ^. showTx)
|
||||
, modalOverlay `nodeVisible` isJust (model ^. modalMsg)
|
||||
]
|
||||
mainWindow =
|
||||
vstack
|
||||
|
|
@ -383,7 +395,7 @@ buildUI wenv model = widgetTree
|
|||
(fromIntegral $ qrCodeWidth qr))
|
||||
[fitWidth]
|
||||
Nothing ->
|
||||
image_ "./assets/2620_color.png" [fitEither]) `styleBasic`
|
||||
image_ "./assets/1F928_color.png" [fitEither]) `styleBasic`
|
||||
[bgColor white, height 100, width 100]
|
||||
, filler
|
||||
] `styleBasic`
|
||||
|
|
@ -418,7 +430,7 @@ buildUI wenv model = widgetTree
|
|||
txRow :: Int -> Entity UserTx -> WidgetNode AppModel AppEvent
|
||||
txRow idx tx =
|
||||
box_
|
||||
[onClick $ ShowMsg ("You clicked transaction " <> showt idx)]
|
||||
[onClick $ ShowTx idx]
|
||||
(hstack
|
||||
[ label
|
||||
(T.pack $
|
||||
|
|
@ -515,6 +527,75 @@ buildUI wenv model = widgetTree
|
|||
, 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 = do
|
||||
|
|
@ -592,10 +673,11 @@ handleEvent ::
|
|||
-> [AppEventResponse AppModel AppEvent]
|
||||
handleEvent wenv node model evt =
|
||||
case evt of
|
||||
AppInit -> []
|
||||
AppInit -> [Event NewWallet | isNothing currentWallet]
|
||||
ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False]
|
||||
ShowError t ->
|
||||
[Model $ model & msg ?~ t & menuPopup .~ False & inError .~ True]
|
||||
ShowModal t -> [Model $ model & modalMsg ?~ t]
|
||||
WalletClicked -> [Model $ model & walPopup .~ True]
|
||||
AccountClicked -> [Model $ model & accPopup .~ True]
|
||||
MenuClicked -> [Model $ model & menuPopup .~ True]
|
||||
|
|
@ -635,6 +717,7 @@ handleEvent wenv node model evt =
|
|||
SaveAddress acc ->
|
||||
if T.length (model ^. mainInput) > 1
|
||||
then [ Task $ addNewAddress (model ^. mainInput) External acc
|
||||
, Event $ ShowModal "Generating QR codes..."
|
||||
, 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]
|
||||
SaveWallet ->
|
||||
[ if T.length (model ^. mainInput) > 1
|
||||
then Event $ ShowMsg $ "You saved wallet: " <> model ^. mainInput
|
||||
else Event $ ShowError "Invalid input"
|
||||
, Event ConfirmCancel
|
||||
]
|
||||
if T.length (model ^. mainInput) > 1
|
||||
then [Task addNewWallet, Event ConfirmCancel]
|
||||
else [Event $ ShowError "Invalid input"]
|
||||
SetPool p ->
|
||||
[ Model $ model & selPool .~ p
|
||||
[ Model $ model & selPool .~ p & modalMsg .~ Nothing
|
||||
, Task $
|
||||
SwitchQr <$> do
|
||||
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
|
||||
|
|
@ -687,7 +768,8 @@ handleEvent wenv node model evt =
|
|||
Just wal -> runNoLoggingT $ getAccounts dbPool $ entityKey wal
|
||||
]
|
||||
CopyAddr a ->
|
||||
[ setClipboardData $
|
||||
[ setClipboardData ClipboardEmpty
|
||||
, setClipboardData $
|
||||
ClipboardText $
|
||||
case model ^. selPool of
|
||||
Orchard -> maybe "None" (getUA . walletAddressUAddress . entityVal) a
|
||||
|
|
@ -706,20 +788,35 @@ handleEvent wenv node model evt =
|
|||
, Event $ ShowMsg "Copied address!"
|
||||
]
|
||||
CopySeed s ->
|
||||
[ setClipboardData $ ClipboardText s
|
||||
[ setClipboardData ClipboardEmpty
|
||||
, setClipboardData $ ClipboardText s
|
||||
, Event $ ShowMsg "Copied seed phrase!"
|
||||
]
|
||||
CopyTx t ->
|
||||
[ setClipboardData ClipboardEmpty
|
||||
, setClipboardData $ ClipboardText t
|
||||
, Event $ ShowMsg "Copied transaction ID!"
|
||||
]
|
||||
LoadTxs t -> [Model $ model & transactions .~ t]
|
||||
LoadAddrs 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]
|
||||
LoadAccs a ->
|
||||
if not (null a)
|
||||
then [Model $ model & accounts .~ a, Event $ SwitchAcc 0]
|
||||
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]
|
||||
CloseSeed -> [Model $ model & showSeed .~ False]
|
||||
CloseTx -> [Model $ model & showTx .~ Nothing]
|
||||
ShowTx i -> [Model $ model & showTx ?~ i]
|
||||
where
|
||||
currentWallet =
|
||||
if null (model ^. wallets)
|
||||
|
|
@ -781,6 +878,35 @@ handleEvent wenv node model evt =
|
|||
Just _x -> do
|
||||
aList <- runNoLoggingT $ getAccounts pool (entityKey w')
|
||||
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 = do
|
||||
|
|
@ -848,6 +974,8 @@ runZenithGUI config = do
|
|||
else Nothing)
|
||||
False
|
||||
False
|
||||
Nothing
|
||||
Nothing
|
||||
startApp model handleEvent buildUI params
|
||||
Left e -> do
|
||||
initDb dbFilePath
|
||||
|
|
@ -882,6 +1010,8 @@ runZenithGUI config = do
|
|||
(SaveAddress Nothing)
|
||||
False
|
||||
False
|
||||
Nothing
|
||||
Nothing
|
||||
startApp model handleEvent buildUI params
|
||||
where
|
||||
params =
|
||||
|
|
|
|||
Loading…
Reference in a new issue