@@ -3,7 +3,7 @@ module DMS (runDMS) where
33
44import Control.Applicative
55import Control.Concurrent.Async (race_)
6−import Control.Exception (throwIO, Exception)
6+import Control.Exception (throwIO, try, Exception)
77import Control.Monad
88import Control.Monad.IO.Class
99import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
@@ -72,7 +72,7 @@ runDMS = do
7272 projName <- coerce . pack <$> getEnvOrDie "PROJECT_NAME"
7373 domain <- coerce . pack <$> getEnvOrDie "BASE_DOMAIN"
7474 ns <- coerce . pack <$> getEnvOrDie "NAMESPACE"
75− archRetention <- ArchiveRetention . read <$> getEnvOrDie "ARCHIVE_RETENTION"
75+ archRetention <- coerce . read @Int <$> getEnvOrDie "ARCHIVE_RETENTION"
7676 creationCmd <- coerce . pack <$> getEnvOrDie "CREATION_COMMAND"
7777 updateCmd <- coerce . pack <$> getEnvOrDie "UPDATE_COMMAND"
7878 deletionCmd <- coerce . pack <$> getEnvOrDie "DELETION_COMMAND"
@@ -155,7 +155,10 @@ createH dep = do
155155 "INSERT INTO deployments (name, tag, envs) VALUES (?, ?, ?)"
156156 -- FIXME: make EnvPairs a newtype and give it ToField instance
157157 (n, t, formatEnvPairs e)
158− void $ liftIO $ createDep pgPool dep
158+ res :: Either SqlError Int64 <- liftIO . try $ createDep pgPool dep
159+ case res of
160+ Right _ -> pure ()
161+ Left _ -> throwError err400 { errBody = "deployment already exists" }
159162 ec <- createDeployment dep st
160163 void $ liftIO $ do
161164 createDeploymentLog pgPool dep "create" ec $ ArchivedFlag False
@@ -185,8 +188,8 @@ createDeployment dep st = do
185188getH :: DeploymentName -> AppM Deployment
186189getH dName = do
187190 st <- ask
191+ dep <- selectDeployment (pool st) dName AllDeployments
188192 liftIO $ do
189− dep <- selectDeployment (pool st) dName AllDeployments
190193 logInfo (logger st) $ "get deployment: " <> (pack . show $ dep)
191194 return dep
192195
@@ -212,28 +215,25 @@ selectDeployment
212215 :: PgPool
213216 -> DeploymentName
214217 -> DeploymentListType
215− -> IO Deployment
216−selectDeployment p n t = selectDeployments p n t >>= \case
217− [d] -> pure d
218− [] -> error "deployment not found"
219− _ -> error "more than one deployment found in the database"
220−
221−selectDeployments
222− :: PgPool
223− -> DeploymentName
224− -> DeploymentListType
225− -> IO [Deployment]
226−selectDeployments p dName lType = do
218+ -> AppM Deployment
219+selectDeployment p dName lType = do
227220 let
228221 q AllDeployments =
229− "SELECT name, tag, envs FROM deployments WHERE name = ?"
222+ "SELECT name, tag, envs FROM deployments \
223+ \WHERE name = ?"
230224 q ArchivedOnlyDeployments =
231225 "SELECT name, tag, envs FROM deployments \
232226 \WHERE name = ? AND archived = 't'"
233227
234− retrieved <- withResource p $ \conn ->
235− query conn (q lType) (Only dName)
236− for retrieved $ \(n, t, e) -> Deployment n t <$> parseEnvs (lines e)
228+ deps <- liftIO $ do
229+ retrieved <- withResource p $ \conn ->
230+ query conn (q lType) (Only dName)
231+ for retrieved $ \(n, t, e) -> Deployment n t <$> parseEnvs (lines e)
232+ case deps of
233+ [dep] -> pure dep
234+ [] -> throwError err404 { errBody = "deployment not found" }
235+ _ -> throwError err406
236+ { errBody = "more than one deployment found in the database" }
237237
238238editH :: DeploymentName -> EnvPairs -> AppM NoContent
239239editH dName dEnvs = do
@@ -290,8 +290,8 @@ deleteH dName = do
290290 , "--name", coerce dName
291291 ]
292292 cmd = coerce $ deletionCommand st
293+ dep <- selectDeployment pgPool dName AllDeployments
293294 liftIO $ do
294− dep <- selectDeployment pgPool dName AllDeployments
295295 log $ "call " <> unwords (cmd : args)
296296 ec <- withProcessWait (proc (unpack cmd) (unpack <$> args)) waitProcess
297297 void $ archiveDeployment pgPool dName
@@ -366,8 +366,8 @@ infoH :: DeploymentName -> AppM [DeploymentInfo]
366366infoH dName = do
367367 st <- ask
368368 let pgPool = pool st
369+ dep <- selectDeployment pgPool dName AllDeployments
369370 liftIO $ do
370− dep <- selectDeployment pgPool dName AllDeployments
371371 depLogs <- selectDeploymentLogs pgPool dName
372372 let depInfo = DeploymentInfo dep $ reverse depLogs
373373 logInfo (logger st) $ "get deployment info: " <> (pack . show $ depInfo)
@@ -382,6 +382,9 @@ pingH = do
382382
383383statusH :: DeploymentName -> AppM DeploymentStatus
384384statusH dName = do
385+ st <- ask
386+ let pgPool = pool st
387+ void $ selectDeployment pgPool dName AllDeployments
385388 cmd <- checkingCommand <$> ask
386389 let args = [unpack . coerce $ dName]
387390 ec <- liftIO $ withProcessWait (proc (unpack $ coerce cmd) args) waitProcess
@@ -444,7 +447,7 @@ restoreH :: DeploymentName -> AppM NoContent
444447restoreH dName = do
445448 st <- ask
446449 let pgPool = pool st
447− dep <- liftIO $ selectDeployment pgPool dName ArchivedOnlyDeployments
450+ dep <- selectDeployment pgPool dName ArchivedOnlyDeployments
448451 ec <- createDeployment dep st
449452 void $ liftIO $ do
450453 let