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

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

import           Codec.Archive.TempTarball
import           Control.Applicative       ((<$>), (<*>))
import           Control.Arrow             ((***))
import           Control.Concurrent        (forkIO, threadDelay)
import           Control.Concurrent.STM
import           Control.Exception         (IOException, bracketOnError,
                                            throwIO, try, catch)
import           Control.Monad             (void, when, liftM)
import qualified Data.CaseInsensitive      as CI
import           Data.Conduit.LogFile      (RotatingLog)
import qualified Data.Conduit.LogFile      as LogFile
import           Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,
                                            monitorProcess,
                                            terminateMonitoredProcess)
import           Data.Foldable             (for_)
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           Data.Yaml.FilePath
import System.FilePath ((</>))
import           System.Directory          (canonicalizePath, doesFileExist,
                                            removeDirectoryRecursive)
import           Keter.HostManager         hiding (start)
import           Keter.PortPool            (PortPool, getPort, releasePort)
import           Keter.Types
import           Network.Socket
import           Prelude                   hiding (FilePath)
import           System.Environment        (getEnvironment)
import           System.IO                 (hClose, IOMode(..))
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 FilePath)
appDir            :: !(TVar (Maybe FilePath))
    , App -> AppStartConfig
appAsc            :: !AppStartConfig
    , App -> TVar (Maybe RotatingLog)
appRlog           :: !(TVar (Maybe RotatingLog))
    }
instance Show App where
  show :: App -> FilePath
show App {AppId
appId :: AppId
appId :: App -> AppId
appId, TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe FilePath)
TVar (Maybe EpochTime)
TVar (Maybe RotatingLog)
TVar (Set Host)
AppStartConfig
appRlog :: TVar (Maybe RotatingLog)
appAsc :: AppStartConfig
appDir :: TVar (Maybe FilePath)
appHosts :: TVar (Set Host)
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appRlog :: App -> TVar (Maybe RotatingLog)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe FilePath)
appHosts :: App -> TVar (Set Host)
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} = FilePath
"App{appId=" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> AppId -> FilePath
forall a. Show a => a -> FilePath
show AppId
appId FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"}"

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

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

unpackBundle :: AppStartConfig
             -> FilePath
             -> AppId
             -> IO (FilePath, BundleConfig)
unpackBundle :: AppStartConfig -> FilePath -> AppId -> IO (FilePath, BundleConfig)
unpackBundle AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
TempFolder
ProcessTracker
KeterConfig
PortPool
HostManager
LogMessage -> IO ()
ascKeterConfig :: AppStartConfig -> KeterConfig
ascLog :: AppStartConfig -> LogMessage -> IO ()
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
ascKeterConfig :: KeterConfig
ascLog :: LogMessage -> IO ()
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
..} FilePath
bundle AppId
aid = do
    LogMessage -> IO ()
