@@ -9,11 +9,13 @@ module DMS.Lib
99
1010import Prelude hiding (lines, unlines, unwords)
1111
12−import Control.Exception (throwIO, Exception)
12+import Control.Exception (bracket, throwIO, Exception)
13+import Control.Monad (unless)
1314import Control.Monad.IO.Class
1415import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
1516import Data.ByteString (ByteString)
1617import Data.Int (Int64)
18+import Data.IORef
1719import Data.Monoid ((<>))
1820import Data.Text (lines, pack, unlines, unpack, unwords)
1921import Data.Pool
@@ -27,6 +29,7 @@ import System.Process.Typed
2729
2830import API.Lib
2931import DMS.Helm
32+import DMS.Git
3033
3134data Args
3235 = Args { port :: Int, db :: ByteString, dbPoolSize :: Int }
@@ -39,9 +42,15 @@ type PgPool = Pool Connection
3942type AppM = ReaderT State Handler
4043
4144data State
42− = State { pool :: PgPool, logger :: TimedFastLogger, helm :: FilePath, b2bHelm :: FilePath }
43−
44−newtype DeploymentException = DeploymentFailed Int
45+ = State { pool :: PgPool
46+ , logger :: TimedFastLogger
47+ , helm :: FilePath
48+ , b2bHelm :: FilePath
49+ , git :: FilePath
50+ , gitUpgradeSemaphore :: IORef Int
51+ }
52+
53+data DeploymentException = DeploymentFailed Int | ThereIsAcriveDeployment
4554 deriving (Show)
4655
4756instance Exception DeploymentException
@@ -54,12 +63,15 @@ runDMS = do
5463 args <- getRecord "DMS"
5564 helm <- helmPath
5665 b2bHelm <- b2bHelmPath
57− case (helm, b2bHelm) of
58− (Just h, Just b) -> do
66+ git <- gitPath
67+ semaphore <- newIORef 0
68+ case (helm, b2bHelm, git) of
69+ (Just h, Just b, Just g) -> do
5970 pool <- initConnectionPool (db args) (dbPoolSize args)
60− run (port args) (app $ State pool logger h b)
61− (Nothing, _) -> die "helm not found"
62− (_, _) -> die "b2b-helm not found"
71+ run (port args) (app $ State pool logger h b g semaphore)
72+ (Nothing, _, _) -> die "helm not found"
73+ (_, Nothing, _) -> die "b2b-helm not found"
74+ (_, _, Nothing) -> die "git not found"
6375
6476initConnectionPool :: ByteString -> Int -> IO PgPool
6577initConnectionPool db = createPool (connectPostgreSQL db) close 1 30
@@ -90,10 +102,12 @@ list = do
90102
91103create :: Deployment -> AppM Text
92104create d = do
93− State{pool = p, logger = l, b2bHelm = b} <- ask
105+ State { pool = p, logger = l, b2bHelm = b, git = g, gitUpgradeSemaphore = s } <- ask
94106 let ia = infraArgs d
95107 aa = appArgs d
96− liftIO $ do
108+ liftIO $ withSemaphore s $ do
109+ logInfo l "upgrading git repo..."
110+ upgradeRepo g
97111 createDeployment p d
98112 logInfo l $ "call " <> unwords (pack <$> b : ia)
99113 ec1 <- createInfra ia b
@@ -115,10 +129,10 @@ create d = do
115129 appArgs Deployment { name = n, tag = t, envs = e } = createAppArgs (unpack n) (unpack t) (fmap unpack e)
116130
117131 createInfra :: [String] -> String -> IO ExitCode
118− createInfra args b2bHelm = withProcessWait (proc b2bHelm args) waitProcess
132+ createInfra args b2bHelm = withProcessWait (withRepoPath $ proc b2bHelm args) waitProcess
119133
120134 createApp :: [String] -> String -> IO ExitCode
121− createApp args b2bHelm = withProcessWait (proc b2bHelm args) waitProcess
135+ createApp args b2bHelm = withProcessWait (withRepoPath $ proc b2bHelm args) waitProcess
122136
123137get :: Text -> AppM [Deployment]
124138get n = do
@@ -135,13 +149,15 @@ get n = do
135149
136150edit :: Text -> Deployment -> AppM Text
137151edit n d@Deployment { envs = e } = do
138− State{pool = p, logger = l, b2bHelm = b} <- ask
152+ State { pool = p, logger = l, b2bHelm = b, git = g, gitUpgradeSemaphore = s } <- ask
139153 t <- liftIO $ getTag p
140154 case t of
141155 t : _ -> do
142156 let d' = d { name = n, tag = t }
143157 aa = appArgs d'
144− liftIO $ do
158+ liftIO $ withSemaphore s $ do
159+ logInfo l "upgrading git repo..."
160+ upgradeRepo g
145161 editDeployment p
146162 logInfo l $ "call " <> unwords (pack <$> b : aa)
147163 ec <- editApp aa b
@@ -162,13 +178,13 @@ edit n d@Deployment { envs = e } = do
162178 execute conn "UPDATE deployments SET envs = ?, updated_at = now() WHERE name = ?" (unlines e, n)
163179
164180 editApp :: [String] -> String -> IO ExitCode
165− editApp args b2bHelm = liftIO . withProcessWait (proc b2bHelm args) $ waitProcess
181+ editApp args b2bHelm = liftIO . withProcessWait (withRepoPath $ proc b2bHelm args) $ waitProcess
166182
167183 appArgs Deployment { name = n, tag = t, envs = e } = editAppArgs (unpack n) (unpack t) (fmap unpack e)
168184
169185destroy :: Text -> AppM Text
170186destroy n = do
171− State{pool = p, logger = l, helm = h} <- ask
187+ State { pool = p, logger = l, helm = h } <- ask
172188 let ia = infraArgs n
173189 aa = appArgs n
174190 liftIO $ do
@@ -196,20 +212,22 @@ destroy n = do
196212 appArgs = destroyAppArgs . unpack
197213
198214 destroyApp :: [String] -> String -> IO ExitCode
199− destroyApp args helm = withProcessWait (proc helm args) waitProcess
215+ destroyApp args helm = withProcessWait (withRepoPath $ proc helm args) waitProcess
200216
201217 destroyInfra :: [String] -> String -> IO ExitCode
202− destroyInfra args helm = withProcessWait (proc helm args) waitProcess
218+ destroyInfra args helm = withProcessWait (withRepoPath $ proc helm args) waitProcess
203219
204220update :: Text -> Deployment -> AppM Text
205221update n d@Deployment { tag = t } = do
206− State{pool = p, logger = l, b2bHelm = b} <- ask
222+ State { pool = p, logger = l, b2bHelm = b, git = g, gitUpgradeSemaphore = s} <- ask
207223 e <- liftIO $ getEnvs p
208224 case e of
209225 e : _ -> do
210226 let d' = d { name = n, envs = lines e }
211227 aa = appArgs d'
212− liftIO $ do
228+ liftIO $ withSemaphore s $ do
229+ logInfo l "upgrading git repo..."
230+ upgradeRepo g
213231 updateDeployment p
214232 logInfo l $ "call " <> unwords (pack <$> b : aa)
215233 ec <- updateApp aa b
@@ -230,13 +248,13 @@ update n d@Deployment { tag = t } = do
230248 execute conn "UPDATE deployments SET tag = ?, updated_at = now() WHERE name = ?" (t, n)
231249
232250 updateApp :: [String] -> String -> IO ExitCode
233− updateApp args b2bHelm = withProcessWait (proc b2bHelm args) waitProcess
251+ updateApp args b2bHelm = withProcessWait (withRepoPath $ proc b2bHelm args) waitProcess
234252
235253 appArgs Deployment { name = n, tag = t, envs = e } = updateAppArgs (unpack n) (unpack t) (fmap unpack e)
236254
237255info :: Text -> AppM [DeploymentInfo]
238256info n = do
239− State{pool = p, logger = l} <- ask
257+ State { pool = p, logger = l } <- ask
240258 liftIO $ do
241259 d <- getDeployment p
242260 dl <- getDeploymentLogs p
@@ -263,7 +281,7 @@ info n = do
263281
264282ping :: AppM Text
265283ping = do
266− State{pool = p} <- ask
284+ State { pool = p } <- ask
267285 getSomething p
268286 return ""
269287
@@ -282,6 +300,18 @@ handleExitCode :: ExitCode -> IO ()
282300handleExitCode ExitSuccess = return ()
283301handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c
284302
303+withSemaphore :: IORef Int -> IO () -> IO ()
304+withSemaphore semaphore action
305+ = bracket (tryToAcquireSemaphore semaphore >>= \r -> unless r $ throwIO ThereIsAcriveDeployment)
306+ (\_ -> releaseSemaphore semaphore)
307+ (const action)
308+
309+tryToAcquireSemaphore :: IORef Int -> IO Bool
310+tryToAcquireSemaphore s = atomicModifyIORef' s (\a -> (if a == 0 then 1 else a, a == 0))
311+
312+releaseSemaphore :: IORef Int -> IO ()
313+releaseSemaphore s = modifyIORef' s pred
314+
285315createDeploymentLog :: PgPool -> Deployment -> Text -> ExitCode -> IO Int64
286316createDeploymentLog pool Deployment {name = n, tag = t, envs = e} action exitCode
287317 = withResource pool $ \conn -> execute conn q (action, t, unlines e, exitCode', n)