git.iko.soy/typeable/octopod
on master help sign in
"View staging" screen (#49)
commit85b39630434a02eb854a5bc46985a2b8a4cf1ff5 authorNikita <anisimoff.nikita@gmail.com> dateWed 1 Jul 2020, 17:45 (6 years ago) parentb3ff27d
9 files changed+466−106
compare with master
unifiedsplit
dm-common/dm-common.cabal+3 dm-common/src/Common/Utils.hs+22 dm-css+1−1 dm-frontend/dm-frontend.cabal+1 dm-frontend/src/Main.hs+40−4 dm-frontend/src/Page/ClassicPopup.hs+9−7 dm-frontend/src/Page/Deployment.hs+281 dm-frontend/src/Page/Deployments.hs+36−74 dm-frontend/src/Page/Utils.hs+73−20
dm-common/dm-common.cabal+3
@@ -19,6 +19,7 @@ library
1919 exposed-modules: Common
2020 , Common.API
2121 , Common.Types
22+ , Common.Utils
2223 -- other-modules:
2324 -- other-extensions:
2425 default-extensions: BlockArguments
@@ -39,6 +40,8 @@ library
3940 , bytestring
4041 , deriving-aeson
4142 , http-api-data
43+ , generic-lens
44+ , lens
4245 , servant
4346 , text
4447 hs-source-dirs: src
dm-common/src/Common/Utils.hsnew file+22
@@ -0,0 +1,22 @@
1+module Common.Utils where
2+
3+import Control.Lens
4+import Data.Monoid
5+import Data.Generics.Product
6+
7+import Common.Types
8+
9+-- Lens convenience helpers
10+(<^.>) :: Functor f => f a -> Getting b a b -> f b
11+(<^.>) fa l = fa <&> (^. l)
12+
13+(<^?>) :: Functor f => f a -> Getting (First b) a b -> f (Maybe b)
14+(<^?>) fa l = fa <&> (^? l)
15+
16+(<^..>) :: Functor f => f a -> Getting (Endo [b]) a b -> f [b]
17+(<^..>) fa t = fa <&> (^.. t)
18+
19+infixl 8 <^.>, <^..>, <^?>
20+
21+dfiName :: Getter DeploymentFullInfo DeploymentName
22+dfiName = field @"deployment" . field @"name"
dm-css+1−1

Submodule changed.

dm-frontend/dm-frontend.cabal+1
@@ -27,6 +27,7 @@ executable frontend
2727 other-modules: Frontend.API
2828 , Frontend.Route
2929 , Page.ClassicPopup
30+ , Page.Deployment
3031 , Page.Deployments
3132 , Page.NewStagingPopup
3233 , Page.Utils
dm-frontend/src/Main.hs+40−4
@@ -1,26 +1,49 @@
11module Main where
22
3+import Data.ByteString (ByteString)
34import Obelisk.Route.Frontend
45import Reflex.Dom
6+import Servant.Reflex
57
8+import Common.Types as CT
9+import Frontend.API
610import Frontend.Route
11+import Page.Deployment
712import Page.Deployments
813
914main :: IO ()
10−main = mainWidgetWithHead headWidget $
15+main = mainWidgetWithHead headWidget $ do
16+ headerWidget
1117 routeWidget
1218
13−routeWidget :: MonadWidget t m => m ()
19+wsUpdate :: forall t m . MonadWidget t m => m (Event t ())
20+wsUpdate = do
21+ let
22+ wsConfig = WebSocketConfig
23+ { _webSocketConfig_send = (never :: Event t [ByteString])
24+ , _webSocketConfig_close = never
25+ , _webSocketConfig_reconnect = True
26+ , _webSocketConfig_protocols = []
27+ }
28+ ws <- webSocket "wss://dm-genfly-ws.stage.thebestagent.pro/event" wsConfig
29+ pure $ () <$ _webSocket_recv ws
30+
31+routeWidget
32+ ::
33+ ( MonadWidget t m
34+ , Prerender js t m )
35+ => m ()
1436routeWidget = do
1537 let Right encoder = checkEncoder routeEncoder
1638 pb <- getPostBuild
39+ updAllEv <- wsUpdate
1740 runRouteViewT encoder pb True $ mdo
1841 subRoute_ $ \case
1942 DashboardRoute -> do
2043 r <- askRoute
2144 dyn_ $ ffor r $ \case
22− Nothing -> deploymentsPage
23− Just _ -> blank
45+ Nothing -> deploymentsPage updAllEv
46+ Just dn -> deploymentPage updAllEv dn
2447 blank
2548
2649headWidget :: DomBuilder t m => m ()
@@ -38,3 +61,16 @@ headWidget = do
3861 elAttr "link"
3962 ( "href" =: "/static/styles/style.css"
4063 <> "rel" =: "stylesheet") blank
64+
65+
66+headerWidget :: MonadWidget t m => m ()
67+headerWidget =
68+ elClass "header" "header" $
69+ divClass "header__wrap container" $ do
70+ elClass "b" "header__logo" $
71+ text "Deployment Manager"
72+ elClass "div" "header__project" $ do
73+ pb <- getPostBuild
74+ respEv <- projectName pb
75+ nameDyn <- holdDyn "" $ uProjectName <$> fmapMaybe reqSuccess respEv
76+ dynText nameDyn
dm-frontend/src/Page/ClassicPopup.hs+9−7
@@ -26,13 +26,15 @@ popupWidget
2626 => m (Event t (), Event t ())
2727 -> m (Event t (), Event t ())
2828popupWidget m =
29− elAttr "div" ("class" =: "classic-popup" <> "style" =: "display: block;") $
30− divClass "classic-popup__container" $
31− divClass "classic-popup__viewport" $
32− divClass "classic-popup__slot" $ do
33− (okEv, cancelEv) <- m
34− closeEv <- buttonClass "classic-popup__close" "Close"
35− pure $ (okEv, leftmost [cancelEv, closeEv])
29+ fmap snd $
30+ elDynAttrWithStopPropagationEvent' Click "div"
31+ (constDyn $ "class" =: "classic-popup" <> "style" =: "display: block;") $
32+ divClass "classic-popup__container" $
33+ divClass "classic-popup__viewport" $
34+ divClass "classic-popup__slot" $ do
35+ (okEv, cancelEv) <- m
36+ closeEv <- buttonClass "classic-popup__close" "Close"
37+ pure $ (okEv, leftmost [cancelEv, closeEv])
3638
3739confirmDeletePopup
3840 :: MonadWidget t m
dm-frontend/src/Page/Deployment.hsnew file+281
@@ -0,0 +1,281 @@
1+module Page.Deployment (deploymentPage) where
2+
3+import Control.Lens
4+import Control.Monad
5+import Data.Coerce
6+import Data.Generics.Product (field)
7+import Data.List as L (find)
8+import Data.Text as T (Text, pack)
9+import Obelisk.Route.Frontend
10+import Reflex.Dom
11+import Servant.Reflex
12+
13+import Common.Types as CT
14+import Common.Utils
15+import Frontend.API
16+import Frontend.Route
17+import Page.Utils
18+
19+
20+deploymentPage
21+ ::
22+ ( MonadWidget t m
23+ , RouteToUrl (R Routes) m
24+ , SetRoute t (R Routes) m
25+ , Prerender js t m )
26+ => Event t ()
27+ -> DeploymentName -> m ()
28+deploymentPage updAllEv dname = pageWrapper $ do
29+ backButton
30+ pb <- getPostBuild
31+ respEv <- listEndpoint pb
32+ let (okEv, errEv) = processResp dname respEv
33+ widgetHold_ (loadingWidget dname) $ leftmost
34+ [ errorWidget dname <$ errEv
35+ , deploymentWidget updAllEv <$> okEv ]
36+
37+
38+deploymentWidget :: MonadWidget t m => Event t () -> DeploymentFullInfo -> m ()
39+deploymentWidget updEv dfi = do
40+ respEv <- listEndpoint updEv
41+ let
42+ (okEv, _errEv) =
43+ processResp (dfi ^. dfiName) respEv
44+ dfiDyn' <- holdDyn dfi okEv
45+ dfiDyn <- holdUniqDyn dfiDyn'
46+ deploymentHead dfiDyn
47+ stagingNotification never
48+ deploymentBody updEv dfiDyn
49+
50+deploymentHead
51+ :: MonadWidget t m
52+ => Dynamic t DeploymentFullInfo
53+ -> m ()
54+deploymentHead dfiDyn =
55+ divClass "page__head" $ do
56+ elClass "h1" "page__heading title" $ dynText $ dfiDyn <^.> dfiName . coerced
57+ dyn_ $ dfiDyn <^.> field @"archived" <&> \case
58+ True -> do
59+ elClass "a" "page__action button button--secondary button--restore classic-popup-handler" $
60+ text "Recover from archive"
61+ False -> do
62+ elClass "a" "page__action button button--edit popup-handler" $
63+ text "Edit staging"
64+ elClass "a" "page__action button button--secondary button--delete classic-popup-handler" $
65+ text "Move to archive"
66+
67+deploymentBodyWrapper :: MonadWidget t m => m a -> m a
68+deploymentBodyWrapper m = divClass "page__body" $ divClass "staging" $ m
69+
70+deploymentBody
71+ :: MonadWidget t m
72+ => Event t ()
73+ -> Dynamic t DeploymentFullInfo
74+ -> m ()
75+deploymentBody updEv dfiDyn = deploymentBodyWrapper $ do
76+ let nameDyn = dfiDyn <^.> dfiName
77+ divClass "staging__summary" $ do
78+ divClass "staging__stat" $ do
79+ elClass "b" "staging__param" $ text "Status"
80+ divClass "staging__value" $ do
81+ pb <- getPostBuild
82+ respEv <- statusEndpoint (Right <$> nameDyn) $ leftmost [pb, updEv]
83+ let statusEv = fmapMaybe reqSuccess respEv
84+ statusDyn <- holdDyn Nothing $ Just <$> statusEv
85+ statusWidget statusDyn
86+ divClass "staging__stat" $ do
87+ elClass "b" "staging__param" $ text "Created"
88+ divClass "staging__value" $ do
89+ let createdAtDyn = dfiDyn <^.> field @"createdAt"
90+ dynText $ formatPosixToDate <$> createdAtDyn
91+ divClass "staging__stat" $ do
92+ elClass "b" "staging__param" $ text "Changed"
93+ divClass "staging__value" $ do
94+ let createdAtDyn = dfiDyn <^.> field @"updatedAt"
95+ dynText $ formatPosixToDate <$> createdAtDyn
96+ elClass "section" "staging__section" $ do
97+ let tagDyn = dfiDyn <^.> field @"deployment" . field @"tag" . coerced
98+ elClass "h3" "staging__sub-heading" $ text "Tag"
99+ divClass "staging__widget" $
100+ divClass "bar bar--larger" $ dynText tagDyn
101+ elClass "section" "staging__section" $ do
102+ let urlsDyn = dfiDyn <^.> field @"urls"
103+ elClass "h3" "staging__sub-heading" $ text "Links"
104+ divClass "staging__widget" $
105+ divClass "listing" $
106+ void $ simpleList urlsDyn $ \urlDyn' -> do
107+ let
108+ urlDyn = snd <$> urlDyn'
109+ attrDyn = urlDyn <&> \url ->
110+ ( "class" =: "listing__item external bar bar--larger"
111+ <> "href" =: ("https://" <> url)
112+ <> "target" =: "_blank" )
113+ elDynAttr "a" attrDyn $ dynText urlDyn
114+ elClass "section" "staging__section" $ do
115+ let envsDyn = dfiDyn <^.> field @"deployment" . field @"envs"
116+ elClass "h3" "staging__sub-heading" $ text "Overrides"
117+ divClass "staging__widget" $
118+ divClass "listing" $
119+ void $ simpleList envsDyn $ \envDyn -> do
120+ let
121+ varDyn = fst <$> envDyn
122+ valDyn = snd <$> envDyn
123+ divClass "listing__item bar bar--larger" $ do
124+ el "b" $ do
125+ dynText varDyn
126+ text ": "
127+ dynText valDyn
128+
129+ elClass "section" "staging__section" $ do
130+ elClass "h3" "staging__sub-heading" $ text "Actions"
131+ divClass "staging__widget" $
132+ divClass "table table--actions" $
133+ actionsTable updEv nameDyn
134+
135+actionsTable
136+ :: MonadWidget t m
137+ => Event t ()
138+ -> Dynamic t DeploymentName
139+ -> m ()
140+actionsTable updEv nameDyn = do
141+ pb <- getPostBuild
142+ respEv <- infoEndpoint (Right <$> nameDyn) pb
143+ let
144+ okEv = join . fmap logs <$> fmapMaybe reqSuccess respEv
145+ errEv = fmapMaybe reqFailure respEv
146+ el "table" $ do
147+ actionsTableHead
148+ widgetHold_ actionsTableLoading $ leftmost
149+ [ actionsTableError <$ errEv
150+ , actionsTableData updEv nameDyn <$> okEv ]
151+ blank
152+
153+actionsTableHead :: MonadWidget t m => m ()
154+actionsTableHead =
155+ el "thead" $
156+ el "tr" $ do
157+ el "th" $ text "Action type"
158+ el "th" $ text "Image tag"
159+ el "th" $ text "Overrides"
160+ el "th" $ text "Exit code"
161+ el "th" $ text "Created at"
162+ el "th" $ text "Deployment duration"
163+ el "th" $ elClass "span" "visuallyhidden" $ text "Show logs action"
164+
165+
166+actionsTableLoading :: MonadWidget t m => m ()
167+actionsTableLoading =
168+ el "tbody" $
169+ elClass "tr" "no-table" $
170+ elAttr "td" ("colspan" =: "7") $
171+ divClass "loading loading--enlarged loading--alternate" $
172+ text "Loading..."
173+
174+actionsTableError:: MonadWidget t m => m ()
175+actionsTableError =
176+ el "tbody" $
177+ elClass "tr" "no-table" $
178+ elAttr "td" ("colspan" =: "7") $
179+ divClass "null null--data" $ do
180+ elClass "b" "null__heading" $ text "Cannot retrieve the data"
181+ divClass "null__message" $ text "Try to reload page"
182+
183+actionsTableData
184+ :: MonadWidget t m
185+ => Event t ()
186+ -> Dynamic t DeploymentName
187+ -> [DeploymentLog]
188+ -> m ()
189+actionsTableData updEv nameDyn initLogs = do
190+ respEv <- infoEndpoint (Right <$> nameDyn) updEv
191+ let
192+ okEv = join . fmap logs <$> fmapMaybe reqSuccess respEv
193+ logsDyn <- holdDyn initLogs okEv
194+ el "tbody" $
195+ void $ simpleList logsDyn $ \logDyn ->
196+ dyn_ $ actinRow <$> logDyn
197+
198+actinRow :: MonadWidget t m => DeploymentLog -> m ()
199+actinRow DeploymentLog{..} = do
200+ el "tr" $ do
201+ el "td" $ text $ coerce action
202+ el "td" $ text $ coerce deploymentTag
203+ el "td" $ divClass "listing" $ do
204+ forM_ deploymentEnvs $ \(var, val) ->
205+ divClass "listing__item bar" $ do
206+ el "b" $ text $ var <> ":"
207+ text val
208+ el "td" $ text $ pack . show $ exitCode
209+ el "td" $ text $ formatPosixToDateTime createdAt
210+ el "td" $ text $ pack . show . unDuration $ duration
211+
212+backButton
213+ ::
214+ ( MonadWidget t m
215+ , RouteToUrl (R Routes) m
216+ , SetRoute t (R Routes) m
217+ , Prerender js t m )
218+ => m ()
219+backButton = do
220+ let
221+ backRoute = constDyn $ DashboardRoute :/ Nothing
222+ attrs = constDyn $ "class" =: "page__back dash dash--back dash--smaller"
223+ routeLinkDynAttr attrs backRoute $ text "All stagings"
224+
225+processResp
226+ :: Reflex t
227+ => DeploymentName
228+ -> Event t (ReqResult tag [DeploymentFullInfo])
229+ -> (Event t DeploymentFullInfo, Event t ())
230+processResp dname respEv =
231+ let
232+ respOkEv = fmapMaybe reqSuccess respEv
233+ errEv' = fmapMaybe reqFailure respEv
234+ findFunc dfi = dfi ^. dfiName == dname
235+ okEv = fmapMaybe (find findFunc) respOkEv
236+ errEv = leftmost [ () <$ errEv', () <$ difference respOkEv okEv ]
237+ in (okEv, errEv)
238+
239+
240+data DeploymentPageNotification
241+ = DPMOk Text
242+ | DPMError Text
243+
244+loadingWidget :: MonadWidget t m => DeploymentName -> m ()
245+loadingWidget dname = do
246+ divClass "page__head" $
247+ elClass "h1" "page__heading title" $ text $ coerce dname
248+ divClass "page__body" $
249+ divClass "no-staging" $
250+ divClass "loading loading--enlarged loading--alternate" $
251+ text "Loading..."
252+
253+errorWidget :: MonadWidget t m => DeploymentName -> m ()
254+errorWidget dname = do
255+ divClass "page__head" $
256+ elClass "h1" "page__heading title" $ text $ coerce dname
257+ divClass "page__body" $
258+ divClass "no-staging" $
259+ divClass "null null--data" $
260+ divClass "null__content" $ do
261+ elClass "b" "null__heading" $ text "Cannot retrieve the data"
262+ divClass "null__message" $ text "Try to reload page"
263+
264+pageWrapper :: MonadWidget t m => m a -> m a
265+pageWrapper m = divClass "page" $ divClass "page__wrap container" $ m
266+
267+stagingNotification
268+ :: MonadWidget t m => Event t DeploymentPageNotification -> m ()
269+stagingNotification notEv = mdo
270+ let
271+ messageWidget (DPMOk txt) = messageClassWidget txt "notification--success"
272+ messageWidget (DPMError txt) = messageClassWidget txt "notification--danger"
273+ messageClassWidget txt cl =
274+ divClass ("page__output notification " <> cl) $ do
275+ text txt
276+ buttonClass "notification__close" ""
277+ closeEv = switchDyn closeEvDyn
278+ closeEvDyn <- widgetHold (pure never) $ leftmost
279+ [ messageWidget <$> notEv
280+ , pure never <$ closeEv ]
281+ blank
dm-frontend/src/Page/Deployments.hs+36−74
@@ -3,19 +3,17 @@ module Page.Deployments
33
44import Control.Lens
55import Control.Monad
6−import Data.ByteString (ByteString)
76import Data.Coerce
87import Data.Generics.Product (field)
98import Data.List as L (null)
109import Data.Map as M (Map, fromList, partition, toList, filter)
11−import Data.Text as T (Text, pack, toCaseFold, isPrefixOf)
12−import Data.Time
13−import Data.Time.Clock.POSIX
10+import Data.Text as T (Text, toCaseFold, isPrefixOf)
1411import Obelisk.Route.Frontend
1512import Reflex.Dom
1613import Servant.Reflex
1714
1815import Common.Types as CT
16+import Common.Utils
1917import Frontend.API
2018import Frontend.Route
2119import Page.ClassicPopup
@@ -28,22 +26,9 @@ deploymentsPage
2826 ( MonadWidget t m
2927 , RouteToUrl (R Routes) m
3028 , SetRoute t (R Routes) m )
31− => m ()
32−deploymentsPage = do
33− headWidget
34− deploymentsWidget
35−
36−headWidget :: MonadWidget t m => m ()
37−headWidget =
38− elClass "header" "header" $
39− divClass "header__wrap container" $ do
40− elClass "b" "header__logo" $
41− text "Deployment Manager"
42− elClass "div" "header__project" $ do
43− pb <- getPostBuild
44− respEv <- projectName pb
45− nameDyn <- holdDyn "" $ uProjectName <$> fmapMaybe reqSuccess respEv
46− dynText nameDyn
29+ => Event t ()
30+ -> m ()
31+deploymentsPage = deploymentsWidget
4732
4833deploymentsWidgetWrapper :: MonadWidget t m => m a -> m a
4934deploymentsWidgetWrapper m =
@@ -55,11 +40,12 @@ deploymentsWidget
5540 ( MonadWidget t m
5641 , RouteToUrl (R Routes) m
5742 , SetRoute t (R Routes) m )
58− => m ()
59−deploymentsWidget = do
43+ => Event t ()
44+ -> m ()
45+deploymentsWidget updAllEv = do
6046 showNewStagingEv <- deploymentsWidgetWrapper $ mdo
6147 (showNewStagingEv', termDyn) <- deploymentsHeadWidget
62− initDeploymentsListWidget termDyn
48+ initDeploymentsListWidget updAllEv termDyn
6349 pure showNewStagingEv'
6450 void $ newStagingPopup showNewStagingEv never
6551
@@ -68,7 +54,7 @@ deploymentsHeadWidget =
6854 divClass "page__head" $ do
6955 elClass "h1" "page__heading title" $ text "All stagings"
7056 divClass "page__note" $ text "Updated <n> mins ago"
71− termDyn <- divClass "page__search input input--search input--has-clear-type" $ mdo
57+ termDyn <- divClass "page__action input input--search input--has-clear-type page__action--search" $ mdo
7258 termDyn' <- inputElement $ def
7359 & initialAttributes .~
7460 ( "type" =: "text"
@@ -79,7 +65,7 @@ deploymentsHeadWidget =
7965 text "Delete"
8066 pure termDyn'
8167 (nsEl, _) <- elClass' "a"
82− "page__add-staging button button--add popup-handler" $ text "New staging"
68+ "page__action button button--add popup-handler" $ text "New staging"
8369 pure $ (domEvent Click nsEl, value termDyn)
8470
8571initDeploymentsListWidget
@@ -87,47 +73,38 @@ initDeploymentsListWidget
8773 ( MonadWidget t m
8874 , RouteToUrl (R Routes) m
8975 , SetRoute t (R Routes) m )
90− => Dynamic t Text -> m ()
91−initDeploymentsListWidget termDyn = dataWidgetWrapper $ do
76+ => Event t ()
77+ -> Dynamic t Text
78+ -> m ()
79+initDeploymentsListWidget updAllEv termDyn = dataWidgetWrapper $ do
9280 pb <- getPostBuild
9381 respEv <- listEndpoint pb
9482 let
9583 okEv = fmapMaybe reqSuccess respEv
9684 errEv = fmapMaybe reqFailure respEv
9785 widgetHold_ loadingDeploymentsWidget $ leftmost
98− [ deploymentsListWidget termDyn <$> okEv
86+ [ deploymentsListWidget updAllEv termDyn <$> okEv
9987 , errDeploymentsWidget <$ errEv ]
10088
101−wsUpdate :: forall t m . MonadWidget t m => m (Event t ())
102−wsUpdate = do
103− let
104− wsConfig = WebSocketConfig
105− { _webSocketConfig_send = (never :: Event t [ByteString])
106− , _webSocketConfig_close = never
107− , _webSocketConfig_reconnect = True
108− , _webSocketConfig_protocols = []
109− }
110− ws <- webSocket "wss://dm-genfly-ws.stage.thebestagent.pro/event" wsConfig
111− pure $ () <$ _webSocket_recv ws
112−
11389deploymentsListWidget
11490 ::
11591 ( MonadWidget t m
11692 , RouteToUrl (R Routes) m
11793 , SetRoute t (R Routes) m )
118− => Dynamic t Text
94+ => Event t ()
95+ -> Dynamic t Text
11996 -> [DeploymentFullInfo]
12097 -> m ()
121−deploymentsListWidget termDyn ds = mdo
122− updAllEv <- wsUpdate
98+deploymentsListWidget updAllEv termDyn ds = mdo
12399 updRespEv <- listEndpoint updAllEv
124100 let
125101 okUpdEv = fmapMaybe reqSuccess updRespEv
126− mkMap = M.fromList . fmap (\x -> (x ^. field @"deployment" . field @"name" , x) )
102+ mkMap = M.fromList . fmap (\x -> (x ^. dfiName , x) )
127103 dsDyn <- fmap mkMap <$> holdDyn ds okUpdEv
128104 stsDyn <- listWithKey dsDyn $ \k d -> do
129105 pb <- getPostBuild
130− respEv <- statusEndpoint (constDyn $ Right k) $ leftmost [pb, () <$ updated d]
106+ respEv <- statusEndpoint (constDyn $ Right k)
107+ $ leftmost [pb, () <$ updated d]
131108 let stEv = fmapMaybe reqSuccess respEv
132109 stDyn <- holdDyn Nothing $ Just <$> stEv
133110 pure $ (, stDyn) <$> d
@@ -150,7 +127,7 @@ searchDeployments term d = term' `isPrefixOf` dname
150127 where
151128 term' = toCaseFold term
152129 dtag = d ^. field @"deployment" . field @"tag" . coerced . to toCaseFold
153− dname = d ^. field @"deployment" . field @"name" . coerced . to toCaseFold
130+ dname = d ^. dfiName . coerced . to toCaseFold
154131
155132flatDynMapDyn
156133 :: (Reflex t, Ord k)
@@ -180,15 +157,6 @@ activeDeploymentsWidget clickedEv dsDyn =
180157 False -> void $ listWithKey dsDyn (activeDeploymentWidget clickedEv)
181158 True -> emptyTableBody $ noDeploymentsWidget
182159
183−statusWidget :: MonadWidget t m => Dynamic t (Maybe DeploymentStatus) -> m ()
184−statusWidget stDyn = do
185− stDyn' <- holdUniqDyn stDyn
186− dyn_ $ stDyn' <&> \case
187− Nothing -> divClass "loading loading--status-alike" $ text "Loading"
188− Just st -> case status st of
189− CT.Ok -> divClass "status status--success" $ text "Success"
190− CT.Error -> divClass "status status--failure" $ text "Failure"
191−
192160activeDeploymentWidget
193161 ::
194162 ( MonadWidget t m
@@ -202,17 +170,15 @@ activeDeploymentWidget clickedEv dname dDyn' = do
202170 dDyn <- holdUniqDyn $ fst <$> dDyn'
203171 let stDyn = join $ snd <$> dDyn'
204172 dyn_ $ ffor dDyn $ \DeploymentFullInfo{..} -> do
205− el "tr" $ do
206− (linkEl, _) <- el' "td" $ do
173+ (linkEl, _) <- el' "tr" $ do
174+ el "td" $ do
207175 text $ coerce dname
208176 statusWidget stDyn
209− let route = DashboardRoute :/ Just dname
210− setRoute $ route <$ domEvent Click linkEl
211177 el "td" $ do
212178 divClass "listing" $
213179 forM_ urls $ \(_, url) ->
214− elAttr "a"
215− ( "class" =: "listing__item external bar"
180+ void $ elDynAttrWithStopPropagationEvent' Click "a"
181+ ( constDyn $ "class" =: "listing__item external bar"
216182 <> "href" =: ("https://" <> url)
217183 <> "target" =: "_blank") $ text url
218184 el "td" $
@@ -224,11 +190,9 @@ activeDeploymentWidget clickedEv dname dDyn' = do
224190 el "b" $ text $ var <> ": "
225191 text val
226192 el "td" $
227− text $ pack $ formatTime defaultTimeLocale (iso8601DateFormat Nothing)
228− $ intToUTCTime createdAt
193+ text $ formatPosixToDate createdAt
229194 el "td" $
230− text $ pack $ formatTime defaultTimeLocale (iso8601DateFormat Nothing)
231− $ intToUTCTime updatedAt
195+ text $ formatPosixToDate updatedAt
232196 el "td" $ do
233197 let
234198 elId = "deployment_row_" <> (coerce $ deployment ^. field @"name")
@@ -247,6 +211,9 @@ activeDeploymentWidget clickedEv dname dDyn' = do
247211 text $ coerce dname <> " staging?"
248212 void $ deleteEndpoint (constDyn $ Right $ dname) delEv
249213 blank
214+ let route = DashboardRoute :/ Just dname
215+ setRoute $ route <$ domEvent Click linkEl
216+ blank
250217
251218archivedDeploymentsWidget
252219 :: MonadWidget t m
@@ -308,11 +275,9 @@ archivedDeploymentWidget clickedEv dDyn' = do
308275 el "b" $ text $ var <> ": "
309276 text val
310277 el "td" $
311− text $ pack $ formatTime defaultTimeLocale (iso8601DateFormat Nothing)
312− $ intToUTCTime createdAt
278+ text $ formatPosixToDate createdAt
313279 el "td" $
314− text $ pack $ formatTime defaultTimeLocale (iso8601DateFormat Nothing)
315− $ intToUTCTime updatedAt
280+ text $ formatPosixToDate updatedAt
316281 el "td" $ do
317282 let
318283 elId = "deployment_row_" <> (coerce $ deployment ^. field @"name")
@@ -327,12 +292,9 @@ archivedDeploymentWidget clickedEv dDyn' = do
327292 pure never
328293 dropdownWidget' clickedEv btn body
329294
330−intToUTCTime :: Int -> UTCTime
331−intToUTCTime = posixSecondsToUTCTime . realToFrac
332−
333295tableWrapper :: MonadWidget t m => m a -> m a
334296tableWrapper ma =
335− divClass "stagings-table" $
297+ divClass "table table--stagings table--clickable" $
336298 el "table" $ do
337299 tableHeader
338300 el "tbody" ma
@@ -379,7 +341,7 @@ _badSearchWidget = do
379341
380342emptyTableBody :: MonadWidget t m => m () -> m ()
381343emptyTableBody msg =
382− elClass "tr" "no-stagings-table" $
344+ elClass "tr" "no-table" $
383345 elAttr "td" ("colspan" =: "7") msg
384346
385347dataWidgetWrapper :: MonadWidget t m => m a -> m a
dm-frontend/src/Page/Utils.hs+73−20
@@ -1,7 +1,10 @@
11module Page.Utils where
22
3−import Data.Monoid
3+import Data.Map (Map)
4+import Data.Proxy (Proxy(..))
45import Data.Text
6+import Data.Time
7+import Data.Time.Clock.POSIX
58import Control.Lens
69import GHCJS.DOM
710import GHCJS.DOM.Element as DOM
@@ -10,6 +13,8 @@ import GHCJS.DOM.GlobalEventHandlers as Events (click)
1013import GHCJS.DOM.Node as DOM
1114import Reflex.Dom as R
1215
16+import Common.Types as CT
17+
1318newtype ClickedElement =
1419 ClickedElement { unClickedElement :: Maybe DOM.Element }
1520
@@ -36,15 +41,17 @@ dropdownWidget'
3641dropdownWidget' clickedEl btn body = mdo
3742 clickInsideEv <- performEvent $ ffor clickedEl $ \(ClickedElement clicked) ->
3843 DOM.contains (_element_raw btnEl) clicked
39− openedDyn <- foldDyn switchState False clickInsideEv
44+ openedDyn <- foldDyn switchState False
45+ $ leftmost [ clickInsideEv, True <$ domEvent Click btnEl ]
4046 let
4147 switchState ev cur = ev && not cur
4248 wrapperClassDyn = ffor openedDyn $ \case
43− True -> "drop drop--actions drop--expanded"
44− False -> "drop drop--actions"
45− (btnEl, wEv) <- elDynClass' "div" wrapperClassDyn $ do
46− btn
47− divClass "drop__dropdown" body
49+ True -> "class" =: "drop drop--actions drop--expanded"
50+ False -> "class" =: "drop drop--actions"
51+ (btnEl, wEv) <- elDynAttrWithStopPropagationEvent' Click
52+ "div" wrapperClassDyn $ do
53+ btn
54+ divClass "drop__dropdown" body
4855 pure wEv
4956
5057showT :: Show a => a -> Text
@@ -78,19 +85,6 @@ popupOverlay :: DomBuilder t m => m ()
7885popupOverlay =
7986 elAttr "div" ("class" =: "popup__overlay" <> "aria-hidden" =: "true") blank
8087
81−-- Lens convenience helpers
82−(<^.>) :: Functor f => f a -> Getting b a b -> f b
83−(<^.>) fa l = fa <&> (^. l)
84−
85−(<^?>) :: Functor f => f a -> Getting (First b) a b -> f (Maybe b)
86−(<^?>) fa l = fa <&> (^? l)
87−
88−(<^..>) :: Functor f => f a -> Getting (Endo [b]) a b -> f [b]
89−(<^..>) fa t = fa <&> (^.. t)
90−
91−infixl 8 <^.>, <^..>, <^?>
92−
93−
9488eventWriterWrapper :: (MonadWidget t m, Semigroup e) => (Event t e -> EventWriterT t e m ()) -> m (Event t e)
9589eventWriterWrapper m = mdo
9690 (_, ev) <- runEventWriterT (m ev)
@@ -122,3 +116,62 @@ buttonClassEnabled cl lbl dDyn = do
122116 <> "type" =: "button" <> "disabled" =: ""
123117 (bEl, _) <- elDynAttr' "button" attrDyn $ text lbl
124118 return $ domEvent Click bEl
119+
120+intToUTCTime :: Int -> UTCTime
121+intToUTCTime = posixSecondsToUTCTime . realToFrac
122+
123+elDynAttrWithPreventDefaultEvent'
124+ :: forall a en m t. (DomBuilder t m, PostBuild t m)
125+ => EventName en -- ^ Event on the element to configure with 'preventDefault'
126+ -> Text -- ^ Element tag
127+ -> Dynamic t (Map Text Text) -- ^ Element attributes
128+ -> m a -- ^ Child of element
129+ -> m (R.Element EventResult (DomBuilderSpace m) t, a) -- An element and the result of the child
130+elDynAttrWithPreventDefaultEvent' ev = elDynAttrWithModifyConfig'
131+ (\elCfg -> elCfg & elementConfig_eventSpec %~
132+ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) ev (const preventDefault))
133+
134+elDynAttrWithStopPropagationEvent'
135+ :: forall a en m t. (DomBuilder t m, PostBuild t m)
136+ => EventName en -- ^ Event on the element to configure with 'preventDefault'
137+ -> Text -- ^ Element tag
138+ -> Dynamic t (Map Text Text) -- ^ Element attributes
139+ -> m a -- ^ Child of element
140+ -> m (R.Element EventResult (DomBuilderSpace m) t, a) -- An element and the result of the child
141+elDynAttrWithStopPropagationEvent' ev = elDynAttrWithModifyConfig'
142+ (\elCfg -> elCfg & elementConfig_eventSpec %~
143+ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) ev (const stopPropagation))
144+
145+elDynAttrWithModifyConfig'
146+ :: (DomBuilder t m, PostBuild t m)
147+ => (ElementConfig EventResult t (DomBuilderSpace m) -> ElementConfig EventResult t (DomBuilderSpace m))
148+ -> Text
149+ -> Dynamic t (Map Text Text)
150+ -> m a
151+ -> m (R.Element EventResult (DomBuilderSpace m) t, a)
152+elDynAttrWithModifyConfig' f elementTag attrs child = do
153+ modifyAttrs <- dynamicAttributesToModifyAttributes attrs
154+ let cfg = def & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs
155+ result <- R.element elementTag (f cfg) child
156+ postBuild <- getPostBuild
157+ notReadyUntil postBuild
158+ pure result
159+
160+formatPosixToDate :: Int -> Text
161+formatPosixToDate = pack
162+ . formatTime defaultTimeLocale (iso8601DateFormat Nothing)
163+ . intToUTCTime
164+
165+formatPosixToDateTime :: Int -> Text
166+formatPosixToDateTime = pack
167+ . formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))
168+ . intToUTCTime
169+
170+statusWidget :: MonadWidget t m => Dynamic t (Maybe DeploymentStatus) -> m ()
171+statusWidget stDyn = do
172+ stDyn' <- holdUniqDyn stDyn
173+ dyn_ $ stDyn' <&> \case
174+ Nothing -> divClass "loading loading--status-alike" $ text "Loading"
175+ Just st -> case status st of
176+ CT.Ok -> divClass "status status--success" $ text "Success"
177+ CT.Error -> divClass "status status--failure" $ text "Failure"