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

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

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

data App = App
    { App -> TVar (Maybe EpochTime)
appModTime        :: !(TVar (Maybe EpochTime))
    , App -> TVar [RunningWebApp]
appRunningWebApps :: !(TVar [RunningWebApp])
    , App -> TVar [RunningBackgroundApp]
appBackgroundApps :: !(TVar [RunningBackgroundApp])
    , App -> AppId
appId             :: !AppId
    , App -> TVar (Set Host)
appHosts          :: !(TVar (Set Host))
    , App -> TVar (Maybe [Char])
appDir            :: !(TVar (Maybe FilePath))
    , App -> AppStartConfig
appAsc            :: !AppStartConfig
    , App -> TVar (Maybe Logger)
appLog           :: !(TVar (Maybe Logger))
    }
instance Show App where
  show :: App -> [Char]
show App {AppId
appId :: AppId
appId :: App -> AppId
appId, TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe [Char])
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe [Char])
appHosts :: TVar (Set Host)
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe [Char])
appHosts :: App -> TVar (Set Host)
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} = [Char]
"App{appId=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show AppId
appId forall a. Semigroup a => a -> a -> a
<> [Char]
"}"

-- | within an stm context we can show a lot more then the show instance can do
showApp :: App -> STM Text
showApp :: App -> STM Text
showApp App{TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe [Char])
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe [Char])
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe [Char])
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} = do
  Maybe EpochTime
appModTime' <- forall a. TVar a -> STM a
readTVar TVar (Maybe EpochTime)
appModTime
  [RunningWebApp]
appRunning' <- forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
  Set Host
appHosts'   <- forall a. TVar a -> STM a
readTVar TVar (Set Host)
appHosts
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$
    (forall a. Show a => a -> [Char]
show AppId
appId) forall a. Semigroup a => a -> a -> a
<>
    [Char]
" modtime: " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show Maybe EpochTime
appModTime') forall a. Semigroup a => a -> a -> a
<>  [Char]
", webappsRunning: " forall a. Semigroup a => a -> a -> a
<>  forall a. Show a => a -> [Char]
show [RunningWebApp]
appRunning' forall a. Semigroup a => a -> a -> a
<> [Char]
", hosts: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Set Host
appHosts'


data RunningWebApp = RunningWebApp
    { RunningWebApp -> MonitoredProcess
rwaProcess            :: !MonitoredProcess
    , RunningWebApp -> Int
rwaPort               :: !Port
    , RunningWebApp -> Int
rwaEnsureAliveTimeOut :: !Int
    }

instance Show RunningWebApp where
  show :: RunningWebApp -> [Char]
show (RunningWebApp {Int
MonitoredProcess
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..})  = [Char]
"RunningWebApp{rwaPort=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
rwaPort forall a. Semigroup a => a -> a -> a
<> [Char]
", rwaEnsureAliveTimeOut=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
rwaEnsureAliveTimeOut forall a. Semigroup a => a -> a -> a
<> [Char]
",..}"

newtype RunningBackgroundApp = RunningBackgroundApp
    { RunningBackgroundApp -> MonitoredProcess
rbaProcess :: MonitoredProcess
    }

unpackBundle :: FilePath
             -> AppId
             -> KeterM AppStartConfig (FilePath, BundleConfig)
unpackBundle :: [Char] -> AppId -> KeterM AppStartConfig ([Char], BundleConfig)
unpackBundle [Char]
bundle AppId
aid = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: [Char] -> Text
logInfo forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ [Char]
"Unpacking bundle '" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
bundle forall a. Semigroup a => a -> a -> a
<> [Char]
"'"
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
Maybe (UserID, GroupID)
-> TempFolder -> [Char] -> Text -> ([Char] -> IO a) -> IO a
unpackTempTar (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Maybe (Text, (UserID, GroupID))
ascSetuid) TempFolder
ascTempFolder [Char]
bundle Text
folderName forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
        -- Get the FilePath for the keter yaml configuration. Tests for
        -- keter.yml and defaults to keter.yaml.
        [Char]
configFP <- do
            let yml :: [Char]
yml = [Char]
dir [Char] -> ShowS
</> [Char]
"config" [Char] -> ShowS
</> [Char]
"keter.yml"
            Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
yml
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
exists then [Char]
yml
                               else [Char]
dir [Char] -> ShowS
</> [Char]
"config" [Char] -> ShowS
</> [Char]
"keter.yaml"

        Either ParseException BundleConfig
mconfig <- forall a. ParseYamlFile a => [Char] -> IO (Either ParseException a)
decodeFileRelative [Char]
configFP
        BundleConfig
config <-
            case Either ParseException BundleConfig
mconfig of
                Right BundleConfig
config -> forall (m :: * -> *) a. Monad m => a -> m a
return BundleConfig
config
                Left ParseException
e -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ ParseException -> KeterException
InvalidConfigFile ParseException
e
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
dir, BundleConfig
config)
  where
    folderName :: Text
folderName =
        case AppId
aid of
            AppId
AIBuiltin -> Text
"__builtin__"
            AINamed Text
x -> Text
x

