diff --git a/CHANGELOG.md b/CHANGELOG.md index aa0b028..5146869 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,23 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [Unreleased] + +### Added + +- GUI module +- Address list +- Transaction list +- Balance display +- Account selector +- Menu for new addresses, accounts, wallets +- Dialog to display and copy seed phrase +- Dialog to add new address +- Dialog to add new account +- Dialog to add new wallet +- Dialog to display transaction details and copy TX ID + + ## [0.5.3.0-beta] ### Changed diff --git a/app/Main.hs b/app/Main.hs index 6b5ca16..ab40b83 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -19,6 +19,7 @@ import Text.Read (readMaybe) import ZcashHaskell.Types import Zenith.CLI import Zenith.Core (clearSync, testSync) +import Zenith.GUI (runZenithGUI) import Zenith.Types (Config(..), ZcashAddress(..), ZcashPool(..), ZcashTx(..)) import Zenith.Utils import Zenith.Zcashd @@ -201,13 +202,13 @@ main :: IO () main = do config <- load [ "$(HOME)/Zenith/zenith.cfg" ] args <- getArgs - --dbFilePath <- require config "dbFilePath" + dbFileName <- require config "dbFileName" nodeUser <- require config "nodeUser" nodePwd <- require config "nodePwd" zebraPort <- require config "zebraPort" zebraHost <- require config "zebraHost" dbFP <- getZenithPath - let dbFilePath = dbFP ++ "zenith.db" + let dbFilePath = dbFP ++ dbFileName let myConfig = Config (T.pack dbFilePath) zebraHost zebraPort if not (null args) then do @@ -223,6 +224,7 @@ main = do } (root nodeUser nodePwd) "tui" -> runZenithTUI myConfig + "gui" -> runZenithGUI myConfig "rescan" -> clearSync myConfig _ -> printUsage else printUsage diff --git a/assets/1F616_color.png b/assets/1F616_color.png new file mode 100644 index 0000000..ac48165 Binary files /dev/null and b/assets/1F616_color.png differ diff --git a/assets/1F928_color.png b/assets/1F928_color.png new file mode 100644 index 0000000..10095c0 Binary files /dev/null and b/assets/1F928_color.png differ diff --git a/assets/1F993.png b/assets/1F993.png new file mode 100644 index 0000000..290f365 Binary files /dev/null and b/assets/1F993.png differ diff --git a/assets/2620_color.png b/assets/2620_color.png new file mode 100644 index 0000000..ecfdc10 Binary files /dev/null and b/assets/2620_color.png differ diff --git a/assets/Atkinson-Hyperlegible-Bold-102.ttf b/assets/Atkinson-Hyperlegible-Bold-102.ttf new file mode 100644 index 0000000..14b7196 Binary files /dev/null and b/assets/Atkinson-Hyperlegible-Bold-102.ttf differ diff --git a/assets/Atkinson-Hyperlegible-BoldItalic-102.ttf b/assets/Atkinson-Hyperlegible-BoldItalic-102.ttf new file mode 100644 index 0000000..4532705 Binary files /dev/null and b/assets/Atkinson-Hyperlegible-BoldItalic-102.ttf differ diff --git a/assets/Atkinson-Hyperlegible-Font-License-2020-1104.pdf b/assets/Atkinson-Hyperlegible-Font-License-2020-1104.pdf new file mode 100644 index 0000000..afe27dc Binary files /dev/null and b/assets/Atkinson-Hyperlegible-Font-License-2020-1104.pdf differ diff --git a/assets/Atkinson-Hyperlegible-Italic-102.ttf b/assets/Atkinson-Hyperlegible-Italic-102.ttf new file mode 100644 index 0000000..89e5ce4 Binary files /dev/null and b/assets/Atkinson-Hyperlegible-Italic-102.ttf differ diff --git a/assets/Atkinson-Hyperlegible-Regular-102.ttf b/assets/Atkinson-Hyperlegible-Regular-102.ttf new file mode 100644 index 0000000..c4fa6fb Binary files /dev/null and b/assets/Atkinson-Hyperlegible-Regular-102.ttf differ diff --git a/assets/DejaVuSansMono-Bold.ttf b/assets/DejaVuSansMono-Bold.ttf new file mode 100644 index 0000000..b210eb5 Binary files /dev/null and b/assets/DejaVuSansMono-Bold.ttf differ diff --git a/assets/DejaVuSansMono-BoldOblique.ttf b/assets/DejaVuSansMono-BoldOblique.ttf new file mode 100644 index 0000000..3211064 Binary files /dev/null and b/assets/DejaVuSansMono-BoldOblique.ttf differ diff --git a/assets/DejaVuSansMono-Oblique.ttf b/assets/DejaVuSansMono-Oblique.ttf new file mode 100644 index 0000000..ff83b15 Binary files /dev/null and b/assets/DejaVuSansMono-Oblique.ttf differ diff --git a/assets/DejaVuSansMono.ttf b/assets/DejaVuSansMono.ttf new file mode 100644 index 0000000..041cffc Binary files /dev/null and b/assets/DejaVuSansMono.ttf differ diff --git a/assets/OpenMoji-color-glyf_colr_1.ttf b/assets/OpenMoji-color-glyf_colr_1.ttf new file mode 100644 index 0000000..86cf85b Binary files /dev/null and b/assets/OpenMoji-color-glyf_colr_1.ttf differ diff --git a/assets/Roboto-Regular.ttf b/assets/Roboto-Regular.ttf new file mode 100644 index 0000000..8c082c8 Binary files /dev/null and b/assets/Roboto-Regular.ttf differ diff --git a/assets/remixicon.ttf b/assets/remixicon.ttf new file mode 100644 index 0000000..22ce6de Binary files /dev/null and b/assets/remixicon.ttf differ diff --git a/cabal.project b/cabal.project index d245ac1..217198a 100644 --- a/cabal.project +++ b/cabal.project @@ -2,7 +2,7 @@ packages: ./*.cabal zcash-haskell/zcash-haskell.cabal -with-compiler: ghc-9.6.5 +with-compiler: ghc-9.4.8 source-repository-package type: git diff --git a/cabal.project.freeze b/cabal.project.freeze index 76e4598..698a2eb 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -4,12 +4,20 @@ constraints: any.Cabal ==3.8.1.0, any.Clipboard ==2.3.2.0, any.HUnit ==1.6.2.0, any.Hclip ==3.0.0.4, + any.JuicyPixels ==3.3.8, + JuicyPixels -mmap, any.OneTuple ==0.4.1.1, + any.OpenGLRaw ==3.3.4.1, + OpenGLRaw -osandroid +usegles2 +useglxgetprocaddress +usenativewindowslibraries, any.QuickCheck ==2.14.3, QuickCheck -old-random +templatehaskell, + any.RSA ==2.4.1, + any.SHA ==1.6.4.4, + SHA -exe, any.StateVar ==1.2.2, any.X11 ==1.10.3, X11 -pedantic, + any.adjunctions ==4.4.2, any.aeson ==2.2.1.0, aeson +ordered-keymap, any.alex ==3.5.1.0, @@ -30,8 +38,11 @@ constraints: any.Cabal ==3.8.1.0, any.attoparsec ==0.14.4, attoparsec -developer, any.attoparsec-aeson ==2.2.0.1, + any.authenticate-oauth ==1.7, any.auto-update ==0.1.6, any.base ==4.17.2.1, + any.base-compat ==0.13.1, + any.base-compat-batteries ==0.13.1, any.base-orphans ==0.9.1, any.base16 ==1.0, any.base16-bytestring ==1.0.2.0, @@ -54,14 +65,20 @@ constraints: any.Cabal ==3.8.1.0, any.byteorder ==1.0.4, any.bytes ==0.17.3, any.bytestring ==0.11.5.3, + any.bytestring-builder ==0.10.8.2.0, + bytestring-builder +bytestring_has_builder, + any.bytestring-to-vector ==0.3.0.1, any.c2hs ==0.28.8, c2hs +base3 -regression, + any.cabal-doctest ==1.0.9, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, any.cborg ==0.2.10.0, cborg +optimize-gmp, any.cereal ==0.5.8.3, cereal -bytestring-builder, + any.clock ==0.8.4, + clock -llvm, any.colour ==2.3.6, any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, @@ -78,6 +95,7 @@ constraints: any.Cabal ==3.8.1.0, any.cookie ==0.4.6, any.crypto-api ==0.13.3, crypto-api -all_cpolys, + any.crypto-pubkey-types ==0.4.3, any.crypton ==0.34, crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, any.crypton-connection ==0.3.2, @@ -100,20 +118,30 @@ constraints: any.Cabal ==3.8.1.0, distributive +semigroups +tagged, any.dlist ==1.0, dlist -werror, + any.double-conversion ==2.0.5.0, + double-conversion -developer +embedded_double_conversion, any.easy-file ==0.2.5, any.entropy ==0.4.1.10, entropy -donotgetentropy, any.envy ==2.1.3.0, any.esqueleto ==3.5.11.2, any.exceptions ==0.10.5, + any.extra ==1.7.14, any.fast-logger ==3.2.2, any.filepath ==1.4.2.2, + any.fixed ==0.3, any.foldable1-classes-compat ==0.1, foldable1-classes-compat +tagged, any.foreign-rust ==0.1.0, + any.foreign-store ==0.2.1, + any.formatting ==7.2.0, + formatting -no-double-conversion, + any.free ==5.2, + any.generic-deriving ==1.14.5, + generic-deriving +base-4-9, any.generically ==0.1.1, any.generics-sop ==0.5.1.4, - any.ghc ==9.6.5, + any.ghc ==9.4.8, any.ghc-bignum ==1.3, any.ghc-boot ==9.4.8, any.ghc-boot-th ==9.4.8, @@ -150,11 +178,18 @@ constraints: any.Cabal ==3.8.1.0, any.integer-gmp ==1.1, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, + any.invariant ==0.6.3, any.iproute ==1.7.12, + any.kan-extensions ==5.2.5, any.language-c ==0.9.3, language-c -allwarnings +iecfpextension +usebytestrings, + any.lens ==5.2.3, + lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, + any.lens-aeson ==1.2.3, any.lift-type ==0.1.1.1, any.lifted-base ==0.2.3.12, + any.linear ==1.22, + linear -herbie +template-haskell, any.megaparsec ==9.6.1, megaparsec -dev, any.memory ==0.18.0, @@ -169,14 +204,19 @@ constraints: any.Cabal ==3.8.1.0, any.monad-loops ==0.4.3, monad-loops +base4, any.mono-traversable ==1.0.17.0, + any.monomer ==1.6.0.1, + monomer -examples, any.mtl ==2.2.2, any.murmur3 ==1.0.5, + any.nanovg ==0.8.1.0, + nanovg -examples -gl2 -gles3 -stb_truetype, any.network ==3.1.4.0, network -devel, any.network-uri ==2.6.4.2, any.old-locale ==1.0.0.7, any.old-time ==1.1.0.4, any.os-string ==2.0.2, + any.parallel ==3.2.2.0, any.parsec ==3.1.16.1, any.parser-combinators ==1.3.0, parser-combinators -dev, @@ -189,11 +229,17 @@ constraints: any.Cabal ==3.8.1.0, any.pretty ==1.1.3.6, any.primitive ==0.9.0.0, any.process ==1.6.18.0, + any.profunctors ==5.6.2, + any.psqueues ==0.2.8.0, any.pureMD5 ==2.1.4, pureMD5 -test, + any.qrcode-core ==0.9.9, + any.qrcode-juicypixels ==0.8.5, any.quickcheck-io ==0.2.0, any.quickcheck-transformer ==0.3.1.2, any.random ==1.2.1.2, + any.reflection ==2.1.7, + reflection -slow +template-haskell, any.regex-base ==0.94.0.2, any.regex-compat ==0.95.2.1, any.regex-posix ==0.96.0.1, @@ -205,11 +251,15 @@ constraints: any.Cabal ==3.8.1.0, any.safe-exceptions ==0.1.7.4, any.scientific ==0.3.7.0, scientific -bytestring-builder -integer-simple, + any.sdl2 ==2.5.5.0, + sdl2 -examples -no-linear -opengl-example +pkgconfig +recent-ish, any.secp256k1-haskell ==1.2.0, any.semialign ==1.3, semialign +semigroupoids, any.semigroupoids ==6.0.0.1, semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, + any.semigroups ==0.20, + semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, any.serialise ==0.2.6.1, serialise +newtime15, any.silently ==1.2.5.3, @@ -227,6 +277,7 @@ constraints: any.Cabal ==3.8.1.0, any.string-conversions ==0.4.0.1, any.structured-cli ==2.7.0.1, structured-cli -debug, + any.system-cxx-std-lib ==1.0, any.tagged ==0.8.8, tagged +deepseq +transformers, any.template-haskell ==2.19.0.0, @@ -236,6 +287,8 @@ constraints: any.Cabal ==3.8.1.0, any.text-iso8601 ==0.1, any.text-short ==0.1.5, text-short -asserts, + any.text-show ==3.10.4, + text-show +base-4-9 +integer-gmp +new-functor-classes +template-haskell-2-11, any.text-zipper ==0.13, any.tf-random ==0.5, any.th-abstraction ==0.6.0.0, @@ -246,6 +299,8 @@ constraints: any.Cabal ==3.8.1.0, any.time ==1.12.2, any.time-compat ==1.9.6.1, time-compat -old-locale, + any.time-locale-compat ==0.1.1.5, + time-locale-compat -old-locale, any.tls ==2.0.2, tls -devel, any.transformers ==0.5.6.2, @@ -280,6 +335,8 @@ constraints: any.Cabal ==3.8.1.0, any.wide-word ==0.1.6.0, any.witherable ==0.4.2, any.word-wrap ==0.5, - any.zlib ==0.7.0.0, + any.wreq ==0.5.4.3, + wreq -aws -developer +doctest -httpbin, + any.zlib ==0.6.3.0, zlib -bundled-c-zlib +non-blocking-ffi +pkg-config index-state: hackage.haskell.org 2024-04-07T10:14:52Z diff --git a/src/Zenith/DB.hs b/src/Zenith/DB.hs index 8f9eef1..12d4e6c 100644 --- a/src/Zenith/DB.hs +++ b/src/Zenith/DB.hs @@ -77,6 +77,7 @@ import Zenith.Types , TransparentSpendingKeyDB , UnifiedAddressDB(..) , ZcashNetDB(..) + , ZcashPool(..) ) share @@ -252,6 +253,15 @@ share abaddress T.Text UniqueABA abaddress deriving Show Eq + QrCode + address WalletAddressId OnDeleteCascade OnUpdateCascade + version ZcashPool + bytes BS.ByteString + height Int + width Int + name T.Text + UniqueQr address version + deriving Show Eq |] -- * Database functions @@ -422,6 +432,16 @@ getWalletAddresses pool w = do addrs <- mapM (getAddresses pool . entityKey) accs return $ concat addrs +getExternalAddresses :: ConnectionPool -> IO [Entity WalletAddress] +getExternalAddresses pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + addrs <- from $ table @WalletAddress + where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB External) + return addrs + -- | Returns the largest address index for the given account getMaxAddress :: ConnectionPool -- ^ The database path @@ -554,6 +574,41 @@ getZcashTransactions pool b = orderBy [asc $ txs ^. ZcashTransactionBlock] return txs +-- ** QR codes +-- | Functions to manage the QR codes stored in the database +saveQrCode :: + ConnectionPool -- ^ the connection pool + -> QrCode + -> NoLoggingT IO (Maybe (Entity QrCode)) +saveQrCode pool qr = + PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity qr + +getQrCodes :: + ConnectionPool -- ^ the connection pool + -> WalletAddressId + -> IO [Entity QrCode] +getQrCodes pool wId = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + qrs <- from $ table @QrCode + where_ $ qrs ^. QrCodeAddress ==. val wId + return qrs + +getQrCode :: ConnectionPool -> ZcashPool -> WalletAddressId -> IO (Maybe QrCode) +getQrCode pool zp wId = do + r <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + qrs <- from $ table @QrCode + where_ $ qrs ^. QrCodeAddress ==. val wId + where_ $ qrs ^. QrCodeVersion ==. val zp + return qrs + return $ entityVal <$> r + -- * Wallet -- | Get the block of the last transaction known to the wallet getMaxWalletBlock :: diff --git a/src/Zenith/GUI.hs b/src/Zenith/GUI.hs new file mode 100644 index 0000000..6e95af4 --- /dev/null +++ b/src/Zenith/GUI.hs @@ -0,0 +1,1034 @@ +{-# 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.Exception (throwIO, try) +import Control.Monad.Logger (runNoLoggingT) +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.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(..) + , Scope(..) + , ToBytes(..) + , UnifiedAddress(..) + , ZcashNet(..) + , ZebraGetBlockChainInfo(..) + , ZebraGetInfo(..) + ) +import Zenith.Core +import Zenith.DB +import Zenith.GUI.Theme +import Zenith.Types hiding (ZcashAddress(..)) +import Zenith.Utils (displayAmount, showAddress) + +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 + | ShowSeed + | CopySeed !T.Text + | CopyTx !T.Text + | CloseTx + | ShowTx !Int + 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) + } 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) + , 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, 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] + , 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]]) + 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] + ] + +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] + 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] + 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] + 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 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) + 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 + +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 + 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 + 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 + ] diff --git a/src/Zenith/GUI/Theme.hs b/src/Zenith/GUI/Theme.hs new file mode 100644 index 0000000..7322522 --- /dev/null +++ b/src/Zenith/GUI/Theme.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenith.GUI.Theme + ( zenithTheme + ) where + +import Data.Default +import Lens.Micro ((&), (+~), (.~), (?~), (^.), at, set) +import Monomer +import Monomer.Core.Themes.BaseTheme +import Monomer.Core.Themes.SampleThemes +import Monomer.Graphics (rgbHex, transparent) +import Monomer.Graphics.ColorTable +import qualified Monomer.Lens as L + +baseTextStyle :: TextStyle +baseTextStyle = def & L.fontSize ?~ FontSize 10 & L.fontColor ?~ black + +hiliteTextStyle :: TextStyle +hiliteTextStyle = def & L.fontSize ?~ FontSize 10 & L.fontColor ?~ white + +zenithTheme :: Theme +zenithTheme = + baseTheme zgoThemeColors & L.basic . L.labelStyle . L.text ?~ baseTextStyle & + L.hover . + L.tooltipStyle . L.text ?~ + baseTextStyle & + L.hover . + L.labelStyle . L.text ?~ + baseTextStyle & + L.basic . + L.dialogTitleStyle . L.text ?~ + (baseTextStyle & L.fontSize ?~ FontSize 12 & L.font ?~ "Bold") & + L.hover . + L.dialogTitleStyle . L.text ?~ + (baseTextStyle & L.fontSize ?~ FontSize 12 & L.font ?~ "Bold") & + L.basic . + L.btnStyle . L.text ?~ + baseTextStyle & + L.hover . + L.btnStyle . L.text ?~ + baseTextStyle & + L.focus . + L.btnStyle . L.text ?~ + baseTextStyle & + L.focusHover . + L.btnStyle . L.text ?~ + baseTextStyle & + L.active . + L.btnStyle . L.text ?~ + baseTextStyle & + L.basic . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.hover . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.focus . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.focusHover . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.active . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.basic . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.hover . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.focus . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.active . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.focusHover . + L.textFieldStyle . L.text ?~ + baseTextStyle + +zenithThemeColors :: BaseThemeColors +zenithThemeColors = + BaseThemeColors + { clearColor = gray01 + , sectionColor = gray01 + , btnFocusBorder = blue09 + , btnBgBasic = gray07b + , btnBgHover = gray08 + , btnBgFocus = gray07c + , btnBgActive = gray06 + , btnBgDisabled = gray05 + , btnText = gray02 + , btnTextDisabled = gray01 + , btnMainFocusBorder = blue08 + , btnMainBgBasic = btnColor + , btnMainBgHover = btnHiLite + , btnMainBgFocus = btnColor + , btnMainBgActive = btnHiLite + , btnMainBgDisabled = blue04 + , btnMainText = white + , btnMainTextDisabled = gray08 + , dialogBg = gray01 + , dialogBorder = gray01 + , dialogText = white + , dialogTitleText = white + , emptyOverlay = gray05 & L.a .~ 0.8 + , shadow = gray00 & L.a .~ 0.33 + , externalLinkBasic = blue07 + , externalLinkHover = blue08 + , externalLinkFocus = blue07 + , externalLinkActive = blue06 + , externalLinkDisabled = gray06 + , iconBg = gray08 + , iconFg = gray01 + , inputIconFg = black + , inputBorder = gray02 + , inputFocusBorder = blue08 + , inputBgBasic = gray04 + , inputBgHover = gray06 + , inputBgFocus = gray05 + , inputBgActive = gray03 + , inputBgDisabled = gray07 + , inputFgBasic = gray06 + , inputFgHover = blue08 + , inputFgFocus = blue08 + , inputFgActive = blue07 + , inputFgDisabled = gray07 + , inputSndBasic = gray05 + , inputSndHover = gray06 + , inputSndFocus = gray05 + , inputSndActive = gray05 + , inputSndDisabled = gray03 + , inputHlBasic = gray07 + , inputHlHover = blue08 + , inputHlFocus = blue08 + , inputHlActive = blue08 + , inputHlDisabled = gray08 + , inputSelBasic = gray06 + , inputSelFocus = blue06 + , inputText = white + , inputTextDisabled = gray02 + , labelText = white + , scrollBarBasic = gray01 & L.a .~ 0.2 + , scrollThumbBasic = gray07 & L.a .~ 0.6 + , scrollBarHover = gray01 & L.a .~ 0.4 + , scrollThumbHover = gray07 & L.a .~ 0.8 + , slMainBg = gray00 + , slNormalBgBasic = transparent + , slNormalBgHover = gray05 + , slNormalText = white + , slNormalFocusBorder = blue08 + , slSelectedBgBasic = gray04 + , slSelectedBgHover = gray05 + , slSelectedText = white + , slSelectedFocusBorder = blue08 + , tooltipBorder = gray05 + , tooltipBg = rgbHex "#1D212B" + , tooltipText = white + } + +zgoThemeColors = + BaseThemeColors + { clearColor = gray10 -- gray12, + , sectionColor = gray09 -- gray11, + , btnFocusBorder = blue08 + , btnBgBasic = gray07 + , btnBgHover = gray07c + , btnBgFocus = gray07b + , btnBgActive = gray06 + , btnBgDisabled = gray05 + , btnText = gray02 + , btnTextDisabled = gray02 + , btnMainFocusBorder = blue09 + , btnMainBgBasic = btnColor + , btnMainBgHover = btnHiLite + , btnMainBgFocus = btnColor + , btnMainBgActive = btnHiLite + , btnMainBgDisabled = blue04 + , btnMainText = white + , btnMainTextDisabled = white + , dialogBg = white + , dialogBorder = white + , dialogText = black + , dialogTitleText = black + , emptyOverlay = gray07 & L.a .~ 0.8 + , shadow = gray00 & L.a .~ 0.2 + , externalLinkBasic = blue07 + , externalLinkHover = blue08 + , externalLinkFocus = blue07 + , externalLinkActive = blue06 + , externalLinkDisabled = gray06 + , iconBg = gray07 + , iconFg = gray01 + , inputIconFg = black + , inputBorder = gray06 + , inputFocusBorder = blue07 + , inputBgBasic = gray10 + , inputBgHover = white + , inputBgFocus = white + , inputBgActive = gray09 + , inputBgDisabled = gray05 + , inputFgBasic = gray05 + , inputFgHover = blue07 + , inputFgFocus = blue07 + , inputFgActive = blue06 + , inputFgDisabled = gray04 + , inputSndBasic = gray04 + , inputSndHover = gray05 + , inputSndFocus = gray05 + , inputSndActive = gray04 + , inputSndDisabled = gray03 + , inputHlBasic = gray06 + , inputHlHover = blue07 + , inputHlFocus = blue07 + , inputHlActive = blue06 + , inputHlDisabled = gray05 + , inputSelBasic = gray07 + , inputSelFocus = blue08 + , inputText = black + , inputTextDisabled = gray02 + , labelText = black + , scrollBarBasic = gray03 & L.a .~ 0.2 + , scrollThumbBasic = gray01 & L.a .~ 0.2 + , scrollBarHover = gray07 & L.a .~ 0.8 + , scrollThumbHover = gray05 & L.a .~ 0.8 + , slMainBg = white + , slNormalBgBasic = transparent + , slNormalBgHover = gray09 + , slNormalText = black + , slNormalFocusBorder = blue07 + , slSelectedBgBasic = gray08 + , slSelectedBgHover = gray09 + , slSelectedText = black + , slSelectedFocusBorder = blue07 + , tooltipBorder = gray08 + , tooltipBg = gray07 + , tooltipText = black + } + +--black = rgbHex "#000000" +{-white = rgbHex "#FFFFFF"-} +btnColor = rgbHex "#ff5722" --rgbHex "#1818B2" + +btnHiLite = rgbHex "#207DE8" + +blue01 = rgbHex "#002159" + +blue02 = rgbHex "#01337D" + +blue03 = rgbHex "#03449E" + +blue04 = rgbHex "#0552B5" + +blue05 = rgbHex "#0967D2" + +blue05b = rgbHex "#0F6BD7" + +blue05c = rgbHex "#1673DE" + +blue06 = rgbHex "#2186EB" + +blue06b = rgbHex "#2489EE" + +blue06c = rgbHex "#2B8FF6" + +blue07 = rgbHex "#47A3F3" + +blue07b = rgbHex "#50A6F6" + +blue07c = rgbHex "#57ACFC" + +blue08 = rgbHex "#7CC4FA" + +blue09 = rgbHex "#BAE3FF" + +blue10 = rgbHex "#E6F6FF" + +gray00 = rgbHex "#111111" + +gray01 = rgbHex "#2E2E2E" + +gray02 = rgbHex "#393939" + +gray03 = rgbHex "#515151" + +gray04 = rgbHex "#626262" + +gray05 = rgbHex "#7E7E7E" + +gray06 = rgbHex "#9E9E9E" + +gray07 = rgbHex "#B1B1B1" + +gray07b = rgbHex "#B4B4B4" + +gray07c = rgbHex "#BBBBBB" + +gray08 = rgbHex "#CFCFCF" + +gray09 = rgbHex "#E1E1E1" + +gray10 = rgbHex "#F7F7F7" diff --git a/src/Zenith/Types.hs b/src/Zenith/Types.hs index 5526aa6..6176c17 100644 --- a/src/Zenith/Types.hs +++ b/src/Zenith/Types.hs @@ -143,7 +143,9 @@ data ZcashPool | Sprout | Sapling | Orchard - deriving (Show, Eq, Generic, ToJSON) + deriving (Show, Read, Eq, Generic, ToJSON) + +derivePersistField "ZcashPool" instance FromJSON ZcashPool where parseJSON = diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs index 0d43a7c..dcc4e69 100644 --- a/src/Zenith/Utils.hs +++ b/src/Zenith/Utils.hs @@ -13,6 +13,7 @@ import System.Directory import Text.Regex.Posix import ZcashHaskell.Orchard (encodeUnifiedAddress, isValidUnifiedAddress) import ZcashHaskell.Sapling (isValidShieldedAddress) +import ZcashHaskell.Types (ZcashNet(..)) import Zenith.Types ( AddressGroup(..) , UnifiedAddressDB(..) @@ -40,6 +41,12 @@ displayTaz s | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mTAZ" | otherwise = show (fromIntegral s / 100000000) ++ " TAZ" +displayAmount :: ZcashNet -> Integer -> T.Text +displayAmount n a = + if n == MainNet + then T.pack $ displayZec a + else T.pack $ displayTaz a + -- | Helper function to display abbreviated Unified Address showAddress :: UnifiedAddressDB -> T.Text showAddress u = T.take 20 t <> "..." diff --git a/zenith.cabal b/zenith.cabal index f1796e3..59d9c34 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -27,6 +27,8 @@ library ghc-options: -Wall -Wunused-imports exposed-modules: Zenith.CLI + Zenith.GUI + Zenith.GUI.Theme Zenith.Core Zenith.DB Zenith.Types @@ -44,6 +46,7 @@ library , base64-bytestring , brick , bytestring + , data-default , esqueleto , resource-pool , binary @@ -52,15 +55,19 @@ library , vty-crossplatform , secp256k1-haskell , pureMD5 - , ghc >=9.6.5 + , ghc >=9.4.8 , haskoin-core , hexstring , http-client , http-conduit , http-types + , JuicyPixels + , qrcode-core + , qrcode-juicypixels , microlens , microlens-mtl , microlens-th + , monomer , mtl , persistent , Hclip @@ -72,6 +79,7 @@ library , regex-posix , scientific , text + , text-show , time , vector , vty