git.iko.soy/typeable/octopod
on master help sign in
Edit staging popup (#50)
8c2a429Nikita
dm-css+1−1
compare with master
unifiedsplit

Submodule changed.

dm-frontend/dm-frontend.cabal+1
@@ -29,6 +29,7 @@ executable frontend
29 , Page.ClassicPopup
29 , Page.ClassicPopup
30 , Page.Deployment
30 , Page.Deployment
31 , Page.Deployments
31 , Page.Deployments
32+ , Page.EditStagingPopup
32 , Page.NewStagingPopup
33 , Page.NewStagingPopup
33 , Page.Utils
34 , Page.Utils
34 ghc-options: -Wall
35 ghc-options: -Wall
dm-frontend/src/Page/Deployment.hs+10−5
@@ -7,13 +7,14 @@ import Data.Generics.Product (field)
7import Data.List as L (find)
7import Data.List as L (find)
8import Data.Text as T (Text, pack)
8import Data.Text as T (Text, pack)
9import Obelisk.Route.Frontend
9import Obelisk.Route.Frontend
10−import Reflex.Dom
10+import Reflex.Dom as R
11import Servant.Reflex
11import Servant.Reflex
12
12
13import Common.Types as CT
13import Common.Types as CT
14import Common.Utils
14import Common.Utils
15import Frontend.API
15import Frontend.API
16import Frontend.Route
16import Frontend.Route
17+import Page.EditStagingPopup
17import Page.Utils
18import Page.Utils
18
19
19
20
@@ -43,26 +44,30 @@ deploymentWidget updEv dfi = do
43 processResp (dfi ^. dfiName) respEv
44 processResp (dfi ^. dfiName) respEv
44 dfiDyn' <- holdDyn dfi okEv
45 dfiDyn' <- holdDyn dfi okEv
45 dfiDyn <- holdUniqDyn dfiDyn'
46 dfiDyn <- holdUniqDyn dfiDyn'
46− deploymentHead dfiDyn
47+ editEv <- deploymentHead dfiDyn
47 stagingNotification never
48 stagingNotification never
48 deploymentBody updEv dfiDyn
49 deploymentBody updEv dfiDyn
50+ void $ editStagingPopup editEv never
49
51
50deploymentHead
52deploymentHead
51 :: MonadWidget t m
53 :: MonadWidget t m
52 => Dynamic t DeploymentFullInfo
54 => Dynamic t DeploymentFullInfo
53− -> m ()
55+ -> m (Event t DeploymentFullInfo)
54deploymentHead dfiDyn =
56deploymentHead dfiDyn =
55 divClass "page__head" $ do
57 divClass "page__head" $ do
56 elClass "h1" "page__heading title" $ dynText $ dfiDyn <^.> dfiName . coerced
58 elClass "h1" "page__heading title" $ dynText $ dfiDyn <^.> dfiName . coerced
57− dyn_ $ dfiDyn <^.> field @"archived" <&> \case
59+ editEvEv <- dyn $ dfiDyn <^.> field @"archived" <&> \case
58 True -> do
60 True -> do
59 elClass "a" "page__action button button--secondary button--restore classic-popup-handler" $
61 elClass "a" "page__action button button--secondary button--restore classic-popup-handler" $
60 text "Recover from archive"
62 text "Recover from archive"
63+ pure never
61 False -> do
64 False -> do
62− elClass "a" "page__action button button--edit popup-handler" $
65+ (editEl, _) <- elClass' "a" "page__action button button--edit popup-handler" $
63 text "Edit staging"
66 text "Edit staging"
64 elClass "a" "page__action button button--secondary button--delete classic-popup-handler" $
67 elClass "a" "page__action button button--secondary button--delete classic-popup-handler" $
65 text "Move to archive"
68 text "Move to archive"
69+ pure $ R.tag (current dfiDyn) $ domEvent Click editEl
70+ switchHold never editEvEv
66
71
67deploymentBodyWrapper :: MonadWidget t m => m a -> m a
72deploymentBodyWrapper :: MonadWidget t m => m a -> m a
68deploymentBodyWrapper m = divClass "page__body" $ divClass "staging" $ m
73deploymentBodyWrapper m = divClass "page__body" $ divClass "staging" $ m
dm-frontend/src/Page/EditStagingPopup.hsnew file+116
@@ -0,0 +1,116 @@
1+module Page.EditStagingPopup where
2+
3+import Control.Lens (preview, _2, (^.), coerced, to)
4+import Control.Monad
5+import Data.Coerce
6+import Data.Functor
7+import Data.Generics.Product
8+import Data.Generics.Sum
9+import Data.Map as M
10+import Data.Monoid
11+import Data.Text as T (Text, intercalate)
12+import Prelude as P
13+import Reflex.Dom
14+
15+import Common.Types
16+import Common.Utils
17+import Frontend.API
18+import Page.Utils
19+import Servant.Reflex
20+
21+
22+editStagingPopup
23+ :: MonadWidget t m
24+ => Event t DeploymentFullInfo
25+ -> Event t ()
26+ -> m (Event t ())
27+editStagingPopup showEv hideEv = sidebar showEv hideEv $ \dfi -> mdo
28+ divClass "popup__body" $ mdo
29+ let dname = dfi ^. dfiName
30+ (closeEv', saveEv) <- editStagingPopupHeader dname
31+ (deploymentDyn) <- editStagingPopupBody dfi respEv
32+ respEv <- updateEndpoint (constDyn $ Right dname)
33+ (Right <$> deploymentDyn) saveEv
34+ let
35+ successEv =
36+ fmapMaybe (preview (_Ctor @"Success") <=< commandResponse) respEv
37+ closeEv = leftmost [ closeEv', successEv ]
38+ pure (never, closeEv)
39+
40+editStagingPopupHeader
41+ :: MonadWidget t m
42+ => DeploymentName
43+ -> m (Event t (), Event t ())
44+editStagingPopupHeader dname =
45+ divClass "popup__head" $ do
46+ closeEv <- buttonClass "popup__close" "Close popup"
47+ elClass "h2" "popup__project" $ text $ "Edit " <> coerce dname
48+ saveEv <- divClass "popup__operations" $
49+ buttonClass "popup__action button button--save" "Save"
50+ divClass "popup__menu drop drop--actions" blank
51+ pure (closeEv, saveEv)
52+
53+
54+editStagingPopupBody
55+ :: MonadWidget t m
56+ => DeploymentFullInfo
57+ -> Event t (ReqResult tag CommandResponse)
58+ -> m (Dynamic t DeploymentUpdate)
59+editStagingPopupBody dfi errEv =
60+ divClass "staging" $ mdo
61+ let
62+ commandResponseEv = fmapMaybe commandResponse errEv
63+ otherFailureEv = AppError <$> fmapMaybe reqFailure errEv
64+ errsEv = leftmost [commandResponseEv, otherFailureEv]
65+ appErrEv = fmapMaybe (preview (_Ctor @"AppError")) errsEv
66+ tagErrEv = fmapMaybe (preview (_Ctor @"ValidationError" . _2 )) errsEv
67+ toMaybe [] = Nothing
68+ toMaybe xs = Just $ T.intercalate ". " xs
69+ dfiTag = dfi ^. field @"deployment" . field @"tag" . coerced . to Just
70+ dfiVars = dfi ^. field @"deployment" . field @"envs"
71+ tagErrDyn <- holdDyn Nothing $ toMaybe <$> tagErrEv
72+ errorHeader appErrEv
73+ tagDyn <- dmTextInput "tag" "Tag" "Tag" dfiTag tagErrDyn
74+ envVarsDyn <- envVarsInput dfiVars
75+ pure $ DeploymentUpdate
76+ <$> (DeploymentTag <$> tagDyn)
77+ <*> (Just <$> envVarsDyn)
78+
79+errorHeader :: MonadWidget t m => Event t Text -> m ()
80+errorHeader appErrEv = do
81+ widgetHold_ blank $ appErrEv <&> \appErr -> do
82+ divClass "staging__output notification notification--danger" $ do
83+ el "b" $ text "App error: "
84+ text appErr
85+
86+envVarsInput :: MonadWidget t m => EnvPairs -> m (Dynamic t EnvPairs)
87+envVarsInput evs = do
88+ elClass "section" "staging__section" $ do
89+ elClass "h3" "staging__sub-heading" $ text "Overrides"
90+ elClass "div" "staging__widget" $
91+ elClass "div" "overrides" $ mdo
92+ let
93+ initEnvs = fromList $ zip [0..] evs
94+ emptyVar = ("", "")
95+ addEv = clickEv $> Endo (\envs -> P.length envs =: emptyVar <> envs)
96+ envsDyn <- foldDyn appEndo initEnvs $ leftmost [ addEv, updEv ]
97+ (_, updEv) <- runEventWriterT $ listWithKey envsDyn envVarInput
98+ clickEv <- buttonClass "overrides__add dash dash--add" "Add an override"
99+ pure $ elems <$> envsDyn
100+
101+envVarInput
102+ :: (EventWriter t (Endo (Map Int EnvPair)) m, MonadWidget t m)
103+ => Int
104+ -> Dynamic t EnvPair
105+ -> m ()
106+envVarInput ix epDyn = do
107+ ep <- sample $ current epDyn
108+ divClass "overrides__item" $ do
109+ keyDyn <- dmTextInput' "overrides__key" "key" (Just $ fst ep) (constDyn Nothing)
110+ valDyn <- dmTextInput' "overrides__value" "value" (Just $ snd ep) (constDyn Nothing)
111+ closeEv <- buttonClass "overrides__delete spot spot--cancel" "Delete"
112+ let
113+ envEv = updated $ zipDyn keyDyn valDyn
114+ deleteEv = Endo (M.delete ix) <$ closeEv
115+ updEv = Endo . flip update ix . const . Just <$> envEv
116+ tellEvent $ leftmost [deleteEv, updEv]
dm-frontend/src/Page/NewStagingPopup.hs+5−40
@@ -24,7 +24,7 @@ newStagingPopup
24 => Event t ()
24 => Event t ()
25 -> Event t ()
25 -> Event t ()
26 -> m (Event t ())
26 -> m (Event t ())
27−newStagingPopup showEv hideEv = sidebar showEv hideEv $ mdo
27+newStagingPopup showEv hideEv = sidebar showEv hideEv $ const $ mdo
28 divClass "popup__body" $ mdo
28 divClass "popup__body" $ mdo
29 (closeEv', saveEv) <- newStagingPopupHeader enabledDyn
29 (closeEv', saveEv) <- newStagingPopupHeader enabledDyn
30 (deploymentDyn, enabledDyn) <- newStagingPopupBody respEv
30 (deploymentDyn, enabledDyn) <- newStagingPopupBody respEv
@@ -74,8 +74,8 @@ newStagingPopupBody errEv =
74 , okNameEv ]
74 , okNameEv ]
75 tagErrDyn <- holdDyn Nothing $ toMaybe <$> tagErrEv
75 tagErrDyn <- holdDyn Nothing $ toMaybe <$> tagErrEv
76 errorHeader appErrEv
76 errorHeader appErrEv
77− nameDyn <- dmTextInput "tag" "Name" "Name" nameErrDyn
77+ nameDyn <- dmTextInput "tag" "Name" "Name" Nothing nameErrDyn
78− tagDyn <- dmTextInput "tag" "Tag" "Tag" tagErrDyn
78+ tagDyn <- dmTextInput "tag" "Tag" "Tag" Nothing tagErrDyn
79 envVarsDyn <- envVarsInput
79 envVarsDyn <- envVarsInput
80 pure $ (Deployment
80 pure $ (Deployment
81 <$> (DeploymentName <$> nameDyn)
81 <$> (DeploymentName <$> nameDyn)
@@ -89,41 +89,6 @@ errorHeader appErrEv = do
89 el "b" $ text "App error: "
89 el "b" $ text "App error: "
90 text appErr
90 text appErr
91
91
92−dmTextInput
93− :: MonadWidget t m
94− => Text
95− -> Text
96− -> Text
97− -> Dynamic t (Maybe Text)
98− -> m (Dynamic t Text)
99−dmTextInput clss lbl placeholder errDyn =
100− elClass "section" "staging__section" $ do
101− elClass "h3" "staging__sub-heading" $ text lbl
102− elClass "div" "staging__widget" $
103− dmTextInput' clss placeholder errDyn
104−
105−dmTextInput'
106− :: MonadWidget t m
107− => Text
108− -> Text
109− -> Dynamic t (Maybe Text)
110− -> m (Dynamic t Text)
111−dmTextInput' clss placeholder errDyn = do
112− let
113− classDyn = errDyn <&> \case
114− Nothing -> clss <> " input"
115− Just _ -> clss <> " input input--error"
116− elDynClass "div" classDyn $ do
117− inp <- inputElement $ def
118− & initialAttributes .~
119− ( "type" =: "text"
120− <> "class" =: "input__widget"
121− <> "placeholder" =: placeholder )
122− dyn_ $ errDyn <&> \case
123− Nothing -> blank
124− Just x -> divClass "input__output" $ text x
125− pure $ value inp
126−
127envVarsInput :: MonadWidget t m => m (Dynamic t EnvPairs)
92envVarsInput :: MonadWidget t m => m (Dynamic t EnvPairs)
128envVarsInput = do
93envVarsInput = do
129 elClass "section" "staging__section" $ do
94 elClass "section" "staging__section" $ do
@@ -145,8 +110,8 @@ envVarInput
145 -> m ()
110 -> m ()
146envVarInput ix _ = do
111envVarInput ix _ = do
147 divClass "overrides__item" $ do
112 divClass "overrides__item" $ do
148− keyDyn <- dmTextInput' "overrides__key" "key" (constDyn Nothing)
113+ keyDyn <- dmTextInput' "overrides__key" "key" Nothing (constDyn Nothing)
149− valDyn <- dmTextInput' "overrides__value" "value" (constDyn Nothing)
114+ valDyn <- dmTextInput' "overrides__value" "value" Nothing (constDyn Nothing)
150 closeEv <- buttonClass "overrides__delete spot spot--cancel" "Delete"
115 closeEv <- buttonClass "overrides__delete spot spot--cancel" "Delete"
151 let
116 let
152 envEv = updated $ zipDyn keyDyn valDyn
117 envEv = updated $ zipDyn keyDyn valDyn
dm-frontend/src/Page/Utils.hs+44−5
@@ -1,7 +1,8 @@
1module Page.Utils where
1module Page.Utils where
2
2
3−import Data.Map (Map)
3+import Data.Map (Map)
4−import Data.Proxy (Proxy(..))
4+import Data.Proxy (Proxy(..))
5+import Data.Maybe (fromMaybe)
5import Data.Text
6import Data.Text
6import Data.Time
7import Data.Time
7import Data.Time.Clock.POSIX
8import Data.Time.Clock.POSIX
@@ -59,9 +60,9 @@ showT = pack . show
59
60
60sidebar
61sidebar
61 :: MonadWidget t m
62 :: MonadWidget t m
62− => Event t ()
63+ => Event t d
63 -> Event t ()
64 -> Event t ()
64− -> m (Event t a, Event t ())
65+ -> (d -> m (Event t a, Event t ()))
65 -> m (Event t a)
66 -> m (Event t a)
66sidebar showEv closeEv m = mdo
67sidebar showEv closeEv m = mdo
67 let
68 let
@@ -77,7 +78,7 @@ sidebar showEv closeEv m = mdo
77 resultEvDyn <- elDynClass "div" popupClassDyn $ do
78 resultEvDyn <- elDynClass "div" popupClassDyn $ do
78 popupOverlay
79 popupOverlay
79 widgetHold blank' $ leftmost
80 widgetHold blank' $ leftmost
80− [ m <$ showEv
81+ [ m <$> showEv
81 , blank' <$ deferDomClearEv ]
82 , blank' <$ deferDomClearEv ]
82 pure $ switchDyn $ fst <$> resultEvDyn
83 pure $ switchDyn $ fst <$> resultEvDyn
83
84
@@ -175,3 +176,41 @@ statusWidget stDyn = do
175 Just st -> case status st of
176 Just st -> case status st of
176 CT.Ok -> divClass "status status--success" $ text "Success"
177 CT.Ok -> divClass "status status--success" $ text "Success"
177 CT.Error -> divClass "status status--failure" $ text "Failure"
178 CT.Error -> divClass "status status--failure" $ text "Failure"
179+
180+dmTextInput
181+ :: MonadWidget t m
182+ => Text
183+ -> Text
184+ -> Text
185+ -> Maybe Text
186+ -> Dynamic t (Maybe Text)
187+ -> m (Dynamic t Text)
188+dmTextInput clss lbl placeholder val errDyn =
189+ elClass "section" "staging__section" $ do
190+ elClass "h3" "staging__sub-heading" $ text lbl
191+ elClass "div" "staging__widget" $
192+ dmTextInput' clss placeholder val errDyn
193+
194+dmTextInput'
195+ :: MonadWidget t m
196+ => Text
197+ -> Text
198+ -> Maybe Text
199+ -> Dynamic t (Maybe Text)
200+ -> m (Dynamic t Text)
201+dmTextInput' clss placeholder val errDyn = do
202+ let
203+ classDyn = errDyn <&> \case
204+ Nothing -> clss <> " input"
205+ Just _ -> clss <> " input input--error"
206+ elDynClass "div" classDyn $ do
207+ inp <- inputElement $ def
208+ & initialAttributes .~
209+ ( "type" =: "text"
210+ <> "class" =: "input__widget"
211+ <> "placeholder" =: placeholder )
212+ & inputElementConfig_initialValue .~ fromMaybe "" val
213+ dyn_ $ errDyn <&> \case
214+ Nothing -> blank
215+ Just x -> divClass "input__output" $ text x
216+ pure $ value inp