Implement reading QR codes from database

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"