1351 lines
47 KiB
Haskell
1351 lines
47 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Zenith.GUI where
|
|
|
|
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 (runFileLoggingT, runNoLoggingT)
|
|
import Data.Aeson
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
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)
|
|
import Database.Esqueleto.Experimental (ConnectionPool)
|
|
import Database.Persist
|
|
import Lens.Micro ((&), (+~), (.~), (?~), (^.), set)
|
|
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
|
|
( BlockResponse(..)
|
|
, Phrase(..)
|
|
, Scope(..)
|
|
, ToBytes(..)
|
|
, UnifiedAddress(..)
|
|
, ZcashNet(..)
|
|
, 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
|
|
, isRecipientValid
|
|
, jsonNumber
|
|
, parseAddress
|
|
, showAddress
|
|
, validBarValue
|
|
)
|
|
|
|
data AppEvent
|
|
= AppInit
|
|
| ShowMsg !T.Text
|
|
| ShowError !T.Text
|
|
| ShowModal !T.Text
|
|
| CloseMsg
|
|
| WalletClicked
|
|
| AccountClicked
|
|
| MenuClicked
|
|
| NewClicked
|
|
| NewAddress !(Maybe (Entity ZcashAccount))
|
|
| NewAccount !(Maybe (Entity ZcashWallet))
|
|
| NewWallet
|
|
| SetPool !ZcashPool
|
|
| SwitchQr !(Maybe QrCode)
|
|
| SwitchAddr !Int
|
|
| SwitchAcc !Int
|
|
| SwitchWal !Int
|
|
| CopyAddr !(Maybe (Entity WalletAddress))
|
|
| LoadTxs ![Entity UserTx]
|
|
| LoadAddrs ![Entity WalletAddress]
|
|
| LoadAccs ![Entity ZcashAccount]
|
|
| LoadWallets ![Entity ZcashWallet]
|
|
| ConfirmCancel
|
|
| SaveAddress !(Maybe (Entity ZcashAccount))
|
|
| SaveAccount !(Maybe (Entity ZcashWallet))
|
|
| SaveWallet
|
|
| CloseSeed
|
|
| CloseTxId
|
|
| ShowSeed
|
|
| CopySeed !T.Text
|
|
| CopyTx !T.Text
|
|
| CloseTx
|
|
| ShowTx !Int
|
|
| TickUp
|
|
| SyncVal !Float
|
|
| SendTx
|
|
| ShowSend
|
|
| CancelSend
|
|
| CheckRecipient !T.Text
|
|
| CheckAmount !Float
|
|
| ShowTxId !T.Text
|
|
deriving (Eq, Show)
|
|
|
|
data AppModel = AppModel
|
|
{ _configuration :: !Config
|
|
, _network :: !ZcashNet
|
|
, _wallets :: ![Entity ZcashWallet]
|
|
, _selWallet :: !Int
|
|
, _accounts :: ![Entity ZcashAccount]
|
|
, _selAcc :: !Int
|
|
, _addresses :: ![Entity WalletAddress]
|
|
, _selAddr :: !Int
|
|
, _transactions :: ![Entity UserTx]
|
|
, _setTx :: !Int
|
|
, _msg :: !(Maybe T.Text)
|
|
, _zebraOn :: !Bool
|
|
, _balance :: !Integer
|
|
, _unconfBalance :: !(Maybe Integer)
|
|
, _selPool :: !ZcashPool
|
|
, _qrCodeWidget :: !(Maybe QrCode)
|
|
, _accPopup :: !Bool
|
|
, _walPopup :: !Bool
|
|
, _menuPopup :: !Bool
|
|
, _newPopup :: !Bool
|
|
, _mainInput :: !T.Text
|
|
, _confirmTitle :: !(Maybe T.Text)
|
|
, _confirmAccept :: !T.Text
|
|
, _confirmCancel :: !T.Text
|
|
, _confirmEvent :: !AppEvent
|
|
, _inError :: !Bool
|
|
, _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
|
|
, _showId :: !(Maybe T.Text)
|
|
} deriving (Eq, Show)
|
|
|
|
makeLenses ''AppModel
|
|
|
|
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]
|
|
|
|
buildUI ::
|
|
WidgetEnv AppModel AppEvent -> AppModel -> WidgetNode AppModel AppEvent
|
|
buildUI wenv model = widgetTree
|
|
where
|
|
btnColor = rgbHex "#ff5722" --rgbHex "#1818B2"
|
|
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))
|
|
currentAddress =
|
|
if null (model ^. addresses)
|
|
then Nothing
|
|
else Just ((model ^. addresses) !! (model ^. selAddr))
|
|
widgetTree =
|
|
zstack
|
|
[ mainWindow
|
|
, confirmOverlay `nodeVisible` isJust (model ^. confirmTitle)
|
|
, seedOverlay `nodeVisible` model ^. showSeed
|
|
, txOverlay `nodeVisible` isJust (model ^. showTx)
|
|
, sendTxOverlay `nodeVisible` model ^. openSend
|
|
, txIdOverlay `nodeVisible` isJust (model ^. showId)
|
|
, msgOverlay `nodeVisible` isJust (model ^. msg)
|
|
, modalOverlay `nodeVisible` isJust (model ^. modalMsg)
|
|
]
|
|
mainWindow =
|
|
vstack
|
|
[ windowHeader
|
|
, spacer
|
|
, balanceBox
|
|
, filler
|
|
, mainPane
|
|
, filler
|
|
, windowFooter
|
|
]
|
|
windowHeader =
|
|
hstack
|
|
[ 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
|
|
]
|
|
, vstack
|
|
[ box_ [onClick AccountClicked, alignMiddle] accountButton `styleBasic`
|
|
[cursorHand, height 25, padding 3] `styleHover`
|
|
[bgColor btnHiLite]
|
|
, popup accPopup accListPopup
|
|
]
|
|
, filler
|
|
, remixIcon remixErrorWarningFill `styleBasic` [textColor white]
|
|
, label "Testnet" `styleBasic` [textColor white] `nodeVisible`
|
|
(model ^. network == TestNet)
|
|
] `styleBasic`
|
|
[bgColor btnColor]
|
|
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, onClick ShowSeed] (label "Backup Wallet") `styleBasic`
|
|
[bgColor white, borderB 1 gray, padding 3]
|
|
]) `styleBasic`
|
|
[bgColor btnColor, padding 3]
|
|
newBox =
|
|
box_
|
|
[alignMiddle]
|
|
(vstack
|
|
[ box_
|
|
[alignLeft, onClick $ NewAddress currentAccount]
|
|
(hstack [label "Address", filler]) `styleBasic`
|
|
[bgColor white, borderB 1 gray, padding 3]
|
|
, box_
|
|
[alignLeft, onClick $ NewAccount currentWallet]
|
|
(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]
|
|
])
|
|
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]
|
|
]
|
|
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)
|
|
]
|
|
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]
|
|
]
|
|
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
|
|
, width 80
|
|
, styleIf (model ^. selAcc == idx) (borderL 2 btnHiLite)
|
|
, styleIf (model ^. selAcc == idx) (borderR 2 btnHiLite)
|
|
]
|
|
mainPane =
|
|
box_ [alignMiddle] $
|
|
hstack
|
|
[ addressBox
|
|
, vstack
|
|
[ mainButton "Send" ShowSend
|
|
, txBox `nodeVisible` not (null $ model ^. transactions)
|
|
]
|
|
]
|
|
balanceBox =
|
|
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
|
|
]
|
|
addressBox =
|
|
vstack
|
|
[ boxShadow $
|
|
box_
|
|
[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
|
|
]
|
|
addrQRCode :: WidgetNode AppModel AppEvent
|
|
addrQRCode =
|
|
box_
|
|
[alignMiddle]
|
|
(hstack
|
|
[ filler
|
|
, 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/1F928_color.png" [fitEither]) `styleBasic`
|
|
[bgColor white, height 100, width 100]
|
|
, filler
|
|
] `styleBasic`
|
|
[bgColor btnColor, border 2 btnColor]
|
|
] `styleBasic`
|
|
[radius 3, border 1 btnColor]
|
|
, filler
|
|
])
|
|
addrRow :: Int -> Entity WalletAddress -> WidgetNode AppModel AppEvent
|
|
addrRow idx wAddr =
|
|
box_
|
|
[onClick $ SwitchAddr idx, alignLeft]
|
|
(label
|
|
(walletAddressName (entityVal wAddr) <>
|
|
": " <> showAddress (walletAddressUAddress $ entityVal wAddr))) `styleBasic`
|
|
[ padding 1
|
|
, borderB 1 gray
|
|
, styleIf (model ^. selAddr == idx) (borderL 2 btnHiLite)
|
|
, styleIf (model ^. selAddr == idx) (borderR 2 btnHiLite)
|
|
]
|
|
txBox =
|
|
boxShadow $
|
|
box_
|
|
[alignMiddle]
|
|
(vstack
|
|
[ 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 $ ShowTx 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)
|
|
]) `styleBasic`
|
|
[padding 2, borderB 1 gray]
|
|
windowFooter =
|
|
hstack
|
|
[ label
|
|
("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`
|
|
(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)
|
|
]
|
|
msgOverlay =
|
|
alert CloseMsg $
|
|
hstack
|
|
[ filler
|
|
, remixIcon remixErrorWarningFill `styleBasic`
|
|
[textSize 32, textColor btnColor] `nodeVisible`
|
|
(model ^. inError)
|
|
, spacer
|
|
, label $ fromMaybe "" (model ^. msg)
|
|
, filler
|
|
]
|
|
confirmOverlay =
|
|
confirm_
|
|
(model ^. confirmEvent)
|
|
ConfirmCancel
|
|
[ titleCaption $ fromMaybe "" $ model ^. confirmTitle
|
|
, acceptCaption $ model ^. confirmAccept
|
|
, cancelCaption $ model ^. confirmCancel
|
|
]
|
|
(hstack [label "Name:", filler, textField_ mainInput [maxLength 25]])
|
|
sendTxOverlay =
|
|
box
|
|
(vstack
|
|
[ filler
|
|
, hstack
|
|
[ filler
|
|
, box_
|
|
[]
|
|
(vstack
|
|
[ box_
|
|
[alignMiddle]
|
|
(label "Send Zcash" `styleBasic`
|
|
[textFont "Bold", textSize 12])
|
|
, separatorLine `styleBasic` [fgColor btnColor]
|
|
, spacer
|
|
, hstack
|
|
[ label "To:" `styleBasic` [width 50]
|
|
, spacer
|
|
, textField_ sendRecipient [onChange CheckRecipient] `styleBasic`
|
|
[ width 150
|
|
, styleIf
|
|
(not $ model ^. recipientValid)
|
|
(textColor red)
|
|
]
|
|
]
|
|
, hstack
|
|
[ label "Amount:" `styleBasic` [width 50]
|
|
, spacer
|
|
, numericField_
|
|
sendAmount
|
|
[ decimals 8
|
|
, minValue 0.0
|
|
, maxValue
|
|
(fromIntegral (model ^. balance) / 100000000.0)
|
|
, validInput amountValid
|
|
, onChange CheckAmount
|
|
] `styleBasic`
|
|
[ width 150
|
|
, styleIf
|
|
(not $ model ^. amountValid)
|
|
(textColor red)
|
|
]
|
|
]
|
|
, hstack
|
|
[ label "Memo:" `styleBasic` [width 50]
|
|
, spacer
|
|
, textArea sendMemo `styleBasic`
|
|
[width 150, height 40]
|
|
]
|
|
, spacer
|
|
, box_
|
|
[alignMiddle]
|
|
(hstack
|
|
[ spacer
|
|
, button "Cancel" CancelSend
|
|
, spacer
|
|
, mainButton "Send" SendTx `nodeEnabled`
|
|
(model ^. amountValid && model ^. recipientValid)
|
|
, spacer
|
|
])
|
|
]) `styleBasic`
|
|
[radius 4, border 2 btnColor, bgColor white, padding 4]
|
|
, filler
|
|
]
|
|
, filler
|
|
]) `styleBasic`
|
|
[bgColor (white & L.a .~ 0.5)]
|
|
seedOverlay =
|
|
alert CloseSeed $
|
|
vstack
|
|
[ box_
|
|
[]
|
|
(label "Seed Phrase" `styleBasic`
|
|
[textFont "Bold", textSize 12, textColor white]) `styleBasic`
|
|
[bgColor btnColor, radius 2, padding 3]
|
|
, spacer
|
|
, textAreaV_
|
|
(maybe
|
|
"None"
|
|
(E.decodeUtf8Lenient .
|
|
getBytes . getPhrase . zcashWalletSeedPhrase . entityVal)
|
|
currentWallet)
|
|
(const CloseSeed)
|
|
[readOnly, maxLines 2] `styleBasic`
|
|
[textSize 8]
|
|
, spacer
|
|
, hstack
|
|
[ filler
|
|
, box_
|
|
[ onClick $
|
|
CopySeed $
|
|
maybe
|
|
"None"
|
|
(E.decodeUtf8Lenient .
|
|
getBytes . getPhrase . zcashWalletSeedPhrase . entityVal)
|
|
currentWallet
|
|
]
|
|
(hstack
|
|
[ label "Copy" `styleBasic` [textColor white]
|
|
, remixIcon remixFileCopyLine `styleBasic` [textColor white]
|
|
]) `styleBasic`
|
|
[cursorHand, bgColor btnColor, radius 2, padding 3]
|
|
, 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]
|
|
, spacer
|
|
, box_
|
|
[ onClick $
|
|
CopyTx $
|
|
toText $
|
|
getHex $
|
|
userTxHex $ entityVal $ (model ^. transactions) !! i
|
|
]
|
|
(remixIcon remixFileCopyFill `styleBasic`
|
|
[textColor white]) `styleBasic`
|
|
[cursorHand, bgColor btnColor, radius 2, padding 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]
|
|
]
|
|
txIdOverlay =
|
|
case model ^. showId of
|
|
Nothing -> alert CloseTxId $ label "N/A"
|
|
Just t ->
|
|
alert CloseTxId $
|
|
box_
|
|
[alignLeft]
|
|
(vstack
|
|
[ box_ [alignMiddle] $
|
|
label "Transaction Sent!" `styleBasic` [textFont "Bold"]
|
|
, spacer
|
|
, hstack
|
|
[ label "Tx ID " `styleBasic` [width 60, textFont "Bold"]
|
|
, separatorLine `styleBasic` [fgColor btnColor]
|
|
, spacer
|
|
, label_ (txtWrap t) [multiline]
|
|
, spacer
|
|
, box_
|
|
[onClick $ CopyTx t]
|
|
(remixIcon remixFileCopyFill `styleBasic`
|
|
[textColor white]) `styleBasic`
|
|
[cursorHand, bgColor btnColor, radius 2, padding 2]
|
|
]
|
|
]) `styleBasic`
|
|
[padding 2, bgColor white, width 280, borderB 1 gray, borderT 1 gray]
|
|
|
|
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
|
|
|
|
handleEvent ::
|
|
WidgetEnv AppModel AppEvent
|
|
-> WidgetNode AppModel AppEvent
|
|
-> AppModel
|
|
-> AppEvent
|
|
-> [AppEventResponse AppModel AppEvent]
|
|
handleEvent wenv node model evt =
|
|
case evt of
|
|
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 & modalMsg .~
|
|
Nothing
|
|
]
|
|
ShowModal t -> [Model $ model & modalMsg ?~ t]
|
|
WalletClicked -> [Model $ model & walPopup .~ True]
|
|
AccountClicked -> [Model $ model & accPopup .~ True]
|
|
MenuClicked -> [Model $ model & menuPopup .~ True]
|
|
NewClicked -> [Model $ model & newPopup .~ not (model ^. newPopup)]
|
|
NewAddress acc ->
|
|
[ Model $
|
|
model & confirmTitle ?~ "New Address" & confirmAccept .~ "Create" &
|
|
confirmCancel .~
|
|
"Cancel" &
|
|
confirmEvent .~
|
|
SaveAddress acc &
|
|
menuPopup .~
|
|
False
|
|
]
|
|
NewAccount wal ->
|
|
[ Model $
|
|
model & confirmTitle ?~ "New Account" & confirmAccept .~ "Create" &
|
|
confirmCancel .~
|
|
"Cancel" &
|
|
confirmEvent .~
|
|
SaveAccount wal &
|
|
menuPopup .~
|
|
False
|
|
]
|
|
NewWallet ->
|
|
[ Model $
|
|
model & confirmTitle ?~ "New Wallet" & confirmAccept .~ "Create" &
|
|
confirmCancel .~
|
|
"Cancel" &
|
|
confirmEvent .~
|
|
SaveWallet &
|
|
menuPopup .~
|
|
False
|
|
]
|
|
ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""]
|
|
ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False]
|
|
ShowSend -> [Model $ model & openSend .~ True]
|
|
SendTx ->
|
|
case currentAccount of
|
|
Nothing -> [Event $ ShowError "No account available"]
|
|
Just acc ->
|
|
case currentWallet of
|
|
Nothing -> [Event $ ShowError "No wallet available"]
|
|
Just wal ->
|
|
[ Producer $
|
|
sendTransaction
|
|
(model ^. configuration)
|
|
(model ^. network)
|
|
(entityKey acc)
|
|
(zcashWalletLastSync $ entityVal wal)
|
|
(model ^. sendAmount)
|
|
(model ^. sendRecipient)
|
|
(model ^. sendMemo)
|
|
]
|
|
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
|
|
, Event $ ShowModal "Generating QR codes..."
|
|
, Event ConfirmCancel
|
|
]
|
|
else [Event $ ShowError "Invalid input", Event ConfirmCancel]
|
|
SaveAccount wal ->
|
|
if T.length (model ^. mainInput) > 1
|
|
then [ Task $ addNewAccount (model ^. mainInput) wal
|
|
, Event ConfirmCancel
|
|
]
|
|
else [Event $ ShowError "Invalid input", Event ConfirmCancel]
|
|
SaveWallet ->
|
|
if T.length (model ^. mainInput) > 1
|
|
then [Task addNewWallet, Event ConfirmCancel]
|
|
else [Event $ ShowError "Invalid input"]
|
|
SetPool p ->
|
|
[ Model $ model & selPool .~ p & modalMsg .~ Nothing
|
|
, Task $
|
|
SwitchQr <$> do
|
|
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
|
|
case currentAddress of
|
|
Nothing -> return Nothing
|
|
Just wAddr -> getQrCode dbPool p $ entityKey wAddr
|
|
, 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]
|
|
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
|
|
]
|
|
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
|
|
]
|
|
CopyAddr a ->
|
|
[ setClipboardData ClipboardEmpty
|
|
, 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!"
|
|
]
|
|
CopySeed 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 $ 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 $ model ^. selWallet
|
|
]
|
|
else [Event NewWallet]
|
|
CloseMsg -> [Model $ model & msg .~ Nothing & inError .~ False]
|
|
CloseSeed -> [Model $ model & showSeed .~ False]
|
|
CloseTx -> [Model $ model & showTx .~ Nothing]
|
|
CloseTxId -> [Model $ model & showId .~ 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 a -> [Model $ model & recipientValid .~ isRecipientValid a]
|
|
CheckAmount i ->
|
|
[ Model $
|
|
model & amountValid .~
|
|
(i < (fromIntegral (model ^. balance) / 100000000.0))
|
|
]
|
|
ShowTxId tx -> [Model $ model & showId ?~ tx & modalMsg .~ Nothing]
|
|
where
|
|
currentWallet =
|
|
if null (model ^. wallets)
|
|
then Nothing
|
|
else Just ((model ^. wallets) !! (model ^. selWallet))
|
|
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))
|
|
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))
|
|
addNewAddress ::
|
|
T.Text -> Scope -> Maybe (Entity ZcashAccount) -> IO AppEvent
|
|
addNewAddress n scope acc = do
|
|
case acc of
|
|
Nothing -> return $ ShowError "No account available"
|
|
Just a -> do
|
|
pool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
|
|
maxAddr <- getMaxAddress pool (entityKey a) scope
|
|
uA <-
|
|
try $ createWalletAddress n (maxAddr + 1) (model ^. network) scope a :: IO
|
|
(Either IOError WalletAddress)
|
|
case uA of
|
|
Left e -> return $ ShowError $ "Error: " <> T.pack (show e)
|
|
Right uA' -> do
|
|
nAddr <- saveAddress pool uA'
|
|
case nAddr of
|
|
Nothing -> return $ ShowError $ "Address already exists: " <> n
|
|
Just _x -> do
|
|
generateQRCodes $ model ^. configuration
|
|
addrL <- runNoLoggingT $ getAddresses pool $ entityKey a
|
|
return $ LoadAddrs addrL
|
|
addNewAccount :: T.Text -> Maybe (Entity ZcashWallet) -> IO AppEvent
|
|
addNewAccount n w = do
|
|
case w of
|
|
Nothing -> return $ ShowError "No wallet available"
|
|
Just w' -> do
|
|
pool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
|
|
accIx <- getMaxAccount pool $ entityKey w'
|
|
newAcc <-
|
|
try $ createZcashAccount n (accIx + 1) w' :: IO
|
|
(Either IOError ZcashAccount)
|
|
case newAcc of
|
|
Left e -> return $ ShowError "Failed to create account"
|
|
Right newAcc' -> do
|
|
r <- saveAccount pool newAcc'
|
|
case r of
|
|
Nothing -> return $ ShowError "Account already exists"
|
|
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
|
|
|
|
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)
|
|
|
|
sendTransaction ::
|
|
Config
|
|
-> ZcashNet
|
|
-> ZcashAccountId
|
|
-> Int
|
|
-> Float
|
|
-> T.Text
|
|
-> T.Text
|
|
-> (AppEvent -> IO ())
|
|
-> IO ()
|
|
sendTransaction config znet accId bl amt ua memo sendMsg = do
|
|
sendMsg $ ShowModal "Preparing transaction..."
|
|
case parseAddress ua znet of
|
|
Nothing -> sendMsg $ ShowError "Incorrect address"
|
|
Just outUA -> do
|
|
let dbPath = c_dbPath config
|
|
let zHost = c_zebraHost config
|
|
let zPort = c_zebraPort config
|
|
pool <- runNoLoggingT $ initPool dbPath
|
|
res <-
|
|
runFileLoggingT "zenith.log" $
|
|
prepareTx pool zHost zPort znet accId bl amt outUA memo
|
|
case res of
|
|
Left e -> sendMsg $ ShowError $ T.pack $ show e
|
|
Right rawTx -> do
|
|
sendMsg $ ShowModal "Transaction ready, sending to Zebra..."
|
|
resp <-
|
|
makeZebraCall
|
|
zHost
|
|
zPort
|
|
"sendrawtransaction"
|
|
[Data.Aeson.String $ toText rawTx]
|
|
case resp of
|
|
Left e1 -> sendMsg $ ShowError $ "Zebra error: " <> showt e1
|
|
Right txId -> sendMsg $ ShowTxId txId
|
|
|
|
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
|
|
|
|
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
|
|
walList <- getWallets pool $ zgb_net chainInfo
|
|
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
|
|
let model =
|
|
AppModel
|
|
config
|
|
(zgb_net chainInfo)
|
|
walList
|
|
0
|
|
accList
|
|
0
|
|
addrList
|
|
0
|
|
txList
|
|
0
|
|
Nothing
|
|
True
|
|
314259000
|
|
(Just 300000)
|
|
Orchard
|
|
qr
|
|
False
|
|
False
|
|
False
|
|
False
|
|
""
|
|
Nothing
|
|
""
|
|
""
|
|
(SaveAddress $
|
|
if not (null accList)
|
|
then Just (head accList)
|
|
else Nothing)
|
|
False
|
|
False
|
|
Nothing
|
|
Nothing
|
|
0
|
|
1.0
|
|
False
|
|
""
|
|
0.0
|
|
""
|
|
False
|
|
False
|
|
Nothing
|
|
startApp model handleEvent buildUI params
|
|
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)
|
|
Orchard
|
|
Nothing
|
|
False
|
|
False
|
|
False
|
|
False
|
|
""
|
|
Nothing
|
|
""
|
|
""
|
|
(SaveAddress Nothing)
|
|
False
|
|
False
|
|
Nothing
|
|
Nothing
|
|
0
|
|
1.0
|
|
False
|
|
""
|
|
0.0
|
|
""
|
|
False
|
|
False
|
|
Nothing
|
|
startApp model handleEvent buildUI params
|
|
where
|
|
params =
|
|
[ appWindowTitle "Zenith - Zcash Full Node Wallet"
|
|
, appWindowState $ MainWindowNormal (1000, 700)
|
|
, 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
|
|
, appInitEvent AppInit
|
|
]
|