diff --git a/src/Zenith/GUI.hs b/src/Zenith/GUI.hs index 2caf5ef..a304321 100644 --- a/src/Zenith/GUI.hs +++ b/src/Zenith/GUI.hs @@ -15,6 +15,7 @@ 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 @@ -35,6 +36,17 @@ 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 + deriving (Eq, Show) + data AppModel = AppModel { _configuration :: !Config , _network :: !ZcashNet @@ -51,19 +63,11 @@ data AppModel = AppModel , _balance :: !Integer , _unconfBalance :: !(Maybe Integer) , _selPool :: !ZcashPool + , _qrCodeWidget :: !(Maybe QrCode) } 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 @@ -168,108 +172,84 @@ buildUI wenv model = widgetTree "addrScroll" ]) `styleBasic` [padding 3, radius 2, bgColor white] - , addrQRCode currentAddress (model ^. selPool) + , addrQRCode ] - 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] - ] + addrQRCode :: WidgetNode AppModel AppEvent + addrQRCode = + box_ + [alignMiddle] + (hstack + [ filler + , vstack + [ box_ + [onClick (SetPool Orchard)] + (remixIcon remixShieldCheckFill `styleBasic` + [ textSize 14 + , padding 4 + , styleIf (model ^. selPool == Orchard) (bgColor btnColor) + , styleIf (model ^. selPool == Orchard) (textColor white) + ]) , 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 + , box_ + [onClick (SetPool Sapling)] + (remixIcon remixShieldLine `styleBasic` + [ textSize 14 + , padding 4 + , styleIf (model ^. selPool == Sapling) (bgColor btnColor) + , styleIf (model ^. selPool == Sapling) (textColor white) + ]) + , filler + , box_ + [onClick (SetPool Transparent)] + (remixIcon remixDislikeLine `styleBasic` + [ textSize 14 + , padding 4 + , styleIf + (model ^. selPool == Transparent) + (bgColor btnColor) + , styleIf + (model ^. selPool == Transparent) + (textColor white) + ]) + ] + , vstack + [ label + (case model ^. selPool of + Orchard -> "Unified" + Sapling -> "Legacy Shielded" + Transparent -> "Transparent" + Sprout -> "Unknown") `styleBasic` + [textColor white] + , 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] + ] `styleBasic` + [bgColor btnColor, border 2 btnColor] + , filler + ] `styleBasic` + [bgColor white]) addrRow :: Int -> Entity WalletAddress -> WidgetNode AppModel AppEvent addrRow idx wAddr = box_ - [onClick $ ShowMsg ("You clicked address " <> showt idx), alignLeft] + [onClick $ SwitchAddr idx, alignLeft] (label (walletAddressName (entityVal wAddr) <> ": " <> showAddress (walletAddressUAddress $ entityVal wAddr))) `styleBasic` - [padding 1, borderB 1 gray] + [ padding 1 + , borderB 1 gray + , styleIf (model ^. selAddr == idx) (borderL 2 btnHiLite) + , styleIf (model ^. selAddr == idx) (borderR 2 btnHiLite) + ] txBox = boxShadow $ box_ @@ -327,6 +307,74 @@ buildUI wenv model = widgetTree 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 @@ -339,8 +387,31 @@ handleEvent wenv node model evt = 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] + 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 + ] + SwitchQr q -> [Model $ model & qrCodeWidget .~ q] + SwitchAddr i -> [Model $ model & selAddr .~ i, 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)) + currentAddress = + if null (model ^. addresses) + then Nothing + else Just ((model ^. addresses) !! (model ^. selAddr)) runZenithGUI :: Config -> IO () runZenithGUI config = do @@ -358,6 +429,7 @@ runZenithGUI config = do Left e1 -> throwIO e1 Right chainInfo -> do initDb dbFilePath + generateQRCodes config walList <- getWallets pool $ zgb_net chainInfo accList <- if not (null walList) @@ -371,6 +443,10 @@ runZenithGUI config = do 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 @@ -387,7 +463,8 @@ runZenithGUI config = do True 314259000 (Just 300000) - Transparent + Orchard + qr startApp model handleEvent buildUI params Left e -> do initDb dbFilePath @@ -410,10 +487,12 @@ runZenithGUI config = do 314259000 (Just 30000) Orchard + Nothing startApp model handleEvent buildUI params where params = [ appWindowTitle "Zenith - Zcash Full Node Wallet" + , appWindowState $ MainWindowNormal (1000, 600) , appTheme zenithTheme , appFontDef "Regular" "./assets/Atkinson-Hyperlegible-Regular-102.ttf" --"./assets/DejaVuSansMono.ttf" , appFontDef "Bold" "./assets/Atkinson-Hyperlegible-Bold-102.ttf"