src/Zenith/CLI.hs

@@ -25,7 +25,7 @@ import Brick.Forms
 import qualified Brick.Main as M
 import qualified Brick.Types as BT
 import Brick.Types (Widget)
-import Brick.Util (bg, clamp, fg, on, style)
+import Brick.Util (bg, fg, on, style)
 import qualified Brick.Widgets.Border as B
 import Brick.Widgets.Border.Style (unicode, unicodeBold)
 import qualified Brick.Widgets.Center as C
@@ -97,7 +97,13 @@ import Zenith.Types
   , UnifiedAddressDB(..)
   , ZcashNetDB(..)
   )
-import Zenith.Utils (displayTaz, displayZec, jsonNumber, showAddress)
+import Zenith.Utils
+  ( displayTaz
+  , displayZec
+  , jsonNumber
+  , showAddress
+  , validBarValue
+  )
 
 data Name
   = WList
@@ -589,9 +595,6 @@ barDoneAttr = A.attrName "done"
 barToDoAttr :: A.AttrName
 barToDoAttr = A.attrName "remaining"
 
-validBarValue :: Float -> Float
-validBarValue = clamp 0 1
-
 scanZebra :: T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> IO ()
 scanZebra dbP zHost zPort b eChan = do
   _ <- liftIO $ initDb dbP

src/Zenith/GUI.hs

@@ -7,8 +7,11 @@ import Codec.Picture
 import Codec.Picture.Types (pixelFold, promoteImage)
 import Codec.QRCode
 import Codec.QRCode.JuicyPixels
+import Control.Concurrent (threadDelay)
 import Control.Exception (throwIO, try)
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger (runNoLoggingT)
+import Data.Aeson
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import Data.HexString (toText)
@@ -23,13 +26,15 @@ import Lens.Micro.TH
 import Monomer
 import qualified Monomer.Lens as L
 import System.Hclip
+import Text.Printf
 import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText)
 import TextShow hiding (toText)
 import ZcashHaskell.Keys (generateWalletSeedPhrase)
 import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress)
 import ZcashHaskell.Transparent (encodeTransparentReceiver)
 import ZcashHaskell.Types
-  ( Phrase(..)
+  ( BlockResponse(..)
+  , Phrase(..)
   , Scope(..)
   , ToBytes(..)
   , UnifiedAddress(..)
@@ -37,11 +42,13 @@ import ZcashHaskell.Types
   , ZebraGetBlockChainInfo(..)
   , ZebraGetInfo(..)
   )
+import ZcashHaskell.Utils (getBlockTime, makeZebraCall)
 import Zenith.Core
 import Zenith.DB
 import Zenith.GUI.Theme
+import Zenith.Scanner (processTx)
 import Zenith.Types hiding (ZcashAddress(..))
-import Zenith.Utils (displayAmount, showAddress)
+import Zenith.Utils (displayAmount, jsonNumber, showAddress, validBarValue)
 
 data AppEvent
   = AppInit
@@ -76,6 +83,13 @@ data AppEvent
   | CopyTx !T.Text
   | CloseTx
   | ShowTx !Int
+  | TickUp
+  | SyncVal !Float
+  | SendTx
+  | ShowSend
+  | CancelSend
+  | CheckRecipient
+  | CheckAmount
   deriving (Eq, Show)
 
 data AppModel = AppModel
@@ -108,6 +122,14 @@ data AppModel = AppModel
   , _showSeed :: !Bool
   , _modalMsg :: !(Maybe T.Text)
   , _showTx :: !(Maybe Int)
+  , _timer :: !Int
+  , _barValue :: !Float
+  , _openSend :: !Bool
+  , _sendRecipient :: !T.Text
+  , _sendAmount :: !Float
+  , _sendMemo :: !T.Text
+  , _recipientValid :: !Bool
+  , _amountValid :: !Bool
   } deriving (Eq, Show)
 
 makeLenses ''AppModel
@@ -145,6 +167,7 @@ buildUI wenv model = widgetTree
         , confirmOverlay `nodeVisible` isJust (model ^. confirmTitle)
         , seedOverlay `nodeVisible` model ^. showSeed
         , txOverlay `nodeVisible` isJust (model ^. showTx)
+        , sendTxOverlay `nodeVisible` model ^. openSend
         , msgOverlay `nodeVisible` isJust (model ^. msg)
         , modalOverlay `nodeVisible` isJust (model ^. modalMsg)
         ]
@@ -275,7 +298,12 @@ buildUI wenv model = widgetTree
     mainPane =
       box_ [alignMiddle] $
       hstack
