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

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

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

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 :: App -> AppId
appId :: AppId
appId} = [Char]
"App{appId=" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> AppId -> [Char]
forall a. Show a => a -> [Char]
show AppId
appId [Char] -> ShowS
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
appModTime :: App -> TVar (Maybe EpochTime)
appRunningWebApps :: App -> TVar [RunningWebApp]
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appId :: App -> AppId
appHosts :: App -> TVar (Set Host)
appDir :: App -> TVar (Maybe [Char])
appAsc :: App -> AppStartConfig
appLog :: App -> TVar (Maybe Logger)
appModTime :: TVar (Maybe EpochTime)
appRunningWebApps :: TVar [RunningWebApp]
appBackgroundApps :: TVar [RunningBackgroundApp]
appId :: AppId
appHosts :: TVar (Set Host)
appDir :: TVar (Maybe [Char])
appAsc :: AppStartConfig
appLog :: TVar (Maybe Logger)
..} = do
  Maybe EpochTime
appModTime' <- TVar (Maybe EpochTime) -> STM (Maybe EpochTime)
forall a. TVar a -> STM a
readTVar TVar (Maybe EpochTime)
appModTime
  [RunningWebApp]
appRunning' <- TVar [RunningWebApp] -> STM [RunningWebApp]
forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
  Set Host
appHosts'   <- TVar (Set Host) -> STM (Set Host)
forall a. TVar a -> STM a
readTVar TVar (Set Host)
appHosts
  Text -> STM Text
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> STM Text) -> Text -> STM Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
    AppId -> [Char]
forall a. Show a => a -> [Char]
show AppId
appId [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    [Char]
" modtime: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe EpochTime -> [Char]
forall a. Show a => a -> [Char]
show Maybe EpochTime
appModTime' [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>  [Char]
", webappsRunning: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>  [RunningWebApp] -> [Char]
forall a. Show a => a -> [Char]
show [RunningWebApp]
appRunning' [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", hosts: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set Host -> [Char]
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
rwaProcess :: RunningWebApp -> MonitoredProcess
rwaPort :: RunningWebApp -> Int
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaProcess :: MonitoredProcess
rwaPort :: Int
rwaEnsureAliveTimeOut :: Int
..})  = [Char]
"RunningWebApp{rwaPort=" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rwaPort [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", rwaEnsureAliveTimeOut=" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rwaEnsureAliveTimeOut [Char] -> ShowS
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
ascTempFolder :: TempFolder
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascProcessTracker :: ProcessTracker
ascHostManager :: HostManager
ascPortPool :: PortPool
ascPlugins :: Plugins
ascKeterConfig :: KeterConfig
ascTempFolder :: AppStartConfig -> TempFolder
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascHostManager :: AppStartConfig -> HostManager
ascPortPool :: AppStartConfig -> PortPool
ascPlugins :: AppStartConfig -> Plugins
ascKeterConfig :: AppStartConfig -> KeterConfig
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppStartConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Unpacking bundle '" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> [Char]
show [Char]
bundle [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"'"
    IO ([Char], BundleConfig)
-> KeterM AppStartConfig ([Char], BundleConfig)
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Char], BundleConfig)
 -> KeterM AppStartConfig ([Char], BundleConfig))
-> IO ([Char], BundleConfig)
-> KeterM AppStartConfig ([Char], BundleConfig)
forall a b. (a -> b) -> a -> b
$ Maybe (UserID, GroupID)
-> TempFolder
-> [Char]
-> Text
-> ([Char] -> IO ([Char], BundleConfig))
-> IO ([Char], BundleConfig)
forall a.
Maybe (UserID, GroupID)
-> TempFolder -> [Char] -> Text -> ([Char] -> IO a) -> IO a
unpackTempTar (((Text, (UserID, GroupID)) -> (UserID, GroupID))
-> Maybe (Text, (UserID, GroupID)) -> Maybe (UserID, GroupID)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, (UserID, GroupID)) -> (UserID, GroupID)
forall a b. (a, b) -> b
snd Maybe (Text, (UserID, GroupID))
ascSetuid) TempFolder
ascTempFolder [Char]
bundle Text
folderName (([Char] -> IO ([Char], BundleConfig))
 -> IO ([Char], BundleConfig))
-> ([Char] -> IO ([Char], BundleConfig))
-> IO ([Char], BundleConfig)
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
            [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
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 <- [Char] -> IO (Either ParseException BundleConfig)
forall a. ParseYamlFile a => [Char] -> IO (Either ParseException a)
decodeFileRelative [Char]
configFP
        BundleConfig
config <-
            case Either ParseException BundleConfig
mconfig of
                Right BundleConfig
config -> BundleConfig -> IO BundleConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BundleConfig
config
                Left ParseException
e -> KeterException -> IO BundleConfig
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO BundleConfig)
-> KeterException -> IO BundleConfig
forall a b. (a -> b) -> a -> b
$ ParseException -> KeterException
InvalidConfigFile ParseException
e
        ([Char], BundleConfig) -> IO ([Char], BundleConfig)
forall a. a -> IO a
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 Maybe [Char]
forall a. Maybe a
Nothing BundleConfig
bconfig Maybe EpochTime
forall a. Maybe a
Nothing
withConfig AppId
aid (AIBundle [Char]
fp EpochTime
modtime) Maybe [Char]
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f = do
    ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
 -> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
        IO ([Char], BundleConfig)
-> (([Char], BundleConfig) -> IO ())
-> (([Char], BundleConfig) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (KeterM AppStartConfig ([Char], BundleConfig)
-> IO ([Char], BundleConfig)
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig ([Char], BundleConfig)
 -> IO ([Char], BundleConfig))
-> KeterM AppStartConfig ([Char], BundleConfig)
-> IO ([Char], BundleConfig)
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) ((([Char], BundleConfig) -> IO a) -> IO a)
-> (([Char], BundleConfig) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \([Char]
newdir, BundleConfig
bconfig) ->
            KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
newdir) BundleConfig
bconfig (EpochTime -> Maybe EpochTime
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
ascTempFolder :: AppStartConfig -> TempFolder
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascHostManager :: AppStartConfig -> HostManager
ascPortPool :: AppStartConfig -> PortPool
ascPlugins :: AppStartConfig -> Plugins
ascKeterConfig :: AppStartConfig -> KeterConfig
ascTempFolder :: TempFolder
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascProcessTracker :: ProcessTracker
ascHostManager :: HostManager
ascPortPool :: PortPool
ascPlugins :: Plugins
ascKeterConfig :: KeterConfig
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
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)
 -> KeterM AppStartConfig a)
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
        ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
 -> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
            IO (Set Host) -> (Set Host -> IO ()) -> (Set Host -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
              (KeterM AppStartConfig (Set Host) -> IO (Set Host)
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig (Set Host) -> IO (Set Host))
-> KeterM AppStartConfig (Set Host) -> IO (Set Host)
forall a b. (a -> b) -> a -> b
$ (AppStartConfig -> HostManager)
-> KeterM HostManager (Set Host)
-> KeterM AppStartConfig (Set Host)
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> AppStartConfig -> HostManager
forall a b. a -> b -> a
const HostManager
ascHostManager) (KeterM HostManager (Set Host) -> KeterM AppStartConfig (Set Host))
-> KeterM HostManager (Set Host)
-> KeterM AppStartConfig (Set Host)
forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> KeterM HostManager (Set Host)
reserveHosts AppId
aid (Set Host -> KeterM HostManager (Set Host))
-> Set Host -> KeterM HostManager (Set Host)
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials) -> Set Host
forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions)
              (KeterM AppStartConfig () -> IO ()
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig () -> IO ())
-> (Set Host -> KeterM AppStartConfig ()) -> Set Host -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AppStartConfig -> HostManager)
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> AppStartConfig -> HostManager
forall a b. a -> b -> a
const HostManager
ascHostManager) (KeterM HostManager () -> KeterM AppStartConfig ())
-> (Set Host -> KeterM HostManager ())
-> Set Host
-> KeterM AppStartConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> Set Host -> KeterM HostManager ()
forgetReservations AppId
aid)
              (\Set Host
_ -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
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 (Vector (Stanza ()) -> [Stanza ()]
forall a. Vector a -> [a]
V.toList (Vector (Stanza ()) -> [Stanza ()])
-> Vector (Stanza ()) -> [Stanza ()]
forall a b. (a -> b) -> a -> b
$ BundleConfig -> Vector (Stanza ())
bconfigStanzas BundleConfig
bconfig) [] [] Map Host (ProxyAction, Credentials)
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) =
         ([Char] -> Credentials)
