rvv001 - Issue 0085 - URI support implemented in GUI

- Support to generate a ZIP-321 formatted string
		      using a Transparent, Sapling or Unified address
 		      is available.

src/Zenith/GUI.hs

@@ -33,7 +33,6 @@ import Database.Persist
 import Lens.Micro ((&), (+~), (.~), (?~), (^.), set)
 import Lens.Micro.TH
 import Monomer
-
 import qualified Monomer.Lens as L
 import System.Directory (getHomeDirectory)
 import System.FilePath ((</>))
@@ -69,15 +68,16 @@ import Zenith.Types hiding (ZcashAddress(..))
 import Zenith.Utils
   ( displayAmount
   , getChainTip
-  , getZcashPrice
   , isRecipientValidGUI
   , isValidString
   , isZecAddressValid
   , jsonNumber
   , padWithZero
-  , parseZcashPayment
   , showAddress
   , validBarValue
+  , parseZcashPayment
+  , getZcashPrice
+  , createZip321
   )
 
 data VkTypeDef
@@ -96,7 +96,6 @@ data AppEvent
   | AccountClicked
   | MenuClicked
   | NewClicked
-  | ViewingKeysClicked
   | NewAddress !(Maybe (Entity ZcashAccount))
   | NewInternalAddress !(Maybe (Entity ZcashAccount))
   | NewAccount !(Maybe (Entity ZcashWallet))
@@ -162,15 +161,21 @@ data AppEvent
   | ShowFIATBalance
   | DisplayFIATBalance Double Double
   | CloseFIATBalance
+  | ViewingKeysClicked
   | PrepareViewingKey !VkTypeDef !(Maybe (Entity ZcashAccount))
   | ShowViewingKey !VkTypeDef !T.Text
   | CopyViewingKey !T.Text !T.Text
   | CloseShowVK
-  | DisplayPaymentURI
-  | ClosePaymentURI
+  | DisplayPaymentURIForm !T.Text
+  | ClosePaymentURIForm
+  | PrepareURIString
+  | CloseShowURIOverlay
+  | ShowURIOverlay !T.Text
+  | CopyURIString !T.Text
   | DisplayPayUsingURI
   | ClosePayUsingURI
   | ProcIfValidURI
+  | PreparePaymentURIForm
   deriving (Eq, Show)
 
 data AppModel = AppModel
@@ -238,8 +243,10 @@ data AppModel = AppModel
   , _vkTypeName :: !T.Text
   , _vkData :: !T.Text
   , _paymentURIDisplay :: !Bool
+  , _showURIDisplay :: !Bool
   , _usepmtURIOverlay :: !Bool
   , _uriString :: !T.Text
+  , _uriAddr :: !T.Text
   } deriving (Eq, Show)
 
 makeLenses ''AppModel
@@ -283,18 +290,19 @@ buildUI wenv model = widgetTree
         , modalOverlay `nodeVisible` isJust (model ^. modalMsg)
         , adrbookOverlay `nodeVisible` model ^. showAdrBook
         , newAdrBkOverlay `nodeVisible` model ^. newAdrBkEntry
-        , dfBalOverlay `nodeVisible` model ^. displayFIATBalance
         , showABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible`
           model ^.
           showABAddress
         , updateABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible`
           model ^.
           updateABAddress
-        , showVKOverlay `nodeVisible` model ^. viewingKeyDisplay
-        , paymentURIOverlay `nodeVisible` model ^. paymentURIDisplay
-        , pmtUsingURIOverlay `nodeVisible` model ^. usepmtURIOverlay
         , shieldOverlay `nodeVisible` model ^. shieldZec
         , deShieldOverlay `nodeVisible` model ^. deShieldZec
+        , dfBalOverlay `nodeVisible` model ^. displayFIATBalance
+        , showVKOverlay `nodeVisible` model ^. viewingKeyDisplay
+        , paymentURIOverlay `nodeVisible` model ^. paymentURIDisplay
+        , showURIOverlay `nodeVisible` model ^. showURIDisplay
+        , pmtUsingURIOverlay `nodeVisible` model ^. usepmtURIOverlay
         , msgAdrBookOverlay `nodeVisible` isJust (model ^. msgAB)
         ]
     mainWindow =
@@ -387,7 +395,7 @@ buildUI wenv model = widgetTree
                   ("Balance in " <>
                    T.toUpper (c_currencyCode (model ^. configuration)))) `styleBasic`
              [bgColor white, borderB 1 gray, padding 3]
