@@ -9,6 +9,7 @@ module DMS.Lib
99
1010import Prelude hiding (lines, unlines, unwords)
1111
12+import Control.Exception (throwIO, Exception)
1213import Control.Monad.IO.Class
1314import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
1415import Data.ByteString (ByteString)
@@ -40,6 +41,11 @@ type AppM = ReaderT State Handler
4041data State
4142 = State { pool :: PgPool, logger :: TimedFastLogger, helm :: FilePath, b2bHelm :: FilePath }
4243
44+newtype DeploymentException = DeploymentFailed Int
45+ deriving (Show)
46+
47+instance Exception DeploymentException
48+
4349runDMS :: IO ()
4450runDMS = do
4551 timeCache <- newTimeCache "%Y-%m-%d %T%z"
@@ -87,74 +93,76 @@ create d = do
8793 State{pool = p, logger = l, b2bHelm = b} <- ask
8894 let ia = infraArgs d
8995 aa = appArgs d
90− createDeployment p d
91− liftIO . logInfo l $ "call " <> unwords (pack <$> b : ia)
92− createInfra ia b
93− liftIO . logInfo l $ "call " <> unwords (pack <$> b : aa)
94− createApp aa b
95− liftIO . logInfo l $ "deployment created, deployment: " <> (pack . show $ d)
96+ liftIO $ do
97+ createDeployment p d
98+ logInfo l $ "call " <> unwords (pack <$> b : ia)
99+ ec1 <- createInfra ia b
100+ logInfo l $ "call " <> unwords (pack <$> b : aa)
101+ ec2 <- createApp aa b
102+ logInfo l $ "deployment created, deployment: " <> (pack . show $ d)
103+ let ec = max ec1 ec2
104+ createDeploymentLog p d "create" ec
105+ handleExitCode ec
96106 return ""
97107
98108 where
99− createDeployment :: PgPool -> Deployment -> AppM Int64
100− createDeployment p Deployment { name = n, tag = t, envs = e } = liftIO $
101− withResource p $ \conn ->
102− execute conn "INSERT INTO deployments (name, tag, envs) VALUES (?, ?, ?)" (n, t, unlines e)
109+ createDeployment :: PgPool -> Deployment -> IO Int64
110+ createDeployment p Deployment { name = n, tag = t, envs = e } = withResource p $ \conn ->
111+ execute conn "INSERT INTO deployments (name, tag, envs) VALUES (?, ?, ?)" (n, t, unlines e)
103112
104113 infraArgs Deployment { name = n } = createInfraArgs . unpack $ n
105114
106115 appArgs Deployment { name = n, tag = t, envs = e } = createAppArgs (unpack n) (unpack t) (fmap unpack e)
107116
108− createInfra :: [String] -> String -> AppM ()
109− createInfra args b2bHelm = liftIO . withProcessWait_ (proc b2bHelm args) $ \pr -> do
110− print . getStdout $ pr
111− print . getStderr $ pr
117+ createInfra :: [String] -> String -> IO ExitCode
118+ createInfra args b2bHelm = withProcessWait (proc b2bHelm args) waitProcess
112119
113− createApp :: [String] -> String -> AppM ()
114− createApp args b2bHelm = liftIO . withProcessWait_ (proc b2bHelm args) $ \pr -> do
115− print . getStdout $ pr
116− print . getStderr $ pr
120+ createApp :: [String] -> String -> IO ExitCode
121+ createApp args b2bHelm = withProcessWait (proc b2bHelm args) waitProcess
117122
118123get :: Text -> AppM [Deployment]
119124get n = do
120125 State{pool = p, logger = l} <- ask
121− d <- getDeployment p
122− liftIO . logInfo l $ "get deployment: " <> (pack . show $ d)
123− return d
126+ liftIO $ do
127+ d <- getDeployment p
128+ logInfo l $ "get deployment: " <> (pack . show $ d)
129+ return d
124130
125131 where
126− getDeployment :: PgPool -> AppM [Deployment]
127− getDeployment p = fmap (fmap (\(n, t, e) -> Deployment n t $ lines e)) . liftIO $
128− withResource p $ \conn -> query conn "SELECT name, tag, envs FROM deployments WHERE name = ?" (Only n)
132+ getDeployment :: PgPool -> IO [Deployment]
133+ getDeployment p = fmap (fmap (\(n, t, e) -> Deployment n t $ lines e)) $ withResource p $ \conn ->
134+ query conn "SELECT name, tag, envs FROM deployments WHERE name = ?" (Only n)
129135
130136edit :: Text -> Deployment -> AppM Text
131137edit n d@Deployment { envs = e } = do
132138 State{pool = p, logger = l, b2bHelm = b} <- ask
133− t <- getTag p
139+ t <- liftIO $ getTag p
134140 case t of
135141 t : _ -> do
136− let aa = appArgs $ d { name = n, tag = t }
137− editDeployment p
138− liftIO . logInfo l $ "call " <> unwords (pack <$> b : aa)
139− editApp aa b
140− liftIO . logInfo l $ "deployment edited, name: " <> n <> ", envs: " <> unwords e
142+ let d' = d { name = n, tag = t }
143+ aa = appArgs d'
144+ liftIO $ do
145+ editDeployment p
146+ logInfo l $ "call " <> unwords (pack <$> b : aa)
147+ ec <- editApp aa b
148+ logInfo l $ "deployment edited, name: " <> n <> ", envs: " <> unwords e
149+ createDeploymentLog p d' "edit" ec
150+ handleExitCode ec
151+ return ()
141152 _ -> liftIO . logWarning l $ "tag not found, name: " <> n
142153 return ""
143154
144155 where
145− getTag :: PgPool -> AppM [Text]
146− getTag p = fmap (fmap fromOnly) . liftIO $
147− withResource p $ \conn -> query conn "SELECT tag FROM deployments WHERE name = ?" (Only n)
156+ getTag :: PgPool -> IO [Text]
157+ getTag p = fmap (fmap fromOnly) $ withResource p $ \conn ->
158+ query conn "SELECT tag FROM deployments WHERE name = ?" (Only n)
148159
149− editDeployment :: PgPool -> AppM Int64
150− editDeployment p = liftIO $
151− withResource p $ \conn ->
152− execute conn "UPDATE deployments SET envs = ?, updated_at = now() WHERE name = ?" (unlines e, n)
160+ editDeployment :: PgPool -> IO Int64
161+ editDeployment p = withResource p $ \conn ->
162+ execute conn "UPDATE deployments SET envs = ?, updated_at = now() WHERE name = ?" (unlines e, n)
153163
154− editApp :: [String] -> String -> AppM ()
155− editApp args b2bHelm = liftIO . withProcessWait_ (proc b2bHelm args) $ \pr -> do
156− print . getStdout $ pr
157− print . getStderr $ pr
164+ editApp :: [String] -> String -> IO ExitCode
165+ editApp args b2bHelm = liftIO . withProcessWait (proc b2bHelm args) $ waitProcess
158166
159167 appArgs Deployment { name = n, tag = t, envs = e } = editAppArgs (unpack n) (unpack t) (fmap unpack e)
160168
@@ -163,66 +171,69 @@ destroy n = do
163171 State{pool = p, logger = l, helm = h} <- ask
164172 let ia = infraArgs n
165173 aa = appArgs n
166− liftIO . logInfo l $ "call " <> unwords (pack <$> h : aa)
167− destroyApp aa h
168− liftIO . logInfo l $ "call " <> unwords (pack <$> h : ia)
169− destroyInfra ia h
170− deleteDeployment p
171− liftIO . logInfo l $ "deployment destroyed, name: " <> n
174+ liftIO $ do
175+ logInfo l $ "call " <> unwords (pack <$> h : aa)
176+ ec1 <- destroyApp aa h
177+ logInfo l $ "call " <> unwords (pack <$> h : ia)
178+ ec2 <- destroyInfra ia h
179+ deleteDeploymentLogs p
180+ deleteDeployment p
181+ logInfo l $ "deployment destroyed, name: " <> n
182+ handleExitCode $ max ec1 ec2
172183 return ""
173184
174185 where
175− deleteDeployment :: PgPool -> AppM Int64
176− deleteDeployment p = liftIO $
177− withResource p $ \conn ->
178− execute conn "DELETE FROM deployments WHERE name = ?" (Only n)
186+ deleteDeploymentLogs :: PgPool -> IO Int64
187+ deleteDeploymentLogs p = withResource p $ \conn ->
188+ execute conn "DELETE FROM deployment_logs WHERE deployment_id in (SELECT id FROM deployments where name = ?)" (Only n)
189+
190+ deleteDeployment :: PgPool -> IO Int64
191+ deleteDeployment p = withResource p $ \conn ->
192+ execute conn "DELETE FROM deployments WHERE name = ?" (Only n)
179193
180194 infraArgs = destroyInfraArgs . unpack
181195
182196 appArgs = destroyAppArgs . unpack
183197
184− destroyApp :: [String] -> String -> AppM ()
185− destroyApp args helm = liftIO . withProcessWait_ (proc helm args) $ \pr -> do
186− print . getStdout $ pr
187− print . getStderr $ pr
198+ destroyApp :: [String] -> String -> IO ExitCode
199+ destroyApp args helm = withProcessWait (proc helm args) waitProcess
188200
189− destroyInfra :: [String] -> String -> AppM ()
190− destroyInfra args helm = liftIO . withProcessWait_ (proc helm args) $ \pr -> do
191− print . getStdout $ pr
192− print . getStderr $ pr
201+ destroyInfra :: [String] -> String -> IO ExitCode
202+ destroyInfra args helm = withProcessWait (proc helm args) waitProcess
193203
194204update :: Text -> Deployment -> AppM Text
195205update n d@Deployment { tag = t } = do
196206 State{pool = p, logger = l, b2bHelm = b} <- ask
197− e <- getEnvs p
207+ e <- liftIO $ getEnvs p
198208 case e of
199209 e : _ -> do
200− let aa = appArgs $ d { name = n, envs = lines e }
201− updateDeployment p
202− liftIO . logInfo l $ "call " <> unwords (pack <$> b : aa)
203− updateApp aa b
204− liftIO . logInfo l $ "deployment updated, name: " <> n <> ", tag: " <> t
210+ let d' = d { name = n, envs = lines e }
211+ aa = appArgs d'
212+ liftIO $ do
213+ updateDeployment p
214+ logInfo l $ "call " <> unwords (pack <$> b : aa)
215+ ec <- updateApp aa b
216+ logInfo l $ "deployment updated, name: " <> n <> ", tag: " <> t
217+ createDeploymentLog p d' "update" ec
218+ handleExitCode ec
219+ return ()
205220 _ -> liftIO . logWarning l $ "envs not found, name: " <> n
206221 return ""
207222
208223 where
209− getEnvs :: PgPool -> AppM [Text]
210− getEnvs p = fmap (fmap fromOnly) . liftIO $
211− withResource p $ \conn -> query conn "SELECT envs FROM deployments WHERE name = ?" (Only n)
224+ getEnvs :: PgPool -> IO [Text]
225+ getEnvs p = fmap (fmap fromOnly) $ withResource p $ \conn ->
226+ query conn "SELECT envs FROM deployments WHERE name = ?" (Only n)
212227
213− updateDeployment :: PgPool -> AppM Int64
214− updateDeployment p = liftIO $
215− withResource p $ \conn ->
216− execute conn "UPDATE deployments SET tag = ?, updated_at = now() WHERE name = ?" (t, n)
228+ updateDeployment :: PgPool -> IO Int64
229+ updateDeployment p = withResource p $ \conn ->
230+ execute conn "UPDATE deployments SET tag = ?, updated_at = now() WHERE name = ?" (t, n)
217231
218− updateApp :: [String] -> String -> AppM ()
219− updateApp args b2bHelm = liftIO . withProcessWait_ (proc b2bHelm args) $ \pr -> do
220− print . getStdout $ pr
221− print . getStderr $ pr
232+ updateApp :: [String] -> String -> IO ExitCode
233+ updateApp args b2bHelm = withProcessWait (proc b2bHelm args) waitProcess
222234
223235 appArgs Deployment { name = n, tag = t, envs = e } = updateAppArgs (unpack n) (unpack t) (fmap unpack e)
224236
225−
226237ping :: AppM Text
227238ping = do
228239 State{pool = p} <- ask
@@ -234,6 +245,29 @@ ping = do
234245 getSomething p = fmap (fmap fromOnly) . liftIO $
235246 withResource p $ \conn -> query_ conn "SELECT id FROM deployments WHERE id = 0"
236247
248+waitProcess :: (Show stdout, Show stderr) => Process stdin stdout stderr -> IO ExitCode
249+waitProcess p = do
250+ print . getStdout $ p
251+ print . getStderr $ p
252+ waitExitCode p
253+
254+handleExitCode :: ExitCode -> IO ()
255+handleExitCode ExitSuccess = return ()
256+handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c
257+
258+createDeploymentLog :: PgPool -> Deployment -> Text -> ExitCode -> IO Int64
259+createDeploymentLog pool Deployment {name = n, tag = t, envs = e} action exitCode
260+ = withResource pool $ \conn -> execute conn q (action, t, unlines e, exitCode', n)
261+
262+ where q = "INSERT INTO deployment_logs (deployment_id, action, tag, envs, exit_code) (\
263+ \SELECT id, ?, ?, ?, ? \
264+ \FROM deployments \
265+ \WHERE name = ? \
266+ \)"
267+ exitCode' = case exitCode of
268+ ExitSuccess -> 0
269+ ExitFailure e -> e
270+
237271logInfo :: TimedFastLogger -> Text -> IO ()
238272logInfo logger = logWithSeverity logger "INFO"
239273