Implement reading QR codes from database
This commit is contained in:
parent
0c5b2952c7
commit
eb925c21f7
GPG key ID:
65122AD495A7F5B2
1 changed files with 184 additions and 105 deletions
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue