{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} 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.CaseInsensitive as CI import qualified Data.Conduit.LogFile as LogFile import Data.Conduit.LogFile (RotatingLog) import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker, 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 -- 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" 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 (CI.mk $ 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 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) : ("APPROOT", scheme <> CI.original waconfigApprootHost <> pack extport) : 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) (LogFile.addChunk 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) (LogFile.addChunk rlog) (const shouldRestart)) terminateMonitoredProcess (f . RunningBackgroundApp) where name = case aid of AIBuiltin -> "__builtin__" AINamed x -> x killBackgroundApp :: RunningBackgroundApp -> IO () killBackgroundApp RunningBackgroundApp {..} = do terminateMonitoredProcess rbaProcess {- start :: TempFolder -> Maybe (Text, (UserID, GroupID)) -> ProcessTracker -> HostManager -> Plugins -> RotatingLog -> Appname -> (Maybe BundleConfig) -> KIO () -- ^ action to perform to remove this App from list of actives -> KIO (App, KIO ()) start tf muid processTracker portman plugins rlog appname bundle removeFromList = do Prelude.error "FIXME Keter.App.start" chan <- newChan return (App $ writeChan chan, rest chan) where rest chan = forkKIO $ do mres <- unpackBundle tf (snd <$> muid) bundle appname case mres of Left e -> do $logEx e removeFromList Right (dir, config) -> do let common = do 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 Nothing -> do common loop chan dir config Nothing Just appconfig -> do eport <- getPort portman case eport of Left e -> do $logEx e removeFromList Right port -> do eprocess <- runApp port dir appconfig case eprocess of Left e -> do $logEx e removeFromList 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 case command of Terminate -> do removeFromList case bconfigApp configOld of Nothing -> return () Just appconfig -> do 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 log $ TerminatingApp appname terminateOld Reload -> do mres <- unpackBundle tf (snd <$> muid) bundle appname case mres of Left e -> do log $ InvalidBundle bundle e loop chan dirOld configOld mprocPortOld Right (dir, config) -> do eport <- getPort portman case eport of Left e -> $logEx e Right port -> do let common = do 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 Nothing -> do common loop chan dir config Nothing Just appconfig -> 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 case bconfigApp configOld of Just appconfigOld | aconfigHost appconfig /= aconfigHost appconfigOld -> removeEntry portman $ aconfigHost appconfigOld _ -> return () log $ FinishedReloading appname terminateOld loop chan dir config $ Just (process, port) Nothing -> do releasePort portman port case eprocess of Left _ -> return () Right process -> void $ liftIO $ terminateMonitoredProcess process log $ ProcessDidNotStart bundle loop chan dirOld configOld mprocPortOld where terminateOld = forkKIO $ do -} 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 () -- | Get the modification time of the bundle file this app was launched from, -- if relevant. 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 {- 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) -} {- 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 -}