git.iko.soy/typeable/octopod
on master help sign in
Added caching of default overrides and keys (#99)

* Created Control.CacheMap * Use record syntax * Things seem to work * Actually now use the defaults everywhere

commit7303b130c1be1d6374bcaff076d2cdca4f8777b7 authoriko <ilyakooo0@gmail.com> dateTue 14 Sep 2021, 15:27 (5 years ago) parentf0b4e49
9 files changed+331−159
compare with master
unifiedsplit
dev/default.nix+3−1 octopod-backend/octopod-backend.cabal+3 octopod-backend/src/Control/CacheMap.hs+93 octopod-backend/src/Octopod/Server.hs+111−77 octopod-backend/src/Octopod/Server/ControlScriptUtils.hs+5−7 octopod-common/src/Common/Types.hs−8 octopod-frontend/octopod-frontend.cabal+2 octopod-frontend/src/Frontend/Utils.hs+71−25 octopod-frontend/src/Page/Deployment.hs+43−41
dev/default.nix+3−1
@@ -103,7 +103,7 @@ in
103103 infoScript = pkgs.writeScript "info.sh" ''
104104 #!${pkgs.bash}/bin/bash
105105
106− sleep 1
106+ sleep 4
107107
108108 echo "key,value"
109109 echo "key2,value2"
@@ -146,6 +146,8 @@ in
146146 export APPLICATION_KEYS_COMMAND=${infoScript}
147147 export UNARCHIVE_COMMAND=${writeScript}
148148 export POWER_AUTHORIZATION_HEADER="123"
149+ export CACHE_INVALIDATION_TIME="60"
150+ export CACHE_UPDATE_TIME="20"
149151 ${hsPkgs.octopod-backend.components.exes.octopod-exe}/bin/octopod-exe \
150152 --port 4443 \
151153 --ui-port 3002 \
octopod-backend/octopod-backend.cabal+3
@@ -55,6 +55,8 @@ library
5555 , QuantifiedConstraints
5656 , DeriveAnyClass
5757 , ViewPatterns
58+ , TupleSections
59+ , GADTs
5860 exposed-modules:
5961 Octopod.Server
6062 Octopod.Server.Args
@@ -66,6 +68,7 @@ library
6668 Control.Octopod.DeploymentLock
6769 Octopod.PowerAPI.Auth.Server
6870 Octopod.Schema
71+ Control.CacheMap
6972 hs-source-dirs:
7073 src
7174 build-depends:
octopod-backend/src/Control/CacheMap.hsnew file+93
@@ -0,0 +1,93 @@
1+module Control.CacheMap
2+ ( CacheMap,
3+ initCacheMap,
4+ lookupBlocking,
5+ ntCacheMap,
6+ )
7+where
8+
9+import Control.Concurrent.Lifted
10+import Control.Concurrent.STM
11+import Control.Monad
12+import Control.Monad.Base
13+import Control.Monad.Except
14+import Control.Monad.Trans.Control
15+import Data.Fixed
16+import Data.Map.Strict (Map)
17+import qualified Data.Map.Strict as M
18+import Data.Time
19+import System.Mem.Weak
20+
21+data CacheMap e m k v = CacheMap !(InternalCacheMap e k v) !(k -> m v) !NominalDiffTime
22+
23+type InternalCacheMap e k v = TVar (Map k (UTCTime, TMVar (Either e v)))
24+
25+ntCacheMap :: (forall x. m x -> n x) -> CacheMap e m k v -> CacheMap e n k v
26+ntCacheMap f (CacheMap m g t) = CacheMap m (f <$> g) t
27+
28+initCacheMap ::
29+ -- | Time after which a value is considered invalid. Not exact.
30+ NominalDiffTime ->
31+ -- | Time after which the value should be updated.
32+ -- (A value can still be valid and need updating – the caller will get the
33+ -- old valid value in that case.)
34+ NominalDiffTime ->
35+ (k -> m v) ->
36+ IO (CacheMap e m k v)
37+initCacheMap invalid update createValue = do
38+ ref <- newTVarIO M.empty
39+ wRef <- mkWeakTVar ref (pure ())
40+ void $ fork $ removeInvalidCaches invalid wRef
41+ pure $ CacheMap ref createValue update
42+
43+removeInvalidCaches ::
44+ -- | Time after which a value is considered invalid. Not exact.
45+ NominalDiffTime ->
46+ Weak (InternalCacheMap e k v) ->
47+ IO ()
48+removeInvalidCaches invalid wRef = do
49+ threadDelayMicro (realToFrac $ invalid / 10)
50+ cutoff <- addUTCTime (negate invalid) <$> getCurrentTime
51+ deRefWeak wRef >>= \case
52+ Nothing -> pure ()
53+ Just ref -> do
54+ atomically $ modifyTVar' ref $ M.filter (\(t, _) -> t > cutoff)
55+ removeInvalidCaches invalid wRef
56+ where
57+ threadDelayMicro :: Micro -> IO ()
58+ threadDelayMicro (MkFixed i) = threadDelay (fromInteger i)
59+
60+lookupBlocking ::
61+ (MonadBaseControl IO m, MonadError e m, Ord k) =>
62+ CacheMap e m k v ->
63+ k ->
64+ m v
65+lookupBlocking (CacheMap mTVar createValue update) k = do
66+ now <- liftBase getCurrentTime
67+ (vM, recreate) <-
68+ liftBase $
69+ atomically $ do
70+ m <- readTVar mTVar
71+ case M.lookup k m of
72+ Nothing -> do
73+ blank <- newEmptyTMVar
74+ writeTVar mTVar $ M.insert k (now, blank) m
75+ pure (blank, True)
76+ Just (timeCreated, vM) -> do
77+ tryReadTMVar vM >>= \case
78+ Just (Left _) -> do
79+ void $ takeTMVar vM
80+ pure (vM, True)
81+ _ -> pure (vM, timeCreated < addUTCTime (negate update) now)
82+ when recreate $
83+ void $
84+ fork $ do
85+ v' <- (Right <$> createValue k) `catchError` (pure . Left)
86+ replaceTMVar vM v'
87+
88+ (liftBase . atomically . readTMVar) vM >>= liftEither
89+
90+replaceTMVar :: MonadBase IO m => TMVar a -> a -> m ()
91+replaceTMVar mv x = liftBase . atomically $ do
92+ void $ tryTakeTMVar mv
93+ putTMVar mv x
octopod-backend/src/Octopod/Server.hs+111−77
@@ -2,6 +2,8 @@ module Octopod.Server (runOctopodServer) where
22
33import Common.Validation
44import Control.Applicative
5+import Control.CacheMap (CacheMap)
6+import qualified Control.CacheMap as CM
57import Control.Concurrent (threadDelay)
68import Control.Concurrent.Async (race_)
79import qualified Control.Concurrent.Lifted as L
@@ -70,6 +72,12 @@ import Prelude hiding (lines, log, unlines, unwords)
7072
7173type AppM = ReaderT AppState Handler
7274
75+type AppMConstraints m = (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m)
76+
77+-- | This is a polymorphic monad wrapper with the main constraints from 'AppM'.
78+-- Currently used only for CacheMap values.
79+newtype AppM' a = AppM' {runAppM' :: forall m. AppMConstraints m => m a}
80+
7381-- | Octopod Server state definition.
7482data AppState = AppState
7583 { -- | postgres pool
@@ -118,6 +126,10 @@ data AppState = AppState
118126 , -- | Deployments currently being processed which has not yet been
119127 -- recorded in the database.
120128 lockedDeployments :: LockedDeployments
129+ , depOverridesCache :: CacheMap ServerError AppM' () (DefaultConfig 'DeploymentLevel)
130+ , depOverrideKeysCache :: CacheMap ServerError AppM' () [Text]
131+ , appOverridesCache :: CacheMap ServerError AppM' (Config 'DeploymentLevel) (DefaultConfig 'ApplicationLevel)
132+ , appOverrideKeysCache :: CacheMap ServerError AppM' (Config 'DeploymentLevel) [Text]
121133 }
122134 deriving stock (Generic)
123135
@@ -174,11 +186,36 @@ runOctopodServer = do
174186 aKeysCmd <- Command . pack <$> getEnvOrDie "APPLICATION_KEYS_COMMAND"
175187 unarchiveCmd <- Command . pack <$> getEnvOrDie "UNARCHIVE_COMMAND"
176188 powerAuthorizationHeader <- AuthHeader . BSC.pack <$> getEnvOrDie "POWER_AUTHORIZATION_HEADER"
189+ invalidationTime <- fromInteger . maybe (60 * 60 * 24) read <$> lookupEnv "CACHE_INVALIDATION_TIME"
190+ updateTime <- fromInteger . maybe (60 * 10) read <$> lookupEnv "CACHE_UPDATE_TIME"
191+ let cacheMap :: forall a x. (forall m. AppMConstraints m => x -> m a) -> IO (CacheMap ServerError AppM' x a)
192+ cacheMap f = CM.initCacheMap invalidationTime updateTime $ \x -> AppM' $ f x
193+ decodeCSVDefaultConfig :: BSL.ByteString -> Either String (DefaultConfig l)
194+ decodeCSVDefaultConfig bs = do
195+ x <- C.decode C.NoHeader bs
196+ pure $ DefaultConfig . OM.fromList . V.toList $ x
197+ either500S :: (MonadError ServerError m, MonadBase IO m) => Either String x -> m x
198+ either500S (Right x) = pure x
199+ either500S (Left err) = do
200+ liftBase . logWarning logger' . T.pack $ err
201+ throwError err500 {errBody = BSLC.pack err}
177202 notificationCmd <-
178203 (fmap . fmap) (Command . pack) $
179204 lookupEnv "NOTIFICATION_COMMAND" <&> \case
180205 Just "" -> Nothing
181206 x -> x
207+ depOverrideKeysCache' <- cacheMap $ \() -> do
208+ (_, Stdout out, _) <- deploymentOverrideKeys >>= runCommandArgs deploymentOverrideKeysCommand
209+ pure $ T.lines out
210+ depOverridesCache' <- cacheMap $ \() -> do
211+ (_, Stdout out, _) <- defaultDeploymentOverridesArgs >>= runCommandArgs deploymentOverridesCommand
212+ either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
213+ appOverrideKeysCache' <- cacheMap $ \cfg -> do
214+ (_, Stdout out, _) <- applicationOverrideKeys cfg >>= runCommandArgs applicationOverrideKeysCommand
215+ pure $ T.lines out
216+ appOverridesCache' <- cacheMap $ \cfg -> do
217+ (_, Stdout out, _) <- defaultApplicationOverridesArgs cfg >>= runCommandArgs applicationOverridesCommand
218+ either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
182219 dbPool' <-
183220 createPool
184221 (fmap (either (error . show) id) . acquire $ unDBConnectionString $ octopodDB opts)
@@ -190,32 +227,38 @@ runOctopodServer = do
190227 lockedDs <- initLockedDeployments
191228 let appSt =
192229 AppState
193− dbPool'
194− logger'
195− channel
196− bgWorkersC
197− gracefulShutdownAct
198− shutdownS
199− projName
200− domain
201− ns
202− archRetention
203− stUpdateTimeout
204− creationCmd
205− updateCmd
206− archiveCmd
207− checkingCmd
208− cleanupCmd
209− archiveCheckingCmd
210− tagCheckingCmd
211− infoCmd
212− notificationCmd
213− dOverridesCmd
214− dKeysCmd
215− aOverridesCmd
216− aKeysCmd
217− unarchiveCmd
218− lockedDs
230+ { dbPool = dbPool'
231+ , logger = logger'
232+ , eventSink = channel
233+ , bgWorkersCounter = bgWorkersC
234+ , gracefulShutdownActivated = gracefulShutdownAct
235+ , shutdownSem = shutdownS
236+ , projectName = projName
237+ , baseDomain = domain
238+ , namespace = ns
239+ , archiveRetention = archRetention
240+ , statusUpdateTimeout = stUpdateTimeout
241+ , creationCommand = creationCmd
242+ , updateCommand = updateCmd
243+ , archiveCommand = archiveCmd
244+ , checkingCommand = checkingCmd
245+ , cleanupCommand = cleanupCmd
246+ , archiveCheckingCommand = archiveCheckingCmd
247+ , tagCheckingCommand = tagCheckingCmd
248+ , infoCommand = infoCmd
249+ , notificationCommand = notificationCmd
250+ , deploymentOverridesCommand = dOverridesCmd
251+ , deploymentOverrideKeysCommand = dKeysCmd
252+ , applicationOverridesCommand = aOverridesCmd
253+ , applicationOverrideKeysCommand = aKeysCmd
254+ , unarchiveCommand = unarchiveCmd
255+ , lockedDeployments = lockedDs
256+ , depOverridesCache = depOverridesCache'
257+ , depOverrideKeysCache = depOverrideKeysCache'
258+ , appOverridesCache = appOverridesCache'
259+ , appOverrideKeysCache = appOverrideKeysCache'
260+ }
261+
219262 app' = app appSt
220263 wsApp' = wsApp channel
221264 serverPort = octopodPort opts
@@ -283,34 +326,22 @@ server =
283326 :<|> pingH
284327 :<|> projectNameH
285328
286−decodeCSVDefaultConfig :: BSL.ByteString -> Either String (DefaultConfig l)
287−decodeCSVDefaultConfig bs = do
288− x <- C.decode C.NoHeader bs
289− pure $ DefaultConfig . OM.fromList . V.toList $ x
329+lookupCache :: (Ord x, AppMConstraints m) => (AppState -> CacheMap ServerError AppM' x y) -> x -> m y
330+lookupCache f x = do
331+ cm <- asks f
332+ CM.lookupBlocking (CM.ntCacheMap runAppM' cm) x
290333
291−either500S :: MonadError ServerError m => Either String x -> m x
292−either500S (Right x) = pure x
293−either500S (Left err) = throwError err500 {errBody = BSLC.pack err}
334+defaultDeploymentKeysH :: AppMConstraints m => m [Text]
335+defaultDeploymentKeysH = lookupCache depOverrideKeysCache ()
294336
295−defaultDeploymentKeysH :: AppM [Text]
296−defaultDeploymentKeysH = do
297− (_, Stdout out, _) <- deploymentOverrideKeys >>= runCommandArgs deploymentOverrideKeysCommand
298− pure $ T.lines out
337+defaultDeploymentOverridesH :: AppMConstraints m => m (DefaultConfig 'DeploymentLevel)
338+defaultDeploymentOverridesH = lookupCache depOverridesCache ()
299339
300−defaultDeploymentOverridesH :: AppM (DefaultConfig 'DeploymentLevel)
301−defaultDeploymentOverridesH = do
302− (_, Stdout out, _) <- defaultDeploymentOverridesArgs >>= runCommandArgs deploymentOverridesCommand
303− either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
340+defaultApplicationKeysH :: AppMConstraints m => Config 'DeploymentLevel -> m [Text]
341+defaultApplicationKeysH = lookupCache appOverrideKeysCache
304342
305−defaultApplicationKeysH :: Config 'DeploymentLevel -> AppM [Text]
306−defaultApplicationKeysH cfg = do
307− (_, Stdout out, _) <- applicationOverrideKeys cfg >>= runCommandArgs applicationOverrideKeysCommand
308− pure $ T.lines out
309−
310−defaultApplicationOverridesH :: Config 'DeploymentLevel -> AppM (DefaultConfig 'ApplicationLevel)
311−defaultApplicationOverridesH cfg = do
312− (_, Stdout out, _) <- defaultApplicationOverridesArgs cfg >>= runCommandArgs applicationOverridesCommand
313− either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
343+defaultApplicationOverridesH :: AppMConstraints m => Config 'DeploymentLevel -> m (DefaultConfig 'ApplicationLevel)
344+defaultApplicationOverridesH = lookupCache appOverridesCache
314345
315346-- | Application with the octo CLI API.
316347powerApp :: AuthHeader -> AppState -> IO Application
@@ -490,8 +521,8 @@ updateDeploymentInfo ::
490521updateDeploymentInfo dName = do
491522 log <- asks (logWarning . logger)
492523 DeploymentFullInfo {deployment = dep} <- getDeploymentS dName
493− dc <- getDefaultConfig dName
494− (ec, out, err) <- runCommandArgs infoCommand =<< infoCommandArgs dc dep
524+ cfg <- getDeploymentConfig dep
525+ (ec, out, err) <- runCommandArgs infoCommand =<< infoCommandArgs cfg dep
495526 case ec of
496527 ExitSuccess -> case parseDeploymentMetadata (unStdout out) of
497528 Right dMeta -> upsertDeploymentMetadatum dName dMeta
@@ -505,22 +536,24 @@ updateDeploymentInfo dName = do
505536 <> "stderr: "
506537 <> coerce err
507538
508−getDefaultConfig :: Monad m => DeploymentName -> m FullDefaultConfig
509−getDefaultConfig _ =
539+getDeploymentConfig :: AppMConstraints m => Deployment -> m FullConfig
540+getDeploymentConfig dep = do
541+ depCfg <- applyOverrides (dep ^. #deploymentOverrides) <$> defaultDeploymentOverridesH
542+ appCfg <- applyOverrides (dep ^. #appOverrides) <$> defaultApplicationOverridesH depCfg
510543 pure
511− FullDefaultConfig
512− { appDefaultConfig = DefaultConfig OM.empty
513− , depDefaultConfig = DefaultConfig OM.empty
544+ FullConfig
545+ { appConfig = appCfg
546+ , depConfig = depCfg
514547 }
515548
516549-- | Helper to create a new deployment.
517550createDeployment ::
518− (MonadBaseControl IO m, MonadReader AppState m) =>
551+ (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>
519552 Deployment ->
520553 m (ExitCode, Stdout, Stderr)
521554createDeployment dep = do
522555 st <- ask
523− dCfg <- getDefaultConfig $ dep ^. #name
556+ cfg <- getDeploymentConfig dep
524557 let log :: Text -> IO ()
525558 log = logInfo (logger st)
526559 args =
@@ -536,7 +569,7 @@ createDeployment dep = do
536569 , "--tag"
537570 , T.unpack . coerce $ dep ^. #tag
538571 ]
539− <> fullConfigArgs dCfg dep
572+ <> fullConfigArgs cfg
540573 (ec, out, err) <- runCommandArgs creationCommand args
541574 liftBase . log $ "deployment created, deployment: " <> (pack . show $ dep)
542575 pure (ec, out, err)
@@ -807,7 +840,7 @@ updateH dName dUpdate = do
807840
808841 updateDeploymentInfo dName
809842 liftBase $ sendReloadEvent st
810− dCfg <- getDefaultConfig dName
843+ cfg <- getDeploymentConfig dep
811844 let args =
812845 ControlScriptArgs
813846 [ "--project-name"
@@ -821,7 +854,7 @@ updateH dName dUpdate = do
821854 , "--tag"
822855 , T.unpack . coerce $ dep ^. #tag
823856 ]
824− <> fullConfigArgs dCfg dep
857+ <> fullConfigArgs cfg
825858 (ec, out, err) <- runCommandArgs updateCommand args
826859 liftBase . log $
827860 "deployment updated, name: "
@@ -884,9 +917,9 @@ projectNameH = asks projectName
884917-- | Handles the 'status' request.
885918statusH :: DeploymentName -> AppM CurrentDeploymentStatus
886919statusH dName = do
887− dep <- getDeploymentS dName
888− dCfg <- getDefaultConfig dName
889− (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs dCfg (dep ^. #deployment)
920+ (view #deployment -> dep) <- getDeploymentS dName
921+ cfg <- getDeploymentConfig dep
922+ (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep
890923 pure . CurrentDeploymentStatus $
891924 case ec of
892925 ExitSuccess -> Ok
@@ -985,10 +1018,10 @@ restoreH dName = do
9851018 failIfImageNotFound $ dep ^. #deployment
9861019 failIfGracefulShutdownActivated
9871020 runDeploymentBgWorker (Just CreatePending) dName (pure ()) $ \() -> do
988− dep' <- getDeploymentS dName
1021+ (view #deployment -> dep') <- getDeploymentS dName
9891022 updateDeploymentInfo dName
990− dCfg <- getDefaultConfig dName
991− (ec, out, err) <- runCommandArgs unarchiveCommand =<< unarchiveCommandArgs dCfg (dep' ^. #deployment)
1023+ cfg <- getDeploymentConfig dep'
1024+ (ec, out, err) <- runCommandArgs unarchiveCommand =<< unarchiveCommandArgs cfg dep'
9921025 t2 <- liftBase getCurrentTime
9931026 let elTime = elapsedTime t2 t1
9941027 transitionToStatusS dName $
@@ -1089,8 +1122,8 @@ upsertDeploymentMetadatum dName dMetadata =
10891122-- Returns 404 'Tag not found' response if the deployment tag doesn't exist.
10901123failIfImageNotFound :: Deployment -> AppM ()
10911124failIfImageNotFound dep = do
1092− dCfg <- getDefaultConfig $ dep ^. #name
1093− (ec, _, _) <- runCommandArgs tagCheckingCommand =<< tagCheckCommandArgs dCfg dep
1125+ cfg <- getDeploymentConfig dep
1126+ (ec, _, _) <- runCommandArgs tagCheckingCommand =<< tagCheckCommandArgs cfg dep
10941127 case ec of
10951128 ExitSuccess -> pure ()
10961129 ExitFailure _ ->
@@ -1112,7 +1145,7 @@ sendReloadEvent state =
11121145
11131146-- | Returns time delta between 2 timestamps.
11141147elapsedTime :: UTCTime -> UTCTime -> Duration
1115−elapsedTime t1 t2 = Duration . calendarTimeTime $ t2 `diffUTCTime` t1
1148+elapsedTime t1 t2 = Duration . calendarTimeTime $ Prelude.abs $ t2 `diffUTCTime` t1
11161149
11171150-- | Runs the status updater.
11181151runStatusUpdater :: AppState -> IO ()
@@ -1124,7 +1157,10 @@ runStatusUpdater state = do
11241157 forever $ do
11251158 currentTime <- liftBase getCurrentTime
11261159 let cutoff = addUTCTime (negate interval) currentTime
1127− flip runReaderT state $ do
1160+ logLeft :: Either ServerError () -> IO ()
1161+ logLeft (Left err) = logErr . T.pack $ displayException err
1162+ logLeft (Right ()) = pure ()
1163+ (>>= logLeft) . runExceptT . flip runReaderT state $ do
11281164 rows' <- runStatement . select $ do
11291165 ds <- each deploymentSchema
11301166 where_ $ ds ^. #checkedAt <. litExpr cutoff
@@ -1139,9 +1175,9 @@ runStatusUpdater state = do
11391175 _ -> do
11401176 getSingleFullInfo dName >>= \case
11411177 Nothing -> liftBase (logErr $ "Couldn't find deployment: " <> coerce dName) $> Nothing
1142− Just dep -> do
1143− dCfg <- getDefaultConfig dName
1144− (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs dCfg (dep ^. #deployment)
1178+ Just (view #deployment -> dep) -> do
1179+ cfg <- getDeploymentConfig dep
1180+ (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep
11451181 pure $ Just ec
11461182 pure $ mEc <&> \ec -> (dName, statusTransition ec dStatus ts timeout, dStatus)
11471183 updated <-
@@ -1287,7 +1323,6 @@ extractDeploymentFullInfo ::
12871323extractDeploymentFullInfo d = do
12881324 let dName = d ^. #name
12891325 locked <- isDeploymentLocked dName
1290− dCfg <- getDefaultConfig dName
12911326 pure
12921327 DeploymentFullInfo
12931328 { deployment = extractDeployment d
@@ -1298,5 +1333,4 @@ extractDeploymentFullInfo d = do
12981333 , metadata = d ^. #metadata
12991334 , createdAt = d ^. #createdAt
13001335 , updatedAt = d ^. #updatedAt
1301− , deploymentDefaultConfig = dCfg
13021336 }
octopod-backend/src/Octopod/Server/ControlScriptUtils.hs+5−7
@@ -48,12 +48,12 @@ type GenericDeploymentCommandArgs m r =
4848 , HasType ProjectName r
4949 , HasType Domain r
5050 ) =>
51− FullDefaultConfig ->
51+ FullConfig ->
5252 Deployment ->
5353 m ControlScriptArgs
5454
5555genericDeploymentCommandArgs :: GenericDeploymentCommandArgs m r
56−genericDeploymentCommandArgs dCfg dep = do
56+genericDeploymentCommandArgs cfg dep = do
5757 (Namespace namespace) <- asks getTyped
5858 (ProjectName projectName) <- asks getTyped
5959 (Domain domain) <- asks getTyped
@@ -70,7 +70,7 @@ genericDeploymentCommandArgs dCfg dep = do
7070 , "--tag"
7171 , T.unpack . coerce $ tag dep
7272 ]
73− <> fullConfigArgs dCfg dep
73+ <> fullConfigArgs cfg
7474
7575type GenericDeploymentCommandArgsNoConfig m r =
7676 ( MonadReader r m
@@ -223,10 +223,8 @@ runCommandWithoutPipes :: FilePath -> [String] -> IO ExitCode
223223runCommandWithoutPipes cmd args =
224224 withProcessWait (proc cmd args) waitExitCode
225225
226−fullConfigArgs :: FullDefaultConfig -> Deployment -> ControlScriptArgs
227−fullConfigArgs defCfg dep =
228− overridesArgs (applyOverrides (dep ^. #appOverrides) (appDefaultConfig defCfg))
229− <> overridesArgs (applyOverrides (dep ^. #deploymentOverrides) (depDefaultConfig defCfg))
226+fullConfigArgs :: FullConfig -> ControlScriptArgs
227+fullConfigArgs cfg = overridesArgs (appConfig cfg) <> overridesArgs (depConfig cfg)
230228
231229overridesArgs :: forall l. KnownOverrideLevel l => Config l -> ControlScriptArgs
232230overridesArgs (Config cc) =
octopod-common/src/Common/Types.hs−8
@@ -244,18 +244,10 @@ data DeploymentFullInfo = DeploymentFullInfo
244244 , metadata :: DeploymentMetadata
245245 , createdAt :: UTCTime
246246 , updatedAt :: UTCTime
247− , deploymentDefaultConfig :: FullDefaultConfig
248247 }
249248 deriving stock (Generic, Show, Eq)
250249 deriving (FromJSON, ToJSON) via Snake DeploymentFullInfo
251250
252−getDeploymentConfig :: DeploymentFullInfo -> FullConfig
253−getDeploymentConfig d =
254− FullConfig
255− { appConfig = applyOverrides (d ^. #deployment . #appOverrides) (d ^. #deploymentDefaultConfig . #appDefaultConfig)
256− , depConfig = applyOverrides (d ^. #deployment . #deploymentOverrides) (d ^. #deploymentDefaultConfig . #depDefaultConfig)
257− }
258−
259251isDeploymentArchived :: DeploymentFullInfo -> Bool
260252isDeploymentArchived DeploymentFullInfo {status = s} = case s of
261253 DeploymentNotPending s' -> isArchivedStatus s'
octopod-frontend/octopod-frontend.cabal+2
@@ -56,6 +56,7 @@ executable frontend
5656 -Wno-missed-specialisations
5757 -- Because reflex-dom is a false positive.
5858 -Wno-unused-packages
59+ -Wno-partial-type-signatures
5960 -threaded
6061 default-extensions: BlockArguments
6162 , ConstraintKinds
@@ -87,6 +88,7 @@ executable frontend
8788 , OverloadedLabels
8889 , ViewPatterns
8990 , ApplicativeDo
91+ , PartialTypeSignatures
9092 build-depends: aeson
9193 , base
9294 , bytestring
octopod-frontend/src/Frontend/Utils.hs+71−25
@@ -30,6 +30,11 @@ module Frontend.Utils
3030 dropdownWidget,
3131 dropdownWidget',
3232 buttonDynClass,
33+ deploymentConfigProgressiveComponents,
34+ deploymentConfigProgressive,
35+ holdClearingWith,
36+ unitEv,
37+ deploymentSection,
3338 )
3439where
3540
@@ -533,7 +538,9 @@ deploymentPopupBody ::
533538 m (Dynamic t (Maybe DeploymentUpdate))
534539deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo
535540 pb <- getPostBuild
536− defDep <- defaultDeploymentOverrides pb >>= hReq >>= holdDynMaybe
541+ (defDepEv, defApp, depCfgEv) <- deploymentConfigProgressiveComponents hReq deploymentOvsDyn
542+ defAppM <- holdClearingWith defApp (unitEv deploymentOvsDyn)
543+ defDep <- holdDynMaybe defDepEv
537544 depKeys <- deploymentOverrideKeys pb >>= hReq
538545
539546 let commandResponseEv = fmapMaybe commandResponse errEv
@@ -546,38 +553,23 @@ deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo
546553 holdDCfg dCfgDyn ovs = mdo
547554 ovsDyn <- holdDyn ovs ovsEv
548555 x <- attachDyn (current ovsDyn) dCfgDyn
549− ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput dCfg ovs') >>= switchHold never
556+ ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput dCfg ovs') >>= switchHold never >>= debounce 0.5
550557 pure ovsDyn
551558 holdDKeys n keysDyn = do
552559 let loading = loadingCommonWidget
553− popUpSection n $
560+ deploymentSection n $
554561 widgetHold_ loading $
555562 keysDyn <&> \case
556563 Just keys -> el "ul" $
557564 forM_ keys $ \key -> el "li" $ text key
558565 Nothing -> loading
559566
560− deploymentOvsDyn <- popUpSection "Deployment overrides" $ holdDCfg defDep defDepOv
567+ deploymentOvsDyn <- deploymentSection "Deployment overrides" $ holdDCfg defDep defDepOv
561568 holdDKeys "Deployment keys" (Just <$> depKeys)
562− readyDeploymentCfgDebounced <- debounce 0.5 . catMaybes $
563− updated $ do
564− defDep >>= \case
565− Nothing -> pure Nothing
566− Just depDCfg -> do
567− depOv <- deploymentOvsDyn
568− pure $ Just $ applyOverrides depOv depDCfg
569− defApp <-
570− waitForValuePromptly
571− readyDeploymentCfgDebounced
572− ( \deploymentCfg -> do
573− pb' <- getPostBuild
574− defaultApplicationOverrides (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing
575− )
576− >>= holdDyn Nothing
577− appKeys <- waitForValuePromptly readyDeploymentCfgDebounced $ \deploymentCfg -> do
569+ appKeys <- waitForValuePromptly depCfgEv $ \deploymentCfg -> do
578570 pb' <- getPostBuild
579571 applicationOverrideKeys (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing
580− applicationOvsDyn <- popUpSection "App overrides" $ holdDCfg defApp defAppOv
572+ applicationOvsDyn <- deploymentSection "App overrides" $ holdDCfg defAppM defAppOv
581573 holdDKeys "App keys" appKeys
582574
583575 validDyn <- holdDyn True $ updated tOkEv
@@ -603,6 +595,54 @@ deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo
603595 badNameEv = badTagText <$ ffilter (== "") (updated tagDyn)
604596 in leftmost [tagErrEv, badNameEv]
605597
598+deploymentConfigProgressiveComponents ::
599+ MonadWidget t m =>
600+ RequestErrorHandler t m ->
601+ Dynamic t (Overrides 'DeploymentLevel) ->
602+ m
603+ ( Event t (DefaultConfig 'DeploymentLevel)
604+ , Event t (DefaultConfig 'ApplicationLevel)
605+ , Event t (Config 'DeploymentLevel)
606+ )
607+deploymentConfigProgressiveComponents hReq depOvsDyn = do
608+ pb <- getPostBuild
609+ defDepEv <- defaultDeploymentOverrides pb >>= hReq
610+ defDepMDyn <- holdDynMaybe defDepEv
611+ let depCfgEv = catMaybes . updated $ do
612+ defDepM <- defDepMDyn
613+ depOvs <- depOvsDyn
614+ pure $ defDepM <&> applyOverrides depOvs
615+ defAppEv <-
616+ fmap switchDyn $
617+ networkHold (pure never) $
618+ depCfgEv <&> \depCfg -> do
619+ pb' <- getPostBuild
620+ defaultApplicationOverrides (pure $ Right depCfg) pb' >>= hReq
621+ pure (defDepEv, defAppEv, depCfgEv)
622+
623+deploymentConfigProgressive ::
624+ MonadWidget t m =>
625+ RequestErrorHandler t m ->
626+ Dynamic t (Overrides 'DeploymentLevel) ->
627+ Dynamic t (Overrides 'ApplicationLevel) ->
628+ m (Event t FullConfig)
629+deploymentConfigProgressive hReq depOvsDyn appOvsDyn = do
630+ (_, defAppEv, depCfgEv) <- deploymentConfigProgressiveComponents hReq depOvsDyn
631+ defAppMDyn <- holdDynMaybe defAppEv
632+ depCfgMDyn <- holdDynMaybe depCfgEv
633+ pure . catMaybes . updated $ do
634+ defAppM <- defAppMDyn
635+ appOvs <- appOvsDyn
636+ depCfgM <- depCfgMDyn
637+ pure $ do
638+ defApp <- defAppM
639+ depCfg <- depCfgM
640+ pure
641+ FullConfig
642+ { appConfig = applyOverrides appOvs defApp
643+ , depConfig = depCfg
644+ }
645+
606646waitForValuePromptly :: (MonadHold t m, Adjustable t m) => Event t x -> (x -> m (Event t y)) -> m (Event t y)
607647waitForValuePromptly ev f = fmap switchPromptlyDyn $ networkHold (pure never) $ f <$> ev
608648
@@ -667,11 +707,10 @@ envVarsInput dCfg ovs = mdo
667707 Nothing -> loadingCommonWidget
668708 pure . updated $ destructWorkingOverrides <$> envsDyn
669709
670−popUpSection :: DomBuilder t m => Text -> m a -> m a
671−popUpSection n m = elClass "section" "deployment__section" $ do
710+deploymentSection :: DomBuilder t m => Text -> m a -> m a
711+deploymentSection n m = elClass "section" "deployment__section" $ do
672712 elClass "h3" "deployment__sub-heading" $ text n
673− elClass "div" "deployment__widget" $
674− elClass "div" "overrides" m
713+ elClass "div" "deployment__widget" m
675714
676715-- | Widget for entering a key-value pair. The updated overrides list is
677716-- written to the 'EventWriter'.
@@ -744,3 +783,10 @@ attachDyn b d = do
744783 currD <- sample . current $ d
745784 currB <- sample b
746785 holdDyn (currB, currD) (attach b $ updated d)
786+
787+holdClearingWith :: (Reflex t, MonadHold t m) => Event t a -> Event t () -> m (Dynamic t (Maybe a))
788+holdClearingWith aEv clear =
789+ holdDyn Nothing $ leftmost [fmapCheap Just aEv, fmapCheap (const Nothing) clear]
790+
791+unitEv :: Reflex t => Dynamic t a -> Event t ()
792+unitEv = fmapCheap (const ()) . updated
octopod-frontend/src/Page/Deployment.hs+43−41
@@ -28,6 +28,7 @@ import Frontend.Utils
2828import Page.ClassicPopup
2929import Page.Elements.Links
3030import Page.Popup.EditDeployment
31+import Reflex.Network
3132import Servant.Reflex.Extra
3233
3334-- | The root widget of a deployment page. It requests the deployment data.
@@ -178,56 +179,57 @@ deploymentBody ::
178179 -- | Deployment data.
179180 Dynamic t DeploymentFullInfo ->
180181 m ()
181−deploymentBody updEv dfiDyn = deploymentBodyWrapper $ do
182− let nameDyn = dfiDyn <^.> dfiName
183− cfg = dfiDyn <&> getDeploymentConfig
184− divClass "deployment__summary" $ do
185− divClass "deployment__stat" $ do
186− elClass "b" "deployment__param" $ text "Status"
187− divClass "deployment__value" $ do
188− statusWidget $ dfiDyn <^.> field @"status"
189− divClass "deployment__stat" $ do
190− elClass "b" "deployment__param" $ text "Created"
191− divClass "deployment__value" $ do
192− let createdAtDyn = dfiDyn <^.> field @"createdAt"
193− dynText $ formatPosixToDate <$> createdAtDyn
194− divClass "deployment__stat" $ do
195− elClass "b" "deployment__param" $ text "Changed"
196− divClass "deployment__value" $ do
197− let createdAtDyn = dfiDyn <^.> field @"updatedAt"
198− dynText $ formatPosixToDate <$> createdAtDyn
199− elClass "section" "deployment__section" $ do
200− let tagDyn = dfiDyn <^.> field @"deployment" . field @"tag" . coerced
201− elClass "h3" "deployment__sub-heading" $ text "Tag"
202− divClass "deployment__widget" $ dynText tagDyn
203− elClass "section" "deployment__section" $ do
204− let urlsDyn = dfiDyn <^.> field @"metadata" . to unDeploymentMetadata
205− elClass "h3" "deployment__sub-heading" $ text "Links"
206− divClass "deployment__widget" $
207− divClass "listing" $
208− void $ simpleList urlsDyn renderMetadataLink
209− elClass "section" "deployment__section" $ do
210− let envsDyn = cfg <^.> #appConfig
211− allEnvsWidget "App overrides" envsDyn
212− elClass "section" "deployment__section" $ do
213− let envsDyn = cfg <^.> #depConfig
214− allEnvsWidget "Deployment overrides" envsDyn
215− elClass "section" "deployment__section" $ do
216− elClass "h3" "deployment__sub-heading" $ text "Actions"
217− divClass "deployment__widget" $
182+deploymentBody updEv dfiDyn = deploymentBodyWrapper $
183+ wrapRequestErrors $ \hReq -> do
184+ let nameDyn = dfiDyn <^.> dfiName
185+ depDyn = dfiDyn <^.> #deployment
186+ cfgEv <- deploymentConfigProgressive hReq (depDyn <^.> #deploymentOverrides) (depDyn <^.> #appOverrides)
187+ cfgMDyn <-
188+ holdClearingWith cfgEv $
189+ leftmost [unitEv $ depDyn <^.> #deploymentOverrides, unitEv $ depDyn <^.> #appOverrides]
190+ divClass "deployment__summary" $ do
191+ divClass "deployment__stat" $ do
192+ elClass "b" "deployment__param" $ text "Status"
193+ divClass "deployment__value" $ do
194+ statusWidget $ dfiDyn <^.> field @"status"
195+ divClass "deployment__stat" $ do
196+ elClass "b" "deployment__param" $ text "Created"
197+ divClass "deployment__value" $ do
198+ let createdAtDyn = dfiDyn <^.> field @"createdAt"
199+ dynText $ formatPosixToDate <$> createdAtDyn
200+ divClass "deployment__stat" $ do
201+ elClass "b" "deployment__param" $ text "Changed"
202+ divClass "deployment__value" $ do
203+ let createdAtDyn = dfiDyn <^.> field @"updatedAt"
204+ dynText $ formatPosixToDate <$> createdAtDyn
205+ deploymentSection "Tag" $ do
206+ let tagDyn = dfiDyn <^.> field @"deployment" . field @"tag" . coerced
207+ divClass "deployment__widget" $ dynText tagDyn
208+ deploymentSection "Links" $ do
209+ let urlsDyn = dfiDyn <^.> field @"metadata" . to unDeploymentMetadata
210+ divClass "deployment__widget" $
211+ divClass "listing" $
212+ void $ simpleList urlsDyn renderMetadataLink
213+ void $
214+ networkView $
215+ cfgMDyn <&> \cfgM -> do
216+ let showVars :: Getting (Config l) FullConfig (Config l) -> _
217+ showVars l = case cfgM of
218+ Just cfg -> allEnvsWidget (pure $ cfg ^. l)
219+ Nothing -> loadingCommonWidget
220+ deploymentSection "App overrides" $ showVars #appConfig
221+ deploymentSection "Deployment overrides" $ showVars #depConfig
222+ deploymentSection "Actions" $
218223 divClass "table table--actions" $
219224 actionsTable updEv nameDyn
220225
221226-- | Widget that shows overrides list. It does not depend on their type.
222227allEnvsWidget ::
223228 MonadWidget t m =>
224− -- | Widget header.
225− Text ->
226229 -- | Overrides list.
227230 Dynamic t (Config l) ->
228231 m ()
229−allEnvsWidget headerText envsDyn = do
230− elClass "h3" "deployment__sub-heading" $ text headerText
232+allEnvsWidget envsDyn =
231233 divClass "deployment__widget" $
232234 divClass "listing listing--for-text listing--larger" $
233235 void $