@@ -1,14 +1,12 @@
11module DMS (runDMS) where
22
3−import Prelude hiding (lines, unlines, unwords, log)
43
5−import Control.Exception (bracket, throwIO, Exception)
6−import Control.Monad (unless, void)
4+import Control.Exception (throwIO, Exception)
5+import Control.Monad
76import Control.Monad.IO.Class
87import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
98import Data.ByteString (ByteString)
109import Data.Coerce
11−import Data.IORef
1210import Data.Int (Int64)
1311import Data.Monoid ((<>))
1412import Data.Pool
@@ -17,8 +15,11 @@ import Data.Traversable
1715import Database.PostgreSQL.Simple
1816import Network.Wai.Handler.Warp
1917import Options.Generic
18+import Prelude hiding (lines, unlines, unwords, log)
2019import Servant
2120import System.Exit
21+import System.FilePath.Posix
22+import System.IO.Temp
2223import System.Log.FastLogger
2324import System.Process.Typed
2425
@@ -39,12 +40,11 @@ type PgPool = Pool Connection
3940type AppM = ReaderT AppState Handler
4041
4142data AppState = AppState
42− { pool :: PgPool
43− , logger :: TimedFastLogger
44− , helm :: FilePath
45− , b2bHelm :: FilePath
46− , git :: FilePath
47− , gitUpgradeSemaphore :: IORef Int
43+ { pool :: PgPool
44+ , logger :: TimedFastLogger
45+ , helm :: FilePath
46+ , b2bHelm :: FilePath
47+ , git :: FilePath
4848 }
4949
5050data DeploymentException
@@ -63,11 +63,10 @@ runDMS = do
6363 helmBin <- helmPath
6464 b2bHelmBin <- b2bHelmPath
6565 gitBin <- gitPath
66− semaphore <- newIORef 0
6766 case (helmBin, b2bHelmBin, gitBin) of
6867 (Just h, Just b, Just g) -> do
6968 pgPool <- initConnectionPool (db args) (dbPoolSize args)
70− run (port args) (app $ AppState pgPool logger' h b g semaphore)
69+ run (port args) (app $ AppState pgPool logger' h b g)
7170 (Nothing, _, _) -> die "helm not found"
7271 (_, Nothing, _) -> die "b2b-helm not found"
7372 (_, _, Nothing) -> die "git not found"
@@ -106,24 +105,10 @@ createH dep = do
106105 log :: Text -> IO ()
107106 log = logInfo (logger st)
108107 b2bHelmBin = b2bHelm st
108+ gitBin = git st
109109 pgPool = pool st
110110 infraCmdArgs = createInfraArgs $ name dep
111111 appCmdArgs = appArgs dep
112− liftIO $ withSemaphore (gitUpgradeSemaphore st) $ do
113− log "upgrading git repo"
114− void $ upgradeRepo $ git st
115− void $ createDeployment pgPool dep
116− log $ "call " <> unwords (pack b2bHelmBin : infraCmdArgs)
117− ec1 <- createInfra infraCmdArgs b2bHelmBin
118− log $ "call " <> mconcat (pack b2bHelmBin : appCmdArgs)
119− ec2 <- createApp appCmdArgs b2bHelmBin
120− log $ "deployment created, deployment: " <> (pack . show $ dep)
121− let ec = max ec1 ec2
122− createDeploymentLog pgPool dep "create" ec
123− handleExitCode ec
124− pure NoContent
125−
126− where
127112 createDeployment :: PgPool -> Deployment -> IO Int64
128113 createDeployment p Deployment { name = n, tag = t, envs = e } =
129114 withResource p $ \conn -> execute
@@ -131,17 +116,44 @@ createH dep = do
131116 "INSERT INTO deployments (name, tag, envs) VALUES (?, ?, ?)"
132117 -- FIXME: make EnvPairs a newtype and give it ToField instance
133118 (n, t, formatEnvPairs e)
119+ liftIO $ withTempDirectory "/tmp" "dms" $ \tempDir -> do
120+ log $ "clone git repo to " <> pack tempDir
121+ void $ cloneRepo gitBin tempDir >> copyB2BHelm b2bHelmBin tempDir
122+ let b2bHelmSandboxedBin = tempDir </> takeFileName b2bHelmBin
123+ void $ createDeployment pgPool dep
124+ log $ "call " <> unwords (pack b2bHelmSandboxedBin : infraCmdArgs)
125+ ec1 <- createInfra infraCmdArgs b2bHelmSandboxedBin tempDir
126+ log $ "call " <> mconcat (pack b2bHelmSandboxedBin : appCmdArgs)
127+ ec2 <- createApp appCmdArgs b2bHelmSandboxedBin tempDir
128+ log $ "deployment created, deployment: " <> (pack . show $ dep)
129+ let ec = max ec1 ec2
130+ createDeploymentLog pgPool dep "create" ec
131+ handleExitCode ec
132+ pure NoContent
133+
134+copyB2BHelm :: FilePath -> FilePath -> IO ExitCode
135+copyB2BHelm b2bHelmBin repoPath =
136+ withProcessWait (proc "cp" [b2bHelmBin, repoPath]) waitProcess
134137
135138appArgs :: Deployment -> [CommandArg]
136139appArgs (Deployment n t e) = composeAppArgs n t e
137140
138−createInfra :: [CommandArg] -> FilePath -> IO ExitCode
139−createInfra args b2bHelmBin =
140− withProcessWait (withRepoPath $ proc b2bHelmBin $ unpack <$> args) waitProcess
141−
142−createApp :: [CommandArg] -> FilePath -> IO ExitCode
143−createApp args b2bHelmBin =
144− withProcessWait (withRepoPath $ proc b2bHelmBin $ unpack <$> args) waitProcess
141+createInfra
142+ :: [CommandArg]
143+ -> FilePath -- ^ b2b helm path
144+ -> FilePath -- ^ Repo path
145+ -> IO ExitCode
146+createInfra args b2bHelmBin repoPath =
147+ withProcessWait (setWorkingDir repoPath $ proc b2bHelmBin $ unpack <$> args) waitProcess
148+
149+createApp
150+ :: [CommandArg]
151+ -> FilePath -- ^ b2b helm path
152+ -> FilePath -- ^ repo path
153+ -> IO ExitCode
154+createApp args b2bHelmBin repoPath = withProcessWait
155+ (setWorkingDir repoPath $ proc b2bHelmBin $ unpack <$> args)
156+ waitProcess
145157
146158getH :: DeploymentName -> AppM Deployment
147159getH dName = do
@@ -189,15 +201,17 @@ editH n e = do
189201 log = logInfo (logger st)
190202 b2bHelmBin = b2bHelm st
191203 pgPool = pool st
204+ gitBin = git st
192205 liftIO $ getTag pgPool >>= \case
193206 t : _ -> do
194− liftIO $ withSemaphore (gitUpgradeSemaphore st) $ do
195− log "upgrading git repo..."
196− void $ upgradeRepo $ git st
207+ liftIO $ withTempDirectory "/tmp" "dms" $ \tempDir -> do
208+ log $ "clone git repo to " <> pack tempDir
209+ void $ cloneRepo gitBin tempDir >> copyB2BHelm b2bHelmBin tempDir
210+ let b2bHelmSandboxedBin = tempDir </> takeFileName b2bHelmBin
197211 void $ updateEditDeployment pgPool
198212 let dep = Deployment n t e
199− log $ "call " <> unwords (pack b2bHelmBin : appArgs dep)
200− ec <- editApp (appArgs dep) (b2bHelm st)
213+ log $ "call " <> unwords (pack b2bHelmSandboxedBin : appArgs dep)
214+ ec <- editApp (appArgs dep) b2bHelmSandboxedBin tempDir
201215 log
202216 $ "deployment edited, name: " <> coerce n
203217 <> ", envs: " <> formatEnvPairs e
@@ -217,9 +231,13 @@ editH n e = do
217231 -- FIXME: make EnvPairs a newtype and give it ToField instance
218232 (formatEnvPairs e, n)
219233
220−editApp :: [CommandArg] -> FilePath -> IO ExitCode
221−editApp args b2bHelmBin = liftIO . withProcessWait
222− (withRepoPath $ proc b2bHelmBin $ unpack <$> args) $ waitProcess
234+editApp
235+ :: [CommandArg]
236+ -> FilePath -- ^ b2b helm path
237+ -> FilePath -- ^ repo path
238+ -> IO ExitCode
239+editApp args b2bHelmBin repoPath = liftIO . withProcessWait
240+ (setWorkingDir repoPath $ proc b2bHelmBin $ unpack <$> args) $ waitProcess
223241
224242destroyH :: DeploymentName -> AppM NoContent
225243destroyH dName = do
@@ -243,11 +261,11 @@ destroyH dName = do
243261
244262destroyApp :: [CommandArg] -> FilePath -> IO ExitCode
245263destroyApp args helmBin =
246− withProcessWait (withRepoPath $ proc helmBin $ unpack <$> args) waitProcess
264+ withProcessWait (proc helmBin $ unpack <$> args) waitProcess
247265
248266destroyInfra :: [CommandArg] -> FilePath -> IO ExitCode
249267destroyInfra args helmBin =
250− withProcessWait (withRepoPath $ proc helmBin $ unpack <$> args) waitProcess
268+ withProcessWait (proc helmBin $ unpack <$> args) waitProcess
251269
252270deleteDeploymentLogs :: PgPool -> DeploymentName -> IO Int64
253271deleteDeploymentLogs p n = withResource p $ \conn -> execute
@@ -260,6 +278,11 @@ deleteDeployment :: PgPool -> DeploymentName -> IO Int64
260278deleteDeployment p n = withResource p $ \conn ->
261279 execute conn "DELETE FROM deployments WHERE name = ?" (Only n)
262280
281+updateApp :: [CommandArg] -> FilePath -> FilePath -> IO ExitCode
282+updateApp cmdArgs b2bHelmBin repoPath = withProcessWait
283+ (setWorkingDir repoPath $ proc b2bHelmBin $ unpack <$> cmdArgs)
284+ waitProcess
285+
263286updateH :: DeploymentName -> DeploymentTag -> AppM NoContent
264287updateH dName dTag = do
265288 st <- ask
@@ -272,18 +295,16 @@ updateH dName dTag = do
272295 let
273296 b2bHelmBin = b2bHelm st
274297 log = logInfo (logger st)
275− args = composeAppArgs dName dTag envPairs
276− liftIO $ withSemaphore (gitUpgradeSemaphore st) $ do
277− log "upgrading git repo..."
278− void $ upgradeRepo (git st)
298+ args = composeAppArgs dName dTag envPairs
299+ gitBin = git st
300+ liftIO $ withTempDirectory "/tmp" "dms" $ \tempDir -> do
301+ log $ "clone git repo to " <> pack tempDir
302+ void $ cloneRepo gitBin tempDir >> copyB2BHelm b2bHelmBin tempDir
303+ let b2bHelmSandboxedBin = tempDir </> takeFileName b2bHelmBin
279304 void $ updateDeploymentNameAndTag pgPool dName dTag
280− log $ "call " <> unwords (pack b2bHelmBin : args)
305+ log $ "call " <> unwords (pack b2bHelmSandboxedBin : args)
281306 let
282− updateApp :: [CommandArg] -> IO ExitCode
283− updateApp args' = withProcessWait
284− (withRepoPath $ proc b2bHelmBin $ unpack <$> args')
285− waitProcess
286− ec <- updateApp args
307+ ec <- updateApp args b2bHelmSandboxedBin tempDir
287308 log $ "deployment updated, name: "
288309 <> coerce dName <> ", tag: " <> coerce dTag
289310 createDeploymentLog pgPool (Deployment dName dTag envPairs) "update" ec
@@ -338,19 +359,6 @@ handleExitCode :: ExitCode -> IO ()
338359handleExitCode ExitSuccess = return ()
339360handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c
340361
341−withSemaphore :: IORef Int -> IO () -> IO ()
342−withSemaphore semaphore act = bracket
343− (tryToAcquireSemaphore semaphore >>= \r ->
344− unless r $ throwIO ThereIsAcriveDeployment)
345− (\_ -> releaseSemaphore semaphore)
346− (const act)
347−
348−tryToAcquireSemaphore :: IORef Int -> IO Bool
349−tryToAcquireSemaphore s = atomicModifyIORef' s (\a -> (if a == 0 then 1 else a, a == 0))
350−
351−releaseSemaphore :: IORef Int -> IO ()
352−releaseSemaphore s = modifyIORef' s pred
353−
354362createDeploymentLog :: PgPool -> Deployment -> Action -> ExitCode -> IO ()
355363createDeploymentLog pgPool (Deployment n t e) a ec = do
356364 let