zenith/src/Zenith/GUI.hs

{-# 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
  | SetPool !ZcashPool
  | SwitchQr !(Maybe QrCode)
  | SwitchAddr !Int
  | SwitchAcc !Int
  | CopyAddr !(Maybe (Entity WalletAddress))
  | LoadTxs ![Entity UserTx]
  | LoadAddrs ![Entity WalletAddress]
  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
  } 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, 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]
        , 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]
    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]
        ]
    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
      , 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]

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]
    WalletClicked -> [Model $ model & msg ?~ "You clicked Wallet!"]
    AccountClicked -> [Model $ model & accPopup .~ True]
    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
      ]
    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]
    CloseMsg -> [Model $ model & msg .~ Nothing]
  where
    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))
    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
          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
      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
      ]