data AppStartConfig = AppStartConfig
    { AppStartConfig -> TempFolder
ascTempFolder     :: !TempFolder
    , AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascSetuid         :: !(Maybe (Text, (UserID, GroupID)))
    , AppStartConfig -> ProcessTracker
ascProcessTracker :: !ProcessTracker
    , AppStartConfig -> HostManager
ascHostManager    :: !HostManager
    , AppStartConfig -> PortPool
ascPortPool       :: !PortPool
    , AppStartConfig -> Plugins
ascPlugins        :: !Plugins
    , AppStartConfig -> KeterConfig
ascKeterConfig    :: !KeterConfig
    }

withConfig :: AppId
           -> AppInput
           -> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
           -> KeterM AppStartConfig a
withConfig :: forall a.
AppId
-> AppInput
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
_aid (AIData BundleConfig
bconfig) Maybe [Char]
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f = Maybe [Char]
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f forall a. Maybe a
Nothing BundleConfig
bconfig forall a. Maybe a
Nothing
withConfig AppId
aid (AIBundle [Char]
fp EpochTime
modtime) Maybe [Char]
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f = do
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
        forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ [Char] -> AppId -> KeterM AppStartConfig ([Char], BundleConfig)
unpackBundle [Char]
fp AppId
aid) (\([Char]
newdir, BundleConfig
_) -> [Char] -> IO ()
removeDirectoryRecursive [Char]
newdir) forall a b. (a -> b) -> a -> b
$ \([Char]
newdir, BundleConfig
bconfig) -> 
            forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f (forall a. a -> Maybe a
Just [Char]
newdir) BundleConfig
bconfig (forall a. a -> Maybe a
Just EpochTime
modtime)

withReservations :: AppId
                 -> BundleConfig
                 -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> KeterM AppStartConfig a)
                 -> KeterM AppStartConfig a
