keter 0.3.3 → 0.3.4
raw patch · 7 files changed
+164/−10 lines, 7 files
Files
- Keter/App.hs +4/−1
- Keter/Main.hs +3/−0
- Keter/Process.hs +8/−3
- Keter/ProcessTracker.hs +36/−0
- Keter/Proxy.hs +10/−5
- cbits/process-tracker.c +100/−0
- keter.cabal +3/−1
Keter/App.hs view
@@ -15,6 +15,7 @@ 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,6 +167,7 @@ start :: TempFolder -> Maybe (Text, (UserID, GroupID))+ -> ProcessTracker -> PortManager -> Postgres -> Logger@@ -173,7 +175,7 @@ -> 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 @@ : ("APPROOT", (if configSsl config then "https://" else "http://") ++ configHost config) : otherEnv run+ processTracker (fst <$> muid) ("config" </> configExec config) dir
Keter/Main.hs view
@@ -10,6 +10,7 @@ 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 @@ 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 @@ (app, rest) <- App.start tf muid+ processTracker portman postgres logger
Keter/Process.hs view
@@ -8,6 +8,7 @@ ) 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 @@ 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 @@ 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
+ Keter/ProcessTracker.hs view
@@ -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
Keter/Proxy.hs view
@@ -10,6 +10,7 @@ ) where import Prelude hiding ((++), FilePath)+import Keter.Prelude ((++)) import Data.Conduit import Data.Conduit.Network import Data.ByteString (ByteString)@@ -37,12 +38,14 @@ rawProxyTo getDest where getDest headers = do- mport <- maybe (return Nothing) portLookup $ lookup "host" headers+ mport <- maybe (return Nothing) portLookup mhost case mport of- Nothing -> return $ Left $ srcToApp $ toResponse []+ Nothing -> return $ Left $ srcToApp $ toResponse mhost Just (PEPort port) -> return $ Right $ ProxyDest "127.0.0.1" port Just (PEStatic root) -> return $ Left $ waiToRaw $ staticApp $ defaultFileServerSettings root Just (PERedirect host) -> return $ Left $ waiToRaw $ redirectApp host+ where+ mhost = lookup "host" headers redirectApp :: ByteString -> Wai.Application redirectApp host req = return $ Wai.responseLBS@@ -60,6 +63,8 @@ srcToApp :: Monad m => Source m ByteString -> Application m srcToApp src appdata = src $$ appSink appdata -toResponse :: Monad m => [ByteString] -> Source m ByteString-toResponse hosts =- yield "HTTP/1.1 200 OK\r\nContent-Type: text/html; charset=utf-8\r\n\r\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided is not recognized.</p></body></html>"+toResponse :: Monad m => Maybe ByteString -> Source m ByteString+toResponse Nothing =+ yield "HTTP/1.1 200 OK\r\nContent-Type: text/html; charset=utf-8\r\n\r\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You did not provide a virtual hostname for this request.</p></body></html>"+toResponse (Just host) =+ yield $ "HTTP/1.1 200 OK\r\nContent-Type: text/html; charset=utf-8\r\n\r\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>" ++ host ++ "</code>, is not recognized.</p></body></html>"
+ cbits/process-tracker.c view
@@ -0,0 +1,100 @@+#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]);++ // Prevent monitoring programs like Upstart from killing this+ // new process along with the parent+ setpgid(0, 0);++ 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];+ }+}
keter.cabal view
@@ -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 @@ , wai >= 1.3 && < 1.4 , http-types Exposed-Modules: Keter.Process+ Keter.ProcessTracker Keter.Postgres Keter.TempFolder Keter.App@@ -53,6 +54,7 @@ Keter.Proxy Keter.PortManager Keter.SSL+ c-sources: cbits/process-tracker.c ghc-options: -Wall Executable keter