ascLog (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> LogMessage
UnpackingBundle FilePath
bundle
    Maybe (UserID, GroupID)
-> TempFolder
-> FilePath
-> Text
-> (FilePath -> IO (FilePath, BundleConfig))
-> IO (FilePath, BundleConfig)
forall a.
Maybe (UserID, GroupID)
-> TempFolder -> FilePath -> Text -> (FilePath -> 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 FilePath
bundle Text
folderName ((FilePath -> IO (FilePath, BundleConfig))
 -> IO (FilePath, BundleConfig))
-> (FilePath -> IO (FilePath, BundleConfig))
-> IO (FilePath, BundleConfig)
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        -- Get the FilePath for the keter yaml configuration. Tests for
        -- keter.yml and defaults to keter.yaml.
        FilePath
configFP <- do
            let yml :: FilePath
yml = FilePath
dir FilePath -> ShowS
</> FilePath
"config" FilePath -> ShowS
</> FilePath
"keter.yml"
            Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
yml
            FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ if Bool
exists then FilePath
yml
                               else FilePath
dir FilePath -> ShowS
</> FilePath
"config" FilePath -> ShowS
</> FilePath
"keter.yaml"

        Either ParseException BundleConfig
mconfig <- FilePath -> IO (Either ParseException BundleConfig)
forall a.
ParseYamlFile a =>
FilePath -> IO (Either ParseException a)
decodeFileRelative FilePath
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
        (FilePath, BundleConfig) -> IO (FilePath, BundleConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
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 -> LogMessage -> IO ()
ascLog            :: !(LogMessage -> IO ())
    , AppStartConfig -> KeterConfig
ascKeterConfig    :: !KeterConfig
    }

withConfig :: AppStartConfig
           -> AppId
           -> AppInput
           -> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a)
           -> IO a
withConfig :: AppStartConfig
-> AppId
-> AppInput
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a)
-> IO a
withConfig AppStartConfig
_asc AppId
_aid (AIData BundleConfig
bconfig) Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a
f = Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a
f Maybe FilePath
forall a. Maybe a
Nothing BundleConfig
bconfig Maybe EpochTime
forall a. Maybe a
Nothing
withConfig AppStartConfig
asc AppId
aid (AIBundle FilePath
fp EpochTime
modtime) Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a
f = IO (FilePath, BundleConfig)
-> ((FilePath, BundleConfig) -> IO ())
-> ((FilePath, BundleConfig) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
    (AppStartConfig -> FilePath -> AppId -> IO (FilePath, BundleConfig)
unpackBundle AppStartConfig
asc FilePath
fp AppId
aid)
    (\(FilePath
newdir, BundleConfig
_) -> FilePath -> IO ()
removeDirectoryRecursive FilePath
newdir)
    (((FilePath, BundleConfig) -> IO a) -> IO a)
-> ((FilePath, BundleConfig) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(FilePath
newdir, BundleConfig
bconfig) -> Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a
f (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
newdir) BundleConfig
bconfig (EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
modtime)

withReservations :: AppStartConfig
                 -> AppId
                 -> BundleConfig
                 -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a)
                 -> IO a
withReservations :: AppStartConfig
-> AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO a)
-> IO a
withReservations AppStartConfig
asc AppId
aid BundleConfig
bconfig [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
f = AppStartConfig
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO a)
-> IO a
forall a.
AppStartConfig
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO a)
-> IO a
withActions AppStartConfig
asc BundleConfig
bconfig (([WebAppConfig Int]
  -> [BackgroundConfig]
  -> Map Host (ProxyAction, Credentials)
  -> IO a)
 -> IO a)
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions -> 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
    ((LogMessage -> IO ())
-> HostManager -> AppId -> Set Host -> IO (Set Host)
reserveHosts (AppStartConfig -> LogMessage -> IO ()
ascLog AppStartConfig
asc) (AppStartConfig -> HostManager
ascHostManager AppStartConfig
asc) AppId
aid (Set Host -> IO (Set Host)) -> Set Host -> IO (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)
    ((LogMessage -> IO ()) -> HostManager -> AppId -> Set Host -> IO ()
forgetReservations (AppStartConfig -> LogMessage -> IO ()
ascLog AppStartConfig
asc) (AppStartConfig -> HostManager
ascHostManager AppStartConfig
asc) AppId
aid)
    (IO a -> Set Host -> IO a
forall a b. a -> b -> a
const (IO a -> Set Host -> IO a) -> IO a -> Set Host -> IO a
forall a b. (a -> b) -> a -> b
$ [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
f [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions)

withActions :: AppStartConfig
            -> BundleConfig
            -> ([ WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a)
            -> IO a
withActions :: AppStartConfig
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO a)
-> IO a
withActions AppStartConfig
asc BundleConfig
bconfig [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
f =
    [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
forall port.
[Stanza port]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO 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 FilePath
certFile Vector FilePath
chainCertFiles FilePath
keyFile) =
         (FilePath -> Credentials)
-> (Credential -> Credentials)
-> Either FilePath Credential
-> Credentials
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Credentials -> FilePath -> 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 FilePath Credential -> Credentials)
-> IO (Either FilePath Credential) -> IO Credentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> [FilePath] -> FilePath -> IO (Either FilePath Credential)
TLS.credentialLoadX509Chain FilePath
certFile (Vector FilePath -> [FilePath]
forall a. Vector a -> [a]
V.toList Vector FilePath
chainCertFiles) FilePath
keyFile
    loadCert SSLConfig
_ = Credentials -> IO Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials
forall a. Monoid a => a
mempty

    loop :: [Stanza port]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
loop [] [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions = [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
f [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions
    loop (Stanza (StanzaWebApp WebAppConfig port
wac) Bool
rs:[Stanza port]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions = 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
        ((LogMessage -> IO ()) -> PortPool -> IO (Either SomeException Int)
getPort (AppStartConfig -> LogMessage -> IO ()
ascLog AppStartConfig
asc) (AppStartConfig -> PortPool
ascPortPool AppStartConfig
asc) 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 port -> SSLConfig
forall port. WebAppConfig port -> SSLConfig
waconfigSsl WebAppConfig port
wac)
        )
        (\(Int
port, Credentials
_)    -> PortPool -> Int -> IO ()
releasePort (AppStartConfig -> PortPool
ascPortPool AppStartConfig
asc) Int
port)
        (\(Int
port, Credentials
cert) -> [Stanza port]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
loop
            [Stanza port]
stanzas
            (WebAppConfig port
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 port -> Maybe Int
forall port. WebAppConfig port -> Maybe Int
waconfigTimeout WebAppConfig port
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 port -> Host
forall port. WebAppConfig port -> Host
waconfigApprootHost WebAppConfig port
wac) (WebAppConfig port -> Set Host
forall port. WebAppConfig port -> Set Host
waconfigHosts WebAppConfig port
wac)
    loop (Stanza (StanzaStaticFiles StaticFilesConfig
sfc) Bool
rs:[Stanza port]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
        Credentials
cert <- SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
forall a b. (a -> b) -> a -> b
$ StaticFilesConfig -> SSLConfig
sfconfigSsl StaticFilesConfig
sfc
        [Stanza port]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
loop [Stanza port]
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 port]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
        Credentials
cert <- SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
forall a b. (a -> b) -> a -> b
$ RedirectConfig -> SSLConfig
redirconfigSsl RedirectConfig
red
        [Stanza port]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
loop [Stanza port]
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 port]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
        Credentials
cert <- SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> SSLConfig
reversingUseSSL ReverseProxyConfig
rev
        [Stanza port]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
loop [Stanza port]
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 port]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions =
        [Stanza port]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> IO a
loop [Stanza port]
stanzas [WebAppConfig Int]
wacs (BackgroundConfig
backBackgroundConfig -> [BackgroundConfig] -> [BackgroundConfig]
forall a. a -> [a] -> [a]
:[BackgroundConfig]
backs) Map Host (ProxyAction, Credentials)
actions

withRotatingLog :: AppStartConfig
                -> AppId
                -> Maybe (TVar (Maybe RotatingLog))
                -> ((TVar (Maybe RotatingLog)) -> RotatingLog -> IO a)
                -> IO a
withRotatingLog :: AppStartConfig
-> AppId
-> Maybe (TVar (Maybe RotatingLog))
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO a)
-> IO a
withRotatingLog AppStartConfig
asc AppId
aid Maybe (TVar (Maybe RotatingLog))
Nothing TVar (Maybe RotatingLog) -> RotatingLog -> IO a
f = do
    TVar (Maybe RotatingLog)
var <- Maybe RotatingLog -> IO (TVar (Maybe RotatingLog))
forall a. a -> IO (TVar a)
newTVarIO Maybe RotatingLog
forall a. Maybe a
Nothing
    AppStartConfig
-> AppId
-> Maybe (TVar (Maybe RotatingLog))
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO a)
-> IO a
forall a.
AppStartConfig
-> AppId
-> Maybe (TVar (Maybe RotatingLog))
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO a)
-> IO a
withRotatingLog AppStartConfig
asc AppId
aid (TVar (Maybe RotatingLog) -> Maybe (TVar (Maybe RotatingLog))
forall a. a -> Maybe a
Just TVar (Maybe RotatingLog)
var) TVar (Maybe RotatingLog) -> RotatingLog -> IO a
f
withRotatingLog AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
TempFolder
ProcessTracker
KeterConfig
PortPool
HostManager
LogMessage -> IO ()
ascKeterConfig :: KeterConfig
ascLog :: LogMessage -> IO ()
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascLog :: AppStartConfig -> LogMessage -> IO ()
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} AppId
aid (Just TVar (Maybe RotatingLog)
var) TVar (Maybe RotatingLog) -> RotatingLog -> IO a
f = do
    Maybe RotatingLog
mrlog <- TVar (Maybe RotatingLog) -> IO (Maybe RotatingLog)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe RotatingLog)
var
    case Maybe RotatingLog
