{-# 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.Maybe (fromMaybe, isJust) 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 TextShow import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) import ZcashHaskell.Transparent (encodeTransparentReceiver) import ZcashHaskell.Types ( 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 | CloseMsg | WalletClicked | AccountClicked | MenuClicked | NewClicked | NewAddress | NewAccount | 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] | ConfirmCancel | SaveAddress 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 } 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) , msgOverlay `nodeVisible` isJust (model ^. msg) ] 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] (label "Backup Wallet") `styleBasic` [bgColor white, borderB 1 gray, padding 3] ]) `styleBasic` [bgColor btnColor, padding 3] newBox = box_ [alignMiddle] (vstack [ box_ [alignLeft, onClick NewAddress] (hstack [label "Address", filler]) `styleBasic` [bgColor white, borderB 1 gray, padding 3] , box_ [alignLeft, onClick NewAccount] (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] 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/2620_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 $ ShowMsg ("You clicked transaction " <> showt 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, 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]]) 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 -> [] ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False] WalletClicked -> [Model $ model & walPopup .~ True] AccountClicked -> [Model $ model & accPopup .~ True] MenuClicked -> [Model $ model & menuPopup .~ True] NewClicked -> [Model $ model & newPopup .~ not (model ^. newPopup)] NewAddress -> [ Model $ model & confirmTitle ?~ "New Address" & confirmAccept .~ "Create" & confirmCancel .~ "Cancel" ] NewAccount -> [Event $ ShowMsg "You clicked new account"] NewWallet -> [Event $ ShowMsg "You clicked new wallet"] ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""] SaveAddress -> [Event $ ShowMsg $ "You saved address: " <> model ^. mainInput] SetPool p -> [ Model $ model & selPool .~ p , 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 $ 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!" ] LoadTxs t -> [Model $ model & transactions .~ t] LoadAddrs a -> [Model $ model & addresses .~ a, Event $ SetPool Orchard] LoadAccs a -> [Model $ model & accounts .~ a, Event $ SwitchAcc 0] CloseMsg -> [Model $ model & msg .~ 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)) 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 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 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 ]