{-# 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.Persist import Lens.Micro ((&), (+~), (.~), (?~), (^.), set) import Lens.Micro.TH import Monomer import qualified Monomer.Lens as L 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 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 } deriving (Eq, Show) makeLenses ''AppModel data AppEvent = AppInit | ShowMsg !T.Text | CloseMsg | WalletClicked | AccountClicked | SetPool !ZcashPool deriving (Eq, Show) 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, msgOverlay `nodeVisible` isJust (model ^. msg)] mainWindow = vstack [ windowHeader , spacer , balanceBox , filler , mainPane , filler , windowFooter ] windowHeader = hstack [ box_ [onClick WalletClicked, alignMiddle] walletButton `styleBasic` [cursorHand, height 25, padding 3] `styleHover` [bgColor btnHiLite] , box_ [onClick AccountClicked, alignMiddle] accountButton `styleBasic` [cursorHand, height 25, padding 3] `styleHover` [bgColor btnHiLite] , filler , remixIcon remixErrorWarningFill `styleBasic` [textColor white] , label "Testnet" `styleBasic` [textColor white] `nodeVisible` (model ^. network == TestNet) ] `styleBasic` [bgColor btnColor] 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] ] 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] ] 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 = boxShadow $ vstack [ 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 currentAddress (model ^. selPool) ] addrQRCode :: Maybe (Entity WalletAddress) -> ZcashPool -> WidgetNode AppModel AppEvent addrQRCode wAddr zp = case encodeText (defaultQRCodeOptions L) Utf8WithoutECI =<< dispAddr of Just qr -> box_ [alignMiddle] (hstack [ filler , vstack [ box_ [onClick (SetPool Orchard)] (remixIcon remixShieldCheckFill `styleBasic` [ textSize 14 , padding 4 , styleIf (model ^. selPool == Orchard) (bgColor btnColor) ]) , filler , box_ [onClick (SetPool Sapling)] (remixIcon remixShieldLine `styleBasic` [ textSize 14 , padding 4 , styleIf (model ^. selPool == Sapling) (bgColor btnColor) ]) , filler , box_ [onClick (SetPool Transparent)] (remixIcon remixDislikeLine `styleBasic` [ textSize 14 , padding 4 , styleIf (model ^. selPool == Transparent) (bgColor btnColor) ]) ] , vstack [ label (case model ^. selPool of Orchard -> "Unified" Sapling -> "Legacy Shielded" Transparent -> "Transparent" Sprout -> "Unknown") , imageMem_ (T.pack $ show zp) (qrCodeBytes qr) (qrCodeSize qr) [fitNone] ] , filler ]) Nothing -> box_ [alignMiddle] (image_ "./assets/2620_color.png" [fitFill]) where qrCodeImg :: QRImage -> Image PixelRGBA8 qrCodeImg qr = promoteImage (toImage 4 1 qr) qrCodeSize :: QRImage -> Size qrCodeSize qr = Size (fromIntegral $ imageWidth $ qrCodeImg qr) (fromIntegral $ imageHeight $ qrCodeImg qr) qrCodeBytes :: QRImage -> BS.ByteString qrCodeBytes qr = BS.pack $ pixelFold (\bs _ _ (PixelRGBA8 i j k l) -> bs <> [i, j, k, l]) [] (qrCodeImg qr) dispAddr :: Maybe T.Text dispAddr = case zp of Transparent -> T.append "zcash:" . encodeTransparentReceiver (model ^. network) <$> (t_rec =<< (isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<< wAddr) Sapling -> T.append "zcash:" <$> (getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress . entityVal =<< wAddr) Orchard -> T.append "zcash:" . getUA . walletAddressUAddress . entityVal <$> wAddr Sprout -> Nothing addrRow :: Int -> Entity WalletAddress -> WidgetNode AppModel AppEvent addrRow idx wAddr = box_ [onClick $ ShowMsg ("You clicked address " <> showt idx), alignLeft] (label (walletAddressName (entityVal wAddr) <> ": " <> showAddress (walletAddressUAddress $ entityVal wAddr))) `styleBasic` [padding 1, borderB 1 gray] 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] 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] WalletClicked -> [Model $ model & msg ?~ "You clicked Wallet!"] AccountClicked -> [Model $ model & msg ?~ "You clicked Account!"] SetPool p -> [Model $ model & selPool .~ p] CloseMsg -> [Model $ model & msg .~ Nothing] 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 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 [] let model = AppModel config (zgb_net chainInfo) walList 0 accList 0 addrList 0 txList 0 Nothing True 314259000 (Just 300000) Transparent 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 startApp model handleEvent buildUI params where params = [ appWindowTitle "Zenith - Zcash Full Node Wallet" , 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 ]