-           , box_ [alignLeft, onClick DisplayPaymentURI] (label "Create URI") `styleBasic`
+           , box_ [alignLeft, onClick PreparePaymentURIForm] (label "Create URI") `styleBasic`
              [bgColor white, borderB 1 gray, padding 3]
            , box_
                [alignLeft, onClick DisplayPayUsingURI]
@@ -1241,66 +1249,68 @@ buildUI wenv model = widgetTree
            , filler
            ]) `styleBasic`
       [bgColor (white & L.a .~ 0.5)]
+    --
     paymentURIOverlay =
-      box
-        (vstack
-           [ filler
-           , hstack
-               [ filler
-               , box_
-                   []
-                   (vstack
-                      [ box_
-                          [alignMiddle]
-                          (label "Create URI" `styleBasic`
-                           [textColor white, textFont "Bold", textSize 12]) `styleBasic`
-                        [bgColor btnColor]
-                      , separatorLine `styleBasic` [fgColor btnColor]
-                      , spacer
-                      , hstack
-                          [ label "Amount:" `styleBasic`
-                            [width 50, textFont "Bold"]
-                          , spacer
-                          , numericField_
-                              sendAmount
-                              [ decimals 8
-                              , minValue 0.0
-                              , maxValue
-                                  (fromIntegral (model ^. balance) / 100000000.0)
-                              , validInput amountValid
-                              , onChange CheckAmount
-                              ] `styleBasic`
-                            [ width 150
-                            , styleIf
-                                (not $ model ^. amountValid)
-                                (textColor red)
-                            ]
-                          ]
-                      , hstack
-                          [ label "Memo:" `styleBasic`
-                            [width 50, textFont "Bold"]
-                          , spacer
-                          , textArea sendMemo `styleBasic`
-                            [width 150, height 40]
-                          ]
-                      , spacer
-                      , box_
-                          [alignMiddle]
-                          (hstack
-                             [ spacer
-                             , mainButton "Create URI" NotImplemented `nodeEnabled`
-                               True
-                             , spacer
-                             , button "Cancel" ClosePaymentURI
-                             , spacer
-                             ])
-                      ]) `styleBasic`
-                 [radius 4, border 2 btnColor, bgColor white, padding 4]
-               , filler
-               ]
-           , filler
-           ]) `styleBasic`
-      [bgColor (white & L.a .~ 0.5)]
+      alert ClosePaymentURIForm $
+      vstack
+        [ box_
+            []
+            (label "Create a Payment URI" `styleBasic`
+             [textFont "Bold", textColor white, textSize 10, padding 3]) `styleBasic`
+          [bgColor btnColor, radius 2, padding 3]
+        , spacer
+        , hstack
+            [ filler
+            , label "Current Address:" `styleBasic` [textFont "Bold"]
+            , spacer
+            , label_ (txtWrapN (model ^. uriAddr) 64) [multiline]
+            , filler
+            ]
+        , spacer
+        , hstack
+            [ label "Amount : " `styleBasic` [textFont "Bold"]
+            , numericField_ sendAmount
+              [ decimals 8 ]
+                `nodeKey` "floatInput"
+                `styleBasic`
+                   [ width 150
+                   , styleIf (model ^. sendAmount <= 0.0) (textColor red)
+                   ]
+            ]
+        , spacer
+        , hstack
+            [ label "Memo: "  `styleBasic` [textFont "Bold"]
+            , spacer
+            , textField_ sendMemo [] `styleBasic` [width 300]
+            ]
+        , spacer
+        , hstack
+            [ filler
+            , mainButton "Create URI" PrepareURIString `nodeEnabled`
+                  (model ^. sendAmount > 0.0)
+            , filler
+            ]
+        ]  `styleBasic`  [bgColor (white & L.a .~ 0.5)]
+    --      
+    showURIOverlay =
+      alert CloseShowURIOverlay $
+      vstack
+        [ box_
+            []
+            (label "Payment URI" `styleBasic`
+             [textFont "Bold", textColor white, textSize 12, padding 3]) `styleBasic`
+          [bgColor btnColor, radius 2, padding 3]
+        , spacer
+        , hstack
+            [filler, label_ (txtWrapN (model ^. uriString ) 64) [multiline], filler]
+        , spacer
+        , hstack
+            [ filler
+            , button "Copy to Clipboard" $
+              CopyURIString (model ^. uriString)
+            , filler
+            ]
+        ]
     pmtUsingURIOverlay =
       box
         (vstack
@@ -1694,6 +1704,7 @@ handleEvent wenv node model evt =
         model & amountValid .~
         (i < (fromIntegral (model ^. balance) / 100000000.0))
       ]