-> (Credential -> Credentials)
-> Either [Char] Credential
-> Credentials
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Credentials -> [Char] -> Credentials
forall a b. a -> b -> a
const Credentials
forall a. Monoid a => a
mempty) ([Credential] -> Credentials
TLS.Credentials ([Credential] -> Credentials)
-> (Credential -> [Credential]) -> Credential -> Credentials
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Credential -> [Credential] -> [Credential]
forall a. a -> [a] -> [a]
:[]))
            (Either [Char] Credential -> Credentials)
-> IO (Either [Char] Credential) -> IO Credentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> [Char] -> IO (Either [Char] Credential)
TLS.credentialLoadX509Chain [Char]
certFile (Vector [Char] -> [[Char]]
forall a. Vector a -> [a]
V.toList Vector [Char]
chainCertFiles) [Char]
keyFile
    loadCert SSLConfig
_ = Credentials -> IO Credentials
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials
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
ascTempFolder :: AppStartConfig -> TempFolder
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascHostManager :: AppStartConfig -> HostManager
ascPortPool :: AppStartConfig -> PortPool
ascPlugins :: AppStartConfig -> Plugins
ascKeterConfig :: AppStartConfig -> KeterConfig
ascTempFolder :: TempFolder
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascProcessTracker :: ProcessTracker
ascHostManager :: HostManager
ascPortPool :: PortPool
ascPlugins :: Plugins
ascKeterConfig :: KeterConfig
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
      ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
 -> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
        IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO (Int, Credentials)
-> ((Int, Credentials) -> IO ())
-> ((Int, Credentials) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
          (KeterM AppStartConfig (Either SomeException Int)
-> IO (Either SomeException Int)
forall a. KeterM AppStartConfig a -> IO a
rio (PortPool -> KeterM AppStartConfig (Either SomeException Int)
forall cfg. PortPool -> KeterM cfg (Either SomeException Int)
getPort PortPool
ascPortPool) IO (Either SomeException Int)
-> (Either SomeException Int -> IO (Int, Credentials))
-> IO (Int, Credentials)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO (Int, Credentials))
-> (Int -> IO (Int, Credentials))
-> Either SomeException Int
-> IO (Int, Credentials)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO (Int, Credentials)
forall e a. Exception e => e -> IO a
throwIO
               (\Int
p -> (Credentials -> (Int, Credentials))
-> IO Credentials -> IO (Int, Credentials)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
p,) (IO Credentials -> IO (Int, Credentials))
-> (SSLConfig -> IO Credentials)
-> SSLConfig
-> IO (Int, Credentials)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO (Int, Credentials))
-> SSLConfig -> IO (Int, Credentials)
forall a b. (a -> b) -> a -> b
$ WebAppConfig () -> SSLConfig
forall port. WebAppConfig port -> SSLConfig
waconfigSsl WebAppConfig ()
wac)
          )
          (\(Int
port, Credentials
_)    -> PortPool -> Int -> IO ()
releasePort PortPool
ascPortPool Int
port)
          (\(Int
port, Credentials
cert) -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop
              [Stanza ()]
stanzas
              (WebAppConfig ()
wac { waconfigPort = port } WebAppConfig Int -> [WebAppConfig Int] -> [WebAppConfig Int]
forall a. a -> [a] -> [a]
: [WebAppConfig Int]
wacs)
              [BackgroundConfig]
backs
              ([Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map Host (ProxyAction, Credentials)]
 -> Map Host (ProxyAction, Credentials))
-> [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions Map Host (ProxyAction, Credentials)
-> [Map Host (ProxyAction, Credentials)]
-> [Map Host (ProxyAction, Credentials)]
forall a. a -> [a] -> [a]
: (Host -> Map Host (ProxyAction, Credentials))
-> [Host] -> [Map Host (ProxyAction, Credentials)]
forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> Host
-> (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
forall k a. k -> a -> Map k a
Map.singleton Host
host ((Int -> Maybe Int -> ProxyActionRaw
PAPort Int
port (WebAppConfig () -> Maybe Int
forall port. WebAppConfig port -> Maybe Int
waconfigTimeout WebAppConfig ()
wac), Bool
rs), Credentials
cert)) [Host]
hosts))
      where
        hosts :: [Host]
