rvv001 - Issue 0085 - URI support implemented in GUI

- Support to generate and display a QR Code containing
		       a  ZIP-321 formatted string

src/Zenith/GUI.hs

@@ -22,11 +22,15 @@ import Control.Monad.Logger
   )
 import Data.Aeson
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
 import Data.HexString (toText)
 import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Scientific (Scientific, fromFloatDigits)
+import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as E
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TLE
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Database.Esqueleto.Experimental (ConnectionPool, fromSqlKey)
 import Database.Persist
@@ -170,7 +174,7 @@ data AppEvent
   | ClosePaymentURIForm
   | PrepareURIString
   | CloseShowURIOverlay
-  | ShowURIOverlay !T.Text
+  | ShowURIOverlay  !(Maybe URIQrCode) !T.Text
   | CopyURIString !T.Text
   | DisplayPayUsingURI
   | ClosePayUsingURI
@@ -247,6 +251,7 @@ data AppModel = AppModel
   , _usepmtURIOverlay :: !Bool
   , _uriString :: !T.Text
   , _uriAddr :: !T.Text
+  , _uriQRImage :: !(Maybe URIQrCode)
   } deriving (Eq, Show)
 
 makeLenses ''AppModel
@@ -260,6 +265,18 @@ remixHourglassFill = toGlyph 0xF338
 remixIcon :: T.Text -> WidgetNode s e
 remixIcon i = label i `styleBasic` [textFont "Remix", textMiddle]
 
+getURIQRWidth :: Maybe URIQrCode -> Int
+getURIQRWidth qr = 
+  case qr of 
+    Nothing -> 0
+    Just qr -> round (uriWidth qr)
+
+getURIQRHeight :: Maybe URIQrCode -> Int
+getURIQRHeight qr = 
+  case qr of 
+    Nothing -> 0
+    Just qr -> round (uriHeight qr)
+
 buildUI ::
      WidgetEnv AppModel AppEvent -> AppModel -> WidgetNode AppModel AppEvent
 buildUI wenv model = widgetTree
@@ -1251,66 +1268,112 @@ buildUI wenv model = widgetTree
       [bgColor (white & L.a .~ 0.5)]
     --
     paymentURIOverlay =
-      alert ClosePaymentURIForm $
+      box
-      vstack
+        (vstack  
-        [ box_
+          [ filler 
-            []
+          , hstack 
-            (label "Create a Payment URI" `styleBasic`
+              [ filler 
-             [textFont "Bold", textColor white, textSize 10, padding 3]) `styleBasic`
+              , box_ 
-          [bgColor btnColor, radius 2, padding 3]
+                  []
-        , spacer
+                  (vstack
-        , hstack
+                    [ box_
-            [ filler
+                        []
-            , label "Current Address:" `styleBasic` [textFont "Bold"]
+                        (label "Create a Payment URI" `styleBasic`
-            , spacer
+                         [textFont "Bold", textColor white, textSize 10, padding 3]) `styleBasic`
-            , label_ (txtWrapN (model ^. uriAddr) 64) [multiline]
+                      [bgColor btnColor, radius 2, padding 3]
-            , filler
+                    , spacer
-            ]
+                    , hstack
-        , spacer
+                        [ filler
-        , hstack
+                        , label "Current Address:" `styleBasic` [textFont "Bold"]
-            [ label "Amount : " `styleBasic` [textFont "Bold"]
+                        , spacer
-            , numericField_ sendAmount
+                        , label_ (txtWrapN (model ^. uriAddr) 64) [multiline]
-              [ decimals 8 ]
+                        , filler
-                `nodeKey` "floatInput"
+                        ]
-                `styleBasic`
+                    , spacer
-                   [ width 150
+                    , hstack
-                   , styleIf (model ^. sendAmount <= 0.0) (textColor red)
+                        [ label "Amount : " `styleBasic` [textFont "Bold"]
-                   ]
+                        , numericField_ sendAmount
-            ]
+                          [ decimals 8 ]
-        , spacer
+                            `nodeKey` "floatInput"
-        , hstack
+                            `styleBasic`
-            [ label "Memo: "  `styleBasic` [textFont "Bold"]
+                               [ width 150
-            , spacer
+                               , styleIf (model ^. sendAmount <= 0.0) (textColor red)
-            , textField_ sendMemo [] `styleBasic` [width 300]
+                               ]
-            ]
+                        ]
-        , spacer
+                    , spacer
-        , hstack
+                    , hstack
-            [ filler
+                        [ label "Memo: "  `styleBasic` [textFont "Bold"]
-            , mainButton "Create URI" PrepareURIString `nodeEnabled`
+                        , spacer
-                  (model ^. sendAmount > 0.0)
+                        , textField_ sendMemo [] `styleBasic` [width 300]
-            , filler
+                        ]
-            ]
+                    , spacer
-        ]  `styleBasic`  [bgColor (white & L.a .~ 0.5)]
+                    , hstack
+                        [ filler
+                        , mainButton "Create URI" PrepareURIString `nodeEnabled`
+                              (model ^. sendAmount > 0.0)
+                        , spacer 
+                        , button "Cancel" ClosePaymentURIForm
+                        , filler
+                        ]
+                    ]) `styleBasic`
+                 [radius 4, border 2 btnColor, bgColor white, padding 4] 
+              , filler     
+              ]
+          , filler 
+          ]) `styleBasic`
+        [bgColor (white & L.a .~ 0.5)]
     --     
     showURIOverlay =