mrlog of
        Maybe RotatingLog
Nothing -> IO RotatingLog
-> (RotatingLog -> IO ()) -> (RotatingLog -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
            (FilePath -> Word -> IO RotatingLog
LogFile.openRotatingLog FilePath
dir Word
LogFile.defaultMaxTotal)
            RotatingLog -> IO ()
LogFile.close
            (TVar (Maybe RotatingLog) -> RotatingLog -> IO a
f TVar (Maybe RotatingLog)
var)
        Just RotatingLog
rlog ->  TVar (Maybe RotatingLog) -> RotatingLog -> IO a
f TVar (Maybe RotatingLog)
var RotatingLog
rlog
  where
    dir :: FilePath
dir = KeterConfig -> FilePath
kconfigDir KeterConfig
ascKeterConfig FilePath -> ShowS
</> FilePath
"log" FilePath -> ShowS
</> FilePath
name
    name :: FilePath
name =
        case AppId
aid of
            AppId
AIBuiltin -> FilePath
"__builtin__"
            AINamed Text
x -> Text -> FilePath
unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
"app-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x

withSanityChecks :: AppStartConfig -> BundleConfig -> IO a -> IO a
withSanityChecks :: AppStartConfig -> BundleConfig -> IO a -> IO a
withSanityChecks AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
TempFolder
ProcessTracker
KeterConfig
PortPool
HostManager
LogMessage -> IO ()
ascKeterConfig :: KeterConfig
ascLog :: LogMessage -> IO ()
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascLog :: AppStartConfig -> LogMessage -> IO ()
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} IO a
f = do
    (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
    LogMessage -> IO ()
ascLog LogMessage
SanityChecksPassed
    IO a
f
  where
    go :: Stanza port -> IO ()
go (Stanza (StanzaWebApp WebAppConfig {port
FilePath
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 -> FilePath
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 :: FilePath
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
      FilePath -> IO ()
isExec FilePath
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 {FilePath
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 -> FilePath
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: FilePath
..}) Bool
_) = FilePath -> IO ()
isExec FilePath
bgconfigExec
    go Stanza port
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    isExec :: FilePath -> IO ()
isExec FilePath
fp = do
        Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
fp
        if Bool
exists
            then do
                Bool
canExec <- FilePath -> Bool -> Bool -> Bool -> IO Bool
fileAccess FilePath
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
$ FilePath -> KeterException
FileNotExecutable FilePath
fp
            else KeterException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO ()) -> KeterException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> KeterException
ExecutableNotFound FilePath
fp

start :: AppStartConfig
      -> AppId
      -> AppInput
      -> IO App
start :: AppStartConfig -> AppId -> AppInput -> IO App
start AppStartConfig
asc AppId
aid AppInput
input =
    AppStartConfig
-> AppId
-> Maybe (TVar (Maybe RotatingLog))
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO App)
-> IO App
forall a.
AppStartConfig
-> AppId
-> Maybe (TVar (Maybe RotatingLog))
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO a)
-> IO a
withRotatingLog AppStartConfig
asc AppId
aid Maybe (TVar (Maybe RotatingLog))
forall a. Maybe a
Nothing ((TVar (Maybe RotatingLog) -> RotatingLog -> IO App) -> IO App)
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO App) -> IO App
forall a b. (a -> b) -> a -> b
$ \TVar (Maybe RotatingLog)
trlog RotatingLog
rlog ->
    AppStartConfig