-        [addressBox, txBox `nodeVisible` not (null $ model ^. transactions)]
+        [ addressBox
+        , vstack
+            [ mainButton "Send" ShowSend
+            , txBox `nodeVisible` not (null $ model ^. transactions)
+            ]
+        ]
     balanceBox =
       hstack
         [ filler
@@ -456,6 +484,8 @@ buildUI wenv model = widgetTree
             ("Last block sync: " <>
              maybe "N/A" (showt . zcashWalletLastSync . entityVal) currentWallet) `styleBasic`
           [padding 3, textSize 8]
+        , spacer
+        , label (showt $ model ^. timer) `styleBasic` [padding 3, textSize 8]
         , filler
         , image_ "./assets/1F993.png" [fitHeight] `styleBasic`
           [height 24, width 24] `nodeVisible`
@@ -489,6 +519,31 @@ buildUI wenv model = widgetTree
         , cancelCaption $ model ^. confirmCancel
         ]
         (hstack [label "Name:", filler, textField_ mainInput [maxLength 25]])
+    sendTxOverlay =
+      confirm_
+        SendTx
+        CancelSend
+        [ titleCaption "Send Transaction"
+        , acceptCaption "Send"
+        , cancelCaption "Cancel"
+        ]
+        (vstack
+           [ hstack
+               [ label "To:" `styleBasic` [width 50]
+               , filler
+               , textField_ sendRecipient []
+               ]
+           , hstack
+               [ label "Amount:" `styleBasic` [width 50]
+               , filler
+               , numericField_ sendAmount [minValue 0.0, decimals 8]
+               ]
+           , hstack
+               [ label "Memo:" `styleBasic` [width 50]
+               , filler
+               , textArea sendMemo
+               ]
+           ])
     seedOverlay =
       alert CloseSeed $
       vstack
@@ -679,7 +734,8 @@ handleEvent ::
   -> [AppEventResponse AppModel AppEvent]
 handleEvent wenv node model evt =
   case evt of
-    AppInit -> [Event NewWallet | isNothing currentWallet]
+    AppInit ->
+      [Event NewWallet | isNothing currentWallet] <> [Producer timeTicker]
     ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False]
     ShowError t ->
       [Model $ model & msg ?~ t & menuPopup .~ False & inError .~ True]
@@ -720,6 +776,14 @@ handleEvent wenv node model evt =
       ]
     ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""]
     ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False]