withReservations :: forall a.
AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withReservations AppId
aid BundleConfig
bconfig [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
f = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall a.
BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withActions BundleConfig
bconfig forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
        forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
            forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
              (forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const HostManager
ascHostManager) forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> KeterM HostManager (Set Host)
reserveHosts AppId
aid forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions)
              (\Set Host
rsvs -> forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const HostManager
ascHostManager)  forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> KeterM HostManager ()
forgetReservations AppId
aid Set Host
rsvs)
              (\Set Host
_ -> forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
f [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions)

withActions :: BundleConfig
            -> ([ WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> KeterM AppStartConfig a)
            -> KeterM AppStartConfig a
withActions :: forall a.
BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withActions BundleConfig
bconfig [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
f =
    [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop (forall a. Vector a -> [a]
V.toList forall a b. (a -> b) -> a -> b
$ BundleConfig -> Vector (Stanza ())
bconfigStanzas BundleConfig
bconfig) [] [] forall k a. Map k a
Map.empty
  where
    -- todo: add loading from relative location
    loadCert :: SSLConfig -> IO Credentials
loadCert (SSL [Char]
certFile Vector [Char]
chainCertFiles [Char]
keyFile) =
         forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) ([Credential] -> Credentials
TLS.Credentials forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]))
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> [Char] -> IO (Either [Char] Credential)
TLS.credentialLoadX509Chain [Char]
certFile (forall a. Vector a -> [a]
V.toList Vector [Char]
chainCertFiles) [Char]
keyFile
    loadCert SSLConfig
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

    loop :: [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [] [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions = [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
f [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions
    loop (Stanza (StanzaWebApp WebAppConfig ()
wac) Bool
rs:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions = do
      AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
      forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> 
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
          (forall a. KeterM AppStartConfig a -> IO a
rio (forall cfg. PortPool -> KeterM cfg (Either SomeException Int)
getPort PortPool
ascPortPool) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO
               (\Int
p -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
p,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SSLConfig -> IO Credentials
loadCert forall a b. (a -> b) -> a -> b
$ forall port. WebAppConfig port -> SSLConfig
waconfigSsl WebAppConfig ()
wac)
          )
          (\(Int
port, Credentials
_)    -> PortPool -> Int -> IO ()
releasePort PortPool
ascPortPool Int
port)
          (\(Int
port, Credentials
cert) -> forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop
              [Stanza ()]
stanzas
              (WebAppConfig ()
wac { waconfigPort :: Int
waconfigPort = Int
port } forall a. a -> [a] -> [a]
: [WebAppConfig Int]
wacs)
              [BackgroundConfig]
backs
              (forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> forall k a. k -> a -> Map k a
Map.singleton Host
host ((Int -> Maybe Int -> ProxyActionRaw
PAPort Int
port (forall port. WebAppConfig port -> Maybe Int
waconfigTimeout WebAppConfig ()
wac), Bool
rs), Credentials
cert)) [Host]
hosts))
      where
        hosts :: [Host]
hosts = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert (forall port. WebAppConfig port -> Host
waconfigApprootHost WebAppConfig ()
wac) (forall port. WebAppConfig port -> Set Host
waconfigHosts WebAppConfig ()
wac)
    loop (Stanza (StanzaStaticFiles StaticFilesConfig
sfc) Bool
rs:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
        Credentials
cert <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert forall a b. (a -> b) -> a -> b
$ StaticFilesConfig -> SSLConfig
sfconfigSsl StaticFilesConfig
sfc
        [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [Stanza ()]
stanzas [WebAppConfig Int]
wacs [BackgroundConfig]
backs (Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert)
      where
        actions :: Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
                forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions0
                forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> forall k a. k -> a -> Map k a
Map.singleton Host
host ((StaticFilesConfig -> ProxyActionRaw
PAStatic StaticFilesConfig
sfc, Bool
rs), Credentials
cert))
                  (forall a. Set a -> [a]
Set.toList (StaticFilesConfig -> Set Host
sfconfigHosts StaticFilesConfig
sfc))
    loop (Stanza (StanzaRedirect RedirectConfig
red) Bool
rs:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
        Credentials
cert <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert forall a b. (a -> b) -> a -> b
$ RedirectConfig -> SSLConfig
redirconfigSsl RedirectConfig
red
        [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [Stanza ()]
stanzas [WebAppConfig Int]
wacs [BackgroundConfig]
backs (Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert)
      where
        actions :: Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
                forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions0
                forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> forall k a. k -> a -> Map k a
Map.singleton Host
host ((RedirectConfig -> ProxyActionRaw
PARedirect RedirectConfig
red, Bool
rs), Credentials
cert))
                  (forall a. Set a -> [a]
Set.toList (RedirectConfig -> Set Host
redirconfigHosts RedirectConfig
red))
    loop (Stanza (StanzaReverseProxy ReverseProxyConfig
rev [MiddlewareConfig]
mid Maybe Int
to) Bool
rs:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
        Credentials
cert <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> SSLConfig
reversingUseSSL ReverseProxyConfig
rev
        [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [Stanza ()]
stanzas [WebAppConfig Int]
wacs [BackgroundConfig]
backs (Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert)
      where
        actions :: Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall s. FoldCase s => s -> CI s
CI.mk forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> Text
reversingHost ReverseProxyConfig
rev) ((ReverseProxyConfig
-> [MiddlewareConfig] -> Maybe Int -> ProxyActionRaw
PAReverseProxy ReverseProxyConfig
rev [MiddlewareConfig]
mid Maybe Int
to, Bool
rs), Credentials
cert) Map Host (ProxyAction, Credentials)
actions0
    loop (Stanza (StanzaBackground BackgroundConfig
back) Bool
_:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions =
        [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [Stanza ()]
stanzas [WebAppConfig Int]
wacs (BackgroundConfig
backforall a. a -> [a] -> [a]
:[BackgroundConfig]
backs) Map Host (ProxyAction, Credentials)
actions

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

withLogger :: AppId
           -> Maybe (TVar (Maybe Logger))
           -> ((TVar (Maybe Logger)) -> Logger -> KeterM AppStartConfig a)
           -> KeterM AppStartConfig a
withLogger :: forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
aid Maybe (TVar (Maybe Logger))
Nothing TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f = do
    TVar (Maybe Logger)
var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO forall a. Maybe a
Nothing
    forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
aid (forall a. a -> Maybe a
Just TVar (Maybe Logger)
var) TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f
withLogger AppId
aid (Just TVar (Maybe Logger)
var) TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe Logger
mappLogger <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar (Maybe Logger)
var
    case Maybe Logger
mappLogger of
        Maybe Logger
Nothing -> forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> 
          forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (KeterConfig -> [Char] -> IO Logger
Log.createLoggerViaConfig KeterConfig
ascKeterConfig (AppId -> [Char]
appLogName AppId
aid)) Logger -> IO ()
Log.loggerClose (forall a. KeterM AppStartConfig a -> IO a
rio forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f TVar (Maybe Logger)
var)
        Just Logger
appLogger ->  TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f TVar (Maybe Logger)
var Logger
appLogger
  where

withSanityChecks :: BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks :: forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig{Object
Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} KeterM AppStartConfig a
f = do
    cfg :: AppStartConfig
cfg@AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ forall {port}. Stanza port -> IO ()
go Vector (Stanza ())
bconfigStanzas
    $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: [Char] -> Text
logInfo Text
"Sanity checks passed"
    KeterM AppStartConfig a
f
  where
    go :: Stanza port -> IO ()
go (Stanza (StanzaWebApp WebAppConfig {port
[Char]
Maybe Int
Map Text Text
Host
Set Text
Set Host
Vector Text
SSLConfig
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigExec :: forall port. WebAppConfig port -> [Char]
waconfigEnsureAliveTimeout :: Maybe Int
waconfigTimeout :: Maybe Int
waconfigForwardEnv :: Set Text
waconfigPort :: port
waconfigSsl :: SSLConfig
waconfigHosts :: Set Host
waconfigApprootHost :: Host
waconfigEnvironment :: Map Text Text
waconfigArgs :: Vector Text
waconfigExec :: [Char]
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigPort :: forall port. WebAppConfig port -> port
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
..}) Bool
_) = do
      [Char] -> IO ()
isExec [Char]
waconfigExec
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
waconfigEnsureAliveTimeout
        forall a b. (a -> b) -> a -> b
$ \Int
x -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x forall a. Ord a => a -> a -> Bool
< Int
1) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Int -> KeterException
EnsureAliveShouldBeBiggerThenZero Int
x
    go (Stanza (StanzaBackground BackgroundConfig {[Char]
Word
Map Text Text
Set Text
Vector Text
RestartCount
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigExec :: BackgroundConfig -> [Char]
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: [Char]
..}) Bool
_) = [Char] -> IO ()
isExec [Char]
bgconfigExec
    go Stanza port
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    isExec :: [Char] -> IO ()
isExec [Char]
fp = do
        Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
fp
        if Bool
exists
            then do
                Bool
canExec <- [Char] -> Bool -> Bool -> Bool -> IO Bool
fileAccess [Char]
fp Bool
True Bool
False Bool
True
                if Bool
canExec
                    then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> KeterException
FileNotExecutable [Char]
fp
            else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> KeterException
ExecutableNotFound [Char]
fp

start :: AppId
      -> AppInput
      -> KeterM AppStartConfig App
start :: AppId -> AppInput -> KeterM AppStartConfig App
start AppId
aid AppInput
input =
    forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
aid forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ \TVar (Maybe Logger)
tAppLogger Logger
appLogger ->
    forall a.
AppId
-> AppInput
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
aid AppInput
input forall a b. (a -> b) -> a -> b
$ \Maybe [Char]
newdir BundleConfig
bconfig Maybe EpochTime
mmodtime ->
    forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig
bconfig forall a b. (a -> b) -> a -> b
$
    forall a.
AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withReservations AppId
aid BundleConfig
bconfig forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
webapps [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
    forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
aid BundleConfig
bconfig Maybe [Char]
newdir Logger
appLogger [BackgroundConfig]
backs forall a b. (a -> b) -> a -> b
$ \[RunningBackgroundApp]
runningBacks ->
    forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
aid BundleConfig
bconfig Maybe [Char]
newdir Logger
appLogger [WebAppConfig Int]
webapps forall a b. (a -> b) -> a -> b
$ \[RunningWebApp]
runningWebapps -> do
        asc :: AppStartConfig
asc@AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> IO ()
ensureAlive [RunningWebApp]
runningWebapps
        forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const HostManager
ascHostManager) forall a b. (a -> b) -> a -> b
$ AppId
-> Map Host (ProxyAction, Credentials) -> KeterM HostManager ()
activateApp AppId
aid Map Host (ProxyAction, Credentials)
actions
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 
          TVar (Maybe EpochTime)
-> TVar [RunningWebApp]
-> TVar [RunningBackgroundApp]
-> AppId
-> TVar (Set Host)
-> TVar (Maybe [Char])
-> AppStartConfig
-> TVar (Maybe Logger)
-> App
App
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (TVar a)
newTVarIO Maybe EpochTime
mmodtime
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO [RunningWebApp]
runningWebapps
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO [RunningBackgroundApp]
runningBacks
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return AppId
aid
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO (forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO Maybe [Char]
newdir
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return AppStartConfig
asc
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return TVar (Maybe Logger)
tAppLogger

bracketedMap :: (a -> (b -> IO c) -> IO c)
             -> ([b] -> IO c)
             -> [a]
             -> IO c
bracketedMap :: forall a b c.
(a -> (b -> IO c) -> IO c) -> ([b] -> IO c) -> [a] -> IO c
bracketedMap a -> (b -> IO c) -> IO c
with [b] -> IO c
inside =
    ([b] -> [b]) -> [a] -> IO c
loop forall a. a -> a
id
  where
    loop :: ([b] -> [b]) -> [a] -> IO c
loop [b] -> [b]
front [] = [b] -> IO c
inside forall a b. (a -> b) -> a -> b
$ [b] -> [b]
front []
    loop [b] -> [b]
front (a
c:[a]
cs) = a -> (b -> IO c) -> IO c
with a
c forall a b. (a -> b) -> a -> b
$ \b
x -> ([b] -> [b]) -> [a] -> IO c
loop ([b] -> [b]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b
xforall a. a -> [a] -> [a]
:)) [a]
cs

withWebApps :: AppId
            -> BundleConfig
            -> Maybe FilePath
            -> Logger
            -> [WebAppConfig Port]
            -> ([RunningWebApp] -> KeterM AppStartConfig a)
            -> KeterM AppStartConfig a
withWebApps :: forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
aid BundleConfig
bconfig Maybe [Char]
mdir Logger
appLogger [WebAppConfig Int]
configs0 [RunningWebApp] -> KeterM AppStartConfig a
f =
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> 
      forall a b c.
(a -> (b -> IO c) -> IO c) -> ([b] -> IO c) -> [a] -> IO c
bracketedMap (\WebAppConfig Int
wac RunningWebApp -> IO a
f -> forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
alloc WebAppConfig Int
wac (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunningWebApp -> IO a
f)) (forall a. KeterM AppStartConfig a -> IO a
rio forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RunningWebApp] -> KeterM AppStartConfig a
f) [WebAppConfig Int]
configs0
  where
    alloc :: WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
alloc = forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
launchWebApp AppId
aid BundleConfig
bconfig Maybe [Char]
mdir Logger
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 :: AppId -> LogType -> LogStr -> LogStr
formatAppLog AppId
aid (FL.LogStderr Int
_) LogStr
msg = forall msg. ToLogStr msg => msg -> LogStr
toLogStr (AppId -> [Char]
appLogName AppId
aid) forall a. Semigroup a => a -> a -> a
<> LogStr
"> " forall a. Semigroup a => a -> a -> a
<> LogStr
msg
formatAppLog AppId
_ LogType
_ LogStr
msg = LogStr
msg

launchWebApp :: AppId
             -> BundleConfig
             -> Maybe FilePath
             -> Logger
             -> WebAppConfig Port
             -> (RunningWebApp -> KeterM AppStartConfig a)
             -> KeterM AppStartConfig a
launchWebApp :: forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
launchWebApp AppId
aid BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} Maybe [Char]
mdir Logger
appLogger WebAppConfig {Int
[Char]
Maybe Int
Map Text Text
Host
Set Text
Set Host
Vector Text
SSLConfig
waconfigEnsureAliveTimeout :: Maybe Int
waconfigTimeout :: Maybe Int
waconfigForwardEnv :: Set Text
waconfigPort :: Int
waconfigSsl :: SSLConfig
waconfigHosts :: Set Host
waconfigApprootHost :: Host
waconfigEnvironment :: Map Text Text
waconfigArgs :: Vector Text
waconfigExec :: [Char]
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigExec :: forall port. WebAppConfig port -> [Char]
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigPort :: forall port. WebAppConfig port -> port
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
..} RunningWebApp -> KeterM AppStartConfig a
f = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    [(Text, Text)]
otherEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ascPlugins Text
name Object
bconfigPlugins
    Map Text Text
forwardedEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Set Text -> IO (Map Text Text)
getForwardedEnv Set Text
waconfigForwardEnv
    let httpPort :: Int
httpPort  = KeterConfig -> Int
kconfigExternalHttpPort  KeterConfig
ascKeterConfig
        httpsPort :: Int
httpsPort = KeterConfig -> Int
kconfigExternalHttpsPort KeterConfig
ascKeterConfig
        (Text
scheme, [Char]
extport) =
            if SSLConfig
waconfigSsl forall a. Eq a => a -> a -> Bool
== SSLConfig
SSLFalse
                then (Text
"http://",  if Int
httpPort  forall a. Eq a => a -> a -> Bool
==  Int
80 then [Char]
"" else Char
':' forall a. a -> [a] -> [a]
: forall a. Show a => a -> [Char]
show Int
httpPort)
                else (Text
"https://", if Int
httpsPort forall a. Eq a => a -> a -> Bool
== Int
443 then [Char]
"" else Char
':' forall a. a -> [a] -> [a]
: forall a. Show a => a -> [Char]
show Int
httpsPort)
        env :: [(Text, Text)]
env = forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
            -- Ordering chosen specifically to precedence rules: app specific,
            -- plugins, global, and then auto-set Keter variables.
            [ Map Text Text
waconfigEnvironment
            , Map Text Text
forwardedEnv
            , forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
otherEnv
            , KeterConfig -> Map Text Text
kconfigEnvironment KeterConfig
ascKeterConfig
            , forall k a. k -> a -> Map k a
Map.singleton Text
"PORT" forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
waconfigPort
            , forall k a. k -> a -> Map k a
Map.singleton Text
"APPROOT" forall a b. (a -> b) -> a -> b
$ Text
scheme forall a. Semigroup a => a -> a -> a
<> forall s. CI s -> s
CI.original Host
waconfigApprootHost forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack [Char]
extport
            ]
    [Char]
exec <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
waconfigExec
    Loc -> Text -> LogLevel -> LogStr -> IO ()
mainLogger <- forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> m MonitoredProcess
monitorProcess
            ProcessTracker
ascProcessTracker
            (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, (UserID, GroupID))
ascSetuid)
            (Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
exec)
            (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack) Maybe [Char]
mdir)
            (forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList Vector Text
waconfigArgs)
            (forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
encodeUtf8 forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
encodeUtf8) [(Text, Text)]
env)
            (Logger -> forall a. ToLogStr a => a -> IO ()
Log.loggerLog Logger
appLogger forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> LogType -> LogStr -> LogStr
formatAppLog AppId
aid (Logger -> LogType
Log.loggerType Logger
appLogger) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall msg. ToLogStr msg => msg -> LogStr
toLogStr)
            (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True))
        MonitoredProcess -> IO ()
terminateMonitoredProcess
        forall a b. (a -> b) -> a -> b
$ \MonitoredProcess
mp -> forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ RunningWebApp -> KeterM AppStartConfig a
f RunningWebApp
            { rwaProcess :: MonitoredProcess
rwaProcess = MonitoredProcess
mp
            , rwaPort :: Int
rwaPort = Int
waconfigPort
            , rwaEnsureAliveTimeOut :: Int
rwaEnsureAliveTimeOut = forall a. a -> Maybe a -> a
fromMaybe (Int
90 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000) Maybe Int
waconfigEnsureAliveTimeout
            }
  where
    name :: Text
name =
        case AppId
aid of
            AppId
AIBuiltin -> Text
"__builtin__"
            AINamed Text
x -> Text
x

killWebApp :: RunningWebApp -> KeterM cfg ()
killWebApp :: forall cfg. RunningWebApp -> KeterM cfg ()
killWebApp RunningWebApp {Int
MonitoredProcess
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..} = do
    Text
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MonitoredProcess -> IO Text
printStatus MonitoredProcess
rwaProcess
    $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> KeterM cfg ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: [Char] -> Text
logInfo forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ [Char]
"Killing " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
unpack Text
status forall a. Semigroup a => a -> a -> a
<> [Char]
" running on port: "  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
rwaPort
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MonitoredProcess -> IO ()
terminateMonitoredProcess MonitoredProcess
rwaProcess

ensureAlive :: RunningWebApp -> IO ()
ensureAlive :: RunningWebApp -> IO ()
ensureAlive RunningWebApp {Int
MonitoredProcess
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..} = do
    Bool
didAnswer <- Int -> IO Bool
testApp Int
rwaPort
    if Bool
didAnswer
        then forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"ensureAlive failed, this means keter couldn't " forall a. Semigroup a => a -> a -> a
<>
                      [Char]
"detect your app at port " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
rwaPort forall a. Semigroup a => a -> a -> a
<>
                      [Char]
", check your app logs detailed errors. " forall a. Semigroup a => a -> a -> a
<>
                      [Char]
" 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 :: Int -> IO Bool
testApp Int
port = do
        Maybe Bool
res <- forall a. Int -> IO a -> IO (Maybe a)
timeout Int
rwaEnsureAliveTimeOut IO Bool
testApp'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
res
      where
        testApp' :: IO Bool
testApp' = do
            Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
2 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
            Either IOException Handle
eres <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO Handle
connectTo [Char]
"127.0.0.1" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
port
            case Either IOException Handle
eres of
                Left (IOException
_ :: IOException) -> IO Bool
testApp'
                Right Handle
handle -> do
                    Handle -> IO ()
hClose Handle
handle
                    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        connectTo :: [Char] -> [Char] -> IO Handle
connectTo [Char]
host [Char]
serv = do
            let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
                                     , addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
            [AddrInfo]
addrs <- Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just [Char]
host) (forall a. a -> Maybe a
Just [Char]
serv)
            forall {b}. [IO b] -> IO b
firstSuccessful forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> IO Handle
tryToConnect [AddrInfo]
addrs
            where
              tryToConnect :: AddrInfo -> IO Handle
tryToConnect AddrInfo
addr =
                forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
                  (Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
                  (Socket -> IO ()
close)  -- only done if there's an error
                  (\Socket
sock -> do
                    Socket -> SockAddr -> IO ()
connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
                    Socket -> IOMode -> IO Handle
socketToHandle Socket
sock IOMode
ReadWriteMode
                  )
              firstSuccessful :: [IO b] -> IO b
firstSuccessful = forall {b}. Maybe IOException -> [IO b] -> IO b
go forall a. Maybe a
Nothing
                where
                  go :: Maybe IOException -> [IO b] -> IO b
go Maybe IOException
_ (IO b
p:[IO b]
ps) = do
                    Either IOException b
r <- forall a. IO a -> IO (Either IOException a)
tryIO IO b
p
                    case Either IOException b
r of
                          Right b
x -> forall (m :: * -> *) a. Monad m => a -> m a
return b
x
                          Left  IOException
e -> Maybe IOException -> [IO b] -> IO b
go (forall a. a -> Maybe a
Just IOException
e) [IO b]
ps
                 -- All operations failed, throw error if one exists
                  go Maybe IOException
Nothing  [] = forall a. IOException -> IO a
ioError forall a b. (a -> b) -> a -> b
$ [Char] -> IOException
userError forall a b. (a -> b) -> a -> b
$ [Char]
"connectTo firstSuccessful: empty list"
                  go (Just IOException
e) [] = forall e a. Exception e => e -> IO a
throwIO IOException
e
                  tryIO :: IO a -> IO (Either IOException a)
                  tryIO :: forall a. IO a -> IO (Either IOException a)
tryIO IO a
m = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. b -> Either a b
Right IO a
m) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)


withBackgroundApps :: AppId
                   -> BundleConfig
                   -> Maybe FilePath
                   -> Logger
                   -> [BackgroundConfig]
                   -> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
                   -> KeterM AppStartConfig a
withBackgroundApps :: forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
aid BundleConfig
bconfig Maybe [Char]
mdir Logger
appLogger [BackgroundConfig]
configs [RunningBackgroundApp] -> KeterM AppStartConfig a
f =
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> forall a b c.
(a -> (b -> IO c) -> IO c) -> ([b] -> IO c) -> [a] -> IO c
bracketedMap (\BackgroundConfig
cfg RunningBackgroundApp -> IO a
f -> forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ BackgroundConfig
-> (RunningBackgroundApp -> IO a) -> KeterM AppStartConfig a
alloc BackgroundConfig
cfg (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunningBackgroundApp -> IO a
f)) (forall a. KeterM AppStartConfig a -> IO a
rio forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RunningBackgroundApp] -> KeterM AppStartConfig a
f) [BackgroundConfig]
configs
  where
    alloc :: BackgroundConfig
