module Keter.App
( App
, AppStartConfig (..)
, start
, reload
, getTimestamp
, Keter.App.terminate
) where
import Codec.Archive.TempTarball
import Control.Applicative ((<$>), (<*>))
import Control.Arrow ((***))
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Exception (bracketOnError, throwIO)
import Control.Exception (IOException, try)
import Control.Monad (void, when)
import qualified Data.Conduit.LogFile as LogFile
import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,
RotatingLog, monitorProcess,
terminateMonitoredProcess)
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
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
import Filesystem (canonicalizePath, isFile,
removeTree)
import qualified Filesystem.Path.CurrentOS as F
import Keter.HostManager hiding (start)
import Keter.PortPool (PortPool, getPort, releasePort)
import Keter.Types
import qualified Network
import Prelude hiding (FilePath)
import System.IO (hClose)
import System.Posix.Files (fileAccess)
import System.Posix.Types (EpochTime)
import System.Posix.Types (GroupID, UserID)
import System.Timeout (timeout)
data App = App
{ appModTime :: !(TVar (Maybe EpochTime))
, appRunningWebApps :: !(TVar [RunningWebApp])
, appBackgroundApps :: !(TVar [RunningBackgroundApp])
, appId :: !AppId
, appHosts :: !(TVar (Set Host))
, appDir :: !(TVar (Maybe FilePath))
, appAsc :: !AppStartConfig
, appRlog :: !(TVar (Maybe RotatingLog))
}
data RunningWebApp = RunningWebApp
{ rwaProcess :: !MonitoredProcess
, rwaPort :: !Port
}
newtype RunningBackgroundApp = RunningBackgroundApp
{ rbaProcess :: MonitoredProcess
}
unpackBundle :: AppStartConfig
-> FilePath
-> AppId
-> IO (FilePath, BundleConfig)
unpackBundle AppStartConfig {..} bundle aid = do
ascLog $ UnpackingBundle bundle
unpackTempTar (fmap snd ascSetuid) ascTempFolder bundle folderName $ \dir -> do
let configFP = dir F.</> "config" F.</> "keter.yaml"
mconfig <- decodeFileRelative configFP
config <-
case mconfig of
Right config -> return config
Left e -> throwIO $ InvalidConfigFile e
return (dir, config)
where
folderName =
case aid of
AIBuiltin -> "__builtin__"
AINamed x -> x
data AppStartConfig = AppStartConfig
{ ascTempFolder :: !TempFolder
, ascSetuid :: !(Maybe (Text, (UserID, GroupID)))
, ascProcessTracker :: !ProcessTracker
, ascHostManager :: !HostManager
, ascPortPool :: !PortPool
, ascPlugins :: !Plugins
, ascLog :: !(LogMessage -> IO ())
, ascKeterConfig :: !KeterConfig
}
withConfig :: AppStartConfig
-> AppId
-> AppInput
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a)
-> IO a
withConfig _asc _aid (AIData bconfig) f = f Nothing bconfig Nothing
withConfig asc aid (AIBundle fp modtime) f = bracketOnError
(unpackBundle asc fp aid)
(\(newdir, _) -> removeTree newdir)
$ \(newdir, bconfig) -> f (Just newdir) bconfig (Just modtime)
withReservations :: AppStartConfig
-> AppId
-> BundleConfig
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)
-> IO a
withReservations asc aid bconfig f = withActions asc bconfig $ \wacs backs actions -> bracketOnError
(reserveHosts (ascLog asc) (ascHostManager asc) aid $ Map.keysSet actions)
(forgetReservations (ascLog asc) (ascHostManager asc) aid)
(const $ f wacs backs actions)
withActions :: AppStartConfig
-> BundleConfig
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)
-> IO a
withActions asc bconfig f =
loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty
where
loop [] wacs backs actions = f wacs backs actions
loop (StanzaWebApp wac:stanzas) wacs backs actions = bracketOnError
(getPort (ascLog asc) (ascPortPool asc) >>= either throwIO return)
(releasePort (ascPortPool asc))
(\port -> loop
stanzas
(wac { waconfigPort = port } : wacs)
backs
(Map.unions $ actions : map (\host -> Map.singleton host $ PAPort port) hosts))
where
hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)
loop (StanzaStaticFiles sfc:stanzas) wacs backs actions0 =
loop stanzas wacs backs actions
where
actions = Map.unions
$ actions0
: map (\host -> Map.singleton host $ PAStatic sfc)
(Set.toList (sfconfigHosts sfc))
loop (StanzaRedirect red:stanzas) wacs backs actions0 =
loop stanzas wacs backs actions
where
actions = Map.unions
$ actions0
: map (\host -> Map.singleton host $ PARedirect red)
(Set.toList (redirconfigHosts red))
loop (StanzaReverseProxy rev:stanzas) wacs backs actions0 =
loop stanzas wacs backs actions
where
actions = Map.insert (reversingHost rev) (PAReverseProxy rev) actions0
loop (StanzaBackground back:stanzas) wacs backs actions =
loop stanzas wacs (back:backs) actions
withRotatingLog :: AppStartConfig
-> AppId
-> Maybe (TVar (Maybe RotatingLog))
-> ((TVar (Maybe RotatingLog)) -> RotatingLog -> IO a)
-> IO a
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
where
dir = kconfigDir ascKeterConfig F.</> "log" F.</> name
name =
case aid of
AIBuiltin -> "__builtin__"
AINamed x -> F.fromText $ "app-" <> x
withSanityChecks :: AppStartConfig -> BundleConfig -> IO a -> IO a
withSanityChecks AppStartConfig {..} BundleConfig {..} f = do
V.mapM_ go bconfigStanzas
ascLog SanityChecksPassed
f
where
go (StanzaWebApp WebAppConfig {..}) = isExec waconfigExec
go (StanzaBackground BackgroundConfig {..}) = isExec bgconfigExec
go _ = return ()
isExec fp = do
exists <- isFile fp
if exists
then do
canExec <- fileAccess (F.encodeString fp) True False True
if canExec
then return ()
else throwIO $ FileNotExecutable fp
else throwIO $ ExecutableNotFound fp
start :: AppStartConfig
-> AppId
-> AppInput
-> IO App
start asc aid input =
withRotatingLog asc aid Nothing $ \trlog rlog ->
withConfig asc aid input $ \newdir bconfig mmodtime ->
withSanityChecks asc bconfig $
withReservations asc aid bconfig $ \webapps backs actions ->
withBackgroundApps asc aid bconfig newdir rlog backs $ \runningBacks ->
withWebApps asc aid bconfig newdir rlog webapps $ \runningWebapps -> do
mapM_ ensureAlive runningWebapps
activateApp (ascLog asc) (ascHostManager asc) aid actions
App
<$> newTVarIO mmodtime
<*> newTVarIO runningWebapps
<*> newTVarIO runningBacks
<*> return aid
<*> newTVarIO (Map.keysSet actions)
<*> newTVarIO newdir
<*> return asc
<*> return trlog
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
withWebApps :: AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [WebAppConfig Port]
-> ([RunningWebApp] -> IO a)
-> IO a
withWebApps asc aid bconfig mdir rlog configs0 f =
bracketedMap alloc f configs0
where
alloc = launchWebApp asc aid bconfig mdir rlog
launchWebApp :: AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> WebAppConfig Port
-> (RunningWebApp -> IO a)
-> IO a
launchWebApp AppStartConfig {..} aid BundleConfig {..} mdir rlog WebAppConfig {..} f = do
otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins
let env = ("PORT", pack $ show waconfigPort)
: ("APPROOT", (if waconfigSsl then "https://" else "http://") <> waconfigApprootHost)
: Map.toList waconfigEnvironment ++ otherEnv
exec <- canonicalizePath waconfigExec
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 waconfigArgs)
(map (encodeUtf8 *** encodeUtf8) env)
rlog
(const $ return True))
terminateMonitoredProcess
$ \mp -> f RunningWebApp
{ rwaProcess = mp
, rwaPort = waconfigPort
}
where
name =
case aid of
AIBuiltin -> "__builtin__"
AINamed x -> x
killWebApp :: RunningWebApp -> IO ()
killWebApp RunningWebApp {..} = do
terminateMonitoredProcess rwaProcess
ensureAlive :: RunningWebApp -> IO ()
ensureAlive RunningWebApp {..} = do
didAnswer <- testApp rwaPort
if didAnswer
then return ()
else error "ensureAlive failed"
where
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
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 ->
(count + 1, count < maxCount)
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)
rlog
(const shouldRestart))
terminateMonitoredProcess
(f . RunningBackgroundApp)
where
name =
case aid of
AIBuiltin -> "__builtin__"
AINamed x -> x
killBackgroundApp :: RunningBackgroundApp -> IO ()
killBackgroundApp RunningBackgroundApp {..} = do
terminateMonitoredProcess rbaProcess
reload :: App -> AppInput -> IO ()
reload App {..} input =
withRotatingLog appAsc appId (Just appRlog) $ \_ rlog ->
withConfig appAsc appId input $ \newdir bconfig mmodtime ->
withSanityChecks appAsc bconfig $
withReservations appAsc appId bconfig $ \webapps backs actions ->
withBackgroundApps appAsc appId bconfig newdir rlog backs $ \runningBacks ->
withWebApps appAsc appId bconfig newdir rlog webapps $ \runningWebapps -> do
mapM_ ensureAlive runningWebapps
readTVarIO appHosts >>= reactivateApp (ascLog appAsc) (ascHostManager appAsc) appId actions
(oldApps, oldBacks, oldDir) <- atomically $ do
oldApps <- readTVar appRunningWebApps
oldBacks <- readTVar appBackgroundApps
oldDir <- readTVar appDir
writeTVar appModTime mmodtime
writeTVar appRunningWebApps runningWebapps
writeTVar appBackgroundApps runningBacks
writeTVar appHosts $ Map.keysSet actions
writeTVar appDir newdir
return (oldApps, oldBacks, oldDir)
void $ forkIO $ terminateHelper appAsc appId oldApps oldBacks oldDir
terminate :: App -> IO ()
terminate App {..} = do
(hosts, apps, backs, mdir, rlog) <- atomically $ do
hosts <- readTVar appHosts
apps <- readTVar appRunningWebApps
backs <- readTVar appBackgroundApps
mdir <- readTVar appDir
rlog <- readTVar appRlog
writeTVar appModTime Nothing
writeTVar appRunningWebApps []
writeTVar appBackgroundApps []
writeTVar appHosts Set.empty
writeTVar appDir Nothing
writeTVar appRlog Nothing
return (hosts, apps, backs, mdir, rlog)
deactivateApp ascLog ascHostManager appId hosts
void $ forkIO $ terminateHelper appAsc appId apps backs mdir
maybe (return ()) LogFile.close rlog
where
AppStartConfig {..} = appAsc
terminateHelper :: AppStartConfig
-> AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe FilePath
-> IO ()
terminateHelper AppStartConfig {..} aid apps backs mdir = do
threadDelay $ 20 * 1000 * 1000
ascLog $ TerminatingOldProcess aid
mapM_ killWebApp apps
mapM_ killBackgroundApp backs
threadDelay $ 60 * 1000 * 1000
case mdir of
Nothing -> return ()
Just dir -> do
ascLog $ RemovingOldFolder dir
res <- try $ removeTree dir
case res of
Left e -> $logEx ascLog e
Right () -> return ()
getTimestamp :: App -> STM (Maybe EpochTime)
getTimestamp = readTVar . appModTime
pluginsGetEnv :: Plugins -> Appname -> Object -> IO [(Text, Text)]
pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps