mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-14 08:05:40 +03:00
Removed Keter.Process
This commit is contained in:
Michael Snoyman
parent
f4aefc0634
commit
f99f8cfe5a
70
Keter/App.hs
70
Keter/App.hs
@ -13,7 +13,6 @@ module Keter.App
|
||||
import Prelude (IO, Eq, Ord, fst, snd, concat, mapM)
|
||||
import Keter.Prelude
|
||||
import Codec.Archive.TempTarball
|
||||
import Keter.Process
|
||||
import Keter.Types
|
||||
import Keter.PortManager hiding (start)
|
||||
import qualified Filesystem.Path.CurrentOS as F
|
||||
@ -25,9 +24,10 @@ import Data.Maybe (fromMaybe)
|
||||
import Control.Exception (throwIO)
|
||||
import System.IO (hClose)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import System.Posix.Types (UserID, GroupID)
|
||||
import Data.Conduit.Process.Unix (ProcessTracker, RotatingLog)
|
||||
import Data.Conduit.Process.Unix (ProcessTracker, RotatingLog, terminateMonitoredProcess, monitorProcess)
|
||||
import Data.Yaml.FilePath
|
||||
|
||||
data Command = Reload | Terminate
|
||||
@ -78,13 +78,15 @@ start tf muid processTracker portman plugins rlog appname bundle removeFromList
|
||||
let env = ("PORT", show port)
|
||||
: ("APPROOT", (if aconfigSsl config then "https://" else "http://") ++ aconfigHost config)
|
||||
: otherEnv
|
||||
run
|
||||
log' <- getIOLogger
|
||||
liftIO $ monitorProcess
|
||||
(log' . decodeUtf8With lenientDecode)
|
||||
processTracker
|
||||
(fst <$> muid)
|
||||
(aconfigExec config)
|
||||
dir
|
||||
(aconfigArgs config)
|
||||
env
|
||||
(encodeUtf8 . fst <$> muid)
|
||||
(encodeUtf8 $ either id id $ F.toText $ aconfigExec config)
|
||||
(encodeUtf8 $ either id id $ F.toText dir)
|
||||
(map encodeUtf8 $ aconfigArgs config)
|
||||
(map (encodeUtf8 *** encodeUtf8) env)
|
||||
rlog
|
||||
|
||||
rest chan = forkKIO $ do
|
||||
@ -108,18 +110,23 @@ start tf muid processTracker portman plugins rlog appname bundle removeFromList
|
||||
$logEx e
|
||||
removeFromList
|
||||
Right port -> do
|
||||
process <- runApp port dir appconfig
|
||||
b <- testApp port
|
||||
if b
|
||||
then do
|
||||
addEntry portman (aconfigHost appconfig) $ PEPort port
|
||||
mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig
|
||||
common
|
||||
loop chan dir config $ Just (process, port)
|
||||
else do
|
||||
eprocess <- runApp port dir appconfig
|
||||
case eprocess of
|
||||
Left e -> do
|
||||
$logEx e
|
||||
removeFromList
|
||||
releasePort portman port
|
||||
Keter.Process.terminate process
|
||||
Right process -> do
|
||||
b <- testApp port
|
||||
if b
|
||||
then do
|
||||
addEntry portman (aconfigHost appconfig) $ PEPort port
|
||||
mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig
|
||||
common
|
||||
loop chan dir config $ Just (process, port)
|
||||
else do
|
||||
removeFromList
|
||||
releasePort portman port
|
||||
void $ liftIO $ terminateMonitoredProcess process
|
||||
|
||||
loop chan dirOld configOld mprocPortOld = do
|
||||
command <- readChan chan
|
||||
@ -154,10 +161,17 @@ start tf muid processTracker portman plugins rlog appname bundle removeFromList
|
||||
common
|
||||
loop chan dir config Nothing
|
||||
Just appconfig -> do
|
||||
process <- runApp port dir appconfig
|
||||
b <- testApp port
|
||||
if b
|
||||
then do
|
||||
eprocess <- runApp port dir appconfig
|
||||
mprocess <-
|
||||
case eprocess of
|
||||
Left _ -> return Nothing
|
||||
Right process -> do
|
||||
b <- testApp port
|
||||
return $ if b
|
||||
then Just process
|
||||
else Nothing
|
||||
case mprocess of
|
||||
Just process -> do
|
||||
addEntry portman (aconfigHost appconfig) $ PEPort port
|
||||
mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig
|
||||
common
|
||||
@ -168,9 +182,11 @@ start tf muid processTracker portman plugins rlog appname bundle removeFromList
|
||||
log $ FinishedReloading appname
|
||||
terminateOld
|
||||
loop chan dir config $ Just (process, port)
|
||||
else do
|
||||
Nothing -> do
|
||||
releasePort portman port
|
||||
Keter.Process.terminate process
|
||||
case eprocess of
|
||||
Left _ -> return ()
|
||||
Right process -> void $ liftIO $ terminateMonitoredProcess process
|
||||
log $ ProcessDidNotStart bundle
|
||||
loop chan dirOld configOld mprocPortOld
|
||||
where
|
||||
@ -179,7 +195,7 @@ start tf muid processTracker portman plugins rlog appname bundle removeFromList
|
||||
log $ TerminatingOldProcess appname
|
||||
case mprocPortOld of
|
||||
Nothing -> return ()
|
||||
Just (processOld, _) -> Keter.Process.terminate processOld
|
||||
Just (processOld, _) -> void $ liftIO $ terminateMonitoredProcess processOld
|
||||
threadDelay $ 60 * 1000 * 1000
|
||||
log $ RemovingOldFolder dirOld
|
||||
res <- liftIO $ removeTree dirOld
|
||||
|
||||
@ -27,6 +27,7 @@ module Keter.Prelude
|
||||
, liftIO
|
||||
, forkKIO
|
||||
, forkKIO'
|
||||
, getIOLogger
|
||||
, (++)
|
||||
, P.minBound
|
||||
, P.succ
|
||||
@ -165,6 +166,7 @@ data LogMessage
|
||||
| RemovingOldFolder F.FilePath
|
||||
| ReceivedInotifyEvent T.Text
|
||||
| ProcessWaiting F.FilePath
|
||||
| OtherMessage T.Text
|
||||
|
||||
instance P.Show LogMessage where
|
||||
show (ProcessCreated f) = "Created process: " ++ F.encodeString f
|
||||
@ -195,6 +197,10 @@ instance P.Show LogMessage where
|
||||
show (RemovingOldFolder fp) = "Removing unneeded folder: " ++ F.encodeString fp
|
||||
show (ReceivedInotifyEvent t) = "Received unknown INotify event: " ++ T.unpack t
|
||||
show (ProcessWaiting f) = "Process restarting too quickly, waiting before trying again: " ++ F.encodeString f
|
||||
show (OtherMessage t) = T.unpack t
|
||||
|
||||
getIOLogger :: KIO (T.Text -> P.IO ())
|
||||
getIOLogger = KIO $ \f -> P.return $ f . OtherMessage
|
||||
|
||||
logEx :: TH.Q TH.Exp
|
||||
logEx = do
|
||||
|
||||
@ -1,80 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Keter.Process
|
||||
( run
|
||||
, terminate
|
||||
, Process
|
||||
) where
|
||||
|
||||
import Keter.Prelude
|
||||
import Data.Time (diffUTCTime)
|
||||
import Data.Conduit.Process.Unix (forkExecuteLog, killProcess, terminateProcess, ProcessTracker, trackProcess, RotatingLog, waitForProcess)
|
||||
import System.Process (ProcessHandle)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
|
||||
data Status = NeedsRestart | NoRestart | Running ProcessHandle
|
||||
|
||||
-- | Run the given command, restarting if the process dies.
|
||||
run :: ProcessTracker
|
||||
-> Maybe Text -- ^ setuid
|
||||
-> FilePath -- ^ executable
|
||||
-> FilePath -- ^ working directory
|
||||
-> [String] -- ^ command line parameter
|
||||
-> [(String, String)] -- ^ environment
|
||||
-> RotatingLog
|
||||
-> KIO Process
|
||||
run processTracker msetuid exec dir args env rlog = do
|
||||
mstatus <- newMVar NeedsRestart
|
||||
let loop mlast = do
|
||||
next <- modifyMVar mstatus $ \status ->
|
||||
case status of
|
||||
NoRestart -> return (NoRestart, return ())
|
||||
_ -> do
|
||||
now <- getCurrentTime
|
||||
case mlast of
|
||||
Just last | diffUTCTime now last < 5 -> do
|
||||
log $ ProcessWaiting exec
|
||||
threadDelay $ 5 * 1000 * 1000
|
||||
_ -> return ()
|
||||
let cmd0 = encodeUtf8 $ either id id $ toText exec
|
||||
args0 = map encodeUtf8 args
|
||||
(cmd, args') =
|
||||
case msetuid of
|
||||
Nothing -> (cmd0, args0)
|
||||
Just setuid -> ("sudo", "-E" : "-u" : encodeUtf8 setuid : "--" : cmd0 : args0)
|
||||
res <- liftIO $ forkExecuteLog
|
||||
cmd
|
||||
args'
|
||||
(Just $ map (encodeUtf8 *** encodeUtf8) env)
|
||||
(Just $ encodeUtf8 $ either id id $ toText dir)
|
||||
(Just $ return ())
|
||||
rlog
|
||||
case res of
|
||||
Left e -> do
|
||||
$logEx e
|
||||
return (NeedsRestart, return ())
|
||||
Right pid -> do
|
||||
log $ ProcessCreated exec
|
||||
return (Running pid, do
|
||||
void $ liftIO $ do
|
||||
void $ trackProcess processTracker pid
|
||||
void $ waitForProcess pid
|
||||
loop (Just now))
|
||||
next
|
||||
forkKIO $ loop Nothing
|
||||
return $ Process mstatus
|
||||
|
||||
-- | Abstract type containing information on a process which will be restarted.
|
||||
newtype Process = Process (MVar Status)
|
||||
|
||||
-- | Terminate the process and prevent it from being restarted.
|
||||
terminate :: Process -> KIO ()
|
||||
terminate (Process mstatus) = do
|
||||
status <- swapMVar mstatus NoRestart
|
||||
case status of
|
||||
Running pid -> do
|
||||
void $ liftIO $ terminateProcess pid
|
||||
threadDelay 1000000
|
||||
void $ liftIO $ killProcess pid
|
||||
_ -> return ()
|
||||
@ -61,8 +61,7 @@ Library
|
||||
, warp-tls
|
||||
, aeson
|
||||
, unordered-containers
|
||||
Exposed-Modules: Keter.Process
|
||||
Keter.Plugin.Postgres
|
||||
Exposed-Modules: Keter.Plugin.Postgres
|
||||
Keter.Types
|
||||
Keter.Types.V04
|
||||
Keter.Types.V10
|
||||
|
||||
Loading…
Reference in New Issue
Block a user