-> (RunningBackgroundApp -> IO a) -> KeterM AppStartConfig a
alloc = forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
launchBackgroundApp AppId
aid BundleConfig
bconfig Maybe [Char]
mdir Logger
appLogger

launchBackgroundApp :: AppId
                    -> BundleConfig
                    -> Maybe FilePath
                    -> Logger 
                    -> BackgroundConfig
                    -> (RunningBackgroundApp -> IO a)
                    -> KeterM AppStartConfig a
launchBackgroundApp :: forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
launchBackgroundApp AppId
aid BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} Maybe [Char]
mdir Logger
appLogger BackgroundConfig {[Char]
Word
Map Text Text
Set Text
Vector Text
RestartCount
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: [Char]
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigExec :: BackgroundConfig -> [Char]
..} RunningBackgroundApp -> IO a
f = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    [(Text, Text)]
otherEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ascPlugins Text
name Object
bconfigPlugins
    Map Text Text
forwardedEnv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Set Text -> IO (Map Text Text)
getForwardedEnv Set Text
bgconfigForwardEnv
    let env :: [(Text, Text)]
env = forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
            -- Order matters as in launchWebApp
            [ Map Text Text
bgconfigEnvironment
            , Map Text Text
forwardedEnv
            , forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
otherEnv
            , KeterConfig -> Map Text Text
kconfigEnvironment KeterConfig
ascKeterConfig
            ]
    [Char]
