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
|
2014-03-20 16:32:56 +04:00
|
|
|
import Data.Conduit.LogFile (RotatingLog)
|
2013-07-28 16:19:08 +04:00
|
|
|
import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,
|
2014-03-20 16:32:56 +04:00
|
|
|
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
|
2014-08-14 06:23:13 +04:00
|
|
|
-- 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
|
2013-07-10 15:09:14 +04:00
|
|
|
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
|
2013-07-30 13:02:55 +04:00
|
|
|
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)
|
2013-07-30 13:02:55 +04:00
|
|
|
: 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)
|
2014-03-20 16:47:53 +04:00
|
|
|
(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)
|
2014-03-20 16:47:53 +04:00
|
|
|
(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))
|
2012-11-19 12:31:35 +04:00
|
|
|
-> ProcessTracker
|
2013-07-25 14:07:48 +04:00
|
|
|
-> HostManager
|
2013-07-10 14:26:37 +04:00
|
|
|
-> Plugins
|
2013-07-10 13:48:46 +04:00
|
|
|
-> 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
|
2012-08-06 18:44:41 +04:00
|
|
|
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
|
|
|
|
-}
|