Resolved metadata event passthrough issue (#170)

typeable · Jun 6, 2022 · 857a4ee · 857a4ee
1 parent a296882
commit 857a4ee
Show file tree

Hide file tree

Showing 7 changed files with 38 additions and 24 deletions.
diff --git a/.vscode/settings.json b/.vscode/settings.json
@@ -4,5 +4,6 @@
   "haskell.plugin.hlint.diagnosticsOn": false,
   "haskell.hlint.logLevel": "none",
   "haskell.hlint.run": "never",
-  "haskell.serverExecutablePath": "haskell-language-server"
+  "haskell.serverExecutablePath": "haskell-language-server",
+  "editor.formatOnSave": true
 }
diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Action.hs b/octopod-frontend/src/Frontend/UIKit/Button/Action.hs
@@ -18,7 +18,7 @@ data ActionButtonConfig t = ActionButtonConfig
   { buttonText :: Text
   , buttonEnabled :: Dynamic t Bool
   , buttonType :: Maybe ActionButtonType
-  , buttonBaseTag :: BaseButtonTag
+  , buttonBaseTag :: BaseButtonTag t
   }
   deriving stock (Generic)
 

diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Common.hs b/octopod-frontend/src/Frontend/UIKit/Button/Common.hs
@@ -39,31 +39,35 @@ data CommonButtonConfig t = CommonButtonConfig
   , disabledClasses :: Classes
   , buttonEnabled :: Dynamic t Bool
   , buttonText :: TextBuilder t
-  , buttonBaseTag :: BaseButtonTag
+  , buttonBaseTag :: BaseButtonTag t
   }
   deriving stock (Generic)
 
-data BaseButtonTag = ButtonTag | ATag Text
+data BaseButtonTag t = ButtonTag | ATag (Dynamic t Text)
 
-baseTag :: BaseButtonTag -> (Text, Map Text Text)
-baseTag ButtonTag = ("button", "type" =: "button")
-baseTag (ATag url) = ("a", "href" =: url <> "target" =: "_blank")
+baseTag :: Reflex t => BaseButtonTag t -> (Text, Dynamic t (Map Text Text))
+baseTag ButtonTag = ("button", pure $ "type" =: "button")
+baseTag (ATag urlDyn) =
+  ( "a"
+  , urlDyn <&> \url -> "href" =: url <> "target" =: "_blank"
+  )
 
 buttonEl ::
   forall m t.
   (DomBuilder t m, PostBuild t m) =>
   CommonButtonConfig t ->
   m (Event t (Either () ()))
 buttonEl cfg = do
-  let (t, staticAttrs) = baseTag (cfg ^. #buttonBaseTag)
+  let (t, tagAttrsDyn) = baseTag (cfg ^. #buttonBaseTag)
       attrsDyn = do
         enabled <- cfg ^. #buttonEnabled
         let (enabledClasses, enabledAttrs) = case enabled of
               True -> (cfg ^. #enabledClasses, mempty)
               False -> (cfg ^. #disabledClasses, "disabled" =: "")
         cs <- cfg ^. #constantClasses
+        tagAttrs <- tagAttrsDyn
         pure $
-          staticAttrs
+          tagAttrs
             <> "class" =: destructClasses (enabledClasses <> cs)
             <> enabledAttrs
   modAttrs <- dynamicAttributesToModifyAttributes attrsDyn

diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Large.hs b/octopod-frontend/src/Frontend/UIKit/Button/Large.hs
@@ -23,7 +23,7 @@ data LargeButtonConfig t = LargeButtonConfig
   , buttonType :: Dynamic t (Maybe LargeButtonType)
   , buttonPriority :: LargeButtonPriority
   , buttonStyle :: LargeButtonStyle
-  , buttonBaseTag :: BaseButtonTag
+  , buttonBaseTag :: BaseButtonTag t
   }
   deriving stock (Generic)
 

diff --git a/octopod-frontend/src/Page/Deployment.hs b/octopod-frontend/src/Page/Deployment.hs
@@ -158,7 +158,7 @@ deploymentHead dfiDyn sentEv =
                     , buttonType = pure $ Just LogsLargeButtonType
                     , buttonPriority = SecondaryLargeButton
                     , buttonStyle = PageActionLargeButtonStyle
-                    , buttonBaseTag = ATag url
+                    , buttonBaseTag = ATag $ pure url
                     }
           )
     delEv <- confirmArchivePopup (archEv $> ()) $ do

diff --git a/octopod-frontend/src/Page/Deployments.hs b/octopod-frontend/src/Page/Deployments.hs
@@ -295,7 +295,7 @@ activeDeploymentWidget dDyn' = do
                               def
                                 { buttonText = "Details"
                                 , buttonType = Just LogsActionButtonType
-                                , buttonBaseTag = ATag url
+                                , buttonBaseTag = ATag $ pure url
                                 }
                       )
                 pure $
@@ -379,7 +379,7 @@ archivedDeploymentWidget dDyn' = do
           btnEv <- dropdownWidget body
           void $ restoreEndpoint (constDyn $ Right $ dName) (btnEv $> ())
       let route = DashboardRoute :/ Just dName
-      setRoute $ route <$ domEvent Dblclick linkEl
+      setRoute $ route <$ domEvent Click linkEl
 
 -- | Sort deployments by the supplied condition.
 sortDeployments ::

diff --git a/octopod-frontend/src/Page/Elements/Links.hs b/octopod-frontend/src/Page/Elements/Links.hs
@@ -4,23 +4,32 @@ module Page.Elements.Links
 where
 
 import Common.Types
+import Common.Utils ((<^.>))
 import Control.Lens
+import Control.Monad
 import qualified Data.Text as T
+import Frontend.UIKit.Button.Common
 import Reflex.Dom
 
 renderMetadataLink ::
   (DomBuilder t m, PostBuild t m) =>
   Dynamic t DeploymentMetadatum ->
   m ()
 renderMetadataLink metadataD = do
-  let attrDyn =
-        metadataD <&> \metadata ->
-          "class" =: "listing__item external bar bar--larger"
-            <> "href" =: metadata ^. #link
-            <> "target" =: "_blank"
-  elDynAttr "a" attrDyn . dynText $
-    metadataD <&> \case
-      -- If the name is empty, then use the url
-      DeploymentMetadatum {name = name}
-        | (not . T.null . T.strip) name -> name
-      DeploymentMetadatum {link = url} -> url
+  void $
+    buttonEl
+      CommonButtonConfig
+        { constantClasses = pure $ "listing__item" <> "external" <> "bar" <> "bar--larger"
+        , enabledClasses = mempty
+        , disabledClasses = "button--disabled"
+        , buttonEnabled = pure True
+        , buttonText =
+            TextBuilder $
+              dynText $
+                metadataD <&> \case
+                  -- If the name is empty, then use the url
+                  DeploymentMetadatum {name = name}
+                    | (not . T.null . T.strip) name -> name
+                  DeploymentMetadatum {link = url} -> url
+        , buttonBaseTag = ATag $ metadataD <^.> #link
+        }