hosts = Set Host -> [Host]
forall a. Set a -> [a]
Set.toList (Set Host -> [Host]) -> Set Host -> [Host]
forall a b. (a -> b) -> a -> b
$ Host -> Set Host -> Set Host
forall a. Ord a => a -> Set a -> Set a
Set.insert (WebAppConfig () -> Host
forall port. WebAppConfig port -> Host
waconfigApprootHost WebAppConfig ()
wac) (WebAppConfig () -> Set Host
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 <- IO Credentials -> KeterM AppStartConfig Credentials
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Credentials -> KeterM AppStartConfig Credentials)
-> IO Credentials -> KeterM AppStartConfig Credentials
forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
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 = [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
                ([Map Host (ProxyAction, Credentials)]
 -> Map Host (ProxyAction, Credentials))
-> [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions0
                Map Host (ProxyAction, Credentials)
-> [Map Host (ProxyAction, Credentials)]
-> [Map Host (ProxyAction, Credentials)]
forall a. a -> [a] -> [a]
: (Host -> Map Host (ProxyAction, Credentials))
-> [Host] -> [Map Host (ProxyAction, Credentials)]
forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> Host
-> (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
forall k a. k -> a -> Map k a
Map.singleton Host
host ((StaticFilesConfig -> ProxyActionRaw
PAStatic StaticFilesConfig
sfc, Bool
rs), Credentials
cert))
                  (Set Host -> [Host]
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 <- IO Credentials -> KeterM AppStartConfig Credentials
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Credentials -> KeterM AppStartConfig Credentials)
-> IO Credentials -> KeterM AppStartConfig Credentials
forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
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 = [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
                ([Map Host (ProxyAction, Credentials)]
 -> Map Host (ProxyAction, Credentials))
-> [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions0
                Map Host (ProxyAction, Credentials)
-> [Map Host (ProxyAction, Credentials)]
-> [Map Host (ProxyAction, Credentials)]
forall a. a -> [a] -> [a]
: (Host -> Map Host (ProxyAction, Credentials))
-> [Host] -> [Map Host (ProxyAction, Credentials)]
forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> Host
-> (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
forall k a. k -> a -> Map k a
Map.singleton Host
host ((RedirectConfig -> ProxyActionRaw
PARedirect RedirectConfig
red, Bool
rs), Credentials
cert))
                  (Set Host -> [Host]
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 <- IO Credentials -> KeterM AppStartConfig Credentials
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Credentials -> KeterM AppStartConfig Credentials)
-> IO Credentials -> KeterM AppStartConfig Credentials
forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
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 = Host
-> (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk (Text -> Host) -> Text -> Host
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
backBackgroundConfig -> [BackgroundConfig] -> [BackgroundConfig]
forall 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-" [Char] -> ShowS
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 <- IO (TVar (Maybe Logger))
-> KeterM AppStartConfig (TVar (Maybe Logger))
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar (Maybe Logger))
 -> KeterM AppStartConfig (TVar (Maybe Logger)))
-> IO (TVar (Maybe Logger))
-> KeterM AppStartConfig (TVar (Maybe Logger))
forall a b. (a -> b) -> a -> b
$ Maybe Logger -> IO (TVar (Maybe Logger))
forall a. a -> IO (TVar a)
newTVarIO Maybe Logger
forall a. Maybe a
Nothing
    AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
aid (TVar (Maybe Logger) -> Maybe (TVar (Maybe Logger))
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
ascTempFolder :: AppStartConfig -> TempFolder
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascHostManager :: AppStartConfig -> HostManager
ascPortPool :: AppStartConfig -> PortPool
ascPlugins :: AppStartConfig -> Plugins
ascKeterConfig :: AppStartConfig -> KeterConfig
ascTempFolder :: TempFolder
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascProcessTracker :: ProcessTracker
ascHostManager :: HostManager
ascPortPool :: PortPool
ascPlugins :: Plugins
ascKeterConfig :: KeterConfig
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe Logger
mappLogger <- IO (Maybe Logger) -> KeterM AppStartConfig (Maybe Logger)
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Logger) -> KeterM AppStartConfig (Maybe Logger))
-> IO (Maybe Logger) -> KeterM AppStartConfig (Maybe Logger)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Logger) -> IO (Maybe Logger)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe Logger)
var
    case Maybe Logger
mappLogger of
        Maybe Logger
Nothing -> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
 -> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
          IO Logger -> (Logger -> IO ()) -> (Logger -> IO a) -> IO a
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
                       ((Logger -> IO a) -> IO a) -> (Logger -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Logger
appLogger -> do
                           STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Logger) -> Maybe Logger -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Logger)
var (Maybe Logger -> STM ()) -> Maybe Logger -> STM ()
forall a b. (a -> b) -> a -> b
$ Logger -> Maybe Logger
forall a. a -> Maybe a
Just Logger
appLogger
                           KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f TVar (Maybe Logger)
var Logger
appLogger
        Just Logger
appLogger ->  TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f TVar (Maybe Logger)
var Logger
appLogger

withSanityChecks :: BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks :: forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig{Object
Vector (Stanza ())
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: Object
bconfigPlugins :: BundleConfig -> Object
..} KeterM AppStartConfig a
f = do
    IO () -> KeterM AppStartConfig ()
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ (Stanza () -> IO ()) -> Vector (Stanza ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ Stanza () -> IO ()
forall {port}. Stanza port -> IO ()
go Vector (Stanza ())
bconfigStanzas
    $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppStartConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
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
Vector Text
Host
Set Text
Set Host
SSLConfig
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
waconfigPort :: forall port. WebAppConfig port -> port
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigExec :: [Char]
waconfigArgs :: Vector Text
waconfigEnvironment :: Map Text Text
waconfigApprootHost :: Host
waconfigHosts :: Set Host
waconfigSsl :: SSLConfig
waconfigPort :: port
waconfigForwardEnv :: Set Text
waconfigTimeout :: Maybe Int
waconfigEnsureAliveTimeout :: Maybe Int
waconfigExec :: forall port. WebAppConfig port -> [Char]
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
..}) Bool
_) = do
      [Char] -> IO ()
isExec [Char]
waconfigExec
      Maybe Int -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
waconfigEnsureAliveTimeout
        ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
x -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KeterException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO ()) -> KeterException -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> KeterException
EnsureAliveShouldBeBiggerThenZero Int
x
    go (Stanza (StanzaBackground BackgroundConfig {[Char]
Word
Map Text Text
Vector Text
Set Text
RestartCount
bgconfigExec :: [Char]
bgconfigArgs :: Vector Text
bgconfigEnvironment :: Map Text Text
bgconfigRestartCount :: RestartCount
bgconfigRestartDelaySeconds :: Word
bgconfigForwardEnv :: Set Text
bgconfigExec :: BackgroundConfig -> [Char]
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigForwardEnv :: BackgroundConfig -> Set Text
..}) Bool
_) = [Char] -> IO ()
isExec [Char]
bgconfigExec
    go Stanza port
_ = () -> IO ()
forall a. a -> IO a
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 () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else KeterException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO ()) -> KeterException -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> KeterException
FileNotExecutable [Char]
fp
            else KeterException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO ()) -> KeterException -> IO ()
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 =
    AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
aid Maybe (TVar (Maybe Logger))
forall a. Maybe a
Nothing ((TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig App)
 -> KeterM AppStartConfig App)
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \TVar (Maybe Logger)
tAppLogger Logger
appLogger ->
    AppId
-> AppInput
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> AppInput
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
aid AppInput
input ((Maybe [Char]
  -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
 -> KeterM AppStartConfig App)
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \Maybe [Char]
newdir BundleConfig
bconfig Maybe EpochTime
mmodtime ->
    BundleConfig
-> KeterM AppStartConfig App -> KeterM AppStartConfig App
forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig
bconfig (KeterM AppStartConfig App -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App -> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$
    AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
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 App)
 -> KeterM AppStartConfig App)
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
webapps [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
    AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
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 (([RunningBackgroundApp] -> KeterM AppStartConfig App)
 -> KeterM AppStartConfig App)
-> ([RunningBackgroundApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \[RunningBackgroundApp]
runningBacks ->
    AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
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 (([RunningWebApp] -> KeterM AppStartConfig App)
 -> KeterM AppStartConfig App)
-> ([RunningWebApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \[RunningWebApp]
runningWebapps -> do
        asc :: AppStartConfig
asc@AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascTempFolder :: AppStartConfig -> TempFolder
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascHostManager :: AppStartConfig -> HostManager
ascPortPool :: AppStartConfig -> PortPool
ascPlugins :: AppStartConfig -> Plugins
ascKeterConfig :: AppStartConfig -> KeterConfig
ascTempFolder :: TempFolder
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascProcessTracker :: ProcessTracker
ascHostManager :: HostManager
ascPortPool :: PortPool
ascPlugins :: Plugins
ascKeterConfig :: KeterConfig
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
        IO () -> KeterM AppStartConfig ()
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ (RunningWebApp -> IO ()) -> [RunningWebApp] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> IO ()
ensureAlive [RunningWebApp]
runningWebapps
        (AppStartConfig -> HostManager)
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> AppStartConfig -> HostManager
forall a b. a -> b -> a
const HostManager
ascHostManager) (KeterM HostManager () -> KeterM AppStartConfig ())
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ AppId
-> Map Host (ProxyAction, Credentials) -> KeterM HostManager ()
activateApp AppId
aid Map Host (ProxyAction, Credentials)
actions
        IO App -> KeterM AppStartConfig App
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO App -> KeterM AppStartConfig App)
-> IO App -> KeterM AppStartConfig App
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
            (TVar (Maybe EpochTime)
 -> TVar [RunningWebApp]
 -> TVar [RunningBackgroundApp]
 -> AppId
 -> TVar (Set Host)
 -> TVar (Maybe [Char])
 -> AppStartConfig
 -> TVar (Maybe Logger)
 -> App)
-> IO (TVar (Maybe EpochTime))
-> IO
     (TVar [RunningWebApp]
      -> TVar [RunningBackgroundApp]
      -> AppId
      -> TVar (Set Host)
      -> TVar (Maybe [Char])
      -> AppStartConfig
      -> TVar (Maybe Logger)
      -> App)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EpochTime -> IO (TVar (Maybe EpochTime))
forall a. a -> IO (TVar a)
newTVarIO Maybe EpochTime
mmodtime
            IO
  (TVar [RunningWebApp]
   -> TVar [RunningBackgroundApp]
   -> AppId
   -> TVar (Set Host)
   -> TVar (Maybe [Char])
   -> AppStartConfig
   -> TVar (Maybe Logger)
   -> App)
-> IO (TVar [RunningWebApp])
-> IO
     (TVar [RunningBackgroundApp]
      -> AppId
      -> TVar (Set Host)
      -> TVar (Maybe [Char])
      -> AppStartConfig
      -> TVar (Maybe Logger)
      -> App)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [RunningWebApp] -> IO (TVar [RunningWebApp])
forall a. a -> IO (TVar a)
newTVarIO [RunningWebApp]
runningWebapps
            IO
  (TVar [RunningBackgroundApp]
   -> AppId
   -> TVar (Set Host)
   -> TVar (Maybe [Char])
   -> AppStartConfig
   -> TVar (Maybe Logger)
   -> App)
-> IO (TVar [RunningBackgroundApp])
-> IO
     (AppId
      -> TVar (Set Host)
      -> TVar (Maybe [Char])
      -> AppStartConfig
      -> TVar (Maybe Logger)
      -> App)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [RunningBackgroundApp] -> IO (TVar [RunningBackgroundApp])
forall a. a -> IO (TVar a)
newTVarIO [RunningBackgroundApp]
runningBacks
            IO
  (AppId
   -> TVar (Set Host)
   -> TVar (Maybe [Char])
   -> AppStartConfig
   -> TVar (Maybe Logger)
   -> App)
-> IO AppId
-> IO
     (TVar (Set Host)
      -> TVar (Maybe [Char])
      -> AppStartConfig
      -> TVar (Maybe Logger)
      -> App)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppId -> IO AppId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AppId
aid
            IO
  (TVar (Set Host)
   -> TVar (Maybe [Char])
   -> AppStartConfig
   -> TVar (Maybe Logger)
   -> App)
-> IO (TVar (Set Host))
-> IO
     (TVar (Maybe [Char])
      -> AppStartConfig -> TVar (Maybe Logger) -> App)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Host -> IO (TVar (Set Host))
forall a. a -> IO (TVar a)
newTVarIO (Map Host (ProxyAction, Credentials) -> Set Host
forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions)
            IO
  (TVar (Maybe [Char])
   -> AppStartConfig -> TVar (Maybe Logger) -> App)
-> IO (TVar (Maybe [Char]))
-> IO (AppStartConfig -> TVar (Maybe Logger) -> App)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [Char] -> IO (TVar (Maybe [Char]))
forall a. a -> IO (TVar a)
newTVarIO Maybe [Char]
newdir
            IO (AppStartConfig -> TVar (Maybe Logger) -> App)
-> IO AppStartConfig -> IO (TVar (Maybe Logger) -> App)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppStartConfig -> IO AppStartConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AppStartConfig
asc
            IO (TVar (Maybe Logger) -> App)
-> IO (TVar (Maybe Logger)) -> IO App
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Maybe Logger) -> IO (TVar (Maybe Logger))
forall a. a -> IO a
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 [b] -> [b]
forall a. a -> a
id
  where
    loop :: ([b] -> [b]) -> [a] -> IO c
loop [b] -> [b]
front [] = [b] -> IO c
inside ([b] -> IO c) -> [b] -> IO c
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 ((b -> IO c) -> IO c) -> (b -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \b
x -> ([b] -> [b]) -> [a] -> IO c
loop ([b] -> [b]
front ([b] -> [b]) -> ([b] -> [b]) -> [b] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b
xb -> [b] -> [b]
forall 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 a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
 -> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
      (WebAppConfig Int -> (RunningWebApp -> IO a) -> IO a)
-> ([RunningWebApp] -> IO a) -> [WebAppConfig Int] -> IO a
forall a b c.
(a -> (b -> IO c) -> IO c) -> ([b] -> IO c) -> [a] -> IO c
bracketedMap (\WebAppConfig Int
wac RunningWebApp -> IO a
f' -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
alloc WebAppConfig Int
wac (IO a -> KeterM AppStartConfig a
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> KeterM AppStartConfig a)
-> (RunningWebApp -> IO a)
-> RunningWebApp
-> KeterM AppStartConfig a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunningWebApp -> IO a
f')) (KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> [RunningWebApp]
-> IO a
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 = AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
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 = [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (AppId -> [Char]
appLogName AppId
aid) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"> " LogStr -> LogStr -> 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 ())
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: Object
..} Maybe [Char]
mdir Logger
appLogger WebAppConfig {Int
[Char]
Maybe Int
Map Text Text
Vector Text
Host
Set Text
Set Host
SSLConfig
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
waconfigPort :: forall port. WebAppConfig port -> port
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigExec :: forall port. WebAppConfig port -> [Char]
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigExec :: [Char]
waconfigArgs :: Vector Text
waconfigEnvironment :: Map Text Text
waconfigApprootHost :: Host
waconfigHosts :: Set Host
waconfigSsl :: SSLConfig
waconfigPort :: Int
waconfigForwardEnv :: Set Text
waconfigTimeout :: Maybe Int
waconfigEnsureAliveTimeout :: Maybe Int
..} RunningWebApp -> KeterM AppStartConfig a
f = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascTempFolder :: AppStartConfig -> TempFolder
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascHostManager :: AppStartConfig -> HostManager
ascPortPool :: AppStartConfig -> PortPool
ascPlugins :: AppStartConfig -> Plugins
ascKeterConfig :: AppStartConfig -> KeterConfig
ascTempFolder :: TempFolder
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascProcessTracker :: ProcessTracker
ascHostManager :: HostManager
ascPortPool :: PortPool
ascPlugins :: Plugins
ascKeterConfig :: KeterConfig
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    [(Text, Text)]
otherEnv <- IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)])
-> IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ascPlugins Text
name Object
bconfigPlugins
    Map Text Text
forwardedEnv <- IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text)
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text))
-> IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text)
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 SSLConfig -> SSLConfig -> Bool
forall a. Eq a => a -> a -> Bool
== SSLConfig
SSLFalse
                then (Text
"http://",  if Int
httpPort  Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==  Int
80 then [Char]
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
httpPort)
                else (Text
"https://", if Int
httpsPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 then [Char]
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
httpsPort)
        env :: [(Text, Text)]
env = Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [Map Text Text] -> Map Text Text
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
            , [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
otherEnv
            , KeterConfig -> Map Text Text
kconfigEnvironment KeterConfig
ascKeterConfig
            , Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"PORT" (Text -> Map Text Text) -> Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
waconfigPort
            , Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"APPROOT" (Text -> Map Text Text) -> Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Host -> Text
forall s. CI s -> s
CI.original Host
waconfigApprootHost Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack [Char]
extport
            ]
    [Char]
exec <- IO [Char] -> KeterM AppStartConfig [Char]
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> KeterM AppStartConfig [Char])
-> IO [Char] -> KeterM AppStartConfig [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
waconfigExec
    ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
 -> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> IO MonitoredProcess
-> (MonitoredProcess -> IO ())
-> (MonitoredProcess -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess)
-> KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess
forall a b. (a -> b) -> a -> b
$ ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> KeterM AppStartConfig MonitoredProcess
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 (Text -> ByteString)
-> ((Text, (UserID, GroupID)) -> Text)
-> (Text, (UserID, GroupID))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (UserID, GroupID)) -> Text
forall a b. (a, b) -> a
fst ((Text, (UserID, GroupID)) -> ByteString)
-> Maybe (Text, (UserID, GroupID)) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, (UserID, GroupID))
ascSetuid)
            (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
exec)
            (ByteString -> ([Char] -> ByteString) -> Maybe [Char] -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> ([Char] -> Text) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack) Maybe [Char]
mdir)
            ((Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 ([Text] -> [ByteString]) -> [Text] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList Vector Text
waconfigArgs)
            (((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 (LogStr -> IO ()) -> (ByteString -> LogStr) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> LogType -> LogStr -> LogStr
formatAppLog AppId
aid (Logger -> LogType
Log.loggerType Logger
appLogger) (LogStr -> LogStr)
-> (ByteString -> LogStr) -> ByteString -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr)
            (IO Bool -> ExitCode -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> ExitCode -> IO Bool) -> IO Bool -> ExitCode -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True))
        MonitoredProcess -> IO ()
terminateMonitoredProcess
        ((MonitoredProcess -> IO a) -> IO a)
-> (MonitoredProcess -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \MonitoredProcess
mp -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
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 = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int
90 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
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
rwaProcess :: RunningWebApp -> MonitoredProcess
rwaPort :: RunningWebApp -> Int
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaProcess :: MonitoredProcess
rwaPort :: Int
rwaEnsureAliveTimeOut :: Int
..} = do
    Text
status <- IO Text -> KeterM cfg Text
forall a. IO a -> KeterM cfg a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> KeterM cfg Text) -> IO Text -> KeterM cfg Text
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 -> Text
Loc -> Text -> LogLevel -> Text -> KeterM cfg ()
(Text -> KeterM cfg ()) -> (Text -> Text) -> Text -> KeterM cfg ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM cfg ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM cfg ()) -> Text -> KeterM cfg ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Killing " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
unpack Text
status [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" running on port: "  [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rwaPort
    IO () -> KeterM cfg ()
forall a. IO a -> KeterM cfg a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM cfg ()) -> IO () -> KeterM cfg ()
forall a b. (a -> b) -> a -> b
$ MonitoredProcess -> IO ()
terminateMonitoredProcess MonitoredProcess
rwaProcess

ensureAlive :: RunningWebApp -> IO ()
ensureAlive :: RunningWebApp -> IO ()
ensureAlive RunningWebApp {Int
MonitoredProcess
rwaProcess :: RunningWebApp -> MonitoredProcess
rwaPort :: RunningWebApp -> Int
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaProcess :: MonitoredProcess
rwaPort :: Int
rwaEnsureAliveTimeOut :: Int
..} = do
    Bool
didAnswer <- Int -> IO Bool
testApp Int
rwaPort
    if Bool
didAnswer
        then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ensureAlive failed, this means keter couldn't " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                      [Char]
"detect your app at port " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rwaPort [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                      [Char]
", check your app logs detailed errors. " [Char] -> ShowS
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 <- Int -> IO Bool -> IO (Maybe Bool)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
rwaEnsureAliveTimeOut IO Bool
testApp'
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
res
      where
        testApp' :: IO Bool
testApp' = do
            Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
            Either IOException Handle
eres <- IO Handle -> IO (Either IOException Handle)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Handle -> IO (Either IOException Handle))
-> IO Handle -> IO (Either IOException Handle)
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO Handle
connectTo [Char]
"127.0.0.1" ([Char] -> IO Handle) -> [Char] -> IO Handle
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
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
                    Bool -> IO Bool
forall a. a -> IO a
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 = [AI_ADDRCONFIG]
                                     , addrSocketType = Stream }
            [AddrInfo]
addrs <- Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO (t AddrInfo)
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
host) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
serv)
            [IO Handle] -> IO Handle
forall {b}. [IO b] -> IO b
firstSuccessful ([IO Handle] -> IO Handle) -> [IO Handle] -> IO Handle
forall a b. (a -> b) -> a -> b
$ (AddrInfo -> IO Handle) -> [AddrInfo] -> [IO Handle]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> IO Handle
tryToConnect [AddrInfo]
addrs
            where
              tryToConnect :: AddrInfo -> IO Handle
tryToConnect AddrInfo
addr =
                IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Handle) -> IO Handle
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 = Maybe IOException -> [IO b] -> IO b
forall {b}. Maybe IOException -> [IO b] -> IO b
go Maybe IOException
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 <- IO b -> IO (Either IOException b)
forall a. IO a -> IO (Either IOException a)
tryIO IO b
p
                    case Either IOException b