-      alert CloseShowURIOverlay $
+      box 
-      vstack
+        (vstack
-        [ box_
+          [ filler 
-            []
+          , hstack 
-            (label "Payment URI" `styleBasic`
+              [ filler 
-             [textFont "Bold", textColor white, textSize 12, padding 3]) `styleBasic`
+              , box_ 
-          [bgColor btnColor, radius 2, padding 3]
+                  []
-        , spacer
+                  (vstack 
-        , hstack
+                      [ box_
-            [filler, label_ (txtWrapN (model ^. uriString ) 64) [multiline], filler]
+                         [alignMiddle]
-        , spacer
+                         (label "Payment URI" `styleBasic`
-        , hstack
+                          [textFont "Bold", textColor white, textSize 11, padding 3]) `styleBasic`
-            [ filler
+                        [bgColor btnColor, radius 2, padding 3]
-            , button "Copy to Clipboard" $
+                      , spacer
-              CopyURIString (model ^. uriString)
+                      , hstack
-            , filler
+                          [filler, label_ (txtWrapN (model ^. uriString ) 64) [multiline], filler]
-            ]
+                      , spacer
-        ]
+                      , hstack
+                          [ filler
+                          , box_
+                              [alignMiddle]
+              --                (image_ (T.pack ((model ^. home) </> "Zenith/assets/qr_image.png")) [fitFill])
+                              (case model ^. uriQRImage of
+                                Just img ->  imageMem_ "URIQRCode" (uriBytes img) (Size (uriWidth img) (uriHeight img) ) [fitWidth]
+                                Nothing  ->  image_
+                                              (T.pack $ (model ^. home) </> "Zenith/assets/cracked_qr.png")
+                                              [fitHeight] )
+                               `styleBasic` [ bgColor white 
+                                            , height 120
+                                            , width 120
+                                            ]
+                          , filler
+                          ]
+                      , spacer
+                      , hstack
+                          [ filler
+                          , button "Copy to Clipboard" $
+                            CopyURIString (model ^. uriString)
+                          , spacer 
+                          , button "Cancel"  CloseShowURIOverlay  
+                          , filler
+                          ]
+                      ]) `styleBasic`
+                 [radius 4, border 2 btnColor, bgColor white, padding 4] 
+              , filler     
+              ]
+          , filler 
+          ] ) `styleBasic`
+        [bgColor (white & L.a .~ 0.5)]
+    --
     pmtUsingURIOverlay =
       box
         (vstack
@@ -1848,13 +1911,14 @@ handleEvent wenv node model evt =
     -- Generate URI 
     --
     PrepareURIString -> [ Task $ genURIString (model ^. uriAddr) (model ^. sendAmount) (model ^. sendMemo) ]
-    ShowURIOverlay uStr ->
+    ShowURIOverlay qr uStr ->
       [ Model $
         model & uriString .~ uStr
+              & uriQRImage .~ qr
               & paymentURIDisplay .~ False
               & showURIDisplay .~ True
       ]
-    CloseShowURIOverlay -> [ Model $ model & showURIDisplay .~ False & uriString .~ "" ]
+    CloseShowURIOverlay -> [ Model $ model & showURIDisplay .~ False & uriString .~ ""  & uriQRImage .~ Nothing]
     --
     -- Display Pay using URI Form
     --
@@ -2110,6 +2174,23 @@ handleEvent wenv node model evt =
                   t_rec =<< (isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<< a
       return $ DisplayPaymentURIForm ua
     --
+    -- Generate a QR code for a String and save it as an PNG image
+    --
+    genURIStringQR :: Int -> T.Text -> Maybe URIQrCode
+    genURIStringQR scaleFactor uriStr = do
+      let qrOptions = defaultQRCodeOptions L
+      case encodeText qrOptions Utf8WithoutECI uriStr of
+        Nothing -> Nothing 
+        Just qrCode -> do
+            let qri = promoteImage (toImage 4 scaleFactor qrCode) 
+            let qrw = fromIntegral $ imageWidth qri
+            let qrh = fromIntegral $ imageHeight qri
+            let qrb = BS.pack $ 
+                      pixelFold (\bs _ _ (PixelRGBA8 i j k l) -> bs <> [i, j, k, l])
+                      []
+                      qri
+            Just URIQrCode { uriBytes=qrb, uriWidth=qrw, uriHeight=qrh }
+    --
     -- Gen URI String
     --   
     genURIString :: T.Text ->  Float -> T.Text -> IO AppEvent
@@ -2118,7 +2199,7 @@ handleEvent wenv node model evt =
                   "" -> Nothing
                   _  -> Just (T.unpack mMemo)
       let uriSt = createZip321 (T.unpack addr) (Just (realToFrac mAmt)) mM
-      return $ ShowURIOverlay (T.pack uriSt)
+      return $ ShowURIOverlay (genURIStringQR 3 (T.pack uriSt)) (T.pack uriSt)
 
 scanZebra ::
      T.Text
@@ -2475,6 +2556,7 @@ runZenithGUI config = do
                           False
                           ""
                           ""
+                          Nothing
                   startApp model handleEvent buildUI (params hD)
         Left _e -> print "Zebra not available"
   where

src/Zenith/Types.hs

@@ -517,3 +517,11 @@ data ZcashPaymentURI = ZcashPaymentURI
   , uriLabel :: Maybe String
   , uriMessage :: Maybe String
   } deriving (Show, Eq)
+
+-- | Define a data structure for the URI QR image
+data URIQrCode = URIQrCode 
+  {
+    uriBytes  :: BS.ByteString -- Image as ByteString
+  , uriWidth  :: Double           -- Number of columns in QR Image
+  , uriHeight :: Double           -- Number of rows in a QR Image
+  }  deriving (Show, Eq)

src/Zenith/Utils.hs

@@ -17,7 +17,6 @@ import Data.Functor (void)
 import Data.Maybe
 import Data.Ord (clamp)
 import Data.Scientific (Scientific(..), scientific, Scientific, toRealFloat)
---import Data.Scientific (Scientific, toRealFloat)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as E
 import qualified Data.Text.Encoding as TE