@@ -3,7 +3,7 @@ module DMS (runDMS) where
33
44import Chronos (Time, getTime, now)
55import Control.Applicative
6−import Control.Concurrent (forkIO)
6+import Control.Concurrent (forkIO, threadDelay)
77import Control.Concurrent.Async (race_)
88import Control.Concurrent.STM
99import Control.Exception (throwIO, try, Exception)
@@ -94,8 +94,8 @@ runDMS = do
9494 (unDBConnectionString $ dmsDB opts) (unDBPoolSize $ dmsDBPoolSize opts)
9595 channel <- liftIO . atomically $ newBroadcastTChan
9696 let
97− app' =
98− app $ AppState
97+ appSt =
98+ AppState
9999 pgPool
100100 logger'
101101 channel
@@ -108,6 +108,7 @@ runDMS = do
108108 deletionCmd
109109 checkingCmd
110110 cleanupCmd
111+ app' = app appSt
111112 wsApp' = wsApp channel
112113 serverPort = dmsPort opts
113114 uiServerPort = unServerPort $ dmsUIPort opts
@@ -120,6 +121,7 @@ runDMS = do
120121 (run uiServerPort app')
121122 `race_` (runTLS tlsOpts warpOpts app')
122123 `race_` (run wsServerPort wsApp')
124+ `race_` (runStatusUpdater appSt)
123125
124126initConnectionPool :: ByteString -> Int -> IO PgPool
125127initConnectionPool dbConnStr =
@@ -160,16 +162,17 @@ listH = do
160162 AppState {pool = p, logger = l, baseDomain = d} <- ask
161163
162164 retrieved <- liftIO $ withResource p $ \conn -> query_ conn q
163− deployments <- liftIO $ for retrieved $ \(n, t, e, a, ct, ut) -> do
165+ deployments <- liftIO $ for retrieved $ \(n, t, e, a, ct, ut, st) -> do
164166 es <- parseEnvs (lines e)
165− pure $ DeploymentFullInfo (Deployment n t es) a ct ut (depUrls d n)
167+ pure $
168+ DeploymentFullInfo (Deployment n t es) (read st) a ct ut (depUrls d n)
166169
167170 liftIO . logInfo l $ "get deployments: " <> (pack . show $ deployments)
168171 return deployments
169172 where
170173 q =
171174 "SELECT name, tag, envs, archived, extract(epoch from created_at)::int, \
172− \extract(epoch from updated_at)::int \
175+ \extract(epoch from updated_at)::int, status::text \
173176 \FROM deployments ORDER BY name"
174177 depUrls domain dName =
175178 [ ("app", appUrl domain dName)
@@ -446,19 +449,20 @@ pingH = do
446449projectNameH :: AppM ProjectName
447450projectNameH = projectName <$> ask
448451
449−statusH :: DeploymentName -> AppM DeploymentStatus
452+statusH :: DeploymentName -> AppM CurrentDeploymentStatus
450453statusH dName = do
451454 st <- ask
452455 let
453456 pgPool = pool st
457+ log = logInfo (logger st)
454458 cmd = checkingCommand st
455459 args =
456460 [ "--namespace", coerce $ namespace st
457461 , "--name", coerce $ dName ]
458462 void $ selectDeployment pgPool dName AllDeployments
459− (ec, out, err) <- liftIO $ runCommand (unpack $ coerce cmd) (unpack <$> args)
460− liftIO $ print out >> print err
461− pure . DeploymentStatus $
463+ liftIO $ log $ "call " <> unwords (coerce cmd : args)
464+ ec <- liftIO $ runCommandWithoutPipes (unpack $ coerce cmd) (unpack <$> args)
465+ pure . CurrentDeploymentStatus $
462466 case ec of
463467 ExitSuccess -> Ok
464468 _ -> Error
@@ -561,6 +565,12 @@ runCommand cmd args = do
561565 err <- hGetContents . getStderr $ p
562566 pure (ec, Stdout out, Stderr err)
563567
568+runCommandWithoutPipes :: FilePath -> [String] -> IO ExitCode
569+runCommandWithoutPipes cmd args = do
570+ withProcessWait (proc cmd args) $ \p -> do
571+ ec <- waitExitCode p
572+ pure ec
573+
564574handleExitCode :: ExitCode -> IO ()
565575handleExitCode ExitSuccess = return ()
566576handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c
@@ -623,6 +633,60 @@ elapsedTime :: Time -> Time -> Duration
623633elapsedTime t1 t2 =
624634 Duration . fromIntegral . (`div` 1000000) . abs $ getTime t2 - getTime t1
625635
636+runStatusUpdater :: AppState -> IO ()
637+runStatusUpdater state = do
638+ let
639+ pgPool = pool state
640+ checkingCmd = checkingCommand state
641+ ns = namespace state
642+ interval = 30 :: Int
643+ select_deps =
644+ "SELECT name, status::text, \
645+ \extract(epoch from now())::int - \
646+ \extract(epoch from status_updated_at)::int \
647+ \FROM deployments \
648+ \WHERE checked_at < now() - interval '?' second"
649+ update_status =
650+ "UPDATE deployments \
651+ \SET status = ?, status_updated_at = now(), checked_at = now() \
652+ \WHERE name = ?"
653+ update_checked_at =
654+ "UPDATE deployments SET checked_at = now() WHERE name = ?"
655+
656+ forever $ do
657+ rows :: [(DeploymentName, Text, Int)] <- liftIO $
658+ withResource pgPool $ \conn -> query conn select_deps (Only interval)
659+ let
660+ checkList :: [(DeploymentName, DeploymentStatus, Timestamp)] =
661+ (\(n, s, t) -> (n, read . unpack $ s, coerce t)) <$> rows
662+ checkResult <- for checkList $ \(dName, dStatus, ts) -> do
663+ let
664+ args = unpack <$> coerce ns : coerce dName : []
665+ cmd = unpack . coerce $ checkingCmd
666+ ec <- runCommandWithoutPipes cmd args
667+ pure (dName, newStatus ec dStatus ts, ts)
668+ void $
669+ for (zip checkList checkResult) $ \((dName, oldSt, _), (_, newSt, _)) ->
670+ withResource pgPool $ \conn ->
671+ if oldSt == newSt
672+ then execute conn update_checked_at (Only dName)
673+ else execute conn update_status (show newSt, dName)
674+ if checkList == checkResult
675+ then pure ()
676+ else sendReloadEvent state
677+ threadDelay 5000000
678+
679+updatePeriod :: Timestamp
680+updatePeriod = Timestamp 600
681+
682+newStatus :: ExitCode -> DeploymentStatus -> Timestamp -> DeploymentStatus
683+newStatus ExitSuccess _ _ = Running
684+newStatus (ExitFailure _) Running _ = Failure
685+newStatus (ExitFailure _) CreatePending ts | ts > updatePeriod = Failure
686+newStatus (ExitFailure _) UpdatePending ts | ts > updatePeriod = Failure
687+newStatus (ExitFailure _) DeletePending _ = Failure
688+newStatus (ExitFailure _) oldStatus _ = oldStatus
689+
626690logInfo :: TimedFastLogger -> Text -> IO ()
627691logInfo l = logWithSeverity l "INFO"
628692