r of
                          Right b
x -> b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
                          Left  IOException
e -> Maybe IOException -> [IO b] -> IO b
go (IOException -> Maybe IOException
forall a. a -> Maybe a
Just IOException
e) [IO b]
ps
                 -- All operations failed, throw error if one exists
                  go Maybe IOException
Nothing  [] = IOException -> IO b
forall a. IOException -> IO a
ioError (IOException -> IO b) -> IOException -> IO b
forall a b. (a -> b) -> a -> b
$ [Char] -> IOException
userError [Char]
"connectTo firstSuccessful: empty list"
                  go (Just IOException
e) [] = IOException -> IO b
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 = IO (Either IOException a)
-> (IOException -> IO (Either IOException a))
-> IO (Either IOException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((a -> Either IOException a) -> IO a -> IO (Either IOException a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either IOException a
forall a b. b -> Either a b
Right IO a
m) (Either IOException a -> IO (Either IOException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOException a -> IO (Either IOException a))
-> (IOException -> Either IOException a)
-> IOException
-> IO (Either IOException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Either IOException a
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 a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
 -> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> (BackgroundConfig -> (RunningBackgroundApp -> IO a) -> IO a)
-> ([RunningBackgroundApp] -> IO a) -> [BackgroundConfig] -> IO a
forall a b c.
(a -> (b -> IO c) -> IO c) -> ([b] -> IO c) -> [a] -> IO c
bracketedMap (\BackgroundConfig
cfg RunningBackgroundApp -> IO a
f' -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ BackgroundConfig
-> (RunningBackgroundApp -> IO a) -> KeterM AppStartConfig a
alloc BackgroundConfig
cfg (IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a)
-> (RunningBackgroundApp -> IO a) -> RunningBackgroundApp -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunningBackgroundApp -> IO a
f')) (KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> [RunningBackgroundApp]
-> IO a
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 = AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
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 ())
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: Object
..} Maybe [Char]
mdir Logger
appLogger BackgroundConfig {[Char]
Word
Map Text Text
Vector Text
Set Text
RestartCount
bgconfigExec :: BackgroundConfig -> [Char]
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigExec :: [Char]
bgconfigArgs :: Vector Text
bgconfigEnvironment :: Map Text Text
bgconfigRestartCount :: RestartCount
bgconfigRestartDelaySeconds :: Word
bgconfigForwardEnv :: Set Text
..} RunningBackgroundApp -> IO a
f = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascTempFolder :: AppStartConfig -> TempFolder
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascHostManager :: AppStartConfig -> HostManager
ascPortPool :: AppStartConfig -> PortPool
ascPlugins :: AppStartConfig -> Plugins
ascKeterConfig :: AppStartConfig -> KeterConfig
ascTempFolder :: TempFolder
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascProcessTracker :: ProcessTracker
ascHostManager :: HostManager
ascPortPool :: PortPool
ascPlugins :: Plugins
ascKeterConfig :: KeterConfig
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    [(Text, Text)]
otherEnv <- IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)])
-> IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ascPlugins Text
name Object
bconfigPlugins
    Map Text Text
forwardedEnv <- IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text)
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text))
-> IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text)
forall a b. (a -> b) -> a -> b
$ Set Text -> IO (Map Text Text)
getForwardedEnv Set Text
bgconfigForwardEnv
    let env :: [(Text, Text)]
env = Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [Map Text Text] -> Map Text Text
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
            , [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
otherEnv
            , KeterConfig -> Map Text Text
kconfigEnvironment KeterConfig
ascKeterConfig
            ]
    [Char]
exec <- IO [Char] -> KeterM AppStartConfig [Char]
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> KeterM AppStartConfig [Char])
-> IO [Char] -> KeterM AppStartConfig [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
canonicalizePath [Char]
bgconfigExec

    let delay :: IO ()
delay = Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Word
bgconfigRestartDelaySeconds Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
1000 Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
1000
    IO Bool
shouldRestart <-
        case RestartCount
bgconfigRestartCount of
            RestartCount
UnlimitedRestarts -> IO Bool -> KeterM AppStartConfig (IO Bool)
forall a. a -> KeterM AppStartConfig a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO Bool -> KeterM AppStartConfig (IO Bool))
-> IO Bool -> KeterM AppStartConfig (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
                IO ()
delay
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            LimitedRestarts Word
maxCount -> do
                IORef Word
icount <- IO (IORef Word) -> KeterM AppStartConfig (IORef Word)
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Word) -> KeterM AppStartConfig (IORef Word))
-> IO (IORef Word) -> KeterM AppStartConfig (IORef Word)
forall a b. (a -> b) -> a -> b
$ Word -> IO (IORef Word)
forall a. a -> IO (IORef a)
newIORef Word
0
                IO Bool -> KeterM AppStartConfig (IO Bool)