-> AppId
-> AppInput
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO App)
-> IO App
forall a.
AppStartConfig
-> AppId
-> AppInput
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a)
-> IO a
withConfig AppStartConfig
asc AppId
aid AppInput
input ((Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO App)
 -> IO App)
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO App)
-> IO App
forall a b. (a -> b) -> a -> b
$ \Maybe FilePath
newdir BundleConfig
bconfig Maybe EpochTime
mmodtime ->
    AppStartConfig -> BundleConfig -> IO App -> IO App
forall a. AppStartConfig -> BundleConfig -> IO a -> IO a
withSanityChecks AppStartConfig
asc BundleConfig
bconfig (IO App -> IO App) -> IO App -> IO App
forall a b. (a -> b) -> a -> b
$
    AppStartConfig
-> AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO App)
-> IO App
forall a.
AppStartConfig
-> AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO a)
-> IO a
withReservations AppStartConfig
asc AppId
aid BundleConfig
bconfig (([WebAppConfig Int]
  -> [BackgroundConfig]
  -> Map Host (ProxyAction, Credentials)
  -> IO App)
 -> IO App)
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO App)
-> IO App
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
webapps [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
    AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> IO App)
-> IO App
forall a.
AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> IO a)
-> IO a
withBackgroundApps AppStartConfig
asc AppId
aid BundleConfig
bconfig Maybe FilePath
newdir RotatingLog
rlog [BackgroundConfig]
backs (([RunningBackgroundApp] -> IO App) -> IO App)
-> ([RunningBackgroundApp] -> IO App) -> IO App
forall a b. (a -> b) -> a -> b
$ \[RunningBackgroundApp]
runningBacks ->
    AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [WebAppConfig Int]
-> ([RunningWebApp] -> IO App)
-> IO App
forall a.
AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [WebAppConfig Int]
-> ([RunningWebApp] -> IO a)
-> IO a
withWebApps AppStartConfig
asc AppId
aid BundleConfig
bconfig Maybe FilePath
newdir RotatingLog
rlog [WebAppConfig Int]
webapps (([RunningWebApp] -> IO App) -> IO App)
-> ([RunningWebApp] -> IO App) -> IO App
forall a b. (a -> b) -> a -> b
$ \[RunningWebApp]
runningWebapps -> do
        (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
        (LogMessage -> IO ())
-> HostManager
-> AppId
-> Map Host (ProxyAction, Credentials)
-> IO ()
activateApp (AppStartConfig -> LogMessage -> IO ()
ascLog AppStartConfig
asc) (AppStartConfig -> HostManager
ascHostManager AppStartConfig
asc) AppId
aid Map Host (ProxyAction, Credentials)
actions
        TVar (Maybe EpochTime)
-> TVar [RunningWebApp]
-> TVar [RunningBackgroundApp]
-> AppId
-> TVar (Set Host)
-> TVar (Maybe FilePath)
-> AppStartConfig
-> TVar (Maybe RotatingLog)
-> App
App
            (TVar (Maybe EpochTime)
 -> TVar [RunningWebApp]
 -> TVar [RunningBackgroundApp]
 -> AppId
 -> TVar (Set Host)
 -> TVar (Maybe FilePath)
 -> AppStartConfig
 -> TVar (Maybe RotatingLog)
 -> App)
-> IO (TVar (Maybe EpochTime))
-> IO
     (TVar [RunningWebApp]
      -> TVar [RunningBackgroundApp]
      -> AppId
      -> TVar (Set Host)
      -> TVar (Maybe FilePath)
      -> AppStartConfig
      -> TVar (Maybe RotatingLog)
      -> 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 FilePath)
   -> AppStartConfig
   -> TVar (Maybe RotatingLog)
   -> App)
-> IO (TVar [RunningWebApp])
-> IO
     (TVar [RunningBackgroundApp]
      -> AppId
      -> TVar (Set Host)
      -> TVar (Maybe FilePath)
      -> AppStartConfig
      -> TVar (Maybe RotatingLog)
      -> 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 FilePath)
   -> AppStartConfig
   -> TVar (Maybe RotatingLog)
   -> App)
-> IO (TVar [RunningBackgroundApp])
-> IO
     (AppId
      -> TVar (Set Host)
      -> TVar (Maybe FilePath)
      -> AppStartConfig
      -> TVar (Maybe RotatingLog)
      -> 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 FilePath)
   -> AppStartConfig
   -> TVar (Maybe RotatingLog)
   -> App)
