add k-account button on keys page (#710)

* add k-account button for keys

* add query to route so that addkaccount button opens in new account view

* add k: Account

Co-authored-by: jmininger <no email>

common/src/Common/Route.hs

@@ -18,6 +18,7 @@ import Control.Category
 
 import           Control.Category       ((.))
 import           Control.Monad.Except   (MonadError)
+import           Data.Map               (Map)
 import           Data.Functor.Identity
 import           Data.Text              (Text)
 import           Prelude                hiding (id, (.))
@@ -50,7 +51,7 @@ data BackendRoute :: * -> * where
 -- | This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.
 data FrontendRoute :: * -> * where
   FrontendRoute_Contracts :: FrontendRoute (Maybe (R ContractRoute))
-  FrontendRoute_Accounts :: FrontendRoute ()
+  FrontendRoute_Accounts :: FrontendRoute (Map Text (Maybe Text))
   FrontendRoute_Keys :: FrontendRoute ()
   FrontendRoute_Resources :: FrontendRoute ()
   FrontendRoute_Settings :: FrontendRoute ()
@@ -86,7 +87,8 @@ backendRouteEncoder = handleEncoder (\_e -> hoistR (FullRoute_Frontend . Obelisk
         -> PathSegment "sass.css" $ unitEncoder mempty
     FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute $ \case
       FrontendRoute_Contracts -> PathSegment "contracts" $ maybeEncoder (unitEncoder mempty) contractRouteEncoder
-      FrontendRoute_Accounts -> PathSegment "accounts" $ unitEncoder mempty
+      FrontendRoute_Accounts -> PathSegment "accounts" $ queryOnlyEncoder
+      -- FrontendRoute_Accounts -> PathSegment "accounts" $ unitEncoder mempty
       FrontendRoute_Keys -> PathSegment "keys" $ unitEncoder mempty
       FrontendRoute_Settings -> PathSegment "settings" $ unitEncoder mempty
       FrontendRoute_Resources -> PathSegment "resources" $ unitEncoder mempty
@@ -109,7 +111,7 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
   }
 
 landingPageRoute :: R FrontendRoute
-landingPageRoute = FrontendRoute_Accounts :/ ()
+landingPageRoute = FrontendRoute_Accounts :/ mempty
 
 concat <$> mapM deriveRouteComponent
   [ ''BackendRoute

frontend/src/Frontend/App.hs

@@ -110,6 +110,13 @@ app sidebarExtra fileFFI appCfg = Store.versionedFrontend (Store.versionedStorag
     route <- askRoute
     routedCfg <- subRoute $ lift . flip runRoutedT route . \case
       FrontendRoute_Accounts -> mkPageContent "accounts" $ mdo
+        query <- askRoute
+        let
+          startOpen :: Dynamic t (Maybe AccountName)
+          startOpen =
+            ffor query $ \case
+              (FrontendRoute_Accounts :/ q) -> fmap AccountName $ join $ Map.lookup "open" q
+              _ -> Nothing
         netCfg <- networkBar ideL
         (transferVisible, barCfg) <- controlBar "Accounts You Are Watching" $ do
           refreshCfg <- uiWalletRefreshButton
@@ -119,7 +126,7 @@ app sidebarExtra fileFFI appCfg = Store.versionedFrontend (Store.versionedStorag
           pure $ (xferVisible, watchCfg <> addCfg <> refreshCfg)
         divClass "wallet-scroll-wrapper" $ do
           transferCfg <- uiGenericTransfer ideL $ TransferCfg transferVisible never never
-          accountsCfg <- uiAccountsTable ideL
+          accountsCfg <- uiAccountsTable ideL startOpen
           pure $ netCfg <> barCfg <> accountsCfg <> transferCfg
       FrontendRoute_Keys -> mkPageContent "keys" $ do
         walletBarCfg <- underNetworkBar "Keys" uiGenerateKeyButton
@@ -206,7 +213,7 @@ walletSidebar sidebarExtra = elAttr "div" ("class" =: "sidebar") $ do
     let sidebarLink r@(r' :/ _) label = routeLink r $ do
           let selected = demuxed route (Some r')
           void $ uiSidebarIcon selected (routeIcon r) label
-    sidebarLink (FrontendRoute_Accounts :/ ()) "Accounts"
+    sidebarLink (FrontendRoute_Accounts :/ mempty) "Accounts"
     sidebarLink (FrontendRoute_Keys :/ ()) "Keys"
     sidebarLink (FrontendRoute_Contracts :/ Nothing) "Contracts"
     elAttr "div" ("style" =: "flex-grow: 1") blank

frontend/src/Frontend/Routes.hs

@@ -103,7 +103,7 @@ handleRoutes m = do
         ContractRoute_Deployed :/ xs -> Just $ "deployed":xs
         ContractRoute_New      :/ () -> Nothing
         ContractRoute_OAuth    :/ _  -> Nothing
-      FrontendRoute_Accounts :/ () -> Nothing
+      FrontendRoute_Accounts :/ _ -> Nothing
       FrontendRoute_Keys :/ () -> Nothing
       FrontendRoute_Resources :/ () -> Nothing
       FrontendRoute_Settings :/ () -> Nothing

frontend/src/Frontend/UI/Button.hs

@@ -53,6 +53,7 @@ module Frontend.UI.Button
   , sendButton
   , completeCrossChainButton
   , detailsButton
+  , addKAccountButton
   , detailsIconButton
   , accordionButton
   , copyToClipboard
@@ -347,6 +348,11 @@ transferToButton cfg =
     imgWithAltCls "button__text-icon" (static @"img/transfer-to.svg") "Transfer to" blank
     elClass "span" "button__text button__text-exclusive" $ text "Transfer to"
 
+addKAccountButton :: StaticButtonConstraints t m => UiButtonCfg -> m (Event t ())
+addKAccountButton cfg =
+  uiButton (cfg & uiButtonCfg_class <>~ "button_type_secondary" <> "button_type_secondary") $
+    text "Add k: Account"
+
 detailsButton :: StaticButtonConstraints t m => UiButtonCfg -> m (Event t ())
 detailsButton cfg =
   uiButton (cfg & uiButtonCfg_class <>~ "button_type_secondary" <> "button_type_secondary") $

frontend/src/Frontend/UI/Wallet.hs

@@ -41,13 +41,15 @@ import qualified Data.Set                    as Set
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
 import           Obelisk.Generated.Static
+import           Obelisk.Route.Frontend
 import           Reflex
 import           Reflex.Dom hiding (Key)
 import           Text.Read
 ------------------------------------------------------------------------------
 import qualified Pact.Types.Pretty as Pact
 import qualified Pact.Types.Term   as Pact
 ------------------------------------------------------------------------------
+import           Common.Route
 import           Frontend.Log (HasLogger, HasLogCfg)
 import           Frontend.Crypto.Class
 import           Frontend.Crypto.Ed25519     (keyToText)
@@ -120,6 +122,7 @@ uiWallet
   :: forall m t key model mConf
      . ( MonadWidget t m
        , HasUiWalletModelCfg model mConf key m t
+       , SetRoute t (R FrontendRoute) m
        )
   => model
   -> m mConf
@@ -137,9 +140,9 @@ hasPrivateKey = isJust . _keyPair_privateKey . snd
 
 uiAccountsTable
   :: forall t m model mConf key.
-  (MonadWidget t m, HasUiWalletModelCfg model mConf key m t, HasTransactionLogger m)
-  => model -> m mConf
-uiAccountsTable model = do
+  (MonadWidget t m, HasUiWalletModelCfg model mConf key m t, HasTransactionLogger m, (SetRoute t (R FrontendRoute) m))
+  => model -> Dynamic t (Maybe AccountName) -> m mConf
+uiAccountsTable model dStartOpen = do
   let net = model ^. network_selectedNetwork
       networks = model ^. wallet_accounts
   mAccounts <- maybeDyn $ ffor2 net networks $ \n (AccountData m) -> case Map.lookup n m of
@@ -152,14 +155,14 @@ uiAccountsTable model = do
         el "strong" $ text "+ Add Account"
         text " button."
       pure mempty
-    Just m -> divClass "wallet__keys-list" $ uiAccountItems model m
+    Just m -> divClass "wallet__keys-list" $ uiAccountItems model m dStartOpen
 
 
 uiAccountItems
   :: forall t m model mConf key.
-  (MonadWidget t m, HasUiWalletModelCfg model mConf key m t, HasTransactionLogger m)
-  => model -> Dynamic t (Map AccountName (AccountInfo Account)) -> m mConf
-uiAccountItems model accountsMap = do
+  (MonadWidget t m, HasUiWalletModelCfg model mConf key m t, HasTransactionLogger m, (SetRoute t (R FrontendRoute) m))
+  => model -> Dynamic t (Map AccountName (AccountInfo Account)) -> Dynamic t (Maybe AccountName) -> m mConf
+uiAccountItems model accountsMap dStartOpen = do
   let net = model ^. network_selectedNetwork
       tableAttrs = mconcat
         [ "style" =: "table-layout: fixed; width: 98%"
@@ -192,7 +195,8 @@ uiAccountItems model accountsMap = do
 
     el "tbody" $ do
       let cwKeys = model ^. wallet_keys
-          startsOpen = (\m -> Map.size m == 1) <$> accountsMap
+          dMapAndOpenAcc = (,) <$> accountsMap <*> dStartOpen
+          startsOpen = ffor dMapAndOpenAcc $ \(m, open) name -> Map.size m == 1 || (Just name == open)
       events <- listWithKey accountsMap (uiAccountItem cwKeys startsOpen)
       dyn_ $ ffor accountsMap $ \accs ->
         when (null accs) $
@@ -285,7 +289,7 @@ unPadChainId (ChainId c) = if T.length c <= 1 then ChainId c else
 uiAccountItem
   :: forall key t m. MonadWidget t m
   => Dynamic t (KeyStorage key)
-  -> Dynamic t Bool
+  -> Dynamic t (AccountName -> Bool)
   -> AccountName
   -> Dynamic t (AccountInfo Account)
   -> m (Event t AccountDialog)
@@ -304,7 +308,7 @@ uiAccountItem cwKeys startsOpen name accountInfo = do
       [] -> "Does not exist"
       xs -> uiAccountBalance False $ Just $ sum xs
 
-    v0 <- sample $ current startsOpen
+    v0 <- sample $ current $ ($ name) <$> startsOpen
     visible <- toggle v0 clk
     results <- accursedUnutterableListWithKey orderedChainMap $ accountRow visible
 
@@ -407,6 +411,8 @@ uiAvailableKeys
   :: forall t m model mConf key.
      ( MonadWidget t m
      , HasUiWalletModelCfg model mConf key m t
+     , HasWalletCfg mConf key t
+     , SetRoute t (R FrontendRoute) m
      )
   => model
   -> m mConf
@@ -423,7 +429,13 @@ uiAvailableKeys model = do
         el "strong" $ text "+ Generate Key"
         text " button, then continue to Accounts."
       pure mempty
-    Just keyMap -> divClass "wallet__keys-list" $ uiKeyItems keyMap
+    Just keyMap -> divClass "wallet__keys-list" $ do
+      let netAccList  =
+            do
+              net <- model^.network_selectedNetwork
+              accs <- model^.wallet_accounts
+              pure $ (net, fmap fst $ Map.toList $ fromMaybe mempty $ accs^? _AccountData . ix net)
+      uiKeyItems keyMap netAccList
 
 -- | Render a list of key items.
 --
@@ -434,10 +446,13 @@ uiKeyItems
      , Monoid mConf, Monoid (ModalCfg mConf t)
      , HasModalCfg mConf (Modal mConf m t) t
      , HasCrypto key m
+     , HasWalletCfg mConf key t
+     , SetRoute t (R FrontendRoute) m
      )
   => Dynamic t (Map Int (Key key))
+  -> Dynamic t (NetworkName, [AccountName])
   -> m mConf
-uiKeyItems keyMap = do
+uiKeyItems keyMap netAndAccs = do
   let
     tableAttrs =
       "style" =: "table-layout: fixed; width: calc(100% - 22px);"
@@ -461,10 +476,23 @@ uiKeyItems keyMap = do
             text "No keys ..."
       pure events
 
-  let modalEvents = switch $ leftmost . Map.elems <$> current events
+  let
+    keyEvents = (fmap . fmap) fst events
+    addAccMap = (fmap . fmap) snd events
+    modalEvents = switch $ leftmost . Map.elems <$> current keyEvents
+    accEvents = switch $ leftmost . Map.elems <$> current addAccMap
+
+    eAddAccWithKey = attach (current netAndAccs) accEvents
+    addAcc ((net, accList), k) =
+      let accName = AccountName $ "k:" <> k
+       in case accName `elem` accList of
+            True -> Nothing
+            False -> Just (net, accName)
 
   pure $ mempty
     & modalCfg_setModal .~ fmap keyModal modalEvents
+    & walletCfg_importAccount .~ fmapMaybe addAcc eAddAccWithKey
+
   where
     keyModal = Just . \case
       KeyDialog_Details i key -> uiKeyDetails i key
@@ -476,16 +504,20 @@ data KeyDialog key
 ------------------------------------------------------------------------------
 -- | Display a key as list item together with its name.
 uiKeyItem
-  :: forall key t m. MonadWidget t m
+  :: forall key t m. (MonadWidget t m, (SetRoute t (R FrontendRoute) m))
   => IntMap.Key
   -> Dynamic t (Key key)
-  -> m (Event t (KeyDialog key))
+  -> m (Event t (KeyDialog key), Event t Text)
 uiKeyItem keyIndex key = trKey $ do
-  td $ dynText $ keyToText . _keyPair_publicKey . _key_pair <$> key
+  let dKeyText = keyToText . _keyPair_publicKey . _key_pair <$> key
+  td $ dynText dKeyText
   td $ buttons $ do
     copyButton' "" bcfg ButtonShade_Dark False (current $ keyToText . _keyPair_publicKey . _key_pair <$> key)
+    eAddK <- addKAccountButton $ cfg & uiButtonCfg_class <>~ "wallet__table-button--hamburger" <> "wallet__table-button-key"
     onDetails <- detailsButton (cfg & uiButtonCfg_class <>~ "wallet__table-button--hamburger" <> "wallet__table-button-key")
-    pure $ KeyDialog_Details keyIndex <$> current key <@ onDetails
+    let addK = current dKeyText <@ eAddK
+    setRoute $ ffor addK $ \k -> FrontendRoute_Accounts :/ ("open" =: (Just $ "k:" <> k))
+    pure $ (KeyDialog_Details keyIndex <$> current key <@ onDetails, addK)
   where
     bcfg = btnCfgSecondary & uiButtonCfg_class <>~ "wallet__table-button-with-background" <> "button_border_none"
     trKey = elClass "tr" "wallet__table-row wallet__table-row-key"