App.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Keter.App
    ( start
    , reload
    , getTimestamp
    , Keter.App.terminate
    ) where

import Control.Arrow ((***))
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Exception
       (IOException, SomeException, bracketOnError, catch, throwIO, try)
import Control.Monad (void, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Unlift (withRunInIO)
import Control.Monad.Logger
import Control.Monad.Reader (ask)
import Data.CaseInsensitive qualified as CI
import Data.Foldable (for_)
import Data.IORef
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Data.Vector qualified as V
import Data.Yaml
import Keter.Common
import Keter.Conduit.Process.Unix
       ( monitorProcess
       , printStatus
       , terminateMonitoredProcess
       )
import Keter.Config
import Keter.Context
import Keter.HostManager hiding (start)
import Keter.Logger (Logger)
import Keter.Logger qualified as Log
import Keter.PortPool (getPort, releasePort)
import Keter.Rewrite (ReverseProxyConfig(..))
import Keter.SharedData.App
import Keter.SharedData.AppManager (AppState(..))
import Keter.TempTarball
import Keter.Yaml.FilePath
import Network.Socket
import Network.TLS qualified as TLS
import Prelude hiding (FilePath)
import System.Directory
       (canonicalizePath, doesFileExist, removeDirectoryRecursive)
import System.Environment (getEnvironment)
import System.FilePath (FilePath, (</>))
import System.IO (IOMode(..), hClose)
import System.Log.FastLogger qualified as FL
import System.Posix.Files (fileAccess)
import System.Posix.Types (EpochTime)
import System.Timeout (timeout)

import Keter.Config.Middleware (processMiddlewareIO, MiddlewareConfig)
import Network.Wai (Middleware)

unpackBundle :: FilePath
             -> AppId
             -> KeterM AppStartConfig (FilePath, BundleConfig)
unpackBundle bundle aid = do
    AppStartConfig{..} <- ask
    $logInfo $ pack $ "Unpacking bundle '" <> show bundle <> "'"
    liftIO $ 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.
        let yml = dir </> "config" </> "keter.yml"
        exists <- doesFileExist yml
        let configFP = if exists then yml else dir </> "config" </> "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

withConfig :: AppId
           -> AppInput
           -> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
           -> KeterM AppStartConfig a
withConfig _aid (AIData bconfig) f = f Nothing bconfig Nothing
withConfig aid (AIBundle fp modtime) f = do
    withRunInIO $ \rio ->
        bracketOnError (rio $ unpackBundle fp aid) (\(newdir, _) -> removeDirectoryRecursive newdir) $ \(newdir, bconfig) ->
            rio $ f (Just newdir) bconfig (Just modtime)

withReservations :: AppId
                 -> BundleConfig
                 -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> KeterM AppStartConfig a)
                 -> KeterM AppStartConfig a
withReservations aid bconfig f = do
    AppStartConfig{..} <- ask
    withActions bconfig $ \wacs backs actions ->
        withRunInIO $ \rio ->
            bracketOnError
              (rio $ withMappedConfig (const ascHostManager) $ reserveHosts aid $ Map.keysSet actions)
              (rio . withMappedConfig (const ascHostManager) . forgetReservations aid)
              (\_ -> rio $ f wacs backs actions)