forall a. a -> KeterM AppStartConfig a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO Bool -> KeterM AppStartConfig (IO Bool))
-> IO Bool -> KeterM AppStartConfig (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
                    Bool
res <- IORef Word -> (Word -> (Word, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Word
icount ((Word -> (Word, Bool)) -> IO Bool)
-> (Word -> (Word, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Word
count ->
                        (Word
count Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1, Word
count Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
maxCount)
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
res IO ()
delay
                    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
res
    ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
 -> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> IO MonitoredProcess
-> (MonitoredProcess -> IO ())
-> (MonitoredProcess -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess)
-> KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess
forall a b. (a -> b) -> a -> b
$ ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> KeterM AppStartConfig MonitoredProcess
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 (Text -> ByteString)
-> ((Text, (UserID, GroupID)) -> Text)
-> (Text, (UserID, GroupID))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (UserID, GroupID)) -> Text
forall a b. (a, b) -> a
fst ((Text, (UserID, GroupID)) -> ByteString)
-> Maybe (Text, (UserID, GroupID)) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, (UserID, GroupID))
ascSetuid)
            (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
exec)
            (ByteString -> ([Char] -> ByteString) -> Maybe [Char] -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> ([Char] -> Text) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack) Maybe [Char]
mdir)
            ((Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 ([Text] -> [ByteString]) -> [Text] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList Vector Text
bgconfigArgs)
            (((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 (LogStr -> IO ()) -> (ByteString -> LogStr) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> LogType -> LogStr -> LogStr
formatAppLog AppId
aid (Logger -> LogType
Log.loggerType Logger
appLogger) (LogStr -> LogStr)
-> (ByteString -> LogStr) -> ByteString -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr)
            (IO Bool -> ExitCode -> IO Bool
forall a b. a -> b -> a
const IO Bool
shouldRestart))
        MonitoredProcess -> IO ()
terminateMonitoredProcess
        (RunningBackgroundApp -> IO a
f (RunningBackgroundApp -> IO a)
-> (MonitoredProcess -> RunningBackgroundApp)
-> MonitoredProcess
-> IO a
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 :: RunningBackgroundApp -> MonitoredProcess
rbaProcess :: 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
appModTime :: App -> TVar (Maybe EpochTime)
appRunningWebApps :: App -> TVar [RunningWebApp]
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appId :: App -> AppId
appHosts :: App -> TVar (Set Host)
appDir :: App -> TVar (Maybe [Char])
appAsc :: App -> AppStartConfig
appLog :: App -> TVar (Maybe Logger)
appModTime :: TVar (Maybe EpochTime)
appRunningWebApps :: TVar [RunningWebApp]
appBackgroundApps :: TVar [RunningBackgroundApp]
appId :: AppId
appHosts :: TVar (Set Host)
appDir :: TVar (Maybe [Char])
appAsc :: AppStartConfig
appLog :: TVar (Maybe Logger)
..} <- KeterM App App
forall r (m :: * -> *). MonadReader r m => m r
ask
    (App -> AppStartConfig)
-> KeterM AppStartConfig () -> KeterM App ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (AppStartConfig -> App -> AppStartConfig
forall a b. a -> b -> a
const AppStartConfig
appAsc) (KeterM AppStartConfig () -> KeterM App ())
-> KeterM AppStartConfig () -> KeterM App ()
forall a b. (a -> b) -> a -> b
$
      AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
appId (TVar (Maybe Logger) -> Maybe (TVar (Maybe Logger))
forall a. a -> Maybe a
Just TVar (Maybe Logger)
appLog) ((TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig ())
 -> KeterM AppStartConfig ())
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \TVar (Maybe Logger)
_ Logger
appLogger ->
      AppId
-> AppInput
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> AppInput
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
appId AppInput
input ((Maybe [Char]
  -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
 -> KeterM AppStartConfig ())
-> (Maybe [Char]
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \Maybe [Char]
newdir BundleConfig
bconfig Maybe EpochTime
mmodtime ->
      BundleConfig
-> KeterM AppStartConfig () -> KeterM AppStartConfig ()
forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig
bconfig (KeterM AppStartConfig () -> KeterM AppStartConfig ())
-> KeterM AppStartConfig () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$
      AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withReservations AppId
appId BundleConfig
bconfig (([WebAppConfig Int]
  -> [BackgroundConfig]
  -> Map Host (ProxyAction, Credentials)
  -> KeterM AppStartConfig ())
 -> KeterM AppStartConfig ())
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
webapps [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
      AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
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 (([RunningBackgroundApp] -> KeterM AppStartConfig ())
 -> KeterM AppStartConfig ())
-> ([RunningBackgroundApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \[RunningBackgroundApp]
runningBacks ->
      AppId
-> BundleConfig
-> Maybe [Char]
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
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 (([RunningWebApp] -> KeterM AppStartConfig ())
 -> KeterM AppStartConfig ())
-> ([RunningWebApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \[RunningWebApp]
runningWebapps -> do
          IO () -> KeterM AppStartConfig ()
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ (RunningWebApp -> IO ()) -> [RunningWebApp] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> IO ()
ensureAlive [RunningWebApp]
runningWebapps
          IO (Set Host) -> KeterM AppStartConfig (Set Host)
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar (Set Host) -> IO (Set Host)
forall a. TVar a -> IO a
readTVarIO TVar (Set Host)
appHosts) KeterM AppStartConfig (Set Host)
-> (Set Host -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b.
KeterM AppStartConfig a
-> (a -> KeterM AppStartConfig b) -> KeterM AppStartConfig b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Set Host
hosts ->
            (AppStartConfig -> HostManager)
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> AppStartConfig -> HostManager
forall a b. a -> b -> a
const (HostManager -> AppStartConfig -> HostManager)
-> HostManager -> AppStartConfig -> HostManager
forall a b. (a -> b) -> a -> b
$ AppStartConfig -> HostManager
ascHostManager AppStartConfig
appAsc) (KeterM HostManager () -> KeterM AppStartConfig ())
-> KeterM HostManager () -> KeterM AppStartConfig ()
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) <- IO
  ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
   Maybe Logger)
-> KeterM
     AppStartConfig
     ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
    Maybe Logger)
 -> KeterM
      AppStartConfig
      ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
       Maybe Logger))
-> IO
     ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
-> KeterM
     AppStartConfig
     ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a b. (a -> b) -> a -> b
$ STM
  ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
   Maybe Logger)
-> IO
     ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a. STM a -> IO a
atomically (STM
   ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
    Maybe Logger)
 -> IO
      ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
       Maybe Logger))
-> STM
     ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
-> IO
     ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a b. (a -> b) -> a -> b
$ do
              [RunningWebApp]
oldApps <- TVar [RunningWebApp] -> STM [RunningWebApp]
forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
              [RunningBackgroundApp]
oldBacks <- TVar [RunningBackgroundApp] -> STM [RunningBackgroundApp]
forall a. TVar a -> STM a
readTVar TVar [RunningBackgroundApp]
appBackgroundApps
              Maybe [Char]
oldDir <- TVar (Maybe [Char]) -> STM (Maybe [Char])
forall a. TVar a -> STM a
readTVar TVar (Maybe [Char])
appDir
              Maybe Logger
oldRlog <- TVar (Maybe Logger) -> STM (Maybe Logger)
forall a. TVar a -> STM a
readTVar TVar (Maybe Logger)
appLog

              TVar (Maybe EpochTime) -> Maybe EpochTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe EpochTime)
appModTime Maybe EpochTime
mmodtime
              TVar [RunningWebApp] -> [RunningWebApp] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningWebApp]
appRunningWebApps [RunningWebApp]
runningWebapps
              TVar [RunningBackgroundApp] -> [RunningBackgroundApp] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningBackgroundApp]
appBackgroundApps [RunningBackgroundApp]
runningBacks
              TVar (Set Host) -> Set Host -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Set Host)
appHosts (Set Host -> STM ()) -> Set Host -> STM ()
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials) -> Set Host
forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions
              TVar (Maybe [Char]) -> Maybe [Char] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe [Char])
appDir Maybe [Char]
newdir
              ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
 Maybe Logger)
-> STM
     ([RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RunningWebApp]
oldApps, [RunningBackgroundApp]
oldBacks, Maybe [Char]
oldDir, Maybe Logger
oldRlog)
          KeterM AppStartConfig ThreadId -> KeterM AppStartConfig ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KeterM AppStartConfig ThreadId -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ThreadId -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ ((forall a. KeterM AppStartConfig a -> IO a) -> IO ThreadId)
-> KeterM AppStartConfig ThreadId
forall b.
((forall a. KeterM AppStartConfig a -> IO a) -> IO b)
-> KeterM AppStartConfig b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO ThreadId)
 -> KeterM AppStartConfig ThreadId)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO ThreadId)
