Permalink
Browse files

Kill processes when Keter shuts down (#3)

  • Loading branch information...
1 parent 93676ee commit c1e49dc1cfa6ac8a5476ec40f1f65d546d4d05e9 @snoyberg committed Nov 19, 2012
Showing with 149 additions and 5 deletions.
  1. +4 −1 Keter/App.hs
  2. +3 −0 Keter/Main.hs
  3. +8 −3 Keter/Process.hs
  4. +36 −0 Keter/ProcessTracker.hs
  5. +95 −0 cbits/process-tracker.c
  6. +3 −1 keter.cabal
View
5 Keter/App.hs
@@ -15,6 +15,7 @@ import Keter.Prelude
import Keter.TempFolder
import Keter.Postgres
import Keter.Process
+import Keter.ProcessTracker (ProcessTracker)
import Keter.Logger (Logger, detach)
import Keter.PortManager hiding (start)
import qualified Codec.Archive.Tar as Tar
@@ -166,14 +167,15 @@ unpackTar muid dir =
start :: TempFolder
-> Maybe (Text, (UserID, GroupID))
+ -> ProcessTracker
-> PortManager
-> Postgres
-> Logger
-> Appname
-> F.FilePath -- ^ app bundle
-> KIO () -- ^ action to perform to remove this App from list of actives
-> KIO (App, KIO ())
-start tf muid portman postgres logger appname bundle removeFromList = do
+start tf muid processTracker portman postgres logger appname bundle removeFromList = do
chan <- newChan
return (App $ writeChan chan, rest chan)
where
@@ -202,6 +204,7 @@ start tf muid portman postgres logger appname bundle removeFromList = do
: ("APPROOT", (if configSsl config then "https://" else "http://") ++ configHost config)
: otherEnv
run
+ processTracker
(fst <$> muid)
("config" </> configExec config)
dir
View
3 Keter/Main.hs
@@ -10,6 +10,7 @@ module Keter.Main
import Keter.Prelude hiding (getCurrentTime)
import qualified Keter.TempFolder as TempFolder
import qualified Keter.App as App
+import qualified Keter.ProcessTracker as ProcessTracker
import qualified Keter.Postgres as Postgres
import qualified Keter.LogFile as LogFile
import qualified Keter.Logger as Logger
@@ -86,6 +87,7 @@ keter input' = do
Left (_ :: SomeException) -> P.error $ T.unpack $ "Invalid user ID: " ++ t
Right ue -> return $ Just (T.pack $ userName ue, (userID ue, userGroupID ue))
+ processTracker <- ProcessTracker.initProcessTracker
portman <- runThrow $ PortMan.start configPortMan
tf <- runThrow $ TempFolder.setup $ dir </> "temp"
postgres <- runThrow $ Postgres.load def $ dir </> "etc" </> "postgres.yaml"
@@ -143,6 +145,7 @@ keter input' = do
(app, rest) <- App.start
tf
muid
+ processTracker
portman
postgres
logger
View
11 Keter/Process.hs
@@ -8,6 +8,7 @@ module Keter.Process
) where
import Keter.Prelude
+import Keter.ProcessTracker
import Keter.Logger (Logger, attach, LogPipes (..), mkLogPipe)
import Data.Time (diffUTCTime)
import Data.Conduit.Process.Unix (forkExecuteFile, waitForProcess, killProcess, terminateProcess)
@@ -21,14 +22,15 @@ import Control.Exception (onException)
data Status = NeedsRestart | NoRestart | Running ProcessHandle
-- | Run the given command, restarting if the process dies.
-run :: Maybe Text -- ^ setuid
+run :: ProcessTracker
+ -> Maybe Text -- ^ setuid
-> FilePath -- ^ executable
-> FilePath -- ^ working directory
-> [String] -- ^ command line parameter
-> [(String, String)] -- ^ environment
-> Logger
-> KIO Process
-run msetuid exec dir args env logger = do
+run processTracker msetuid exec dir args env logger = do
mstatus <- newMVar NeedsRestart
let loop mlast = do
next <- modifyMVar mstatus $ \status ->
@@ -67,7 +69,10 @@ run msetuid exec dir args env logger = do
attach logger $ LogPipes pout perr
log $ ProcessCreated exec
return (Running pid, do
- _ <- liftIO $ waitForProcess pid `onException` killProcess pid
+ _ <- liftIO $ do
+ unregister <- trackProcess processTracker pid
+ _ <- waitForProcess pid `onException` killProcess pid
+ unregister
loop (Just now))
next
forkKIO $ loop Nothing
View
36 Keter/ProcessTracker.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- | Ensures that processes are stopped when Keter shuts down.
+module Keter.ProcessTracker
+ ( ProcessTracker
+ , trackProcess
+ , initProcessTracker
+ ) where
+
+import System.Process.Internals
+import Foreign.C (CInt (..))
+import System.Posix.Types (CPid (..))
+import Control.Concurrent.MVar (readMVar)
+
+foreign import ccall unsafe "launch_process_tracker"
+ c_launch_process_tracker :: IO CInt
+
+foreign import ccall unsafe "track_process"
+ c_track_process :: ProcessTracker -> CPid -> CInt -> IO ()
+
+newtype ProcessTracker = ProcessTracker CInt
+
+initProcessTracker :: IO ProcessTracker
+initProcessTracker = do
+ i <- c_launch_process_tracker
+ if i == -1
+ then error "Unable to launch process tracker"
+ else return $ ProcessTracker i
+
+trackProcess :: ProcessTracker -> ProcessHandle -> IO (IO ())
+trackProcess pt (ProcessHandle mph) = do
+ mpid <- readMVar mph
+ case mpid of
+ ClosedHandle{} -> return $ return ()
+ OpenHandle pid -> do
+ c_track_process pt pid 1
+ return $ c_track_process pt pid 0
View
95 cbits/process-tracker.c
@@ -0,0 +1,95 @@
+#include <unistd.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <signal.h>
+
+struct node {
+ pid_t pid;
+ struct node *next;
+};
+
+static struct node * add_node(pid_t pid, struct node *n) {
+ struct node *n2 = malloc(sizeof(struct node));
+ n2->pid = pid;
+ n2->next = n;
+ return n2;
+}
+
+static struct node * remove_node(pid_t pid, struct node *n) {
+ if (!n) {
+ return n;
+ }
+ else if (n->pid == pid) {
+ struct node *n2 = n->next;
+ free(n);
+ return remove_node(pid, n2);
+ }
+ else {
+ n->next = remove_node(pid, n->next);
+ return n;
+ }
+}
+
+extern void track_process(int fd, pid_t pid, int b) {
+ unsigned int buffer[2];
+
+ //printf("Tracking process %d, %d\n", pid, b);
+
+ buffer[0] = pid;
+ buffer[1] = b;
+ if (! write(fd, buffer, sizeof(unsigned int) * 2)) {
+ //printf("Error writing to fd %d\n", fd);
+ }
+}
+
+// Returns FD to write to, or -1 on failure.
+extern int launch_process_tracker(void) {
+ int pipes[2];
+ pid_t child;
+
+ if (pipe(pipes)) {
+ return -1;
+ }
+
+ child = fork();
+
+ if (child < 0) {
+ return -1;
+ }
+ else if (child == 0) {
+ unsigned int buffer[2];
+ struct node *n = 0, *n2;
+ close(pipes[1]);
+
+ while (read(pipes[0], buffer, sizeof(unsigned int) * 2) > 0) {
+ if (buffer[1]) {
+ //printf("Adding node %d\n", buffer[0]);
+ n = add_node(buffer[0], n);
+ }
+ else {
+ //printf("Removing node %d\n", buffer[0]);
+ n = remove_node(buffer[0], n);
+ }
+ }
+
+ for (n2 = n; n2; n2 = n2->next) {
+ //printf("Sending process %d TERM signal\n", n2->pid);
+ kill(n2->pid, SIGTERM);
+ }
+
+ sleep(2);
+
+ while (n) {
+ //printf("Sending process %d KILL signal\n", n->pid);
+ kill(n2->pid, SIGKILL);
+
+ n2 = n;
+ n = n->next;
+ free(n2);
+ }
+ }
+ else {
+ close(pipes[0]);
+ return pipes[1];
+ }
+}
View
4 keter.cabal
@@ -1,5 +1,5 @@
Name: keter
-Version: 0.3.3
+Version: 0.3.4
Synopsis: Web application deployment manager, focusing on Haskell web frameworks
Description: Handles deployment of web apps, providing a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: <https://github.com/snoyberg/keter#readme>
Homepage: http://www.yesodweb.com/
@@ -43,6 +43,7 @@ Library
, wai >= 1.3 && < 1.4
, http-types
Exposed-Modules: Keter.Process
+ Keter.ProcessTracker
Keter.Postgres
Keter.TempFolder
Keter.App
@@ -53,6 +54,7 @@ Library
Keter.Proxy
Keter.PortManager
Keter.SSL
+ c-sources: cbits/process-tracker.c
ghc-options: -Wall
Executable keter

0 comments on commit c1e49dc

Please sign in to comment.