exec <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
bgconfigExec

    let delay :: IO ()
delay = Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word
bgconfigRestartDelaySeconds forall a. Num a => a -> a -> a
* Word
1000 forall a. Num a => a -> a -> a
* Word
1000
    IO Bool
shouldRestart <-
        case RestartCount
bgconfigRestartCount of
            RestartCount
UnlimitedRestarts -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
                IO ()
delay
                forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            LimitedRestarts Word
maxCount -> do
                IORef Word
icount <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Word
0
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
                    Bool
res <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Word
icount forall a b. (a -> b) -> a -> b
$ \Word
count ->
                        (Word
count forall a. Num a => a -> a -> a
+ Word
1, Word
count forall a. Ord a => a -> a -> Bool
< Word
maxCount)
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
res IO ()
delay
                    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
res
    Loc -> Text -> LogLevel -> LogStr -> IO ()
mainLogger <- forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> m MonitoredProcess
monitorProcess
            ProcessTracker
ascProcessTracker
            (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, (UserID, GroupID))
ascSetuid)
            (Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
exec)
            (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack) Maybe [Char]
mdir)
            (forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList Vector Text
bgconfigArgs)
            (forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
encodeUtf8 forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
encodeUtf8) [(Text, Text)]
env)
            (Logger -> forall a. ToLogStr a => a -> IO ()
Log.loggerLog Logger
appLogger forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> LogType -> LogStr -> LogStr
formatAppLog AppId
aid (Logger -> LogType
Log.loggerType Logger
appLogger) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall msg. ToLogStr msg => msg -> LogStr
toLogStr)
            (forall a b. a -> b -> a
const IO Bool
shouldRestart))
        MonitoredProcess -> IO ()