-> IO AppId
-> IO
     (TVar (Set Host)
      -> TVar (Maybe FilePath)
      -> AppStartConfig
      -> TVar (Maybe RotatingLog)
      -> 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 FilePath)
   -> AppStartConfig
   -> TVar (Maybe RotatingLog)
   -> App)
-> IO (TVar (Set Host))
-> IO
     (TVar (Maybe FilePath)
      -> AppStartConfig -> TVar (Maybe RotatingLog) -> 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 FilePath)
   -> AppStartConfig -> TVar (Maybe RotatingLog) -> App)
-> IO (TVar (Maybe FilePath))
-> IO (AppStartConfig -> TVar (Maybe RotatingLog) -> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe FilePath -> IO (TVar (Maybe FilePath))
forall a. a -> IO (TVar a)
newTVarIO Maybe FilePath
newdir
            IO (AppStartConfig -> TVar (Maybe RotatingLog) -> App)
-> IO AppStartConfig -> IO (TVar (Maybe RotatingLog) -> 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 RotatingLog) -> App)
-> IO (TVar (Maybe RotatingLog)) -> IO App
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Maybe RotatingLog) -> IO (TVar (Maybe RotatingLog))
forall (m :: * -> *) a. Monad m => a -> m a
return TVar (Maybe RotatingLog)
trlog

bracketedMap :: (a -> (b -> IO c) -> IO c)
             -> ([b] -> IO c)
             -> [a]
             -> IO c
bracketedMap :: (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 :: AppStartConfig
            -> AppId
            -> BundleConfig
            -> Maybe FilePath
            -> RotatingLog
            -> [WebAppConfig Port]
            -> ([RunningWebApp] -> IO a)
            -> IO a
withWebApps :: AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [WebAppConfig Int]
-> ([RunningWebApp] -> IO a)
-> IO a
withWebApps AppStartConfig
asc AppId
aid BundleConfig
bconfig Maybe FilePath
mdir RotatingLog
rlog [WebAppConfig Int]
configs0 [RunningWebApp] -> IO a
f =
    (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 -> (RunningWebApp -> IO a) -> IO a
forall a. WebAppConfig Int -> (RunningWebApp -> IO a) -> IO a
alloc [RunningWebApp] -> IO a
f [WebAppConfig Int]
configs0
  where
    alloc :: WebAppConfig Int -> (RunningWebApp -> IO a) -> IO a
alloc = AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> WebAppConfig Int
-> (RunningWebApp -> IO a)
-> IO a
forall a.
AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> WebAppConfig Int
-> (RunningWebApp -> IO a)
-> IO a
launchWebApp AppStartConfig
asc AppId
aid BundleConfig
bconfig Maybe FilePath
mdir RotatingLog
rlog

launchWebApp :: AppStartConfig
             -> AppId
             -> BundleConfig
             -> Maybe FilePath
             -> RotatingLog
             -> WebAppConfig Port
             -> (RunningWebApp -> IO a)
             -> IO a
launchWebApp :: AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> WebAppConfig Int
-> (RunningWebApp -> IO a)
-> IO a
launchWebApp AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
TempFolder
ProcessTracker
KeterConfig
PortPool
HostManager
LogMessage -> IO ()
ascKeterConfig :: KeterConfig
ascLog :: LogMessage -> IO ()
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascLog :: AppStartConfig -> LogMessage -> IO ()
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} AppId
aid BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} Maybe FilePath
mdir RotatingLog
rlog WebAppConfig {Int
FilePath
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 :: FilePath
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 -> FilePath
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 -> IO a
f = do
    [(Text, Text)]
otherEnv <- Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ascPlugins Text
name Object
bconfigPlugins
    Map Text Text
forwardedEnv <- 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, FilePath
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 FilePath
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> FilePath
forall a. Show a => a -> FilePath
show Int
httpPort)
                else (Text
"https://", if Int
httpsPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 then FilePath
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> FilePath
forall a. Show a => a -> FilePath
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
$ FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
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
<> FilePath -> Text
pack FilePath
extport
            ]
    FilePath
exec <- FilePath -> IO FilePath
canonicalizePath FilePath
waconfigExec
    IO MonitoredProcess