withActions :: BundleConfig
            -> ([ WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> KeterM AppStartConfig a)
            -> KeterM AppStartConfig a
withActions bconfig f =
    loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty
  where
    -- todo: add loading from relative location
    loadCert (SSL certFile chainCertFiles keyFile) =
         either (const mempty) (TLS.Credentials . (:[]))
            <$> TLS.credentialLoadX509Chain certFile (V.toList chainCertFiles) keyFile
    loadCert _ = return mempty

    setupMW :: [Keter.Config.Middleware.MiddlewareConfig] -> IO Middleware
    setupMW = processMiddlewareIO

    loop [] wacs backs actions = f wacs backs actions
    loop (Stanza (StanzaWebApp wac) rs:stanzas) wacs backs actions = do
      AppStartConfig{..} <- ask
      withRunInIO $ \rio ->
        liftIO $ bracketOnError
          (rio (getPort ascPortPool) >>= either throwIO pure)
          (\port -> releasePort ascPortPool port)
          (\port -> do
              mw <- setupMW (waconfigMiddleware wac)
              let wac' = wac { waconfigPort = port }
                  action = PAPort port mw (waconfigTimeout wac)
                  hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)
              cert <- loadCert (waconfigSsl wac)
              rio $ loop
                stanzas
                (wac' : wacs)
                backs
                (Map.unions $ actions : map (\host -> Map.singleton host ((action, rs), cert)) hosts)
          )
    loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 = do
        cert <- liftIO $ loadCert $ sfconfigSsl sfc
        mw <- liftIO $ setupMW (sfconfigMiddleware sfc)
        let action = PAStatic sfc mw
        loop stanzas wacs backs (actions action cert)
      where
        actions action cert =
          Map.unions $ actions0 :
            map (\host -> Map.singleton host ((action, rs), cert))
                (Set.toList (sfconfigHosts sfc))
    loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 = do
        cert <- liftIO $ loadCert $ redirconfigSsl red
        let action = PARedirect red
        loop stanzas wacs backs (actions action cert)
      where
        actions action cert =
          Map.unions $ actions0 :
            map (\host -> Map.singleton host ((action, rs), cert))
                (Set.toList (redirconfigHosts red))
    loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 = do
        cert <- liftIO $ loadCert $ reversingUseSSL rev
        mw <- liftIO $ setupMW mid
        let action = PAReverseProxy rev mw to
        loop stanzas wacs backs (Map.insert (CI.mk $ reversingHost rev) ((action, rs), cert) actions0)
    loop (Stanza (StanzaBackground back) _:stanzas) wacs backs actions =
        loop stanzas wacs (back:backs) actions

-- | Gives the log file or log tag name for a given 'AppId'
appLogName :: AppId -> String
appLogName AIBuiltin = "__builtin__"
appLogName (AINamed x) = "app-" <> unpack x

withLogger :: AppId
           -> Maybe (TVar (Maybe Logger))
           -> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
           -> KeterM AppStartConfig a
withLogger aid Nothing f = do
    var <- liftIO $ newTVarIO Nothing
    withLogger aid (Just var) f
withLogger aid (Just var) f = do
    AppStartConfig{..} <- ask
    mappLogger <- liftIO $ readTVarIO var
    case mappLogger of
        Nothing -> withRunInIO $ \rio ->
          bracketOnError (Log.createLoggerViaConfig ascKeterConfig (appLogName aid))
                         Log.loggerClose
                       $ \appLogger -> do
                           atomically $ writeTVar var $ Just appLogger
                           rio $ f var appLogger
        Just appLogger ->  f var appLogger

withSanityChecks :: BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig{..} f = do
    liftIO $ V.mapM_ go bconfigStanzas
    $logInfo "Sanity checks passed"
    f
  where
    go (Stanza (StanzaWebApp WebAppConfig {..}) _) = do
      isExec waconfigExec
      for_ waconfigEnsureAliveTimeout
        $ \x -> when (x < 1) $ throwIO $ EnsureAliveShouldBeBiggerThenZero x
    go (Stanza (StanzaBackground BackgroundConfig {..}) _) = isExec bgconfigExec
    go _ = return ()

    isExec fp = do
        exists <- doesFileExist fp
        if exists
            then do
                canExec <- fileAccess fp True False True
                if canExec
                    then return ()
                    else throwIO $ FileNotExecutable fp
            else throwIO $ ExecutableNotFound fp

start :: AppId
      -> AppInput
      -> TVar AppState
      -> KeterM AppStartConfig App
start aid input tstate =
    withLogger aid Nothing $ \tAppLogger appLogger ->
    withConfig aid input $ \newdir bconfig mmodtime ->
    withSanityChecks bconfig $ 
    withReservations aid bconfig $ \webapps backs actions ->
    withBackgroundApps aid bconfig newdir appLogger backs $ \runningBacks ->
    withWebApps aid bconfig newdir appLogger webapps $ \runningWebapps -> do
        asc@AppStartConfig{..} <- ask
        liftIO $ mapM_ (ensureAlive tstate) runningWebapps
        withMappedConfig (const ascHostManager) $ activateApp aid actions
        liftIO $
          App
            <$> newTVarIO mmodtime
            <*> newTVarIO runningWebapps
            <*> newTVarIO runningBacks
            <*> return aid
            <*> newTVarIO (Map.keysSet actions)
            <*> newTVarIO newdir
            <*> return asc
            <*> return tAppLogger

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 :: AppId
            -> BundleConfig
            -> Maybe FilePath
            -> Logger
            -> [WebAppConfig Port]
            -> ([RunningWebApp] -> KeterM AppStartConfig a)
            -> KeterM AppStartConfig a
withWebApps aid bconfig mdir appLogger configs0 f =
    withRunInIO $ \rio ->
      bracketedMap (\wac f' -> rio $ alloc wac (liftIO <$> f')) (rio . f) configs0
  where
    alloc = launchWebApp aid bconfig mdir appLogger