-> KeterM AppStartConfig ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
            IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ KeterM AppStartConfig () -> IO ()
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig () -> IO ())
-> KeterM AppStartConfig () -> IO ()
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
appModTime :: App -> TVar (Maybe EpochTime)
appRunningWebApps :: App -> TVar [RunningWebApp]
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appId :: App -> AppId
appHosts :: App -> TVar (Set Host)
appDir :: App -> TVar (Maybe [Char])
appAsc :: App -> AppStartConfig
appLog :: App -> TVar (Maybe Logger)
appModTime :: TVar (Maybe EpochTime)
appRunningWebApps :: TVar [RunningWebApp]
appBackgroundApps :: TVar [RunningBackgroundApp]
appId :: AppId
appHosts :: TVar (Set Host)
appDir :: TVar (Maybe [Char])
appAsc :: AppStartConfig
appLog :: TVar (Maybe Logger)
..} <- KeterM App App
forall r (m :: * -> *). MonadReader r m => m r
ask
    let AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascTempFolder :: AppStartConfig -> TempFolder
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascHostManager :: AppStartConfig -> HostManager
ascPortPool :: AppStartConfig -> PortPool
ascPlugins :: AppStartConfig -> Plugins
ascKeterConfig :: AppStartConfig -> KeterConfig
ascTempFolder :: TempFolder
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascProcessTracker :: ProcessTracker
ascHostManager :: HostManager
ascPortPool :: PortPool
ascPlugins :: Plugins
ascKeterConfig :: KeterConfig
..} = AppStartConfig
appAsc
    (Set Host
hosts, [RunningWebApp]
apps, [RunningBackgroundApp]
backs, Maybe [Char]
mdir, Maybe Logger
appLogger) <- IO
  (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
   Maybe Logger)
-> KeterM
     App
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a. IO a -> KeterM App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
    Maybe Logger)
 -> KeterM
      App
      (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
       Maybe Logger))
-> IO
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
-> KeterM
     App
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a b. (a -> b) -> a -> b
$ STM
  (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
   Maybe Logger)
-> IO
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a. STM a -> IO a
atomically (STM
   (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
    Maybe Logger)
 -> IO
      (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
       Maybe Logger))
-> STM
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
-> IO
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe [Char],
      Maybe Logger)
forall a b. (a -> b) -> a -> b
$ do
        Set Host
hosts <- TVar (Set Host) -> STM (Set Host)
forall a. TVar a -> STM a
readTVar TVar (Set Host)
appHosts
        [RunningWebApp]
apps <- TVar [RunningWebApp] -> STM [RunningWebApp]
forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
        [RunningBackgroundApp]
backs <- TVar [RunningBackgroundApp] -> STM [RunningBackgroundApp]
forall a. TVar a -> STM a
readTVar TVar [RunningBackgroundApp]
appBackgroundApps
        Maybe [Char]
mdir <- TVar (Maybe [Char]) -> STM (Maybe [Char])
forall a. TVar a -> STM a
readTVar TVar (Maybe [Char])
appDir
        Maybe Logger
appLogger <- TVar (Maybe Logger) -> STM (Maybe Logger)
forall a. TVar a -> STM a
readTVar TVar (Maybe Logger)
appLog

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

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

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

    KeterM App ThreadId -> KeterM App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KeterM App ThreadId -> KeterM App ())
-> KeterM App ThreadId -> KeterM App ()
forall a b. (a -> b) -> a -> b
$ ((forall a. KeterM App a -> IO a) -> IO ThreadId)
-> KeterM App ThreadId
forall b.
((forall a. KeterM App a -> IO a) -> IO b) -> KeterM App b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM App a -> IO a) -> IO ThreadId)
 -> KeterM App ThreadId)
-> ((forall a. KeterM App a -> IO a) -> IO ThreadId)
-> KeterM App ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM App a -> IO a
rio ->
      IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ KeterM App () -> IO ()
forall a. KeterM App a -> IO a
rio (KeterM App () -> IO ()) -> KeterM App () -> IO ()
forall a b. (a -> b) -> a -> b
$ (App -> AppStartConfig)
-> KeterM AppStartConfig () -> KeterM App ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (AppStartConfig -> App -> AppStartConfig
forall a b. a -> b -> a
const AppStartConfig
appAsc) (KeterM AppStartConfig () -> KeterM App ())
-> KeterM AppStartConfig () -> KeterM App ()
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
    IO () -> KeterM App ()
forall a. IO a -> KeterM App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM App ()) -> IO () -> KeterM App ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Logger -> IO ()) -> Maybe Logger -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
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
    IO () -> KeterM AppStartConfig ()
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
    $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppStartConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
        [Char]
"Sending old process TERM signal: "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ case AppId
aid of { AINamed Text
t -> Text -> [Char]
unpack Text
t; AppId
AIBuiltin -> [Char]
"builtin" }
    (RunningWebApp -> KeterM AppStartConfig ())
-> [RunningWebApp] -> KeterM AppStartConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> KeterM AppStartConfig ()
forall cfg. RunningWebApp -> KeterM cfg ()
killWebApp [RunningWebApp]
apps
    IO () -> KeterM AppStartConfig ()
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ do
        (RunningBackgroundApp -> IO ()) -> [RunningBackgroundApp] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningBackgroundApp -> IO ()
killBackgroundApp [RunningBackgroundApp]
backs
        Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
    case Maybe [Char]
mdir of
        Maybe [Char]
Nothing -> () -> KeterM AppStartConfig ()
forall a. a -> KeterM AppStartConfig a
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 -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppStartConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Removing unneeded folder: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
dir
            Either SomeException ()
res <- IO (Either SomeException ())
-> KeterM AppStartConfig (Either SomeException ())
forall a. IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException ())
 -> KeterM AppStartConfig (Either SomeException ()))
-> IO (Either SomeException ())
-> KeterM AppStartConfig (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either 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 -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppStartConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logError (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
                Right () -> () -> KeterM AppStartConfig ()
forall a. a -> KeterM AppStartConfig a
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 = TVar (Maybe EpochTime) -> STM (Maybe EpochTime)
forall a. TVar a -> STM a
readTVar (TVar (Maybe EpochTime) -> STM (Maybe EpochTime))
-> (App -> TVar (Maybe EpochTime)) -> App -> STM (Maybe EpochTime)
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 = [[(Text, Text)]] -> [(Text, Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Text, Text)]] -> [(Text, Text)])
-> IO [[(Text, Text)]] -> IO [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Plugin -> IO [(Text, Text)]) -> Plugins -> IO [[(Text, Text)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 ([([Char], [Char])] -> Map Text Text)
-> IO [([Char], [Char])] -> IO (Map Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [([Char], [Char])]
getEnvironment
  where
    filterEnv :: [([Char], [Char])] -> Map Text Text
filterEnv = (Text -> Text -> Bool) -> Map Text Text -> Map Text Text
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Text
k Text
_ -> Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
k Set Text
vars)
              (Map Text Text -> Map Text Text)
-> ([([Char], [Char])] -> Map Text Text)
-> [([Char], [Char])]
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              ([(Text, Text)] -> Map Text Text)
-> ([([Char], [Char])] -> [(Text, Text)])
-> [([Char], [Char])]
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> (Text, Text))
-> [([Char], [Char])] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
pack ([Char] -> Text)
-> ([Char] -> Text) -> ([Char], [Char]) -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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
            -}