+    -- 
     ShowTxId tx -> [Model $ model & showId ?~ tx & modalMsg .~ Nothing]
     -- |
     -- | Address Book Events
@@ -1752,6 +1763,11 @@ handleEvent wenv node model evt =
       , setClipboardData $ ClipboardText v
       , Event $ ShowMessage (t <> " viewing key copied!!")
       ]
+    CopyURIString u ->
+      [ setClipboardData ClipboardEmpty
+      , setClipboardData $ ClipboardText u
+      , Event $ ShowMessage "URI string copied to clipboard!!"
+      ]
     DeleteABEntry a ->
       [ Task $ deleteAdrBook (model ^. configuration) a
       , Model $
@@ -1799,26 +1815,46 @@ handleEvent wenv node model evt =
     --
     ShowViewingKey vkType vkText ->
       case vkType of
-        VkFull -> [ Model $ 
+        VkFull -> [ Model $
                     model & vkTypeName .~ "Full"
                           & vkData .~ vkText
                           & viewingKeyDisplay .~ True
                           & menuPopup .~ False
                   ]
         VkIncoming -> [ Model $
-                        model & vkTypeName .~ "Incoming" 
+                        model & vkTypeName .~ "Incoming"
                               & vkData .~ vkText
-                              & viewingKeyDisplay .~ True 
+                              & viewingKeyDisplay .~ True
                               & menuPopup .~ False
                       ]
     --
     -- Display PaymentURI Form
     --
-    DisplayPaymentURI ->
+    PreparePaymentURIForm ->
+      [ Task $ getCurrentAddress currentAddress ]
+    -- 
+    DisplayPaymentURIForm ua->
       [ Model $
-        model & paymentURIDisplay .~ True & uriString .~ "" & menuPopup .~ False
+        model & uriString .~ ""
+              & uriAddr .~ ua
+              & amountValid .~ False
+              & sendAmount .~ 0.0
+              & sendMemo .~ ""
+              & paymentURIDisplay .~ True
+              & menuPopup .~ False
       ]
-    ClosePaymentURI -> [Model $ model & paymentURIDisplay .~ False]
+    ClosePaymentURIForm -> [Model $ model & paymentURIDisplay .~ False]
+    --
+    -- Generate URI 
+    --
+    PrepareURIString -> [ Task $ genURIString (model ^. uriAddr) (model ^. sendAmount) (model ^. sendMemo) ]
+    ShowURIOverlay uStr ->
+      [ Model $
+        model & uriString .~ uStr 
+              & paymentURIDisplay .~ False
+              & showURIDisplay .~ True
+      ]
+    CloseShowURIOverlay -> [ Model $ model & showURIDisplay .~ False & uriString .~ "" ]
     --
     -- Display Pay using URI Form
     --
@@ -1841,9 +1877,8 @@ handleEvent wenv node model evt =
                 T.pack (uriAddress p) &
                 sendAmount .~
                 realToFrac a &
-                sendMemo .~
-                (uriMemo p)
-              , Event $ ClosePaymentURI
+                sendMemo .~ (uriMemo p)
+              , Event $ ClosePaymentURIForm
               ]
             Nothing ->
               [ Model $
@@ -2046,9 +2081,9 @@ handleEvent wenv node model evt =
         Just acc -> do
             let osk = getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc
             let ssk = getSapSK $ zcashAccountSapSpendKey $ entityVal acc
-            let tsk = getTranSK $ zcashAccountTPrivateKey $ entityVal acc        
-            fvk <- deriveUfvk n osk ssk tsk 
-            return $ ShowViewingKey VkFull fvk 
+            let tsk = getTranSK $ zcashAccountTPrivateKey $ entityVal acc
+            fvk <- deriveUfvk n osk ssk tsk
+            return $ ShowViewingKey VkFull fvk
     --
     -- Get Incoming Viewing Key  
     --
@@ -2059,9 +2094,31 @@ handleEvent wenv node model evt =
         Just acc -> do
             let osk = getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc
             let ssk = getSapSK $ zcashAccountSapSpendKey $ entityVal acc
-            let tsk = getTranSK $ zcashAccountTPrivateKey $ entityVal acc        
-            ivk <- deriveUivk n osk ssk tsk 
-            return $ ShowViewingKey VkIncoming ivk 
+            let tsk = getTranSK $ zcashAccountTPrivateKey $ entityVal acc
+            ivk <- deriveUivk n osk ssk tsk
+            return $ ShowViewingKey VkIncoming ivk
+    --
+    -- Get curret zcash address 
+    --   
+    getCurrentAddress :: Maybe (Entity WalletAddress) -> IO AppEvent
+    getCurrentAddress  a = do
+      let ua = case model ^. selPool of
+                OrchardPool -> maybe "None" (getUA . walletAddressUAddress . entityVal) a
+                SaplingPool -> fromMaybe "None" $ (getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<< a
+                SproutPool -> "None"
+                TransparentPool -> maybe "None" (encodeTransparentReceiver (model ^. network)) $
+                  t_rec =<< (isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<< a
+      return $ DisplayPaymentURIForm ua  
+    --
+    -- Gen URI String
+    --   
+    genURIString :: T.Text ->  Float -> T.Text -> IO AppEvent
+    genURIString addr mAmt mMemo = do
+      let mM = case mMemo of
+                  "" -> Nothing
+                  _  -> Just (T.unpack mMemo) 
+      let uriSt = createZip321 (T.unpack addr) (Just (realToFrac mAmt)) mM 
+      return $ ShowURIOverlay (T.pack uriSt)
 
 scanZebra ::
      T.Text
@@ -2415,6 +2472,8 @@ runZenithGUI config = do
                           ""
                           False
                           False
+                          False
+                          ""
                           ""
                   startApp model handleEvent buildUI (params hD)
         Left _e -> print "Zebra not available"

src/Zenith/Utils.hs

@@ -22,6 +22,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as E
 import qualified Data.Text.Encoding as TE
 import Network.HTTP.Simple
+import Network.URI (escapeURIString, isUnreserved)
 import System.Directory
 import System.Process (createProcess_, shell)
 import Text.Printf (printf)
@@ -334,3 +335,22 @@ padBase64 bs = bs <> BC.replicate paddingLength '='
 -- Function to decode a base64 un-padded string
 decodeBase64Unpadded :: BC.ByteString -> Either String BC.ByteString
 decodeBase64Unpadded = B64.decode . padBase64
+
+-- Function to encode memo as un-padded Base64
+encodeBase64Memo :: String -> String
+encodeBase64Memo = BC.unpack . BC.takeWhile (/= '=') . B64.encode . BC.pack
+
+-- Function to drop trailing zeros 
+dropTrailingZeros :: String -> String
+dropTrailingZeros str =
+    let withoutZeros = reverse (dropWhile (== '0') (reverse str))
+    in if last withoutZeros == '.' 
+           then withoutZeros ++ "0"  -- Ensure at least one decimal place
+           else withoutZeros
+
+-- Function to create a ZIP-321 URI
+createZip321 :: String -> Maybe Double -> Maybe String -> String
+createZip321 address mAmount mMemo =
+  "zcash:" ++ address
+    ++ maybe "" (\amount -> "?amount=" ++ dropTrailingZeros (printf "%.8f" amount) ) mAmount
+    ++ maybe "" (\memo -> "&memo=" ++ escapeURIString isUnreserved (encodeBase64Memo memo)) mMemo

test/Spec.hs

@@ -1138,3 +1138,11 @@ main = do
             print p
             (uriAmount p) `shouldBe` Just 100.0
           Left e -> assertFailure $ "Error: " ++ e
+    describe "Create a ZIP-321 URI payment string " $ do
+      it "Creating an URI using a valid Zcash address, an amount, and a memo " $ do
+        let address = "ztestsapling10yy2ex5dcqkclhc7z7yrnjq2z6feyjad56ptwlfgmy77dmaqqrl9gyhprdx59qgmsnyfska2kez"
+        let amount = Just 1.2345
+        let memo = Just "This is a simple memo."
+        let uriString = createZip321 address amount memo 
+        print uriString 
+        uriString `shouldBe` "zcash:ztestsapling10yy2ex5dcqkclhc7z7yrnjq2z6feyjad56ptwlfgmy77dmaqqrl9gyhprdx59qgmsnyfska2kez?amount=1.2345&memo=VGhpcyBpcyBhIHNpbXBsZSBtZW1vLg"

zenith.cabal

@@ -97,6 +97,7 @@ library
     , word-wrap
     , zcash-haskell
     , unordered-containers
+    , network-uri
   --pkgconfig-depends: rustzcash_wrapper
   default-language: Haskell2010