-- | Format a log message for an app by tagging it with 'app-$name>' (only when it is being logged to stderr)
formatAppLog :: AppId -> FL.LogType -> LogStr -> LogStr
formatAppLog aid (FL.LogStderr _) msg = toLogStr (appLogName aid) <> "> " <> msg
formatAppLog _ _ msg = msg

launchWebApp :: AppId
             -> BundleConfig
             -> Maybe FilePath
             -> Logger
             -> WebAppConfig Port
             -> (RunningWebApp -> KeterM AppStartConfig a)
             -> KeterM AppStartConfig a
launchWebApp aid BundleConfig {..} mdir appLogger WebAppConfig {..} f = do
    AppStartConfig{..} <- ask
    otherEnv <- liftIO $ pluginsGetEnv ascPlugins name bconfigPlugins
    forwardedEnv <- liftIO $ getForwardedEnv waconfigForwardEnv
    let httpPort  = kconfigExternalHttpPort  ascKeterConfig
        httpsPort = kconfigExternalHttpsPort ascKeterConfig
        (scheme, extport) =
            if waconfigSsl == SSLFalse
                then ("http://",  if httpPort  ==  80 then "" else ':' : show httpPort)
                else ("https://", if httpsPort == 443 then "" else ':' : show httpsPort)
        env = Map.toList $ Map.unions
            -- Ordering chosen specifically to precedence rules: app specific,
            -- plugins, global, and then auto-set Keter variables.
            [ waconfigEnvironment
            , forwardedEnv
            , Map.fromList otherEnv
            , kconfigEnvironment ascKeterConfig
            , Map.singleton "PORT" $ pack $ show waconfigPort
            , Map.singleton "APPROOT" $ scheme <> CI.original waconfigApprootHost <> pack extport
            ]
    exec <- liftIO $ canonicalizePath waconfigExec
    withRunInIO $ \rio -> bracketOnError
        (rio $ monitorProcess
            ascProcessTracker
            (encodeUtf8 . fst <$> ascSetuid)
            (encodeUtf8 $ pack exec)
            (maybe "/tmp" (encodeUtf8 . pack) mdir)
            (map encodeUtf8 $ V.toList waconfigArgs)
            (map (encodeUtf8 *** encodeUtf8) env)
            (Log.loggerLog appLogger . formatAppLog aid (Log.loggerType appLogger) . toLogStr)
            (const $ return True))
        terminateMonitoredProcess
        $ \mp -> rio $ f RunningWebApp
            { rwaProcess = mp
            , rwaPort = waconfigPort
            , rwaEnsureAliveTimeOut = fromMaybe (90 * 1000 * 1000) waconfigEnsureAliveTimeout
            }
  where
    name =
        case aid of
            AIBuiltin -> "__builtin__"
            AINamed x -> x

killWebApp :: RunningWebApp -> KeterM cfg ()
killWebApp RunningWebApp {..} = do
    status <- liftIO $ printStatus rwaProcess
    $logInfo $ pack $ "Killing " <> unpack status <> " running on port: "  <> show rwaPort
    liftIO $ terminateMonitoredProcess rwaProcess

