Enable QR codes for addresses

src/Zenith/GUI.hs

@@ -3,10 +3,17 @@
 
 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.Monad.Logger (runNoLoggingT)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
 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.Persist
 import Lens.Micro ((&), (+~), (.~), (?~), (^.), set)
@@ -14,8 +21,11 @@ import Lens.Micro.TH
 import Monomer
 import qualified Monomer.Lens as L
 import TextShow
+import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress)
+import ZcashHaskell.Transparent (encodeTransparentReceiver)
 import ZcashHaskell.Types
-  ( ZcashNet(..)
+  ( UnifiedAddress(..)
+  , ZcashNet(..)
   , ZebraGetBlockChainInfo(..)
   , ZebraGetInfo(..)
   )
@@ -40,6 +50,7 @@ data AppModel = AppModel
   , _zebraOn :: !Bool
   , _balance :: !Integer
   , _unconfBalance :: !(Maybe Integer)
+  , _selPool :: !ZcashPool
   } deriving (Eq, Show)
 
 makeLenses ''AppModel
@@ -50,6 +61,7 @@ data AppEvent
   | CloseMsg
   | WalletClicked
   | AccountClicked
+  | SetPool !ZcashPool
   deriving (Eq, Show)
 
 remixArrowRightWideLine :: T.Text
@@ -75,6 +87,10 @@ buildUI wenv model = widgetTree
       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))
     widgetTree =
       zstack [mainWindow, msgOverlay `nodeVisible` isJust (model ^. msg)]
     mainWindow =
@@ -142,15 +158,110 @@ buildUI wenv model = widgetTree
         ]
     addressBox =
       boxShadow $
-      box_
+      vstack
-        [alignMiddle]
+        [ box_
-        (vstack
+            [alignMiddle]
-           [ label "Addresses" `styleBasic`
+            (vstack
-             [textFont "Bold", textColor white, bgColor btnColor]
+               [ label "Addresses" `styleBasic`
-           , vscroll (vstack (zipWith addrRow [0 ..] (model ^. addresses))) `nodeKey`
+                 [textFont "Bold", textColor white, bgColor btnColor]
-             "addrScroll"
+               , vscroll (vstack (zipWith addrRow [0 ..] (model ^. addresses))) `nodeKey`
-           ]) `styleBasic`
+                 "addrScroll"
-      [padding 3, radius 2, bgColor white]
+               ]) `styleBasic`
+          [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 idx wAddr =
       box_
@@ -228,6 +339,7 @@ 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]
     CloseMsg -> [Model $ model & msg .~ Nothing]
 
 runZenithGUI :: Config -> IO ()
@@ -275,6 +387,7 @@ runZenithGUI config = do
                   True
                   314259000
                   (Just 300000)
+                  Transparent
           startApp model handleEvent buildUI params
     Left e -> do
       initDb dbFilePath
@@ -296,6 +409,7 @@ runZenithGUI config = do
               False
               314259000
               (Just 30000)
+              Orchard
       startApp model handleEvent buildUI params
   where
     params =

zenith.cabal

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