keter/Keter/App.hs

632 lines
26 KiB
Haskell
Raw Normal View History

2013-07-28 16:19:08 +04:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
2012-05-11 08:38:05 +04:00
{-# LANGUAGE ScopedTypeVariables #-}
2013-07-28 16:19:08 +04:00
{-# LANGUAGE TemplateHaskell #-}
2012-05-11 08:38:05 +04:00
module Keter.App
( App
2013-07-26 11:09:11 +04:00
, AppStartConfig (..)
2012-05-11 08:38:05 +04:00
, start
, reload
2013-07-26 11:09:11 +04:00
, getTimestamp
2012-05-11 08:38:05 +04:00
, Keter.App.terminate
) where
2013-07-28 16:19:08 +04:00
import Codec.Archive.TempTarball
2013-07-28 21:47:22 +04:00
import Control.Applicative ((<$>), (<*>))
2013-07-28 16:19:08 +04:00
import Control.Arrow ((***))
2013-07-28 21:47:22 +04:00
import Control.Concurrent (forkIO, threadDelay)
2013-07-28 16:19:08 +04:00
import Control.Concurrent.STM
import Control.Exception (bracketOnError, throwIO)
2013-07-28 21:16:01 +04:00
import Control.Exception (IOException, try)
2013-07-31 18:00:03 +04:00
import Control.Monad (void, when)
2014-09-21 11:42:26 +04:00
import qualified Data.CaseInsensitive as CI
2013-07-28 16:19:08 +04:00
import qualified Data.Conduit.LogFile as LogFile
import Data.Conduit.LogFile (RotatingLog)
2013-07-28 16:19:08 +04:00
import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,
monitorProcess,
2013-07-28 16:19:08 +04:00
terminateMonitoredProcess)
2013-07-31 18:00:03 +04:00
import Data.IORef
2013-07-28 16:19:08 +04:00
import qualified Data.Map as Map
2013-07-28 21:16:01 +04:00
import Data.Maybe (fromMaybe)
2013-07-28 16:19:08 +04:00
import Data.Monoid ((<>))
import qualified Data.Set as Set
import Data.Text (pack)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Vector as V
import Data.Yaml
import Data.Yaml.FilePath
2013-07-28 21:16:01 +04:00
import Filesystem (canonicalizePath, isFile,
removeTree)
2012-05-14 11:15:50 +04:00
import qualified Filesystem.Path.CurrentOS as F
2013-07-28 16:19:08 +04:00
import Keter.HostManager hiding (start)
import Keter.PortPool (PortPool, getPort, releasePort)
import Keter.Types
2013-07-28 21:16:01 +04:00
import qualified Network
2013-07-28 16:19:08 +04:00
import Prelude hiding (FilePath)
2013-07-28 21:16:01 +04:00
import System.IO (hClose)
import System.Posix.Files (fileAccess)
2013-07-28 16:19:08 +04:00
import System.Posix.Types (EpochTime)
import System.Posix.Types (GroupID, UserID)
2013-07-28 21:16:01 +04:00
import System.Timeout (timeout)
2012-10-21 09:07:26 +04:00
2013-07-28 16:19:08 +04:00
data App = App
{ appModTime :: !(TVar (Maybe EpochTime))
2013-07-28 21:47:22 +04:00
, appRunningWebApps :: !(TVar [RunningWebApp])
2013-07-31 18:00:03 +04:00
, appBackgroundApps :: !(TVar [RunningBackgroundApp])
2013-07-28 21:16:01 +04:00
, appId :: !AppId
2013-07-28 21:47:22 +04:00
, appHosts :: !(TVar (Set Host))
, appDir :: !(TVar (Maybe FilePath))
2013-07-28 21:16:01 +04:00
, appAsc :: !AppStartConfig
2013-07-29 08:36:01 +04:00
, appRlog :: !(TVar (Maybe RotatingLog))
2013-07-28 16:19:08 +04:00
}
data RunningWebApp = RunningWebApp
{ rwaProcess :: !MonitoredProcess
2013-07-28 21:16:01 +04:00
, rwaPort :: !Port
2013-07-28 16:19:08 +04:00
}
2012-05-11 08:38:05 +04:00
2013-07-31 18:00:03 +04:00
newtype RunningBackgroundApp = RunningBackgroundApp
{ rbaProcess :: MonitoredProcess
}
2013-07-28 16:19:08 +04:00
unpackBundle :: AppStartConfig
2013-07-28 14:41:42 +04:00
-> FilePath
2013-07-28 16:19:08 +04:00
-> AppId
2013-07-28 14:41:42 +04:00
-> IO (FilePath, BundleConfig)
2013-07-28 16:19:08 +04:00
unpackBundle AppStartConfig {..} bundle aid = do
ascLog $ UnpackingBundle bundle
unpackTempTar (fmap snd ascSetuid) ascTempFolder bundle folderName $ \dir -> do
-- Get the FilePath for the keter yaml configuration. Tests for
-- keter.yml and defaults to keter.yaml.
configFP <- do
let yml = dir F.</> "config" F.</> "keter.yml"
exists <- isFile yml
return $ if exists then yml
else dir F.</> "config" F.</> "keter.yaml"
2013-07-14 14:02:18 +04:00
mconfig <- decodeFileRelative configFP
config <-
case mconfig of
2013-07-14 14:02:18 +04:00
Right config -> return config
Left e -> throwIO $ InvalidConfigFile e
2013-07-25 15:10:09 +04:00
return (dir, config)
2013-07-28 16:19:08 +04:00
where
folderName =
case aid of
AIBuiltin -> "__builtin__"
AINamed x -> x
2012-10-12 14:59:46 +04:00
2013-07-26 11:09:11 +04:00
data AppStartConfig = AppStartConfig
2013-07-28 16:19:08 +04:00
{ ascTempFolder :: !TempFolder
, ascSetuid :: !(Maybe (Text, (UserID, GroupID)))
2013-07-26 11:09:11 +04:00
, ascProcessTracker :: !ProcessTracker
2013-07-28 16:19:08 +04:00
, ascHostManager :: !HostManager
, ascPortPool :: !PortPool
, ascPlugins :: !Plugins
, ascLog :: !(LogMessage -> IO ())
, ascKeterConfig :: !KeterConfig
2013-07-26 11:09:11 +04:00
}
2013-07-28 16:19:08 +04:00
withConfig :: AppStartConfig
-> AppId
-> AppInput
2013-07-28 21:16:01 +04:00
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a)
2013-07-28 16:19:08 +04:00
-> IO a
2013-07-28 21:16:01 +04:00
withConfig _asc _aid (AIData bconfig) f = f Nothing bconfig Nothing
2013-07-28 16:19:08 +04:00
withConfig asc aid (AIBundle fp modtime) f = bracketOnError
(unpackBundle asc fp aid)
(\(newdir, _) -> removeTree newdir)
2013-07-28 21:16:01 +04:00
$ \(newdir, bconfig) -> f (Just newdir) bconfig (Just modtime)
2013-07-26 11:09:11 +04:00
2013-07-28 16:19:08 +04:00
withReservations :: AppStartConfig
-> AppId
-> BundleConfig
2013-07-31 18:00:03 +04:00
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)
2013-07-28 16:19:08 +04:00
-> IO a
2013-07-31 18:00:03 +04:00
withReservations asc aid bconfig f = withActions asc bconfig $ \wacs backs actions -> bracketOnError
2013-07-30 18:49:01 +04:00
(reserveHosts (ascLog asc) (ascHostManager asc) aid $ Map.keysSet actions)
(forgetReservations (ascLog asc) (ascHostManager asc) aid)
2013-07-31 18:00:03 +04:00
(const $ f wacs backs actions)
2013-07-28 16:19:08 +04:00
withActions :: AppStartConfig
-> BundleConfig
2013-07-31 18:00:03 +04:00
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)
2013-07-28 16:19:08 +04:00
-> IO a
withActions asc bconfig f =
2013-07-31 18:00:03 +04:00
loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty
2013-07-28 16:19:08 +04:00
where
2013-07-31 18:00:03 +04:00
loop [] wacs backs actions = f wacs backs actions
loop (StanzaWebApp wac:stanzas) wacs backs actions = bracketOnError
2013-07-28 16:19:08 +04:00
(getPort (ascLog asc) (ascPortPool asc) >>= either throwIO return)
(releasePort (ascPortPool asc))
(\port -> loop
stanzas
(wac { waconfigPort = port } : wacs)
2013-07-31 18:00:03 +04:00
backs
2013-07-28 16:19:08 +04:00
(Map.unions $ actions : map (\host -> Map.singleton host $ PAPort port) hosts))
where
hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)
2013-07-31 18:00:03 +04:00
loop (StanzaStaticFiles sfc:stanzas) wacs backs actions0 =
loop stanzas wacs backs actions
2013-07-28 16:19:08 +04:00
where
actions = Map.unions
$ actions0
: map (\host -> Map.singleton host $ PAStatic sfc)
(Set.toList (sfconfigHosts sfc))
2013-07-31 18:00:03 +04:00
loop (StanzaRedirect red:stanzas) wacs backs actions0 =
loop stanzas wacs backs actions
2013-07-28 16:19:08 +04:00
where
actions = Map.unions
$ actions0
: map (\host -> Map.singleton host $ PARedirect red)
(Set.toList (redirconfigHosts red))
2013-07-31 18:00:03 +04:00
loop (StanzaReverseProxy rev:stanzas) wacs backs actions0 =
loop stanzas wacs backs actions
2013-07-28 16:19:08 +04:00
where
2014-09-21 11:42:26 +04:00
actions = Map.insert (CI.mk $ reversingHost rev) (PAReverseProxy rev) actions0
2013-07-31 18:00:03 +04:00
loop (StanzaBackground back:stanzas) wacs backs actions =
loop stanzas wacs (back:backs) actions
2013-07-28 16:19:08 +04:00
withRotatingLog :: AppStartConfig
-> AppId
2013-07-29 08:36:01 +04:00
-> Maybe (TVar (Maybe RotatingLog))
-> ((TVar (Maybe RotatingLog)) -> RotatingLog -> IO a)
2013-07-28 16:19:08 +04:00
-> IO a
2013-07-29 08:36:01 +04:00
withRotatingLog asc aid Nothing f = do
var <- newTVarIO Nothing
withRotatingLog asc aid (Just var) f
withRotatingLog AppStartConfig {..} aid (Just var) f = do
mrlog <- readTVarIO var
case mrlog of
Nothing -> bracketOnError
(LogFile.openRotatingLog (F.encodeString dir) LogFile.defaultMaxTotal)
LogFile.close
(f var)
Just rlog -> f var rlog
2013-07-28 16:19:08 +04:00
where
dir = kconfigDir ascKeterConfig F.</> "log" F.</> name
name =
case aid of
AIBuiltin -> "__builtin__"
AINamed x -> F.fromText $ "app-" <> x
2013-07-26 11:09:11 +04:00
2013-07-28 20:34:15 +04:00
withSanityChecks :: AppStartConfig -> BundleConfig -> IO a -> IO a
withSanityChecks AppStartConfig {..} BundleConfig {..} f = do
V.mapM_ go bconfigStanzas
ascLog SanityChecksPassed
f
where
2013-07-31 18:00:03 +04:00
go (StanzaWebApp WebAppConfig {..}) = isExec waconfigExec
go (StanzaBackground BackgroundConfig {..}) = isExec bgconfigExec
go _ = return ()
isExec fp = do
exists <- isFile fp
2013-07-28 20:34:15 +04:00
if exists
then do
2013-07-31 18:00:03 +04:00
canExec <- fileAccess (F.encodeString fp) True False True
2013-07-28 20:34:15 +04:00
if canExec
then return ()
2013-07-31 18:00:03 +04:00
else throwIO $ FileNotExecutable fp
else throwIO $ ExecutableNotFound fp
2013-07-28 20:34:15 +04:00
2013-07-26 11:09:11 +04:00
start :: AppStartConfig
-> AppId
2013-07-28 16:19:08 +04:00
-> AppInput
2013-07-28 14:41:42 +04:00
-> IO App
2013-07-28 16:19:08 +04:00
start asc aid input =
2013-07-29 08:36:01 +04:00
withRotatingLog asc aid Nothing $ \trlog rlog ->
2013-07-28 16:19:08 +04:00
withConfig asc aid input $ \newdir bconfig mmodtime ->
2013-07-28 20:34:15 +04:00
withSanityChecks asc bconfig $
2013-07-31 18:00:03 +04:00
withReservations asc aid bconfig $ \webapps backs actions ->
withBackgroundApps asc aid bconfig newdir rlog backs $ \runningBacks ->
2013-07-28 16:19:08 +04:00
withWebApps asc aid bconfig newdir rlog webapps $ \runningWebapps -> do
mapM_ ensureAlive runningWebapps
2013-07-30 18:49:01 +04:00
activateApp (ascLog asc) (ascHostManager asc) aid actions
2013-07-28 21:47:22 +04:00
App
<$> newTVarIO mmodtime
<*> newTVarIO runningWebapps
2013-07-31 18:00:03 +04:00
<*> newTVarIO runningBacks
2013-07-28 21:47:22 +04:00
<*> return aid
<*> newTVarIO (Map.keysSet actions)
<*> newTVarIO newdir
<*> return asc
2013-07-29 08:36:01 +04:00
<*> return trlog
2013-07-28 16:19:08 +04:00
2013-07-31 18:00:03 +04:00
bracketedMap :: (a -> (b -> IO c) -> IO c)
-> ([b] -> IO c)
-> [a]
-> IO c
bracketedMap with inside =
loop id
where
loop front [] = inside $ front []
loop front (c:cs) = with c $ \x -> loop (front . (x:)) cs
2013-07-28 16:19:08 +04:00
withWebApps :: AppStartConfig
-> AppId
-> BundleConfig
2013-07-28 21:16:01 +04:00
-> Maybe FilePath
2013-07-28 16:19:08 +04:00
-> RotatingLog
-> [WebAppConfig Port]
-> ([RunningWebApp] -> IO a)
-> IO a
2013-07-28 21:16:01 +04:00
withWebApps asc aid bconfig mdir rlog configs0 f =
2013-07-31 18:00:03 +04:00
bracketedMap alloc f configs0
2013-07-28 16:19:08 +04:00
where
2013-07-31 18:00:03 +04:00
alloc = launchWebApp asc aid bconfig mdir rlog
2013-07-28 16:19:08 +04:00
launchWebApp :: AppStartConfig
-> AppId
-> BundleConfig
2013-07-28 21:16:01 +04:00
-> Maybe FilePath
2013-07-28 16:19:08 +04:00
-> RotatingLog
-> WebAppConfig Port
2013-07-31 18:00:03 +04:00
-> (RunningWebApp -> IO a)
-> IO a
launchWebApp AppStartConfig {..} aid BundleConfig {..} mdir rlog WebAppConfig {..} f = do
otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins
2014-09-21 02:24:10 +04:00
let httpPort = kconfigExternalHttpPort ascKeterConfig
httpsPort = kconfigExternalHttpsPort ascKeterConfig
(scheme, extport) =
if waconfigSsl
then ("https://", if httpsPort == 443 then "" else ':' : show httpsPort)
else ("http://", if httpPort == 80 then "" else ':' : show httpPort)
env = ("PORT", pack $ show waconfigPort)
2014-09-21 11:42:26 +04:00
: ("APPROOT", scheme <> CI.original waconfigApprootHost <> pack extport)
: Map.toList waconfigEnvironment ++ otherEnv
2013-07-28 20:34:15 +04:00
exec <- canonicalizePath waconfigExec
2013-07-28 16:19:08 +04:00
bracketOnError
(monitorProcess
(ascLog . OtherMessage . decodeUtf8With lenientDecode)
ascProcessTracker
(encodeUtf8 . fst <$> ascSetuid)
2013-07-28 20:34:15 +04:00
(encodeUtf8 $ either id id $ F.toText exec)
2013-07-28 21:16:01 +04:00
(maybe "/tmp" (encodeUtf8 . either id id . F.toText) mdir)
2013-07-28 16:19:08 +04:00
(map encodeUtf8 $ V.toList waconfigArgs)
(map (encodeUtf8 *** encodeUtf8) env)
(LogFile.addChunk rlog)
2013-07-31 18:00:03 +04:00
(const $ return True))
terminateMonitoredProcess
$ \mp -> f RunningWebApp
{ rwaProcess = mp
, rwaPort = waconfigPort
}
2013-07-28 16:19:08 +04:00
where
name =
case aid of
AIBuiltin -> "__builtin__"
AINamed x -> x
killWebApp :: RunningWebApp -> IO ()
2013-07-28 21:02:28 +04:00
killWebApp RunningWebApp {..} = do
terminateMonitoredProcess rwaProcess
2013-07-28 16:19:08 +04:00
ensureAlive :: RunningWebApp -> IO ()
2013-07-28 20:34:15 +04:00
ensureAlive RunningWebApp {..} = do
didAnswer <- testApp rwaPort
if didAnswer
then return ()
else error "ensureAlive failed"
2013-07-28 16:19:08 +04:00
where
2013-07-28 20:34:15 +04:00
testApp :: Port -> IO Bool
testApp port = do
res <- timeout (90 * 1000 * 1000) testApp'
return $ fromMaybe False res
where
testApp' = do
threadDelay $ 2 * 1000 * 1000
eres <- try $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port
case eres of
Left (_ :: IOException) -> testApp'
Right handle -> do
hClose handle
return True
2013-07-26 11:09:11 +04:00
2013-07-31 18:00:03 +04:00
withBackgroundApps :: AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> IO a)
-> IO a
withBackgroundApps asc aid bconfig mdir rlog configs f =
bracketedMap alloc f configs
where
alloc = launchBackgroundApp asc aid bconfig mdir rlog
launchBackgroundApp :: AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> IO a
launchBackgroundApp AppStartConfig {..} aid BundleConfig {..} mdir rlog BackgroundConfig {..} f = do
otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins
let env = Map.toList bgconfigEnvironment ++ otherEnv
exec <- canonicalizePath bgconfigExec
let delay = threadDelay $ fromIntegral $ bgconfigRestartDelaySeconds * 1000 * 1000
shouldRestart <-
case bgconfigRestartCount of
UnlimitedRestarts -> return $ do
delay
return True
LimitedRestarts maxCount -> do
icount <- newIORef 0
return $ do
res <- atomicModifyIORef icount $ \count ->
2013-09-16 14:15:54 +04:00
(count + 1, count < maxCount)
2013-07-31 18:00:03 +04:00
when res delay
return res
bracketOnError
(monitorProcess
(ascLog . OtherMessage . decodeUtf8With lenientDecode)
ascProcessTracker
(encodeUtf8 . fst <$> ascSetuid)
(encodeUtf8 $ either id id $ F.toText exec)
(maybe "/tmp" (encodeUtf8 . either id id . F.toText) mdir)
(map encodeUtf8 $ V.toList bgconfigArgs)
(map (encodeUtf8 *** encodeUtf8) env)
(LogFile.addChunk rlog)
2013-07-31 18:00:03 +04:00
(const shouldRestart))
terminateMonitoredProcess
(f . RunningBackgroundApp)
where
name =
case aid of
AIBuiltin -> "__builtin__"
AINamed x -> x
killBackgroundApp :: RunningBackgroundApp -> IO ()
killBackgroundApp RunningBackgroundApp {..} = do
terminateMonitoredProcess rbaProcess
2013-07-26 11:09:11 +04:00
{-
2012-05-11 08:38:05 +04:00
start :: TempFolder
2012-10-24 18:31:18 +04:00
-> Maybe (Text, (UserID, GroupID))
-> ProcessTracker
2013-07-25 14:07:48 +04:00
-> HostManager
2013-07-10 14:26:37 +04:00
-> Plugins
-> RotatingLog
2012-05-11 12:29:25 +04:00
-> Appname
2013-07-26 11:09:11 +04:00
-> (Maybe BundleConfig)
2012-05-15 12:19:03 +04:00
-> KIO () -- ^ action to perform to remove this App from list of actives
-> KIO (App, KIO ())
2013-07-10 14:26:37 +04:00
start tf muid processTracker portman plugins rlog appname bundle removeFromList = do
2013-07-25 15:10:09 +04:00
Prelude.error "FIXME Keter.App.start"
2012-05-15 12:19:03 +04:00
chan <- newChan
return (App $ writeChan chan, rest chan)
2012-05-11 08:38:05 +04:00
where
2012-05-15 12:19:03 +04:00
rest chan = forkKIO $ do
2012-10-24 18:31:18 +04:00
mres <- unpackBundle tf (snd <$> muid) bundle appname
2012-05-11 08:38:05 +04:00
case mres of
2012-05-15 12:19:03 +04:00
Left e -> do
2012-05-17 10:32:11 +04:00
$logEx e
2012-05-15 12:19:03 +04:00
removeFromList
Right (dir, config) -> do
2013-01-28 11:09:02 +04:00
let common = do
2013-07-14 16:28:48 +04:00
mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ bconfigStaticHosts config
mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ bconfigRedirects config
case bconfigApp config of
2013-01-28 11:09:02 +04:00
Nothing -> do
common
loop chan dir config Nothing
Just appconfig -> do
eport <- getPort portman
case eport of
Left e -> do
$logEx e
2012-05-15 11:49:20 +04:00
removeFromList
2013-01-28 11:09:02 +04:00
Right port -> do
2013-07-14 17:28:43 +04:00
eprocess <- runApp port dir appconfig
case eprocess of
Left e -> do
$logEx e
2013-01-28 11:09:02 +04:00
removeFromList
2013-07-14 17:28:43 +04:00
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
2012-05-11 08:38:05 +04:00
2013-01-28 11:09:02 +04:00
loop chan dirOld configOld mprocPortOld = do
2012-05-15 12:19:03 +04:00
command <- readChan chan
2012-05-11 08:38:05 +04:00
case command of
Terminate -> do
removeFromList
2013-07-14 16:28:48 +04:00
case bconfigApp configOld of
2013-01-28 11:09:02 +04:00
Nothing -> return ()
Just appconfig -> do
2013-07-14 16:28:48 +04:00
removeEntry portman $ aconfigHost appconfig
mapM_ (removeEntry portman) $ Set.toList $ aconfigExtraHosts appconfig
mapM_ (removeEntry portman) $ map shHost $ Set.toList $ bconfigStaticHosts configOld
mapM_ (removeEntry portman) $ map redFrom $ Set.toList $ bconfigRedirects configOld
2012-05-15 12:19:03 +04:00
log $ TerminatingApp appname
2012-05-11 08:38:05 +04:00
terminateOld
Reload -> do
2012-10-24 18:31:18 +04:00
mres <- unpackBundle tf (snd <$> muid) bundle appname
2012-05-11 08:38:05 +04:00
case mres of
2012-05-15 12:19:03 +04:00
Left e -> do
log $ InvalidBundle bundle e
2013-01-28 11:09:02 +04:00
loop chan dirOld configOld mprocPortOld
2012-05-15 12:19:03 +04:00
Right (dir, config) -> do
eport <- getPort portman
2012-05-15 11:49:20 +04:00
case eport of
2012-05-17 10:32:11 +04:00
Left e -> $logEx e
2012-05-15 11:49:20 +04:00
Right port -> do
2013-01-28 11:09:02 +04:00
let common = do
2013-07-14 16:28:48 +04:00
mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ bconfigStaticHosts config
mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ bconfigRedirects config
case bconfigApp config of
2013-01-28 11:09:02 +04:00
Nothing -> do
common
loop chan dir config Nothing
Just appconfig -> do
2013-07-14 17:28:43 +04:00
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
2013-07-14 16:28:48 +04:00
addEntry portman (aconfigHost appconfig) $ PEPort port
mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig
2013-01-28 11:09:02 +04:00
common
2013-07-14 16:28:48 +04:00
case bconfigApp configOld of
Just appconfigOld | aconfigHost appconfig /= aconfigHost appconfigOld ->
removeEntry portman $ aconfigHost appconfigOld
2013-01-28 11:09:02 +04:00
_ -> return ()
log $ FinishedReloading appname
terminateOld
loop chan dir config $ Just (process, port)
2013-07-14 17:28:43 +04:00
Nothing -> do
2013-01-28 11:09:02 +04:00
releasePort portman port
2013-07-14 17:28:43 +04:00
case eprocess of
Left _ -> return ()
Right process -> void $ liftIO $ terminateMonitoredProcess process
2013-01-28 11:09:02 +04:00
log $ ProcessDidNotStart bundle
loop chan dirOld configOld mprocPortOld
2012-05-11 08:38:05 +04:00
where
2012-05-15 12:19:03 +04:00
terminateOld = forkKIO $ do
2013-07-25 15:10:09 +04:00
-}
2012-05-14 12:03:57 +04:00
2013-07-28 14:41:42 +04:00
reload :: App -> AppInput -> IO ()
2013-07-28 21:47:22 +04:00
reload App {..} input =
2013-07-29 08:36:01 +04:00
withRotatingLog appAsc appId (Just appRlog) $ \_ rlog ->
2013-07-28 21:47:22 +04:00
withConfig appAsc appId input $ \newdir bconfig mmodtime ->
withSanityChecks appAsc bconfig $
2013-07-31 18:00:03 +04:00
withReservations appAsc appId bconfig $ \webapps backs actions ->
withBackgroundApps appAsc appId bconfig newdir rlog backs $ \runningBacks ->
2013-07-29 08:36:01 +04:00
withWebApps appAsc appId bconfig newdir rlog webapps $ \runningWebapps -> do
2013-07-28 21:47:22 +04:00
mapM_ ensureAlive runningWebapps
2013-07-30 18:49:01 +04:00
readTVarIO appHosts >>= reactivateApp (ascLog appAsc) (ascHostManager appAsc) appId actions
2013-07-31 18:00:03 +04:00
(oldApps, oldBacks, oldDir) <- atomically $ do
2013-07-28 21:47:22 +04:00
oldApps <- readTVar appRunningWebApps
2013-07-31 18:00:03 +04:00
oldBacks <- readTVar appBackgroundApps
2013-07-28 21:47:22 +04:00
oldDir <- readTVar appDir
2013-07-31 18:00:03 +04:00
2013-07-28 21:47:22 +04:00
writeTVar appModTime mmodtime
writeTVar appRunningWebApps runningWebapps
2013-07-31 18:00:03 +04:00
writeTVar appBackgroundApps runningBacks
2013-07-28 21:47:22 +04:00
writeTVar appHosts $ Map.keysSet actions
writeTVar appDir newdir
2013-07-31 18:00:03 +04:00
return (oldApps, oldBacks, oldDir)
void $ forkIO $ terminateHelper appAsc appId oldApps oldBacks oldDir
2012-05-11 08:38:05 +04:00
2013-07-28 14:41:42 +04:00
terminate :: App -> IO ()
2013-07-28 21:16:01 +04:00
terminate App {..} = do
2013-07-31 18:00:03 +04:00
(hosts, apps, backs, mdir, rlog) <- atomically $ do
2013-07-29 08:36:01 +04:00
hosts <- readTVar appHosts
apps <- readTVar appRunningWebApps
2013-07-31 18:00:03 +04:00
backs <- readTVar appBackgroundApps
2013-07-29 08:36:01 +04:00
mdir <- readTVar appDir
rlog <- readTVar appRlog
writeTVar appModTime Nothing
writeTVar appRunningWebApps []
2013-07-31 18:00:03 +04:00
writeTVar appBackgroundApps []
2013-07-29 08:36:01 +04:00
writeTVar appHosts Set.empty
writeTVar appDir Nothing
writeTVar appRlog Nothing
2013-07-31 18:00:03 +04:00
return (hosts, apps, backs, mdir, rlog)
2013-07-29 08:36:01 +04:00
2013-07-30 18:49:01 +04:00
deactivateApp ascLog ascHostManager appId hosts
2013-07-31 18:00:03 +04:00
void $ forkIO $ terminateHelper appAsc appId apps backs mdir
2013-07-29 08:36:01 +04:00
maybe (return ()) LogFile.close rlog
2013-07-28 21:47:22 +04:00
where
AppStartConfig {..} = appAsc
terminateHelper :: AppStartConfig
-> AppId
-> [RunningWebApp]
2013-07-31 18:00:03 +04:00
-> [RunningBackgroundApp]
2013-07-28 21:47:22 +04:00
-> Maybe FilePath
-> IO ()
2013-07-31 18:00:03 +04:00
terminateHelper AppStartConfig {..} aid apps backs mdir = do
2013-07-28 21:16:01 +04:00
threadDelay $ 20 * 1000 * 1000
2013-07-28 21:47:22 +04:00
ascLog $ TerminatingOldProcess aid
mapM_ killWebApp apps
2013-07-31 18:00:03 +04:00
mapM_ killBackgroundApp backs
2013-07-28 21:16:01 +04:00
threadDelay $ 60 * 1000 * 1000
2013-07-28 21:47:22 +04:00
case mdir of
2013-07-28 21:16:01 +04:00
Nothing -> return ()
Just dir -> do
ascLog $ RemovingOldFolder dir
res <- try $ removeTree dir
case res of
Left e -> $logEx ascLog e
Right () -> return ()
2013-07-10 14:26:37 +04:00
2013-07-26 11:09:11 +04:00
-- | Get the modification time of the bundle file this app was launched from,
-- if relevant.
getTimestamp :: App -> STM (Maybe EpochTime)
2013-07-28 21:47:22 +04:00
getTimestamp = readTVar . appModTime
2013-07-26 11:09:11 +04:00
2013-07-28 16:19:08 +04:00
pluginsGetEnv :: Plugins -> Appname -> Object -> IO [(Text, Text)]
pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps
2013-07-25 18:35:16 +04:00
{- FIXME handle static stanzas
let staticReverse r = do
HostMan.addEntry hostman (ReverseProxy.reversingHost r)
$ HostMan.PEReverseProxy
$ ReverseProxy.RPEntry r manager
runKIO' $ mapM_ staticReverse (Set.toList kconfigReverseProxy)
-}
2013-07-26 11:09:11 +04:00
{- FIXME
rest <-
case Map.lookup appname appMap of
Just (app, _time) -> do
App.reload app
etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)
let time = either (P.const 0) id etime
return (Map.insert appname (app, time) appMap, return ())
Nothing -> do
mlogger <- do
let dirout = kconfigDir </> "log" </> fromText ("app-" ++ appname)
direrr = dirout </> "err"
erlog <- liftIO $ LogFile.openRotatingLog
(F.encodeString dirout)
LogFile.defaultMaxTotal
case erlog of
Left e -> do
$logEx e
return Nothing
Right rlog -> return (Just rlog)
let logger = fromMaybe LogFile.dummy mlogger
(app, rest) <- App.start
tf
muid
processTracker
hostman
plugins
logger
appname
bundle
(removeApp appname)
etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)
let time = either (P.const 0) id etime
let appMap' = Map.insert appname (app, time) appMap
return (appMap', rest)
rest
-}