@@ -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]