-> (MonitoredProcess -> IO ())
-> (MonitoredProcess -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        ((ByteString -> IO ())
-> ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> IO MonitoredProcess
monitorProcess
            (LogMessage -> IO ()
ascLog (LogMessage -> IO ())
-> (ByteString -> LogMessage) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogMessage
OtherMessage (Text -> LogMessage)
-> (ByteString -> Text) -> ByteString -> LogMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode)
            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
$ FilePath -> Text
pack FilePath
exec)
            (ByteString
-> (FilePath -> ByteString) -> Maybe FilePath -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack) Maybe FilePath
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)
            (RotatingLog -> ByteString -> IO ()
LogFile.addChunk RotatingLog
rlog)
            (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 -> RunningWebApp -> IO 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 -> IO ()
killWebApp :: RunningWebApp -> IO ()
killWebApp RunningWebApp {Int
MonitoredProcess
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..} = do
    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 FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"ensureAlive failed"
  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
$ FilePath -> FilePath -> IO Handle
connectTo FilePath
"127.0.0.1" (FilePath -> IO Handle) -> FilePath -> IO Handle
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
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 :: FilePath -> FilePath -> IO Handle
connectTo FilePath
host FilePath
serv = do
            let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
                                     , addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
            [AddrInfo]
addrs <- Maybe AddrInfo -> Maybe FilePath -> Maybe FilePath -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
host) (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
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
$ FilePath -> IOException
userError (FilePath -> IOException) -> FilePath -> IOException
forall a b. (a -> b) -> a -> b
$ FilePath
"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 :: 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 :: AppStartConfig
                   -> AppId
                   -> BundleConfig
                   -> Maybe FilePath
                   -> RotatingLog
                   -> [BackgroundConfig]
                   -> ([RunningBackgroundApp] -> IO a)
                   -> IO a
withBackgroundApps :: AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> IO a)
-> IO a
withBackgroundApps AppStartConfig
asc AppId
aid BundleConfig
bconfig Maybe FilePath
mdir RotatingLog
rlog [BackgroundConfig]
configs [RunningBackgroundApp] -> IO a
f =
    (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 -> (RunningBackgroundApp -> IO a) -> IO a
forall a.
BackgroundConfig -> (RunningBackgroundApp -> IO a) -> IO a
alloc [RunningBackgroundApp] -> IO a
f [BackgroundConfig]
configs
  where
    alloc :: BackgroundConfig -> (RunningBackgroundApp -> IO a) -> IO a
alloc = AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> IO a
forall a.
AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> IO a
launchBackgroundApp AppStartConfig
asc AppId
aid BundleConfig
bconfig Maybe FilePath
mdir RotatingLog
rlog

launchBackgroundApp :: AppStartConfig
                    -> AppId
                    -> BundleConfig
                    -> Maybe FilePath
                    -> RotatingLog
                    -> BackgroundConfig
                    -> (RunningBackgroundApp -> IO a)
                    -> IO a
launchBackgroundApp :: AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> IO a
launchBackgroundApp AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
TempFolder
ProcessTracker
KeterConfig
PortPool
HostManager
LogMessage -> IO ()
ascKeterConfig :: KeterConfig
ascLog :: LogMessage -> IO ()
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascLog :: AppStartConfig -> LogMessage -> IO ()
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} AppId
aid BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} Maybe FilePath
mdir RotatingLog
rlog BackgroundConfig {FilePath
Word
Map Text Text
Set Text
Vector Text
RestartCount
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: FilePath
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigExec :: BackgroundConfig -> FilePath
..} RunningBackgroundApp -> IO a
f = do
    [(Text, Text)]
otherEnv <- Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ascPlugins Text
name Object
bconfigPlugins
    Map Text Text
forwardedEnv <- 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
            ]
    FilePath
exec <- FilePath -> IO FilePath
canonicalizePath FilePath
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 -> IO (IO Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO Bool -> IO (IO Bool)) -> IO Bool -> IO (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 <- Word -> IO (IORef Word)
forall a. a -> IO (IORef a)
newIORef Word
0
                IO Bool -> IO (IO Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO Bool -> IO (IO Bool)) -> IO Bool -> IO (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

    IO MonitoredProcess
-> (MonitoredProcess -> IO ())
-> (MonitoredProcess -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        ((ByteString -> IO ())
-> ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> IO MonitoredProcess
monitorProcess
            (LogMessage -> IO ()
ascLog (LogMessage -> IO ())
-> (ByteString -> LogMessage) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogMessage
OtherMessage (Text -> LogMessage)
-> (ByteString -> Text) -> ByteString -> LogMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode)
            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
$ FilePath -> Text
pack FilePath
exec)
            (ByteString
-> (FilePath -> ByteString) -> Maybe FilePath -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack) Maybe FilePath
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)
            (RotatingLog -> ByteString -> IO ()
LogFile.addChunk RotatingLog
rlog)
            (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 rlog appname bundle removeFromList = do
    Prelude.error "FIXME Keter.App.start"
    chan <- newChan
    return (App $ writeChan chan, rest chan)
  where

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

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

reload :: App -> AppInput -> IO ()
reload :: App -> AppInput -> IO ()
reload App {TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe FilePath)
TVar (Maybe EpochTime)
TVar (Maybe RotatingLog)
TVar (Set Host)
AppId
AppStartConfig
appRlog :: TVar (Maybe RotatingLog)
appAsc :: AppStartConfig
appDir :: TVar (Maybe FilePath)
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appRlog :: App -> TVar (Maybe RotatingLog)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe FilePath)
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} AppInput
input =
    AppStartConfig
-> AppId
-> Maybe (TVar (Maybe RotatingLog))
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO ())
-> IO ()
forall a.
AppStartConfig
-> AppId
-> Maybe (TVar (Maybe RotatingLog))
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO a)
-> IO a
withRotatingLog AppStartConfig
appAsc AppId
appId (TVar (Maybe RotatingLog) -> Maybe (TVar (Maybe RotatingLog))
forall a. a -> Maybe a
Just TVar (Maybe RotatingLog)
appRlog) ((TVar (Maybe RotatingLog) -> RotatingLog -> IO ()) -> IO ())
-> (TVar (Maybe RotatingLog) -> RotatingLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TVar (Maybe RotatingLog)
_ RotatingLog
rlog ->
    AppStartConfig
-> AppId
-> AppInput
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO ())
-> IO ()
forall a.
AppStartConfig
-> AppId
-> AppInput
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a)
-> IO a
withConfig AppStartConfig
appAsc AppId
appId AppInput
input ((Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO ())
 -> IO ())
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe FilePath
newdir BundleConfig
bconfig Maybe EpochTime
mmodtime ->
    AppStartConfig -> BundleConfig -> IO () -> IO ()