ensureAlive :: TVar AppState -> RunningWebApp -> IO ()
ensureAlive tstate RunningWebApp {..} = do
    didAnswer <- testApp rwaPort
    if didAnswer
        then return ()
        else error $ "ensureAlive failed, this means keter couldn't " <>
                      "detect your app at port " <> show rwaPort <>
                      ", check your app logs detailed errors. " <>
                      " Also make sure your app binds to the PORT environment variable (not YESOD_PORT for example)." -- TODO domain name would be good to add as well
  where
    testApp :: Port -> IO Bool
    testApp port = do
        res <- timeout rwaEnsureAliveTimeOut testApp'
        return $ fromMaybe False res
      where
        testApp' = do
            threadDelay $ 2 * 1000 * 1000
            eres <- try $ connectTo "127.0.0.1" $ show port
            case eres of
                Left (_ :: IOException) -> do
                    testApp'required <- not <$> hasNextStartingAction
                    if testApp'required then testApp' else return False
                Right handle -> do
                    hClose handle
                    return True
        hasNextStartingAction :: IO Bool
        hasNextStartingAction = do
            state <- readTVarIO tstate
            case state of
                ASStarting _app _time tmaction -> isJust <$> readTVarIO tmaction
                _ -> return False
        connectTo host serv = do
            let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]
                                     , addrSocketType = Stream }
            addrs <- getAddrInfo (Just hints) (Just host) (Just serv)
            firstSuccessful $ map tryToConnect addrs
            where
              tryToConnect addr =
                bracketOnError
                  (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
                  close  -- only done if there's an error
                  (\sock -> do
                    connect sock (addrAddress addr)
                    socketToHandle sock ReadWriteMode
                  )
              firstSuccessful = go Nothing
                where
                  go _ (p:ps) = do
                    r <- tryIO p
                    case r of
                          Right x -> return x
                          Left  e -> go (Just e) ps
                 -- All operations failed, throw error if one exists
                  go Nothing  [] = ioError $ userError "connectTo firstSuccessful: empty list"
                  go (Just e) [] = throwIO e
                  tryIO :: IO a -> IO (Either IOException a)
                  tryIO m = catch (fmap Right m) (return . Left)


withBackgroundApps :: AppId
                   -> BundleConfig
                   -> Maybe FilePath
                   -> Logger
                   -> [BackgroundConfig]
                   -> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
                   -> KeterM AppStartConfig a
withBackgroundApps aid bconfig mdir appLogger configs f =
    withRunInIO $ \rio -> bracketedMap (\cfg f' -> rio $ alloc cfg (liftIO <$> f')) (rio . f) configs
  where
    alloc = launchBackgroundApp aid bconfig mdir appLogger

launchBackgroundApp :: AppId
                    -> BundleConfig
                    -> Maybe FilePath
                    -> Logger
                    -> BackgroundConfig
                    -> (RunningBackgroundApp -> IO a)
                    -> KeterM AppStartConfig a
