Enable QR codes for addresses

This commit is contained in:
Rene Vergara 2024-06-06 05:43:24 -05:00
parent e098480223
commit dbbce675f5
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
3 changed files with 127 additions and 10 deletions

BIN
assets/2620_color.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 17 KiB

View file

@ -3,10 +3,17 @@
module Zenith.GUI where 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.Exception (throwIO, try)
import Control.Monad.Logger (runNoLoggingT) import Control.Monad.Logger (runNoLoggingT)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Database.Persist import Database.Persist
import Lens.Micro ((&), (+~), (.~), (?~), (^.), set) import Lens.Micro ((&), (+~), (.~), (?~), (^.), set)
@ -14,8 +21,11 @@ import Lens.Micro.TH
import Monomer import Monomer
import qualified Monomer.Lens as L import qualified Monomer.Lens as L
import TextShow import TextShow
import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress)
import ZcashHaskell.Transparent (encodeTransparentReceiver)
import ZcashHaskell.Types import ZcashHaskell.Types
( ZcashNet(..) ( UnifiedAddress(..)
, ZcashNet(..)
, ZebraGetBlockChainInfo(..) , ZebraGetBlockChainInfo(..)
, ZebraGetInfo(..) , ZebraGetInfo(..)
) )
@ -40,6 +50,7 @@ data AppModel = AppModel
, _zebraOn :: !Bool , _zebraOn :: !Bool
, _balance :: !Integer , _balance :: !Integer
, _unconfBalance :: !(Maybe Integer) , _unconfBalance :: !(Maybe Integer)
, _selPool :: !ZcashPool
} deriving (Eq, Show) } deriving (Eq, Show)
makeLenses ''AppModel makeLenses ''AppModel
@ -50,6 +61,7 @@ data AppEvent
| CloseMsg | CloseMsg
| WalletClicked | WalletClicked
| AccountClicked | AccountClicked
| SetPool !ZcashPool
deriving (Eq, Show) deriving (Eq, Show)
remixArrowRightWideLine :: T.Text remixArrowRightWideLine :: T.Text
@ -75,6 +87,10 @@ buildUI wenv model = widgetTree
if null (model ^. accounts) if null (model ^. accounts)
then Nothing then Nothing
else Just ((model ^. accounts) !! (model ^. selAcc)) else Just ((model ^. accounts) !! (model ^. selAcc))
currentAddress =
if null (model ^. addresses)
then Nothing
else Just ((model ^. addresses) !! (model ^. selAddr))
widgetTree = widgetTree =
zstack [mainWindow, msgOverlay `nodeVisible` isJust (model ^. msg)] zstack [mainWindow, msgOverlay `nodeVisible` isJust (model ^. msg)]
mainWindow = mainWindow =
@ -142,7 +158,8 @@ buildUI wenv model = widgetTree
] ]
addressBox = addressBox =
boxShadow $ boxShadow $
box_ vstack
[ box_
[alignMiddle] [alignMiddle]
(vstack (vstack
[ label "Addresses" `styleBasic` [ label "Addresses" `styleBasic`
@ -151,6 +168,100 @@ buildUI wenv model = widgetTree
"addrScroll" "addrScroll"
]) `styleBasic` ]) `styleBasic`
[padding 3, radius 2, bgColor white] [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 :: Int -> Entity WalletAddress -> WidgetNode AppModel AppEvent
addrRow idx wAddr = addrRow idx wAddr =
box_ box_
@ -228,6 +339,7 @@ handleEvent wenv node model evt =
ShowMsg t -> [Model $ model & msg ?~ t] ShowMsg t -> [Model $ model & msg ?~ t]
WalletClicked -> [Model $ model & msg ?~ "You clicked Wallet!"] WalletClicked -> [Model $ model & msg ?~ "You clicked Wallet!"]
AccountClicked -> [Model $ model & msg ?~ "You clicked Account!"] AccountClicked -> [Model $ model & msg ?~ "You clicked Account!"]
SetPool p -> [Model $ model & selPool .~ p]
CloseMsg -> [Model $ model & msg .~ Nothing] CloseMsg -> [Model $ model & msg .~ Nothing]
runZenithGUI :: Config -> IO () runZenithGUI :: Config -> IO ()
@ -275,6 +387,7 @@ runZenithGUI config = do
True True
314259000 314259000
(Just 300000) (Just 300000)
Transparent
startApp model handleEvent buildUI params startApp model handleEvent buildUI params
Left e -> do Left e -> do
initDb dbFilePath initDb dbFilePath
@ -296,6 +409,7 @@ runZenithGUI config = do
False False
314259000 314259000
(Just 30000) (Just 30000)
Orchard
startApp model handleEvent buildUI params startApp model handleEvent buildUI params
where where
params = params =

View file

@ -60,6 +60,9 @@ library
, http-client , http-client
, http-conduit , http-conduit
, http-types , http-types
, JuicyPixels
, qrcode-core
, qrcode-juicypixels
, microlens , microlens
, microlens-mtl , microlens-mtl
, microlens-th , microlens-th