forall a. AppStartConfig -> BundleConfig -> IO a -> IO a
withSanityChecks AppStartConfig
appAsc BundleConfig
bconfig (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    AppStartConfig
-> AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO ())
-> IO ()
forall a.
AppStartConfig
-> AppId
-> BundleConfig
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO a)
-> IO a
withReservations AppStartConfig
appAsc AppId
appId BundleConfig
bconfig (([WebAppConfig Int]
  -> [BackgroundConfig]
  -> Map Host (ProxyAction, Credentials)
  -> IO ())
 -> IO ())
-> ([WebAppConfig Int]
    -> [BackgroundConfig]
    -> Map Host (ProxyAction, Credentials)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
webapps [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
    AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> IO ())
-> IO ()
forall a.
AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> IO a)
-> IO a
withBackgroundApps AppStartConfig
appAsc AppId
appId BundleConfig
bconfig Maybe FilePath
newdir RotatingLog
rlog [BackgroundConfig]
backs (([RunningBackgroundApp] -> IO ()) -> IO ())
-> ([RunningBackgroundApp] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[RunningBackgroundApp]
runningBacks ->
    AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [WebAppConfig Int]
-> ([RunningWebApp] -> IO ())
-> IO ()
forall a.
AppStartConfig
-> AppId
-> BundleConfig
-> Maybe FilePath
-> RotatingLog
-> [WebAppConfig Int]
-> ([RunningWebApp] -> IO a)
-> IO a
withWebApps AppStartConfig
appAsc AppId
appId BundleConfig
bconfig Maybe FilePath
newdir RotatingLog
rlog [WebAppConfig Int]
webapps (([RunningWebApp] -> IO ()) -> IO ())
-> ([RunningWebApp] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[RunningWebApp]
runningWebapps -> do
        (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
        TVar (Set Host) -> IO (Set Host)
forall a. TVar a -> IO a
readTVarIO TVar (Set Host)
appHosts IO (Set Host) -> (Set Host -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LogMessage -> IO ())
-> HostManager
-> AppId
-> Map Host (ProxyAction, Credentials)
-> Set Host
-> IO ()
reactivateApp (AppStartConfig -> LogMessage -> IO ()
ascLog AppStartConfig
appAsc) (AppStartConfig -> HostManager
ascHostManager AppStartConfig
appAsc) AppId
appId Map Host (ProxyAction, Credentials)
actions
        ([RunningWebApp]
oldApps, [RunningBackgroundApp]
oldBacks, Maybe FilePath
oldDir) <- STM ([RunningWebApp], [RunningBackgroundApp], Maybe FilePath)
-> IO ([RunningWebApp], [RunningBackgroundApp], Maybe FilePath)
forall a. STM a -> IO a
atomically (STM ([RunningWebApp], [RunningBackgroundApp], Maybe FilePath)
 -> IO ([RunningWebApp], [RunningBackgroundApp], Maybe FilePath))
-> STM ([RunningWebApp], [RunningBackgroundApp], Maybe FilePath)
-> IO ([RunningWebApp], [RunningBackgroundApp], Maybe FilePath)
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 FilePath
oldDir <- TVar (Maybe FilePath) -> STM (Maybe FilePath)
forall a. TVar a -> STM a
readTVar TVar (Maybe FilePath)
appDir

            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 FilePath) -> Maybe FilePath -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe FilePath)
appDir Maybe FilePath
newdir
            ([RunningWebApp], [RunningBackgroundApp], Maybe FilePath)
-> STM ([RunningWebApp], [RunningBackgroundApp], Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ([RunningWebApp]
oldApps, [RunningBackgroundApp]
oldBacks, Maybe FilePath
oldDir)
        IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ AppStartConfig
-> AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe FilePath
-> IO ()
terminateHelper AppStartConfig
appAsc AppId
appId [RunningWebApp]
oldApps [RunningBackgroundApp]
oldBacks Maybe FilePath
oldDir

terminate :: App -> IO ()
terminate :: App -> IO ()
terminate App {TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe FilePath)
TVar (Maybe EpochTime)
TVar (Maybe RotatingLog)
TVar (Set Host)
AppId
AppStartConfig
appRlog :: TVar (Maybe RotatingLog)
appAsc :: AppStartConfig
appDir :: TVar (Maybe FilePath)
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appRlog :: App -> TVar (Maybe RotatingLog)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe FilePath)
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} = do
    (Set Host
hosts, [RunningWebApp]
apps, [RunningBackgroundApp]
backs, Maybe FilePath
mdir, Maybe RotatingLog
rlog) <- STM
  (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe FilePath,
   Maybe RotatingLog)