terminateMonitoredProcess
        (RunningBackgroundApp -> IO a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonitoredProcess -> RunningBackgroundApp
RunningBackgroundApp)
  where
    name :: Text
name =
        case AppId
aid of
            AppId
AIBuiltin -> Text
"__builtin__"
            AINamed Text
x -> Text
x

killBackgroundApp :: RunningBackgroundApp -> IO ()
killBackgroundApp :: RunningBackgroundApp -> IO ()
killBackgroundApp RunningBackgroundApp {MonitoredProcess
rbaProcess :: MonitoredProcess
rbaProcess :: RunningBackgroundApp -> MonitoredProcess
..} = do
    MonitoredProcess -> IO ()
terminateMonitoredProcess MonitoredProcess
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 -> KeterM App ()
reload :: AppInput -> KeterM App ()
reload AppInput
input = do
    App{TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe [Char])
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe [Char])
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe [Char])
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const AppStartConfig
appAsc) forall a b. (a -> b) -> a -> b
$ 
      forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
appId (forall a. a -> Maybe a
Just TVar (Maybe Logger)
appLog) forall a b. (a -> b) -> a -> b
$ \TVar (Maybe Logger)
_ Logger
appLogger ->
      forall a.
AppId
-> AppInput
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
appId AppInput
input forall a b. (a -> b) -> a -> b
$ \Maybe [Char]
newdir BundleConfig
bconfig Maybe EpochTime
mmodtime ->
      forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig
