Implement reading QR codes from database

src/Zenith/DB.hs

@@ -77,6 +77,7 @@ import Zenith.Types
   , TransparentSpendingKeyDB
   , UnifiedAddressDB(..)
   , ZcashNetDB(..)
+  , ZcashPool(..)
   )
 
 share
@@ -246,6 +247,15 @@ share
     position Int
     UniqueSSPos tx position
     deriving Show Eq
+  QrCode
+    address WalletAddressId OnDeleteCascade OnUpdateCascade
+    version ZcashPool
+    bytes BS.ByteString
+    height Int
+    width Int
+    name T.Text
+    UniqueQr address version
+    deriving Show Eq
     |]
 
 -- * Database functions
@@ -416,6 +426,16 @@ getWalletAddresses pool w = do
   addrs <- mapM (getAddresses pool . entityKey) accs
   return $ concat addrs
 
+getExternalAddresses :: ConnectionPool -> IO [Entity WalletAddress]
+getExternalAddresses pool = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
+      select $ do
+        addrs <- from $ table @WalletAddress
+        where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB External)
+        return addrs
+
 -- | Returns the largest address index for the given account
 getMaxAddress ::
      ConnectionPool -- ^ The database path
@@ -548,6 +568,41 @@ getZcashTransactions pool b =
       orderBy [asc $ txs ^. ZcashTransactionBlock]
       return txs
 
+-- ** QR codes
+-- | Functions to manage the QR codes stored in the database
+saveQrCode ::
+     ConnectionPool -- ^ the connection pool
+  -> QrCode
+  -> NoLoggingT IO (Maybe (Entity QrCode))
+saveQrCode pool qr =
+  PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity qr
+
+getQrCodes ::
+     ConnectionPool -- ^ the connection pool
+  -> WalletAddressId
+  -> IO [Entity QrCode]
+getQrCodes pool wId =
+  runNoLoggingT $
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
+    select $ do
+      qrs <- from $ table @QrCode
+      where_ $ qrs ^. QrCodeAddress ==. val wId
+      return qrs
+
+getQrCode :: ConnectionPool -> ZcashPool -> WalletAddressId -> IO (Maybe QrCode)
+getQrCode pool zp wId = do
+  r <-
+    runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
+      selectOne $ do
+        qrs <- from $ table @QrCode
+        where_ $ qrs ^. QrCodeAddress ==. val wId
+        where_ $ qrs ^. QrCodeVersion ==. val zp
+        return qrs
+  return $ entityVal <$> r
+
 -- * Wallet
 -- | Get the block of the last transaction known to the wallet
 getMaxWalletBlock ::

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,15 +172,10 @@ buildUI wenv model = widgetTree
                  "addrScroll"
                ]) `styleBasic`
           [padding 3, radius 2, bgColor white]
-        , addrQRCode currentAddress (model ^. selPool)
+        , addrQRCode
         ]
-    addrQRCode ::
+    addrQRCode :: WidgetNode AppModel AppEvent
-         Maybe (Entity WalletAddress)
+    addrQRCode =
-      -> ZcashPool
-      -> WidgetNode AppModel AppEvent
-    addrQRCode wAddr zp =
-      case encodeText (defaultQRCodeOptions L) Utf8WithoutECI =<< dispAddr of
-        Just qr ->
       box_
         [alignMiddle]
         (hstack
@@ -187,9 +186,8 @@ buildUI wenv model = widgetTree
                    (remixIcon remixShieldCheckFill `styleBasic`
                     [ textSize 14
                     , padding 4
-                        , styleIf
+                    , styleIf (model ^. selPool == Orchard) (bgColor btnColor)
-                            (model ^. selPool == Orchard)
+                    , styleIf (model ^. selPool == Orchard) (textColor white)
-                            (bgColor btnColor)
                     ])
                , filler
                , box_
@@ -197,9 +195,8 @@ buildUI wenv model = widgetTree
                    (remixIcon remixShieldLine `styleBasic`
                     [ textSize 14
                     , padding 4
-                        , styleIf
+                    , styleIf (model ^. selPool == Sapling) (bgColor btnColor)
-                            (model ^. selPool == Sapling)
+                    , styleIf (model ^. selPool == Sapling) (textColor white)
-                            (bgColor btnColor)
                     ])
                , filler
                , box_
@@ -210,6 +207,9 @@ buildUI wenv model = widgetTree
                     , styleIf
                         (model ^. selPool == Transparent)
                         (bgColor btnColor)
+                    , styleIf
+                        (model ^. selPool == Transparent)
+                        (textColor white)
                     ])
                ]
            , vstack
@@ -218,58 +218,38 @@ buildUI wenv model = widgetTree
                       Orchard -> "Unified"
                       Sapling -> "Legacy Shielded"
                       Transparent -> "Transparent"
-                          Sprout -> "Unknown")
+                      Sprout -> "Unknown") `styleBasic`
-                   , imageMem_
+                 [textColor white]
-                       (T.pack $ show zp)
+               , box_
+                   [alignMiddle]
+                   (case model ^. qrCodeWidget of
+                      Just qr ->
+                        imageMem_
+                          (qrCodeName qr)
                           (qrCodeBytes qr)
-                       (qrCodeSize qr)
+                          (Size
-                       [fitNone]
+                             (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`
-        Nothing ->
+         [bgColor white])
-          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]
+        [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"

src/Zenith/Types.hs

@@ -143,7 +143,9 @@ data ZcashPool
   | Sprout
   | Sapling
   | Orchard
-  deriving (Show, Eq, Generic, ToJSON)
+  deriving (Show, Read, Eq, Generic, ToJSON)
+
+derivePersistField "ZcashPool"
 
 instance FromJSON ZcashPool where
   parseJSON =