-> IO
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe FilePath,
      Maybe RotatingLog)
forall a. STM a -> IO a
atomically (STM
   (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe FilePath,
    Maybe RotatingLog)
 -> IO
      (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe FilePath,
       Maybe RotatingLog))
-> STM
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe FilePath,
      Maybe RotatingLog)
-> IO
     (Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe FilePath,
      Maybe RotatingLog)
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 FilePath
mdir <- TVar (Maybe FilePath) -> STM (Maybe FilePath)
forall a. TVar a -> STM a
readTVar TVar (Maybe FilePath)
appDir
        Maybe RotatingLog
rlog <- TVar (Maybe RotatingLog) -> STM (Maybe RotatingLog)
forall a. TVar a -> STM a
readTVar TVar (Maybe RotatingLog)
appRlog

        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 FilePath) -> Maybe FilePath -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe FilePath)
appDir Maybe FilePath
forall a. Maybe a
Nothing
        TVar (Maybe RotatingLog) -> Maybe RotatingLog -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe RotatingLog)
appRlog Maybe RotatingLog
forall a. Maybe a
Nothing

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

    (LogMessage -> IO ()) -> HostManager -> AppId -> Set Host -> IO ()
deactivateApp LogMessage -> IO ()
ascLog HostManager
ascHostManager AppId
appId Set Host
hosts
    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ AppStartConfig
-> AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe FilePath
-> IO ()
terminateHelper AppStartConfig
appAsc AppId
appId [RunningWebApp]
apps [RunningBackgroundApp]
backs Maybe FilePath
mdir
    IO () -> (RotatingLog -> IO ()) -> Maybe RotatingLog -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) RotatingLog -> IO ()
LogFile.close Maybe RotatingLog
rlog
  where
    AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
TempFolder
ProcessTracker
KeterConfig
PortPool
HostManager
LogMessage -> IO ()
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascHostManager :: HostManager
ascLog :: LogMessage -> IO ()
ascKeterConfig :: AppStartConfig -> KeterConfig
ascLog :: AppStartConfig -> LogMessage -> IO ()
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} = AppStartConfig
appAsc

terminateHelper :: AppStartConfig
                -> AppId
                -> [RunningWebApp]
                -> [RunningBackgroundApp]
                -> Maybe FilePath
                -> IO ()
terminateHelper :: AppStartConfig
-> AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe FilePath
-> IO ()
terminateHelper AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
TempFolder
ProcessTracker
KeterConfig
PortPool
HostManager
LogMessage -> IO ()
ascKeterConfig :: KeterConfig
ascLog :: LogMessage -> IO ()
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascLog :: AppStartConfig -> LogMessage -> IO ()
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} AppId
aid [RunningWebApp]
apps [RunningBackgroundApp]
backs Maybe FilePath
mdir = do
    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
    LogMessage -> IO ()
ascLog (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ AppId -> LogMessage
TerminatingOldProcess AppId
aid
    (RunningWebApp -> IO ()) -> [RunningWebApp] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> IO ()
killWebApp [RunningWebApp]
apps
    (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 FilePath
mdir of
        Maybe FilePath
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just FilePath
dir -> do
            LogMessage -> IO ()
ascLog (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> LogMessage
RemovingOldFolder FilePath
dir
            Either SomeException ()
res <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
dir
            case Either SomeException ()
res of
                Left SomeException
e -> FilePath
FilePath -> Text
Text -> SomeException -> LogMessage
(LogMessage -> IO ())
-> (SomeException -> LogMessage) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: FilePath -> Text
$logEx LogMessage -> IO ()
ascLog SomeException
e
                Right () -> () -> IO ()
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 = [(FilePath, FilePath)] -> Map Text Text
filterEnv ([(FilePath, FilePath)] -> Map Text Text)
-> IO [(FilePath, FilePath)] -> IO (Map Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, FilePath)]
getEnvironment
  where
    filterEnv :: [(FilePath, FilePath)] -> 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)
-> ([(FilePath, FilePath)] -> Map Text Text)
-> [(FilePath, FilePath)]
-> 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)
-> ([(FilePath, FilePath)] -> [(Text, Text)])
-> [(FilePath, FilePath)]
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, FilePath) -> (Text, Text))
-> [(FilePath, FilePath)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
pack (FilePath -> Text)
-> (FilePath -> Text) -> (FilePath, FilePath) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** FilePath -> 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
                        mlogger <- do
                            let dirout = kconfigDir </> "log" </> fromText ("app-" ++ appname)
                                direrr = dirout </> "err"
                            erlog <- liftIO $ LogFile.openRotatingLog
                                (F.encodeString dirout)
                                LogFile.defaultMaxTotal
                            case erlog of
                                Left e -> do
                                    $logEx e
                                    return Nothing
                                Right rlog -> return (Just rlog)
                        let logger = fromMaybe LogFile.dummy mlogger
                        (app, rest) <- App.start
                            tf
                            muid
                            processTracker
                            hostman
                            plugins
                            logger
                            appname
                            bundle
                            (removeApp appname)
                        etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)
                        let time = either (P.const 0) id etime
                        let appMap' = Map.insert appname (app, time) appMap
                        return (appMap', rest)
            rest
            -}