bconfig forall a b. (a -> b) -> a -> b
$
      forall a.
AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withReservations AppId
appId BundleConfig
bconfig forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
webapps [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
      forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
appId BundleConfig
bconfig Maybe [Char]
newdir Logger
appLogger [BackgroundConfig]
backs forall a b. (a -> b) -> a -> b
$ \[RunningBackgroundApp]
runningBacks ->
      forall a.
AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
appId BundleConfig
bconfig Maybe [Char]
newdir Logger
appLogger [WebAppConfig Int]
webapps forall a b. (a -> b) -> a -> b
$ \[RunningWebApp]
runningWebapps -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> IO ()
ensureAlive [RunningWebApp]
runningWebapps
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. TVar a -> IO a
readTVarIO TVar (Set Host)
appHosts) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Set Host
hosts ->
            forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ AppStartConfig -> HostManager
ascHostManager AppStartConfig
appAsc) forall a b. (a -> b) -> a -> b
$ 
              AppId
-> Map Host (ProxyAction, Credentials)
-> Set Host
-> KeterM HostManager ()
reactivateApp AppId
appId Map Host (ProxyAction, Credentials)
actions Set Host
hosts
          ([RunningWebApp]
oldApps, [RunningBackgroundApp]
oldBacks, Maybe [Char]
oldDir, Maybe Logger
oldRlog) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
              [RunningWebApp]
oldApps <- forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
              [RunningBackgroundApp]
oldBacks <- forall a. TVar a -> STM a
readTVar TVar [RunningBackgroundApp]
appBackgroundApps
              Maybe [Char]
oldDir <- forall a. TVar a -> STM a
readTVar TVar (Maybe [Char])
appDir
              Maybe Logger
oldRlog <- forall a. TVar a -> STM a
readTVar TVar (Maybe Logger)
appLog

              forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe EpochTime)
appModTime Maybe EpochTime
mmodtime
              forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningWebApp]
appRunningWebApps [RunningWebApp]
runningWebapps
              forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningBackgroundApp]
appBackgroundApps [RunningBackgroundApp]
runningBacks
              forall a. TVar a -> a -> STM ()
