mirror of
https://github.com/snoyberg/keter.git
synced 2024-12-13 19:28:17 +03:00
Move log file code into unix-process-conduit
This commit is contained in:
Michael Snoyman
parent
fb0259d068
commit
235ceca5bb
10
Keter/App.hs
10
Keter/App.hs
@ -15,7 +15,6 @@ import Keter.Prelude
|
||||
import Keter.TempFolder
|
||||
import Keter.Postgres
|
||||
import Keter.Process
|
||||
import Keter.Logger (Logger, detach)
|
||||
import Keter.PortManager hiding (start)
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
import qualified Codec.Archive.Tar.Check as Tar
|
||||
@ -41,7 +40,7 @@ import Data.Text.Encoding (encodeUtf8)
|
||||
import System.Posix.Types (UserID, GroupID)
|
||||
import System.Posix.Files (setOwnerAndGroup, setFdOwnerAndGroup)
|
||||
import Control.Monad (unless)
|
||||
import Data.Conduit.Process.Unix (ProcessTracker)
|
||||
import Data.Conduit.Process.Unix (ProcessTracker, RotatingLog)
|
||||
|
||||
data AppConfig = AppConfig
|
||||
{ configExec :: F.FilePath
|
||||
@ -193,12 +192,12 @@ start :: TempFolder
|
||||
-> ProcessTracker
|
||||
-> PortManager
|
||||
-> Postgres
|
||||
-> Logger
|
||||
-> RotatingLog
|
||||
-> Appname
|
||||
-> F.FilePath -- ^ app bundle
|
||||
-> KIO () -- ^ action to perform to remove this App from list of actives
|
||||
-> KIO (App, KIO ())
|
||||
start tf muid processTracker portman postgres logger appname bundle removeFromList = do
|
||||
start tf muid processTracker portman postgres rlog appname bundle removeFromList = do
|
||||
chan <- newChan
|
||||
return (App $ writeChan chan, rest chan)
|
||||
where
|
||||
@ -233,7 +232,7 @@ start tf muid processTracker portman postgres logger appname bundle removeFromLi
|
||||
dir
|
||||
(configArgs config)
|
||||
env
|
||||
logger
|
||||
rlog
|
||||
|
||||
rest chan = forkKIO $ do
|
||||
mres <- unpackBundle tf (snd <$> muid) bundle appname
|
||||
@ -283,7 +282,6 @@ start tf muid processTracker portman postgres logger appname bundle removeFromLi
|
||||
mapM_ (removeEntry portman) $ map redFrom $ Set.toList $ configRedirects configOld
|
||||
log $ TerminatingApp appname
|
||||
terminateOld
|
||||
detach logger
|
||||
Reload -> do
|
||||
mres <- unpackBundle tf (snd <$> muid) bundle appname
|
||||
case mres of
|
||||
|
||||
@ -12,13 +12,12 @@ import Keter.Prelude hiding (getCurrentTime)
|
||||
import qualified Keter.TempFolder as TempFolder
|
||||
import qualified Keter.App as App
|
||||
import qualified Keter.Postgres as Postgres
|
||||
import qualified Keter.LogFile as LogFile
|
||||
import qualified Keter.Logger as Logger
|
||||
import qualified Keter.PortManager as PortMan
|
||||
import qualified Keter.Proxy as Proxy
|
||||
import qualified Keter.ReverseProxy as ReverseProxy
|
||||
import System.Posix.Files (modificationTime, getFileStatus)
|
||||
import System.Posix.Signals (sigHUP, installHandler, Handler (Catch))
|
||||
import qualified Data.Conduit.LogFile as LogFile
|
||||
|
||||
import Data.Yaml.FilePath
|
||||
import Data.Aeson (withObject)
|
||||
@ -108,7 +107,9 @@ keter (F.decodeString -> input) = do
|
||||
portman <- runThrow $ PortMan.start configPortMan
|
||||
tf <- runThrow $ TempFolder.setup $ configDir </> "temp"
|
||||
postgres <- runThrow $ Postgres.load def $ configDir </> "etc" </> "postgres.yaml"
|
||||
mainlog <- runThrow $ LogFile.start $ configDir </> "log" </> "keter"
|
||||
mainlog <- runThrow $ liftIO $ LogFile.openRotatingLog
|
||||
(F.encodeString $ configDir </> "log" </> "keter")
|
||||
LogFile.defaultMaxTotal
|
||||
|
||||
let runKIO' = runKIO $ \ml -> do
|
||||
now <- getCurrentTime
|
||||
@ -118,7 +119,7 @@ keter (F.decodeString -> input) = do
|
||||
, show ml
|
||||
, "\n"
|
||||
]
|
||||
runKIOPrint $ LogFile.addChunk mainlog bs
|
||||
LogFile.addChunk mainlog bs
|
||||
runKIOPrint = runKIO P.print
|
||||
|
||||
manager <- HTTP.newManager def
|
||||
@ -156,20 +157,15 @@ keter (F.decodeString -> input) = do
|
||||
mlogger <- do
|
||||
let dirout = configDir </> "log" </> fromText ("app-" ++ appname)
|
||||
direrr = dirout </> "err"
|
||||
elfout <- LogFile.start dirout
|
||||
case elfout of
|
||||
erlog <- liftIO $ LogFile.openRotatingLog
|
||||
(F.encodeString dirout)
|
||||
LogFile.defaultMaxTotal
|
||||
case erlog of
|
||||
Left e -> do
|
||||
$logEx e
|
||||
return Nothing
|
||||
Right lfout -> do
|
||||
elferr <- LogFile.start direrr
|
||||
case elferr of
|
||||
Left e -> do
|
||||
$logEx e
|
||||
LogFile.close lfout
|
||||
return Nothing
|
||||
Right lferr -> fmap Just $ Logger.start lfout lferr
|
||||
let logger = fromMaybe Logger.dummy mlogger
|
||||
Right rlog -> return (Just rlog)
|
||||
let logger = fromMaybe LogFile.dummy mlogger
|
||||
(app, rest) <- App.start
|
||||
tf
|
||||
muid
|
||||
|
||||
@ -8,13 +8,10 @@ module Keter.Process
|
||||
) where
|
||||
|
||||
import Keter.Prelude
|
||||
import Keter.Logger (Logger, attach, LogPipes (..), mkLogPipe)
|
||||
import Data.Time (diffUTCTime)
|
||||
import Data.Conduit.Process.Unix (forkExecuteFile, killProcess, terminateProcess, ProcessTracker, trackProcess)
|
||||
import Data.Conduit.Process.Unix (forkExecuteLog, killProcess, terminateProcess, ProcessTracker, trackProcess, RotatingLog, waitForProcess)
|
||||
import System.Process (ProcessHandle)
|
||||
import Prelude (error)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Conduit (($$))
|
||||
|
||||
data Status = NeedsRestart | NoRestart | Running ProcessHandle
|
||||
|
||||
@ -25,9 +22,9 @@ run :: ProcessTracker
|
||||
-> FilePath -- ^ working directory
|
||||
-> [String] -- ^ command line parameter
|
||||
-> [(String, String)] -- ^ environment
|
||||
-> Logger
|
||||
-> RotatingLog
|
||||
-> KIO Process
|
||||
run processTracker msetuid exec dir args env logger = do
|
||||
run processTracker msetuid exec dir args env rlog = do
|
||||
mstatus <- newMVar NeedsRestart
|
||||
let loop mlast = do
|
||||
next <- modifyMVar mstatus $ \status ->
|
||||
@ -40,30 +37,24 @@ run processTracker msetuid exec dir args env logger = do
|
||||
log $ ProcessWaiting exec
|
||||
threadDelay $ 5 * 1000 * 1000
|
||||
_ -> return ()
|
||||
(pout, sout) <- mkLogPipe
|
||||
(perr, serr) <- mkLogPipe
|
||||
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 $ forkExecuteFile
|
||||
res <- liftIO $ forkExecuteLog
|
||||
cmd
|
||||
args'
|
||||
(Just $ map (encodeUtf8 *** encodeUtf8) env)
|
||||
(Just $ encodeUtf8 $ either id id $ toText dir)
|
||||
(Just $ return ())
|
||||
(Just sout)
|
||||
(Just serr)
|
||||
rlog
|
||||
case res of
|
||||
Left e -> do
|
||||
$logEx e
|
||||
void $ liftIO $ return () $$ sout
|
||||
void $ liftIO $ return () $$ serr
|
||||
return (NeedsRestart, return ())
|
||||
Right pid -> do
|
||||
attach logger $ LogPipes pout perr
|
||||
log $ ProcessCreated exec
|
||||
return (Running pid, do
|
||||
void $ liftIO $ do
|
||||
|
||||
@ -66,8 +66,6 @@ Library
|
||||
Keter.App
|
||||
Keter.Main
|
||||
Keter.Prelude
|
||||
Keter.LogFile
|
||||
Keter.Logger
|
||||
Keter.Proxy
|
||||
Keter.PortManager
|
||||
Keter.ReverseProxy
|
||||
|
||||
Loading…
Reference in New Issue
Block a user