launchBackgroundApp aid BundleConfig {..} mdir appLogger BackgroundConfig {..} f = do
    AppStartConfig{..} <- ask
    otherEnv <- liftIO $ pluginsGetEnv ascPlugins name bconfigPlugins
    forwardedEnv <- liftIO $ getForwardedEnv bgconfigForwardEnv
    let env = Map.toList $ Map.unions
            -- Order matters as in launchWebApp
            [ bgconfigEnvironment
            , forwardedEnv
            , Map.fromList otherEnv
            , kconfigEnvironment ascKeterConfig
            ]
    exec <- liftIO $ canonicalizePath bgconfigExec

    let delay = threadDelay $ fromIntegral $ bgconfigRestartDelaySeconds * 1000 * 1000
    shouldRestart <-
        case bgconfigRestartCount of
            UnlimitedRestarts -> return $ do
                delay
                return True
            LimitedRestarts maxCount -> do
                icount <- liftIO $ newIORef 0
                return $ do
                    res <- atomicModifyIORef icount $ \count ->
                        (count + 1, count < maxCount)
                    when res delay
                    return res
    withRunInIO $ \rio -> bracketOnError
        (rio $ monitorProcess
            ascProcessTracker
            (encodeUtf8 . fst <$> ascSetuid)
            (encodeUtf8 $ pack exec)
            (maybe "/tmp" (encodeUtf8 . pack) mdir)
            (map encodeUtf8 $ V.toList bgconfigArgs)
            (map (encodeUtf8 *** encodeUtf8) env)
            (Log.loggerLog appLogger . formatAppLog aid (Log.loggerType appLogger) . toLogStr)
            (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 appLogger 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 :: AppInput -> TVar AppState -> KeterM App ()
reload input tstate = do
    App{..} <- ask
    withMappedConfig (const appAsc) $
      withLogger appId (Just appLog) $ \_ appLogger ->
      withConfig appId input $ \newdir bconfig mmodtime ->
      withSanityChecks bconfig $
      withReservations appId bconfig $ \webapps backs actions -> 
      withBackgroundApps appId bconfig newdir appLogger backs $ \runningBacks ->
      withWebApps appId bconfig newdir appLogger webapps $ \runningWebapps -> do
          liftIO $ mapM_ (ensureAlive tstate) runningWebapps
          liftIO (readTVarIO appHosts) >>= \hosts ->
            withMappedConfig (const $ ascHostManager appAsc) $
              reactivateApp appId actions hosts
          (oldApps, oldBacks, oldDir, oldRlog) <- liftIO $ atomically $ do
              oldApps <- readTVar appRunningWebApps
              oldBacks <- readTVar appBackgroundApps
              oldDir <- readTVar appDir
              oldRlog <- readTVar appLog

              writeTVar appModTime mmodtime
              writeTVar appRunningWebApps runningWebapps
              writeTVar appBackgroundApps runningBacks
              writeTVar appHosts $ Map.keysSet actions
              writeTVar appDir newdir
              return (oldApps, oldBacks, oldDir, oldRlog)
          void $ withRunInIO $ \rio ->
            forkIO $ rio $ terminateHelper appId oldApps oldBacks oldDir oldRlog

terminate :: KeterM App ()
terminate = do
    App{..} <- ask
    let AppStartConfig {..} = appAsc
    (hosts, apps, backs, mdir, appLogger) <- liftIO $ atomically $ do
        hosts <- readTVar appHosts
        apps <- readTVar appRunningWebApps
        backs <- readTVar appBackgroundApps
        mdir <- readTVar appDir
        appLogger <- readTVar appLog

        writeTVar appModTime Nothing
        writeTVar appRunningWebApps []
        writeTVar appBackgroundApps []
        writeTVar appHosts Set.empty
        writeTVar appDir Nothing
        writeTVar appLog Nothing

        return (hosts, apps, backs, mdir, appLogger)

    withMappedConfig (const ascHostManager) $
        deactivateApp appId hosts

    void $ withRunInIO $ \rio ->
      forkIO $ rio $ withMappedConfig (const appAsc) $
        terminateHelper appId apps backs mdir appLogger
    liftIO $ maybe (return ()) Log.loggerClose appLogger

terminateHelper :: AppId
                -> [RunningWebApp]
                -> [RunningBackgroundApp]
                -> Maybe FilePath
                -> Maybe Logger
                -> KeterM AppStartConfig ()
terminateHelper aid apps backs mdir _appLogger = do
    AppStartConfig{..} <- ask
    let preDelay = maybe (20 * 1000 * 1000) id (kconfigGracefulDrainMicros ascKeterConfig)
    liftIO $ threadDelay preDelay
    $logInfo $ pack $
        "Sending old process TERM signal: "
          ++ case aid of { AINamed t -> unpack t; AIBuiltin -> "builtin" }
    mapM_ killWebApp apps
    liftIO $ do
        mapM_ killBackgroundApp backs
        threadDelay $ 60 * 1000 * 1000
    case mdir of
        Nothing -> return ()
        Just dir -> do
            $logInfo $ pack $ "Removing unneeded folder: " ++ dir
            res <- liftIO $ try @SomeException $ removeDirectoryRecursive dir
            case res of
                Left e -> $logError $ pack $ show 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 = concat <$> mapM (\p -> pluginGetEnv p app o) ps

-- | For the forward-env option. From a Set of desired variables, create a
-- Map pulled from the system environment.
getForwardedEnv :: Set Text -> IO (Map Text Text)
getForwardedEnv vars = filterEnv <$> getEnvironment
  where
    filterEnv = Map.filterWithKey (\k _ -> Set.member k vars)
              . Map.fromList
              . map (pack *** pack)


    {- 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
                        mappLogger <- do
                            let dirout = kconfigDir </> "log" </> fromText ("app-" ++ appname)
                                direrr = dirout </> "err"
                            eappLogger <- liftIO $ Log.openRotatingLog
                                (F.encodeString dirout)
                                Log.defaultMaxTotal
                            case eappLogger of
                                Left e -> do
                                    $logEx e
                                    return Nothing
                                Right appLogger -> return (Just appLogger)
                        let appLogger = fromMaybe Log.dummy mappLogger
                        (app, rest) <- App.start
                            tf
                            muid
                            processTracker
                            hostman
                            plugins
                            appLogger
                            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
            -}