writeTVar TVar (Set Host)
appHosts forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions
              forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe [Char])
appDir Maybe [Char]
newdir
              forall (m :: * -> *) a. Monad m => a -> m a
return ([RunningWebApp]
oldApps, [RunningBackgroundApp]
oldBacks, Maybe [Char]
oldDir, Maybe Logger
oldRlog)
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> 
            IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. KeterM AppStartConfig a -> IO a
rio forall a b. (a -> b) -> a -> b
$ AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe [Char]
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
appId [RunningWebApp]
oldApps [RunningBackgroundApp]
oldBacks Maybe [Char]
oldDir Maybe Logger
oldRlog

terminate :: KeterM App ()
terminate :: KeterM App ()
terminate = do
    App{TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe [Char])
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe [Char])
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe [Char])
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} = AppStartConfig
appAsc
    (Set Host
hosts, [RunningWebApp]
apps, [RunningBackgroundApp]
backs, Maybe [Char]
mdir, Maybe Logger
appLogger) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        Set Host
hosts <- forall a. TVar a -> STM a
readTVar TVar (Set Host)
appHosts
        [RunningWebApp]
apps <- forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
        [RunningBackgroundApp]
backs <- forall a. TVar a -> STM a
readTVar TVar [RunningBackgroundApp]
appBackgroundApps
        Maybe [Char]
mdir <- forall a. TVar a -> STM a
readTVar TVar (Maybe [Char])
appDir
        Maybe Logger
appLogger <- forall a. TVar a -> STM a
readTVar TVar (Maybe Logger)
appLog

        forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe EpochTime)
appModTime forall a. Maybe a
Nothing
        forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningWebApp]
appRunningWebApps []
        forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningBackgroundApp]
appBackgroundApps []
        forall a. TVar a -> a -> STM ()
writeTVar TVar (Set Host)
appHosts forall a. Set a
Set.empty
        forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe [Char])
appDir forall a. Maybe a
Nothing
        forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Logger)
appLog forall a. Maybe a
Nothing

        forall (m :: * -> *) a. Monad m => a -> m a
return (Set Host
hosts, [RunningWebApp]
apps, [RunningBackgroundApp]
backs, Maybe [Char]
mdir, Maybe Logger
appLogger)

    forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const HostManager
ascHostManager) forall a b. (a -> b) -> a -> b
$
        AppId -> Set Host -> KeterM HostManager ()
deactivateApp AppId
appId Set Host
hosts

    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM App a -> IO a
rio ->
      IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. KeterM App a -> IO a
rio forall a b. (a -> b) -> a -> b
$ forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const AppStartConfig
appAsc) forall a b. (a -> b) -> a -> b
$ 
        AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe [Char]
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
appId [RunningWebApp]
apps [RunningBackgroundApp]
backs Maybe [Char]
mdir Maybe Logger
appLogger
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Logger -> IO ()
Log.loggerClose Maybe Logger
appLogger

terminateHelper :: AppId
                -> [RunningWebApp]
                -> [RunningBackgroundApp]
                -> Maybe FilePath
                -> Maybe Logger
                -> KeterM AppStartConfig ()
terminateHelper :: AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe [Char]
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
aid [RunningWebApp]
apps [RunningBackgroundApp]
backs Maybe [Char]
mdir Maybe Logger
appLogger = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
20 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
    $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: [Char] -> Text
logInfo forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ 
        [Char]
"Sending old process TERM signal: " 
          forall a. [a] -> [a] -> [a]
++ case AppId
aid of { AINamed Text
t -> Text -> [Char]
unpack Text
t; AppId
AIBuiltin -> [Char]
"builtin" }
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall cfg. RunningWebApp -> KeterM cfg ()
killWebApp [RunningWebApp]
apps
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do 
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningBackgroundApp -> IO ()
killBackgroundApp [RunningBackgroundApp]
backs
        Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
60 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
    case Maybe [Char]
mdir of
        Maybe [Char]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just [Char]
dir -> do
            $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: [Char] -> Text
logInfo forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ [Char]
"Removing unneeded folder: " forall a. [a] -> [a] -> [a]
++ [Char]
dir
            Either SomeException ()
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeDirectoryRecursive [Char]
dir
            case Either SomeException ()
res of
                Left SomeException
e -> $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: [Char] -> Text
logError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e
                Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Get the modification time of the bundle file this app was launched from,
-- if relevant.
getTimestamp :: App -> STM (Maybe EpochTime)
getTimestamp :: App -> STM (Maybe EpochTime)
getTimestamp = forall a. TVar a -> STM a
readTVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. App -> TVar (Maybe EpochTime)
appModTime

pluginsGetEnv :: Plugins -> Appname -> Object -> IO [(Text, Text)]
pluginsGetEnv :: Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ps Text
app Object
o = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Plugin
p -> Plugin -> Text -> Object -> IO [(Text, Text)]
pluginGetEnv Plugin
p Text
app Object
o) Plugins
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 :: Set Text -> IO (Map Text Text)
getForwardedEnv Set Text
vars = [([Char], [Char])] -> Map Text Text
filterEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [([Char], [Char])]
getEnvironment
  where
    filterEnv :: [([Char], [Char])] -> Map Text Text
filterEnv = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Text
k Text
_ -> forall a. Ord a => a -> Set a -> Bool
Set.member Text
k Set Text
vars)
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
pack forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [Char] -> Text
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
            -}