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

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

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

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

-- | 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 String)
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe String)
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe String)
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} = do
  Maybe EpochTime
appModTime' <- 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> STM Text) -> Text -> STM Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
    (AppId -> String
forall a. Show a => a -> String
show AppId
appId) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    String
" modtime: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Maybe EpochTime -> String
forall a. Show a => a -> String
show Maybe EpochTime
appModTime') String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
", webappsRunning: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  [RunningWebApp] -> String
forall a. Show a => a -> String
show [RunningWebApp]
appRunning' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", hosts: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set Host -> String
forall a. Show a => a -> String
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 -> String
show (RunningWebApp {Int
MonitoredProcess
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..})  = String
"RunningWebApp{rwaPort=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rwaPort String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", rwaEnsureAliveTimeOut=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rwaEnsureAliveTimeOut String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
",..}"

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

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

        Either ParseException BundleConfig
mconfig <- String -> IO (Either ParseException BundleConfig)
forall a. ParseYamlFile a => String -> IO (Either ParseException a)
decodeFileRelative String
configFP
        BundleConfig
config <-
            case Either ParseException BundleConfig
mconfig of
                Right BundleConfig
config -> BundleConfig -> IO BundleConfig
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
        (String, BundleConfig) -> IO (String, BundleConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
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 String
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
_aid (AIData BundleConfig
bconfig) Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f = Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f Maybe String
forall a. Maybe a
Nothing BundleConfig
bconfig Maybe EpochTime
forall a. Maybe a
Nothing
withConfig AppId
aid (AIBundle String
fp EpochTime
modtime) Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f = do
    ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
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 (String, BundleConfig)
-> ((String, BundleConfig) -> IO ())
-> ((String, BundleConfig) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (KeterM AppStartConfig (String, BundleConfig)
-> IO (String, BundleConfig)
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig (String, BundleConfig)
 -> IO (String, BundleConfig))
-> KeterM AppStartConfig (String, BundleConfig)
-> IO (String, BundleConfig)
forall a b. (a -> b) -> a -> b
$ String -> AppId -> KeterM AppStartConfig (String, BundleConfig)
unpackBundle String
fp AppId
aid) (\(String
newdir, BundleConfig
_) -> String -> IO ()
removeDirectoryRecursive String
newdir) (((String, BundleConfig) -> IO a) -> IO a)
-> ((String, BundleConfig) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(String
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 String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f (String -> Maybe String
forall a. a -> Maybe a
Just String
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
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- 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 (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)
              (\Set Host
rsvs -> KeterM AppStartConfig () -> IO ()
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig () -> IO ())
-> KeterM AppStartConfig () -> IO ()
forall a b. (a -> b) -> a -> b
$ (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 -> Set Host -> KeterM HostManager ()
forgetReservations AppId
aid Set Host
rsvs)
              (\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 String
certFile Vector String
chainCertFiles String
keyFile) =
         (String -> Credentials)
-> (Credential -> Credentials)
-> Either String Credential
-> Credentials
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Credentials -> String -> 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 String Credential -> Credentials)
-> IO (Either String Credential) -> IO Credentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO (Either String Credential)
TLS.credentialLoadX509Chain String
certFile (Vector String -> [String]
forall a. Vector a -> [a]
V.toList Vector String
chainCertFiles) String
keyFile
    loadCert SSLConfig
_ = Credentials -> IO Credentials
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
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- 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 (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 (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 (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 (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 :: Int
waconfigPort = Int
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 (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 (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 (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 -> String
appLogName AppId
AIBuiltin = String
"__builtin__"
appLogName (AINamed Text
x) = String
"app-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
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 (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
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe Logger
mappLogger <- IO (Maybe Logger) -> KeterM AppStartConfig (Maybe Logger)
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 (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 -> String -> IO Logger
Log.createLoggerViaConfig KeterConfig
ascKeterConfig (AppId -> String
appLogName AppId
aid)) Logger -> IO ()
Log.loggerClose (KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> (Logger -> KeterM AppStartConfig a) -> Logger -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f TVar (Maybe Logger)
var)
        Just Logger
appLogger ->  TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f TVar (Maybe Logger)
var Logger
appLogger
  where

withSanityChecks :: BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks :: forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig{Object
Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} KeterM AppStartConfig a
f = do
    cfg :: AppStartConfig
cfg@AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> KeterM AppStartConfig ()
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
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo Text
"Sanity checks passed"
    KeterM AppStartConfig a
f
  where
    go :: Stanza port -> IO ()
go (Stanza (StanzaWebApp WebAppConfig {port
String
Maybe Int
Map Text Text
Host
Set Text
Set Host
Vector Text
SSLConfig
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigExec :: forall port. WebAppConfig port -> String
waconfigEnsureAliveTimeout :: Maybe Int
waconfigTimeout :: Maybe Int
waconfigForwardEnv :: Set Text
waconfigPort :: port
waconfigSsl :: SSLConfig
waconfigHosts :: Set Host
waconfigApprootHost :: Host
waconfigEnvironment :: Map Text Text
waconfigArgs :: Vector Text
waconfigExec :: String
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigPort :: forall port. WebAppConfig port -> port
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
..}) Bool
_) = do
      String -> IO ()
isExec String
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 {String
Word
Map Text Text
Set Text
Vector Text
RestartCount
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigExec :: BackgroundConfig -> String
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: String
..}) Bool
_) = String -> IO ()
isExec String
bgconfigExec
    go Stanza port
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    isExec :: String -> IO ()
isExec String
fp = do
        Bool
exists <- String -> IO Bool
doesFileExist String
fp
        if Bool
exists
            then do
                Bool
canExec <- String -> Bool -> Bool -> Bool -> IO Bool
fileAccess String
fp Bool
True Bool
False Bool
True
                if Bool
canExec
                    then () -> IO ()
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
$ String -> KeterException
FileNotExecutable String
fp
            else KeterException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO ()) -> KeterException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> KeterException
ExecutableNotFound String
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 String
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> AppInput
-> (Maybe String
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
aid AppInput
input ((Maybe String
  -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
 -> KeterM AppStartConfig App)
-> (Maybe String
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \Maybe String
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 String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
aid BundleConfig
bconfig Maybe String
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 String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
aid BundleConfig
bconfig Maybe String
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
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
        IO () -> KeterM AppStartConfig ()
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 (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 String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App
App
            (TVar (Maybe EpochTime)
 -> TVar [RunningWebApp]
 -> TVar [RunningBackgroundApp]
 -> AppId
 -> TVar (Set Host)
 -> TVar (Maybe String)
 -> AppStartConfig
 -> TVar (Maybe Logger)
 -> App)
-> IO (TVar (Maybe EpochTime))
-> IO
     (TVar [RunningWebApp]
      -> TVar [RunningBackgroundApp]
      -> AppId
      -> TVar (Set Host)
      -> TVar (Maybe String)
      -> 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 String)
   -> AppStartConfig
   -> TVar (Maybe Logger)
   -> App)
-> IO (TVar [RunningWebApp])
-> IO
     (TVar [RunningBackgroundApp]
      -> AppId
      -> TVar (Set Host)
      -> TVar (Maybe String)
      -> AppStartConfig
      -> TVar (Maybe Logger)
      -> App)
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 String)
   -> AppStartConfig
   -> TVar (Maybe Logger)
   -> App)
-> IO (TVar [RunningBackgroundApp])
-> IO
     (AppId
      -> TVar (Set Host)
      -> TVar (Maybe String)
      -> AppStartConfig
      -> TVar (Maybe Logger)
      -> App)
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 String)
   -> AppStartConfig
   -> TVar (Maybe Logger)
   -> App)
-> IO AppId
-> IO
     (TVar (Set Host)
      -> TVar (Maybe String)
      -> AppStartConfig
      -> TVar (Maybe Logger)
      -> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppId -> IO AppId
forall (m :: * -> *) a. Monad m => a -> m a
return AppId
aid
            IO
  (TVar (Set Host)
   -> TVar (Maybe String)
   -> AppStartConfig
   -> TVar (Maybe Logger)
   -> App)
-> IO (TVar (Set Host))
-> IO
     (TVar (Maybe String)
      -> AppStartConfig -> TVar (Maybe Logger) -> App)
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 String)
   -> AppStartConfig -> TVar (Maybe Logger) -> App)
-> IO (TVar (Maybe String))
-> IO (AppStartConfig -> TVar (Maybe Logger) -> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe String -> IO (TVar (Maybe String))
forall a. a -> IO (TVar a)
newTVarIO Maybe String
newdir
            IO (AppStartConfig -> TVar (Maybe Logger) -> App)
-> IO AppStartConfig -> IO (TVar (Maybe Logger) -> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppStartConfig -> IO AppStartConfig
forall (m :: * -> *) a. Monad m => a -> m a
return AppStartConfig
asc
            IO (TVar (Maybe Logger) -> App)
-> IO (TVar (Maybe Logger)) -> IO App
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Maybe Logger) -> IO (TVar (Maybe Logger))
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 String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
aid BundleConfig
bconfig Maybe String
mdir Logger
appLogger [WebAppConfig Int]
configs0 [RunningWebApp] -> KeterM AppStartConfig a
f =
    ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
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 (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 String
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
launchWebApp AppId
aid BundleConfig
bconfig Maybe String
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 = String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (AppId -> String
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 String
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
launchWebApp AppId
aid BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} Maybe String
mdir Logger
appLogger WebAppConfig {Int
String
Maybe Int
Map Text Text
Host
Set Text
Set Host
Vector Text
SSLConfig
waconfigEnsureAliveTimeout :: Maybe Int
waconfigTimeout :: Maybe Int
waconfigForwardEnv :: Set Text
waconfigPort :: Int
waconfigSsl :: SSLConfig
waconfigHosts :: Set Host
waconfigApprootHost :: Host
waconfigEnvironment :: Map Text Text
waconfigArgs :: Vector Text
waconfigExec :: String
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigExec :: forall port. WebAppConfig port -> String
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigPort :: forall port. WebAppConfig port -> port
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
..} RunningWebApp -> KeterM AppStartConfig a
f = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    [(Text, Text)]
otherEnv <- IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
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 (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, String
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 String
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
httpPort)
                else (Text
"https://", if Int
httpsPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 then String
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
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
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
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
<> String -> Text
pack String
extport
            ]
    String
exec <- IO String -> KeterM AppStartConfig String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> KeterM AppStartConfig String)
-> IO String -> KeterM AppStartConfig String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
waconfigExec
    Loc -> Text -> LogLevel -> LogStr -> IO ()
mainLogger <- KeterM AppStartConfig (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
    ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
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
$ String -> Text
pack String
exec)
            (ByteString -> (String -> ByteString) -> Maybe String -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) Maybe String
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 (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 (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 :: MonitoredProcess -> Int -> Int -> RunningWebApp
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
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..} = do
    Text
status <- IO Text -> KeterM cfg Text
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
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM cfg ()
(Text -> KeterM cfg ()) -> (Text -> Text) -> Text -> KeterM cfg ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo (Text -> KeterM cfg ()) -> Text -> KeterM cfg ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Killing " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
status String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" running on port: "  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rwaPort
    IO () -> KeterM cfg ()
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
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..} = do
    Bool
didAnswer <- Int -> IO Bool
testApp Int
rwaPort
    if Bool
didAnswer
        then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ensureAlive failed, this means keter couldn't " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                      String
"detect your app at port " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rwaPort String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                      String
", check your app logs detailed errors. " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                      String
" 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 (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
$ String -> String -> IO Handle
connectTo String
"127.0.0.1" (String -> IO Handle) -> String -> IO Handle
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        connectTo :: String -> String -> IO Handle
connectTo String
host String
serv = do
            let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
                                     , addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
            [AddrInfo]
addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just String
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 (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
$ String -> IOException
userError (String -> IOException) -> String -> IOException
forall a b. (a -> b) -> a -> b
$ String
"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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Either IOException a
forall a b. b -> Either a b
Right IO a
m) (Either IOException a -> IO (Either IOException 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 String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
aid BundleConfig
bconfig Maybe String
mdir Logger
appLogger [BackgroundConfig]
configs [RunningBackgroundApp] -> KeterM AppStartConfig a
f =
    ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
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 (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 String
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
launchBackgroundApp AppId
aid BundleConfig
bconfig Maybe String
mdir Logger
appLogger

launchBackgroundApp :: AppId
                    -> BundleConfig
                    -> Maybe FilePath
                    -> Logger 
                    -> BackgroundConfig
                    -> (RunningBackgroundApp -> IO a)
                    -> KeterM AppStartConfig a
launchBackgroundApp :: forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
launchBackgroundApp AppId
aid BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} Maybe String
mdir Logger
appLogger BackgroundConfig {String
Word
Map Text Text
Set Text
Vector Text
RestartCount
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: String
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigExec :: BackgroundConfig -> String
..} RunningBackgroundApp -> IO a
f = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    [(Text, Text)]
otherEnv <- IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
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 (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
            ]
    String
exec <- IO String -> KeterM AppStartConfig String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> KeterM AppStartConfig String)
-> IO String -> KeterM AppStartConfig String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Bool
res
    Loc -> Text -> LogLevel -> LogStr -> IO ()
mainLogger <- KeterM AppStartConfig (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
    ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
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
$ String -> Text
pack String
exec)
            (ByteString -> (String -> ByteString) -> Maybe String -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) Maybe String
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 (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 :: MonitoredProcess
rbaProcess :: RunningBackgroundApp -> MonitoredProcess
..} = do
    MonitoredProcess -> IO ()
terminateMonitoredProcess MonitoredProcess
rbaProcess

    {-
start :: TempFolder
      -> Maybe (Text, (UserID, GroupID))
      -> ProcessTracker
      -> HostManager
      -> Plugins
      -> RotatingLog
      -> Appname
      -> (Maybe BundleConfig)
      -> KIO () -- ^ action to perform to remove this App from list of actives
      -> KIO (App, KIO ())
start tf muid processTracker portman plugins appLogger appname bundle removeFromList = do
    Prelude.error "FIXME Keter.App.start"
    chan <- newChan
    return (App $ writeChan chan, rest chan)
  where

    rest chan = forkKIO $ do
        mres <- unpackBundle tf (snd <$> muid) bundle appname
        case mres of
            Left e -> do
                $logEx e
                removeFromList
            Right (dir, config) -> do
                let common = do
                        mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ bconfigStaticHosts config
                        mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ bconfigRedirects config
                case bconfigApp config of
                    Nothing -> do
                        common
                        loop chan dir config Nothing
                    Just appconfig -> do
                        eport <- getPort portman
                        case eport of
                            Left e -> do
                                $logEx e
                                removeFromList
                            Right port -> do
                                eprocess <- runApp port dir appconfig
                                case eprocess of
                                    Left e -> do
                                        $logEx e
                                        removeFromList
                                    Right process -> do
                                        b <- testApp port
                                        if b
                                            then do
                                                addEntry portman (aconfigHost appconfig) $ PEPort port
                                                mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig
                                                common
                                                loop chan dir config $ Just (process, port)
                                            else do
                                                removeFromList
                                                releasePort portman port
                                                void $ liftIO $ terminateMonitoredProcess process

    loop chan dirOld configOld mprocPortOld = do
        command <- readChan chan
        case command of
            Terminate -> do
                removeFromList
                case bconfigApp configOld of
                    Nothing -> return ()
                    Just appconfig -> do
                        removeEntry portman $ aconfigHost appconfig
                        mapM_ (removeEntry portman) $ Set.toList $ aconfigExtraHosts appconfig
                mapM_ (removeEntry portman) $ map shHost $ Set.toList $ bconfigStaticHosts configOld
                mapM_ (removeEntry portman) $ map redFrom $ Set.toList $ bconfigRedirects configOld
                log $ TerminatingApp appname
                terminateOld
            Reload -> do
                mres <- unpackBundle tf (snd <$> muid) bundle appname
                case mres of
                    Left e -> do
                        log $ InvalidBundle bundle e
                        loop chan dirOld configOld mprocPortOld
                    Right (dir, config) -> do
                        eport <- getPort portman
                        case eport of
                            Left e -> $logEx e
                            Right port -> do
                                let common = do
                                        mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ bconfigStaticHosts config
                                        mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ bconfigRedirects config
                                case bconfigApp config of
                                    Nothing -> do
                                        common
                                        loop chan dir config Nothing
                                    Just appconfig -> do
                                        eprocess <- runApp port dir appconfig
                                        mprocess <-
                                            case eprocess of
                                                Left _ -> return Nothing
                                                Right process -> do
                                                    b <- testApp port
                                                    return $ if b
                                                        then Just process
                                                        else Nothing
                                        case mprocess of
                                            Just process -> do
                                                addEntry portman (aconfigHost appconfig) $ PEPort port
                                                mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig
                                                common
                                                case bconfigApp configOld of
                                                    Just appconfigOld | aconfigHost appconfig /= aconfigHost appconfigOld ->
                                                        removeEntry portman $ aconfigHost appconfigOld
                                                    _ -> return ()
                                                log $ FinishedReloading appname
                                                terminateOld
                                                loop chan dir config $ Just (process, port)
                                            Nothing -> do
                                                releasePort portman port
                                                case eprocess of
                                                    Left _ -> return ()
                                                    Right process -> void $ liftIO $ terminateMonitoredProcess process
                                                log $ ProcessDidNotStart bundle
                                                loop chan dirOld configOld mprocPortOld
      where
        terminateOld = forkKIO $ do
    -}

reload :: AppInput -> KeterM App ()
reload :: AppInput -> KeterM App ()
reload AppInput
input = do
    App{TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe String)
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe String)
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe String)
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} <- 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 String
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> AppInput
-> (Maybe String
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
appId AppInput
input ((Maybe String
  -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
 -> KeterM AppStartConfig ())
-> (Maybe String
    -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \Maybe String
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 String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
appId BundleConfig
bconfig Maybe String
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 String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
appId BundleConfig
bconfig Maybe String
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 (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 (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 (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 String
oldDir, Maybe Logger
oldRlog) <- IO
  ([RunningWebApp], [RunningBackgroundApp], Maybe String,
   Maybe Logger)
-> KeterM
     AppStartConfig
     ([RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ([RunningWebApp], [RunningBackgroundApp], Maybe String,
    Maybe Logger)
 -> KeterM
      AppStartConfig
      ([RunningWebApp], [RunningBackgroundApp], Maybe String,
       Maybe Logger))
-> IO
     ([RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
-> KeterM
     AppStartConfig
     ([RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
forall a b. (a -> b) -> a -> b
$ STM
  ([RunningWebApp], [RunningBackgroundApp], Maybe String,
   Maybe Logger)
-> IO
     ([RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
forall a. STM a -> IO a
atomically (STM
   ([RunningWebApp], [RunningBackgroundApp], Maybe String,
    Maybe Logger)
 -> IO
      ([RunningWebApp], [RunningBackgroundApp], Maybe String,
       Maybe Logger))
-> STM
     ([RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
-> IO
     ([RunningWebApp], [RunningBackgroundApp], Maybe String,
      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 String
oldDir <- TVar (Maybe String) -> STM (Maybe String)
forall a. TVar a -> STM a
readTVar TVar (Maybe String)
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 String) -> Maybe String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe String)
appDir Maybe String
newdir
              ([RunningWebApp], [RunningBackgroundApp], Maybe String,
 Maybe Logger)
-> STM
     ([RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return ([RunningWebApp]
oldApps, [RunningBackgroundApp]
oldBacks, Maybe String
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 (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 String
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
appId [RunningWebApp]
oldApps [RunningBackgroundApp]
oldBacks Maybe String
oldDir Maybe Logger
oldRlog

terminate :: KeterM App ()
terminate :: KeterM App ()
terminate = do
    App{TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe String)
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe String)
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe String)
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} <- KeterM App App
forall r (m :: * -> *). MonadReader r m => m r
ask
    let AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} = AppStartConfig
appAsc
    (Set Host
hosts, [RunningWebApp]
apps, [RunningBackgroundApp]
backs, Maybe String
mdir, Maybe Logger
appLogger) <- IO
  (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
   Maybe Logger)
-> KeterM
     App
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
    Maybe Logger)
 -> KeterM
      App
      (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
       Maybe Logger))
-> IO
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
-> KeterM
     App
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
forall a b. (a -> b) -> a -> b
$ STM
  (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
   Maybe Logger)
-> IO
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
forall a. STM a -> IO a
atomically (STM
   (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
    Maybe Logger)
 -> IO
      (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
       Maybe Logger))
-> STM
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
-> IO
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
      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 String
mdir <- TVar (Maybe String) -> STM (Maybe String)
forall a. TVar a -> STM a
readTVar TVar (Maybe String)
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 String) -> Maybe String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe String)
appDir Maybe String
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 String,
 Maybe Logger)
-> STM
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
      Maybe Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Host
hosts, [RunningWebApp]
apps, [RunningBackgroundApp]
backs, Maybe String
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 (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 String
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
appId [RunningWebApp]
apps [RunningBackgroundApp]
backs Maybe String
mdir Maybe Logger
appLogger
    IO () -> KeterM App ()
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 (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 String
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
aid [RunningWebApp]
apps [RunningBackgroundApp]
backs Maybe String
mdir Maybe Logger
appLogger = do
    AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> KeterM AppStartConfig ()
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
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ 
        String
"Sending old process TERM signal: " 
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ case AppId
aid of { AINamed Text
t -> Text -> String
unpack Text
t; AppId
AIBuiltin -> String
"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 (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 String
mdir of
        Maybe String
Nothing -> () -> KeterM AppStartConfig ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just String
dir -> do
            $Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Removing unneeded folder: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dir
            Either SomeException ()
res <- IO (Either SomeException ())
-> KeterM AppStartConfig (Either SomeException ())
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
$ String -> IO ()
removeDirectoryRecursive String
dir
            case Either SomeException ()
res of
                Left SomeException
e -> $Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logError (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
                Right () -> () -> KeterM AppStartConfig ()
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)])
-> IO [[(Text, Text)]] -> IO [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Text, Text)]] -> [(Text, Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[(Text, Text)]] -> IO [(Text, Text)])
-> IO [[(Text, Text)]] -> IO [(Text, Text)]
forall a b. (a -> b) -> a -> 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)
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 = [(String, String)] -> Map Text Text
filterEnv ([(String, String)] -> Map Text Text)
-> IO [(String, String)] -> IO (Map Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
  where
    filterEnv :: [(String, String)] -> 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)
-> ([(String, String)] -> Map Text Text)
-> [(String, String)]
-> 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)
-> ([(String, String)] -> [(Text, Text)])
-> [(String, String)]
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (Text, Text))
-> [(String, String)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
pack (String -> Text)
-> (String -> Text) -> (String, String) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> 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
            -}