+    ShowSend -> [Model $ model & openSend .~ True]
+    SendTx -> []
+    CancelSend ->
+      [ Model $
+        model & openSend .~ False & sendRecipient .~ "" & sendAmount .~ 0.0 &
+        sendMemo .~
+        ""
+      ]
     SaveAddress acc ->
       if T.length (model ^. mainInput) > 1
         then [ Task $ addNewAddress (model ^. mainInput) External acc
@@ -817,12 +881,53 @@ handleEvent wenv node model evt =
         else [Event $ NewAccount currentWallet]
     LoadWallets a ->
       if not (null a)
-        then [Model $ model & wallets .~ a, Event $ SwitchWal 0]
+        then [ Model $ model & wallets .~ a
+             , Event $ SwitchWal $ model ^. selWallet
+             ]
         else [Event NewWallet]
     CloseMsg -> [Model $ model & msg .~ Nothing & inError .~ False]
     CloseSeed -> [Model $ model & showSeed .~ False]
     CloseTx -> [Model $ model & showTx .~ Nothing]
     ShowTx i -> [Model $ model & showTx ?~ i]
+    TickUp ->
+      if (model ^. timer) < 90
+        then [Model $ model & timer .~ (1 + model ^. timer)]
+        else if (model ^. barValue) == 1.0
+               then [ Model $ model & timer .~ 0 & barValue .~ 0.0
+                    , Producer $
+                      scanZebra
+                        (c_dbPath $ model ^. configuration)
+                        (c_zebraHost $ model ^. configuration)
+                        (c_zebraPort $ model ^. configuration)
+                    ]
+               else [Model $ model & timer .~ 0]
+    SyncVal i ->
+      if (i + model ^. barValue) >= 0.999
+        then [ Model $ model & barValue .~ 1.0 & modalMsg .~ Nothing
+             , Task $ do
+                 case currentWallet of
+                   Nothing -> return $ ShowError "No wallet available"
+                   Just cW -> do
+                     syncWallet (model ^. configuration) cW
+                     return $ SwitchAddr (model ^. selAddr)
+             , Task $ do
+                 pool <-
+                   runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
+                 wL <- getWallets pool (model ^. network)
+                 return $ LoadWallets wL
+             ]
+        else [ Model $
+               model & barValue .~ validBarValue (i + model ^. barValue) &
+               modalMsg ?~
+               ("Wallet Sync: " <>
+                T.pack (printf "%.2f%%" (model ^. barValue * 100)))
+             ]
+    CheckRecipient -> []
+    CheckAmount ->
+      [ Model $
+        model & amountValid .~
+        ((model ^. sendAmount) < (fromIntegral (model ^. balance) / 100000000.0))
+      ]
   where
     currentWallet =
       if null (model ^. wallets)
@@ -911,6 +1016,64 @@ handleEvent wenv node model evt =
               wL <- getWallets pool (model ^. network)
               return $ LoadWallets wL
 
+scanZebra :: T.Text -> T.Text -> Int -> (AppEvent -> IO ()) -> IO ()
+scanZebra dbPath zHost zPort sendMsg = do
+  _ <- liftIO $ initDb dbPath
+  bStatus <- liftIO $ checkBlockChain zHost zPort
+  pool <- runNoLoggingT $ initPool dbPath
+  b <- liftIO $ getMinBirthdayHeight pool
+  dbBlock <- runNoLoggingT $ getMaxBlock pool
+  let sb = max dbBlock b
+  if sb > zgb_blocks bStatus || sb < 1
+    then sendMsg (ShowError "Invalid starting block for scan")
+    else do
+      let bList = [(sb + 1) .. (zgb_blocks bStatus)]
+      if not (null bList)
+        then do
+          let step = (1.0 :: Float) / fromIntegral (length bList)
+          mapM_ (processBlock pool step) bList
+        else sendMsg (SyncVal 1.0)
+  where
+    processBlock :: ConnectionPool -> Float -> Int -> IO ()
+    processBlock pool step bl = do
+      r <-
+        liftIO $
+        makeZebraCall
+          zHost
+          zPort
+          "getblock"
+          [Data.Aeson.String $ showt bl, jsonNumber 1]
+      case r of
+        Left e1 -> sendMsg (ShowError $ showt e1)
+        Right blk -> do
+          r2 <-
+            liftIO $
+            makeZebraCall
+              zHost
+              zPort
+              "getblock"
+              [Data.Aeson.String $ showt bl, jsonNumber 0]
+          case r2 of
+            Left e2 -> sendMsg (ShowError $ showt e2)
+            Right hb -> do
+              let blockTime = getBlockTime hb
+              mapM_ (runNoLoggingT . processTx zHost zPort blockTime pool) $
+                bl_txs $ addTime blk blockTime
+              sendMsg (SyncVal step)
+    addTime :: BlockResponse -> Int -> BlockResponse
+    addTime bl t =
+      BlockResponse
+        (bl_confirmations bl)
+        (bl_height bl)
+        (fromIntegral t)
+        (bl_txs bl)
+
+timeTicker :: (AppEvent -> IO ()) -> IO ()
+timeTicker sendMsg = do
+  sendMsg TickUp
+  threadDelay $ 1000 * 1000
+  timeTicker sendMsg
+
 txtWrap :: T.Text -> T.Text
 txtWrap = wrapText (WrapSettings False True NoFill FillAfterFirst) 32
 
@@ -982,6 +1145,14 @@ runZenithGUI config = do
                   False
                   Nothing
                   Nothing
+                  0
+                  1.0
+                  False
+                  ""
+                  0.0
+                  ""
+                  False
+                  False
           startApp model handleEvent buildUI params
     Left e -> do
       initDb dbFilePath
@@ -1018,6 +1189,14 @@ runZenithGUI config = do
               False
               Nothing
               Nothing
+              0
+              1.0
+              False
+              ""
+              0.0
+              ""
+              False
+              False
       startApp model handleEvent buildUI params
   where
     params =

src/Zenith/GUI/Theme.hs

@@ -78,6 +78,36 @@ zenithTheme =
   baseTextStyle &
   L.focusHover .
   L.textFieldStyle . L.text ?~
+  baseTextStyle &
+  L.basic .
+  L.numericFieldStyle . L.text ?~
+  baseTextStyle &
+  L.hover .
+  L.numericFieldStyle . L.text ?~
+  baseTextStyle &
+  L.focus .
+  L.numericFieldStyle . L.text ?~
+  baseTextStyle &
+  L.active .
+  L.numericFieldStyle . L.text ?~
+  baseTextStyle &
+  L.focusHover .
+  L.numericFieldStyle . L.text ?~
+  baseTextStyle &
+  L.basic .
+  L.textAreaStyle . L.text ?~
+  baseTextStyle &
+  L.hover .
+  L.textAreaStyle . L.text ?~
+  baseTextStyle &
+  L.focus .
+  L.textAreaStyle . L.text ?~
+  baseTextStyle &
+  L.active .
+  L.textAreaStyle . L.text ?~
+  baseTextStyle &
+  L.focusHover .
+  L.textAreaStyle . L.text ?~
   baseTextStyle
 
 zenithThemeColors :: BaseThemeColors

src/Zenith/Utils.hs

@@ -5,6 +5,7 @@ module Zenith.Utils where
 import Data.Aeson
 import Data.Functor (void)
 import Data.Maybe
+import Data.Ord (clamp)
 import Data.Scientific (Scientific(..), scientific)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as E
@@ -79,3 +80,7 @@ copyAddress a =
   void $
   createProcess_ "toClipboard" $
   shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard"
+
+-- | Bound a value to the 0..1 range, used for progress reporting on UIs
+validBarValue :: Float -> Float
+validBarValue = clamp (0, 1)