{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Keter.App
( App
, AppStartConfig (..)
, start
, reload
, getTimestamp
, Keter.App.terminate
, showApp
) where
import Keter.Common
import Keter.Context
import Data.Set (Set)
import Data.Text (Text)
import Data.ByteString (ByteString)
import System.FilePath (FilePath)
import Data.Map (Map)
import Keter.Rewrite (ReverseProxyConfig (..))
import Keter.TempTarball
import Control.Applicative ((<$>), (<*>))
import Control.Arrow ((***))
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Exception (IOException, SomeException,
bracketOnError,
throwIO, try, catch)
import Control.Monad (void, when, liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Unlift (withRunInIO)
import Control.Monad.Logger
import Control.Monad.Reader (ask)
import qualified Data.CaseInsensitive as CI
import Keter.Logger (Logger)
import qualified Keter.Logger as Log
import Keter.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,
monitorProcess,
terminateMonitoredProcess, printStatus)
import Data.Foldable (for_, traverse_)
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import qualified Data.Set as Set
import Data.Text (pack, unpack)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Vector as V
import Data.Yaml
import Keter.Yaml.FilePath
import System.FilePath ((</>))
import System.Directory (canonicalizePath, doesFileExist,
removeDirectoryRecursive,
createDirectoryIfMissing)
import Keter.HostManager hiding (start)
import Keter.PortPool (PortPool, getPort, releasePort)
import Keter.Config
import Network.Socket
import Prelude hiding (FilePath)
import System.Environment (getEnvironment)
import System.IO (hClose, IOMode(..))
import qualified System.Log.FastLogger as FL
import System.Posix.Files (fileAccess)
import System.Posix.Types (EpochTime, GroupID, UserID)
import System.Timeout (timeout)
import qualified Network.TLS as TLS
data App = App
{ App -> TVar (Maybe EpochTime)
appModTime :: !(TVar (Maybe EpochTime))
, App -> TVar [RunningWebApp]
appRunningWebApps :: !(TVar [RunningWebApp])
, App -> TVar [RunningBackgroundApp]
appBackgroundApps :: !(TVar [RunningBackgroundApp])
, App -> AppId
appId :: !AppId
, App -> TVar (Set Host)
appHosts :: !(TVar (Set Host))
, App -> TVar (Maybe String)
appDir :: !(TVar (Maybe FilePath))
, App -> AppStartConfig
appAsc :: !AppStartConfig
, App -> TVar (Maybe Logger)
appLog :: !(TVar (Maybe Logger))
}
instance Show App where
show :: App -> String
show App {AppId
appId :: AppId
appId :: App -> AppId
appId, TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe String)
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe String)
appHosts :: TVar (Set Host)
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe String)
appHosts :: App -> TVar (Set Host)
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} = String
"App{appId=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AppId -> String
forall a. Show a => a -> String
show AppId
appId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"
showApp :: App -> STM Text
showApp :: App -> STM Text
showApp App{TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe String)
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe String)
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe String)
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} = do
Maybe EpochTime
appModTime' <- TVar (Maybe EpochTime) -> STM (Maybe EpochTime)
forall a. TVar a -> STM a
readTVar TVar (Maybe EpochTime)
appModTime
[RunningWebApp]
appRunning' <- TVar [RunningWebApp] -> STM [RunningWebApp]
forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
Set Host
appHosts' <- TVar (Set Host) -> STM (Set Host)
forall a. TVar a -> STM a
readTVar TVar (Set Host)
appHosts
Text -> STM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> STM Text) -> Text -> STM Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
(AppId -> String
forall a. Show a => a -> String
show AppId
appId) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
String
" modtime: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Maybe EpochTime -> String
forall a. Show a => a -> String
show Maybe EpochTime
appModTime') String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", webappsRunning: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [RunningWebApp] -> String
forall a. Show a => a -> String
show [RunningWebApp]
appRunning' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", hosts: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set Host -> String
forall a. Show a => a -> String
show Set Host
appHosts'
data RunningWebApp = RunningWebApp
{ RunningWebApp -> MonitoredProcess
rwaProcess :: !MonitoredProcess
, RunningWebApp -> Int
rwaPort :: !Port
, RunningWebApp -> Int
rwaEnsureAliveTimeOut :: !Int
}
instance Show RunningWebApp where
show :: RunningWebApp -> String
show (RunningWebApp {Int
MonitoredProcess
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..}) = String
"RunningWebApp{rwaPort=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rwaPort String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", rwaEnsureAliveTimeOut=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rwaEnsureAliveTimeOut String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
",..}"
newtype RunningBackgroundApp = RunningBackgroundApp
{ RunningBackgroundApp -> MonitoredProcess
rbaProcess :: MonitoredProcess
}
unpackBundle :: FilePath
-> AppId
-> KeterM AppStartConfig (FilePath, BundleConfig)
unpackBundle :: String -> AppId -> KeterM AppStartConfig (String, BundleConfig)
unpackBundle String
bundle AppId
aid = do
AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Unpacking bundle '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
bundle String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"
IO (String, BundleConfig)
-> KeterM AppStartConfig (String, BundleConfig)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, BundleConfig)
-> KeterM AppStartConfig (String, BundleConfig))
-> IO (String, BundleConfig)
-> KeterM AppStartConfig (String, BundleConfig)
forall a b. (a -> b) -> a -> b
$ Maybe (UserID, GroupID)
-> TempFolder
-> String
-> Text
-> (String -> IO (String, BundleConfig))
-> IO (String, BundleConfig)
forall a.
Maybe (UserID, GroupID)
-> TempFolder -> String -> Text -> (String -> IO a) -> IO a
unpackTempTar (((Text, (UserID, GroupID)) -> (UserID, GroupID))
-> Maybe (Text, (UserID, GroupID)) -> Maybe (UserID, GroupID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, (UserID, GroupID)) -> (UserID, GroupID)
forall a b. (a, b) -> b
snd Maybe (Text, (UserID, GroupID))
ascSetuid) TempFolder
ascTempFolder String
bundle Text
folderName ((String -> IO (String, BundleConfig))
-> IO (String, BundleConfig))
-> (String -> IO (String, BundleConfig))
-> IO (String, BundleConfig)
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
String
configFP <- do
let yml :: String
yml = String
dir String -> ShowS
</> String
"config" String -> ShowS
</> String
"keter.yml"
Bool
exists <- String -> IO Bool
doesFileExist String
yml
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ if Bool
exists then String
yml
else String
dir String -> ShowS
</> String
"config" String -> ShowS
</> String
"keter.yaml"
Either ParseException BundleConfig
mconfig <- String -> IO (Either ParseException BundleConfig)
forall a. ParseYamlFile a => String -> IO (Either ParseException a)
decodeFileRelative String
configFP
BundleConfig
config <-
case Either ParseException BundleConfig
mconfig of
Right BundleConfig
config -> BundleConfig -> IO BundleConfig
forall (m :: * -> *) a. Monad m => a -> m a
return BundleConfig
config
Left ParseException
e -> KeterException -> IO BundleConfig
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO BundleConfig)
-> KeterException -> IO BundleConfig
forall a b. (a -> b) -> a -> b
$ ParseException -> KeterException
InvalidConfigFile ParseException
e
(String, BundleConfig) -> IO (String, BundleConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dir, BundleConfig
config)
where
folderName :: Text
folderName =
case AppId
aid of
AppId
AIBuiltin -> Text
"__builtin__"
AINamed Text
x -> Text
x
data AppStartConfig = AppStartConfig
{ AppStartConfig -> TempFolder
ascTempFolder :: !TempFolder
, AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascSetuid :: !(Maybe (Text, (UserID, GroupID)))
, AppStartConfig -> ProcessTracker
ascProcessTracker :: !ProcessTracker
, AppStartConfig -> HostManager
ascHostManager :: !HostManager
, AppStartConfig -> PortPool
ascPortPool :: !PortPool
, AppStartConfig -> Plugins
ascPlugins :: !Plugins
, AppStartConfig -> KeterConfig
ascKeterConfig :: !KeterConfig
}
withConfig :: AppId
-> AppInput
-> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig :: forall a.
AppId
-> AppInput
-> (Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
_aid (AIData BundleConfig
bconfig) Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f = Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f Maybe String
forall a. Maybe a
Nothing BundleConfig
bconfig Maybe EpochTime
forall a. Maybe a
Nothing
withConfig AppId
aid (AIBundle String
fp EpochTime
modtime) Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f = do
((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
IO (String, BundleConfig)
-> ((String, BundleConfig) -> IO ())
-> ((String, BundleConfig) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (KeterM AppStartConfig (String, BundleConfig)
-> IO (String, BundleConfig)
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig (String, BundleConfig)
-> IO (String, BundleConfig))
-> KeterM AppStartConfig (String, BundleConfig)
-> IO (String, BundleConfig)
forall a b. (a -> b) -> a -> b
$ String -> AppId -> KeterM AppStartConfig (String, BundleConfig)
unpackBundle String
fp AppId
aid) (\(String
newdir, BundleConfig
_) -> String -> IO ()
removeDirectoryRecursive String
newdir) (((String, BundleConfig) -> IO a) -> IO a)
-> ((String, BundleConfig) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(String
newdir, BundleConfig
bconfig) ->
KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a
f (String -> Maybe String
forall a. a -> Maybe a
Just String
newdir) BundleConfig
bconfig (EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
modtime)
withReservations :: AppId
-> BundleConfig
-> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withReservations :: forall a.
AppId
-> BundleConfig
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withReservations AppId
aid BundleConfig
bconfig [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
f = do
AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
BundleConfig
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
forall a.
BundleConfig
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withActions BundleConfig
bconfig (([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a)
-> KeterM AppStartConfig a)
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
IO (Set Host) -> (Set Host -> IO ()) -> (Set Host -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(KeterM AppStartConfig (Set Host) -> IO (Set Host)
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig (Set Host) -> IO (Set Host))
-> KeterM AppStartConfig (Set Host) -> IO (Set Host)
forall a b. (a -> b) -> a -> b
$ (AppStartConfig -> HostManager)
-> KeterM HostManager (Set Host)
-> KeterM AppStartConfig (Set Host)
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> AppStartConfig -> HostManager
forall a b. a -> b -> a
const HostManager
ascHostManager) (KeterM HostManager (Set Host) -> KeterM AppStartConfig (Set Host))
-> KeterM HostManager (Set Host)
-> KeterM AppStartConfig (Set Host)
forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> KeterM HostManager (Set Host)
reserveHosts AppId
aid (Set Host -> KeterM HostManager (Set Host))
-> Set Host -> KeterM HostManager (Set Host)
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials) -> Set Host
forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions)
(\Set Host
rsvs -> KeterM AppStartConfig () -> IO ()
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig () -> IO ())
-> KeterM AppStartConfig () -> IO ()
forall a b. (a -> b) -> a -> b
$ (AppStartConfig -> HostManager)
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> AppStartConfig -> HostManager
forall a b. a -> b -> a
const HostManager
ascHostManager) (KeterM HostManager () -> KeterM AppStartConfig ())
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ AppId -> Set Host -> KeterM HostManager ()
forgetReservations AppId
aid Set Host
rsvs)
(\Set Host
_ -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
f [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions)
withActions :: BundleConfig
-> ([ WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withActions :: forall a.
BundleConfig
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withActions BundleConfig
bconfig [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
f =
[Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop (Vector (Stanza ()) -> [Stanza ()]
forall a. Vector a -> [a]
V.toList (Vector (Stanza ()) -> [Stanza ()])
-> Vector (Stanza ()) -> [Stanza ()]
forall a b. (a -> b) -> a -> b
$ BundleConfig -> Vector (Stanza ())
bconfigStanzas BundleConfig
bconfig) [] [] Map Host (ProxyAction, Credentials)
forall k a. Map k a
Map.empty
where
loadCert :: SSLConfig -> IO Credentials
loadCert (SSL String
certFile Vector String
chainCertFiles String
keyFile) =
(String -> Credentials)
-> (Credential -> Credentials)
-> Either String Credential
-> Credentials
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Credentials -> String -> Credentials
forall a b. a -> b -> a
const Credentials
forall a. Monoid a => a
mempty) ([Credential] -> Credentials
TLS.Credentials ([Credential] -> Credentials)
-> (Credential -> [Credential]) -> Credential -> Credentials
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Credential -> [Credential] -> [Credential]
forall a. a -> [a] -> [a]
:[]))
(Either String Credential -> Credentials)
-> IO (Either String Credential) -> IO Credentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO (Either String Credential)
TLS.credentialLoadX509Chain String
certFile (Vector String -> [String]
forall a. Vector a -> [a]
V.toList Vector String
chainCertFiles) String
keyFile
loadCert SSLConfig
_ = Credentials -> IO Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials
forall a. Monoid a => a
mempty
loop :: [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [] [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions = [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
f [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions
loop (Stanza (StanzaWebApp WebAppConfig ()
wac) Bool
rs:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions = do
AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO (Int, Credentials)
-> ((Int, Credentials) -> IO ())
-> ((Int, Credentials) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(KeterM AppStartConfig (Either SomeException Int)
-> IO (Either SomeException Int)
forall a. KeterM AppStartConfig a -> IO a
rio (PortPool -> KeterM AppStartConfig (Either SomeException Int)
forall cfg. PortPool -> KeterM cfg (Either SomeException Int)
getPort PortPool
ascPortPool) IO (Either SomeException Int)
-> (Either SomeException Int -> IO (Int, Credentials))
-> IO (Int, Credentials)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO (Int, Credentials))
-> (Int -> IO (Int, Credentials))
-> Either SomeException Int
-> IO (Int, Credentials)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO (Int, Credentials)
forall e a. Exception e => e -> IO a
throwIO
(\Int
p -> (Credentials -> (Int, Credentials))
-> IO Credentials -> IO (Int, Credentials)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
p,) (IO Credentials -> IO (Int, Credentials))
-> (SSLConfig -> IO Credentials)
-> SSLConfig
-> IO (Int, Credentials)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO (Int, Credentials))
-> SSLConfig -> IO (Int, Credentials)
forall a b. (a -> b) -> a -> b
$ WebAppConfig () -> SSLConfig
forall port. WebAppConfig port -> SSLConfig
waconfigSsl WebAppConfig ()
wac)
)
(\(Int
port, Credentials
_) -> PortPool -> Int -> IO ()
releasePort PortPool
ascPortPool Int
port)
(\(Int
port, Credentials
cert) -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ [Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop
[Stanza ()]
stanzas
(WebAppConfig ()
wac { waconfigPort :: Int
waconfigPort = Int
port } WebAppConfig Int -> [WebAppConfig Int] -> [WebAppConfig Int]
forall a. a -> [a] -> [a]
: [WebAppConfig Int]
wacs)
[BackgroundConfig]
backs
([Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials))
-> [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions Map Host (ProxyAction, Credentials)
-> [Map Host (ProxyAction, Credentials)]
-> [Map Host (ProxyAction, Credentials)]
forall a. a -> [a] -> [a]
: (Host -> Map Host (ProxyAction, Credentials))
-> [Host] -> [Map Host (ProxyAction, Credentials)]
forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> Host
-> (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
forall k a. k -> a -> Map k a
Map.singleton Host
host ((Int -> Maybe Int -> ProxyActionRaw
PAPort Int
port (WebAppConfig () -> Maybe Int
forall port. WebAppConfig port -> Maybe Int
waconfigTimeout WebAppConfig ()
wac), Bool
rs), Credentials
cert)) [Host]
hosts))
where
hosts :: [Host]
hosts = Set Host -> [Host]
forall a. Set a -> [a]
Set.toList (Set Host -> [Host]) -> Set Host -> [Host]
forall a b. (a -> b) -> a -> b
$ Host -> Set Host -> Set Host
forall a. Ord a => a -> Set a -> Set a
Set.insert (WebAppConfig () -> Host
forall port. WebAppConfig port -> Host
waconfigApprootHost WebAppConfig ()
wac) (WebAppConfig () -> Set Host
forall port. WebAppConfig port -> Set Host
waconfigHosts WebAppConfig ()
wac)
loop (Stanza (StanzaStaticFiles StaticFilesConfig
sfc) Bool
rs:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
Credentials
cert <- IO Credentials -> KeterM AppStartConfig Credentials
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Credentials -> KeterM AppStartConfig Credentials)
-> IO Credentials -> KeterM AppStartConfig Credentials
forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
forall a b. (a -> b) -> a -> b
$ StaticFilesConfig -> SSLConfig
sfconfigSsl StaticFilesConfig
sfc
[Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [Stanza ()]
stanzas [WebAppConfig Int]
wacs [BackgroundConfig]
backs (Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert)
where
actions :: Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert = [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
([Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials))
-> [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions0
Map Host (ProxyAction, Credentials)
-> [Map Host (ProxyAction, Credentials)]
-> [Map Host (ProxyAction, Credentials)]
forall a. a -> [a] -> [a]
: (Host -> Map Host (ProxyAction, Credentials))
-> [Host] -> [Map Host (ProxyAction, Credentials)]
forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> Host
-> (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
forall k a. k -> a -> Map k a
Map.singleton Host
host ((StaticFilesConfig -> ProxyActionRaw
PAStatic StaticFilesConfig
sfc, Bool
rs), Credentials
cert))
(Set Host -> [Host]
forall a. Set a -> [a]
Set.toList (StaticFilesConfig -> Set Host
sfconfigHosts StaticFilesConfig
sfc))
loop (Stanza (StanzaRedirect RedirectConfig
red) Bool
rs:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
Credentials
cert <- IO Credentials -> KeterM AppStartConfig Credentials
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Credentials -> KeterM AppStartConfig Credentials)
-> IO Credentials -> KeterM AppStartConfig Credentials
forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
forall a b. (a -> b) -> a -> b
$ RedirectConfig -> SSLConfig
redirconfigSsl RedirectConfig
red
[Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [Stanza ()]
stanzas [WebAppConfig Int]
wacs [BackgroundConfig]
backs (Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert)
where
actions :: Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert = [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
([Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials))
-> [Map Host (ProxyAction, Credentials)]
-> Map Host (ProxyAction, Credentials)
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials)
actions0
Map Host (ProxyAction, Credentials)
-> [Map Host (ProxyAction, Credentials)]
-> [Map Host (ProxyAction, Credentials)]
forall a. a -> [a] -> [a]
: (Host -> Map Host (ProxyAction, Credentials))
-> [Host] -> [Map Host (ProxyAction, Credentials)]
forall a b. (a -> b) -> [a] -> [b]
map (\Host
host -> Host
-> (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
forall k a. k -> a -> Map k a
Map.singleton Host
host ((RedirectConfig -> ProxyActionRaw
PARedirect RedirectConfig
red, Bool
rs), Credentials
cert))
(Set Host -> [Host]
forall a. Set a -> [a]
Set.toList (RedirectConfig -> Set Host
redirconfigHosts RedirectConfig
red))
loop (Stanza (StanzaReverseProxy ReverseProxyConfig
rev [MiddlewareConfig]
mid Maybe Int
to) Bool
rs:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions0 = do
Credentials
cert <- IO Credentials -> KeterM AppStartConfig Credentials
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Credentials -> KeterM AppStartConfig Credentials)
-> IO Credentials -> KeterM AppStartConfig Credentials
forall a b. (a -> b) -> a -> b
$ SSLConfig -> IO Credentials
loadCert (SSLConfig -> IO Credentials) -> SSLConfig -> IO Credentials
forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> SSLConfig
reversingUseSSL ReverseProxyConfig
rev
[Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [Stanza ()]
stanzas [WebAppConfig Int]
wacs [BackgroundConfig]
backs (Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert)
where
actions :: Credentials -> Map Host (ProxyAction, Credentials)
actions Credentials
cert = Host
-> (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
-> Map Host (ProxyAction, Credentials)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Text -> Host
forall s. FoldCase s => s -> CI s
CI.mk (Text -> Host) -> Text -> Host
forall a b. (a -> b) -> a -> b
$ ReverseProxyConfig -> Text
reversingHost ReverseProxyConfig
rev) ((ReverseProxyConfig
-> [MiddlewareConfig] -> Maybe Int -> ProxyActionRaw
PAReverseProxy ReverseProxyConfig
rev [MiddlewareConfig]
mid Maybe Int
to, Bool
rs), Credentials
cert) Map Host (ProxyAction, Credentials)
actions0
loop (Stanza (StanzaBackground BackgroundConfig
back) Bool
_:[Stanza ()]
stanzas) [WebAppConfig Int]
wacs [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions =
[Stanza ()]
-> [WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a
loop [Stanza ()]
stanzas [WebAppConfig Int]
wacs (BackgroundConfig
backBackgroundConfig -> [BackgroundConfig] -> [BackgroundConfig]
forall a. a -> [a] -> [a]
:[BackgroundConfig]
backs) Map Host (ProxyAction, Credentials)
actions
appLogName :: AppId -> String
appLogName :: AppId -> String
appLogName AppId
AIBuiltin = String
"__builtin__"
appLogName (AINamed Text
x) = String
"app-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
x
withLogger :: AppId
-> Maybe (TVar (Maybe Logger))
-> ((TVar (Maybe Logger)) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger :: forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
aid Maybe (TVar (Maybe Logger))
Nothing TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f = do
TVar (Maybe Logger)
var <- IO (TVar (Maybe Logger))
-> KeterM AppStartConfig (TVar (Maybe Logger))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar (Maybe Logger))
-> KeterM AppStartConfig (TVar (Maybe Logger)))
-> IO (TVar (Maybe Logger))
-> KeterM AppStartConfig (TVar (Maybe Logger))
forall a b. (a -> b) -> a -> b
$ Maybe Logger -> IO (TVar (Maybe Logger))
forall a. a -> IO (TVar a)
newTVarIO Maybe Logger
forall a. Maybe a
Nothing
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
aid (TVar (Maybe Logger) -> Maybe (TVar (Maybe Logger))
forall a. a -> Maybe a
Just TVar (Maybe Logger)
var) TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f
withLogger AppId
aid (Just TVar (Maybe Logger)
var) TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f = do
AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
Maybe Logger
mappLogger <- IO (Maybe Logger) -> KeterM AppStartConfig (Maybe Logger)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Logger) -> KeterM AppStartConfig (Maybe Logger))
-> IO (Maybe Logger) -> KeterM AppStartConfig (Maybe Logger)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Logger) -> IO (Maybe Logger)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe Logger)
var
case Maybe Logger
mappLogger of
Maybe Logger
Nothing -> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
IO Logger -> (Logger -> IO ()) -> (Logger -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (KeterConfig -> String -> IO Logger
Log.createLoggerViaConfig KeterConfig
ascKeterConfig (AppId -> String
appLogName AppId
aid)) Logger -> IO ()
Log.loggerClose (KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> (Logger -> KeterM AppStartConfig a) -> Logger -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f TVar (Maybe Logger)
var)
Just Logger
appLogger -> TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a
f TVar (Maybe Logger)
var Logger
appLogger
where
withSanityChecks :: BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks :: forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig{Object
Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} KeterM AppStartConfig a
f = do
cfg :: AppStartConfig
cfg@AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> KeterM AppStartConfig ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ (Stanza () -> IO ()) -> Vector (Stanza ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ Stanza () -> IO ()
forall {port}. Stanza port -> IO ()
go Vector (Stanza ())
bconfigStanzas
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo Text
"Sanity checks passed"
KeterM AppStartConfig a
f
where
go :: Stanza port -> IO ()
go (Stanza (StanzaWebApp WebAppConfig {port
String
Maybe Int
Map Text Text
Host
Set Text
Set Host
Vector Text
SSLConfig
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigExec :: forall port. WebAppConfig port -> String
waconfigEnsureAliveTimeout :: Maybe Int
waconfigTimeout :: Maybe Int
waconfigForwardEnv :: Set Text
waconfigPort :: port
waconfigSsl :: SSLConfig
waconfigHosts :: Set Host
waconfigApprootHost :: Host
waconfigEnvironment :: Map Text Text
waconfigArgs :: Vector Text
waconfigExec :: String
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigPort :: forall port. WebAppConfig port -> port
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
..}) Bool
_) = do
String -> IO ()
isExec String
waconfigExec
Maybe Int -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
waconfigEnsureAliveTimeout
((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
x -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KeterException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO ()) -> KeterException -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> KeterException
EnsureAliveShouldBeBiggerThenZero Int
x
go (Stanza (StanzaBackground BackgroundConfig {String
Word
Map Text Text
Set Text
Vector Text
RestartCount
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigExec :: BackgroundConfig -> String
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: String
..}) Bool
_) = String -> IO ()
isExec String
bgconfigExec
go Stanza port
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isExec :: String -> IO ()
isExec String
fp = do
Bool
exists <- String -> IO Bool
doesFileExist String
fp
if Bool
exists
then do
Bool
canExec <- String -> Bool -> Bool -> Bool -> IO Bool
fileAccess String
fp Bool
True Bool
False Bool
True
if Bool
canExec
then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else KeterException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO ()) -> KeterException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> KeterException
FileNotExecutable String
fp
else KeterException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO ()) -> KeterException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> KeterException
ExecutableNotFound String
fp
start :: AppId
-> AppInput
-> KeterM AppStartConfig App
start :: AppId -> AppInput -> KeterM AppStartConfig App
start AppId
aid AppInput
input =
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
aid Maybe (TVar (Maybe Logger))
forall a. Maybe a
Nothing ((TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App)
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \TVar (Maybe Logger)
tAppLogger Logger
appLogger ->
AppId
-> AppInput
-> (Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> AppInput
-> (Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
aid AppInput
input ((Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App)
-> (Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \Maybe String
newdir BundleConfig
bconfig Maybe EpochTime
mmodtime ->
BundleConfig
-> KeterM AppStartConfig App -> KeterM AppStartConfig App
forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig
bconfig (KeterM AppStartConfig App -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App -> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$
AppId
-> BundleConfig
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> BundleConfig
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withReservations AppId
aid BundleConfig
bconfig (([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig App)
-> KeterM AppStartConfig App)
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
webapps [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
aid BundleConfig
bconfig Maybe String
newdir Logger
appLogger [BackgroundConfig]
backs (([RunningBackgroundApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App)
-> ([RunningBackgroundApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \[RunningBackgroundApp]
runningBacks ->
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
aid BundleConfig
bconfig Maybe String
newdir Logger
appLogger [WebAppConfig Int]
webapps (([RunningWebApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App)
-> ([RunningWebApp] -> KeterM AppStartConfig App)
-> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$ \[RunningWebApp]
runningWebapps -> do
asc :: AppStartConfig
asc@AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> KeterM AppStartConfig ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ (RunningWebApp -> IO ()) -> [RunningWebApp] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> IO ()
ensureAlive [RunningWebApp]
runningWebapps
(AppStartConfig -> HostManager)
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> AppStartConfig -> HostManager
forall a b. a -> b -> a
const HostManager
ascHostManager) (KeterM HostManager () -> KeterM AppStartConfig ())
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ AppId
-> Map Host (ProxyAction, Credentials) -> KeterM HostManager ()
activateApp AppId
aid Map Host (ProxyAction, Credentials)
actions
IO App -> KeterM AppStartConfig App
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO App -> KeterM AppStartConfig App)
-> IO App -> KeterM AppStartConfig App
forall a b. (a -> b) -> a -> b
$
TVar (Maybe EpochTime)
-> TVar [RunningWebApp]
-> TVar [RunningBackgroundApp]
-> AppId
-> TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App
App
(TVar (Maybe EpochTime)
-> TVar [RunningWebApp]
-> TVar [RunningBackgroundApp]
-> AppId
-> TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
-> IO (TVar (Maybe EpochTime))
-> IO
(TVar [RunningWebApp]
-> TVar [RunningBackgroundApp]
-> AppId
-> TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EpochTime -> IO (TVar (Maybe EpochTime))
forall a. a -> IO (TVar a)
newTVarIO Maybe EpochTime
mmodtime
IO
(TVar [RunningWebApp]
-> TVar [RunningBackgroundApp]
-> AppId
-> TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
-> IO (TVar [RunningWebApp])
-> IO
(TVar [RunningBackgroundApp]
-> AppId
-> TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [RunningWebApp] -> IO (TVar [RunningWebApp])
forall a. a -> IO (TVar a)
newTVarIO [RunningWebApp]
runningWebapps
IO
(TVar [RunningBackgroundApp]
-> AppId
-> TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
-> IO (TVar [RunningBackgroundApp])
-> IO
(AppId
-> TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [RunningBackgroundApp] -> IO (TVar [RunningBackgroundApp])
forall a. a -> IO (TVar a)
newTVarIO [RunningBackgroundApp]
runningBacks
IO
(AppId
-> TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
-> IO AppId
-> IO
(TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppId -> IO AppId
forall (m :: * -> *) a. Monad m => a -> m a
return AppId
aid
IO
(TVar (Set Host)
-> TVar (Maybe String)
-> AppStartConfig
-> TVar (Maybe Logger)
-> App)
-> IO (TVar (Set Host))
-> IO
(TVar (Maybe String)
-> AppStartConfig -> TVar (Maybe Logger) -> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Host -> IO (TVar (Set Host))
forall a. a -> IO (TVar a)
newTVarIO (Map Host (ProxyAction, Credentials) -> Set Host
forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions)
IO
(TVar (Maybe String)
-> AppStartConfig -> TVar (Maybe Logger) -> App)
-> IO (TVar (Maybe String))
-> IO (AppStartConfig -> TVar (Maybe Logger) -> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe String -> IO (TVar (Maybe String))
forall a. a -> IO (TVar a)
newTVarIO Maybe String
newdir
IO (AppStartConfig -> TVar (Maybe Logger) -> App)
-> IO AppStartConfig -> IO (TVar (Maybe Logger) -> App)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppStartConfig -> IO AppStartConfig
forall (m :: * -> *) a. Monad m => a -> m a
return AppStartConfig
asc
IO (TVar (Maybe Logger) -> App)
-> IO (TVar (Maybe Logger)) -> IO App
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Maybe Logger) -> IO (TVar (Maybe Logger))
forall (m :: * -> *) a. Monad m => a -> m a
return TVar (Maybe Logger)
tAppLogger
bracketedMap :: (a -> (b -> IO c) -> IO c)
-> ([b] -> IO c)
-> [a]
-> IO c
bracketedMap :: forall a b c.
(a -> (b -> IO c) -> IO c) -> ([b] -> IO c) -> [a] -> IO c
bracketedMap a -> (b -> IO c) -> IO c
with [b] -> IO c
inside =
([b] -> [b]) -> [a] -> IO c
loop [b] -> [b]
forall a. a -> a
id
where
loop :: ([b] -> [b]) -> [a] -> IO c
loop [b] -> [b]
front [] = [b] -> IO c
inside ([b] -> IO c) -> [b] -> IO c
forall a b. (a -> b) -> a -> b
$ [b] -> [b]
front []
loop [b] -> [b]
front (a
c:[a]
cs) = a -> (b -> IO c) -> IO c
with a
c ((b -> IO c) -> IO c) -> (b -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \b
x -> ([b] -> [b]) -> [a] -> IO c
loop ([b] -> [b]
front ([b] -> [b]) -> ([b] -> [b]) -> [b] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b
xb -> [b] -> [b]
forall a. a -> [a] -> [a]
:)) [a]
cs
withWebApps :: AppId
-> BundleConfig
-> Maybe FilePath
-> Logger
-> [WebAppConfig Port]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps :: forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
aid BundleConfig
bconfig Maybe String
mdir Logger
appLogger [WebAppConfig Int]
configs0 [RunningWebApp] -> KeterM AppStartConfig a
f =
((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
(WebAppConfig Int -> (RunningWebApp -> IO a) -> IO a)
-> ([RunningWebApp] -> IO a) -> [WebAppConfig Int] -> IO a
forall a b c.
(a -> (b -> IO c) -> IO c) -> ([b] -> IO c) -> [a] -> IO c
bracketedMap (\WebAppConfig Int
wac RunningWebApp -> IO a
f -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
alloc WebAppConfig Int
wac (IO a -> KeterM AppStartConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> KeterM AppStartConfig a)
-> (RunningWebApp -> IO a)
-> RunningWebApp
-> KeterM AppStartConfig a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunningWebApp -> IO a
f)) (KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> [RunningWebApp]
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RunningWebApp] -> KeterM AppStartConfig a
f) [WebAppConfig Int]
configs0
where
alloc :: WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
alloc = AppId
-> BundleConfig
-> Maybe String
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
launchWebApp AppId
aid BundleConfig
bconfig Maybe String
mdir Logger
appLogger
formatAppLog :: AppId -> FL.LogType -> LogStr -> LogStr
formatAppLog :: AppId -> LogType -> LogStr -> LogStr
formatAppLog AppId
aid (FL.LogStderr Int
_) LogStr
msg = String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (AppId -> String
appLogName AppId
aid) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"> " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg
formatAppLog AppId
_ LogType
_ LogStr
msg = LogStr
msg
launchWebApp :: AppId
-> BundleConfig
-> Maybe FilePath
-> Logger
-> WebAppConfig Port
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
launchWebApp :: forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> WebAppConfig Int
-> (RunningWebApp -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
launchWebApp AppId
aid BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} Maybe String
mdir Logger
appLogger WebAppConfig {Int
String
Maybe Int
Map Text Text
Host
Set Text
Set Host
Vector Text
SSLConfig
waconfigEnsureAliveTimeout :: Maybe Int
waconfigTimeout :: Maybe Int
waconfigForwardEnv :: Set Text
waconfigPort :: Int
waconfigSsl :: SSLConfig
waconfigHosts :: Set Host
waconfigApprootHost :: Host
waconfigEnvironment :: Map Text Text
waconfigArgs :: Vector Text
waconfigExec :: String
waconfigEnsureAliveTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigForwardEnv :: forall port. WebAppConfig port -> Set Text
waconfigEnvironment :: forall port. WebAppConfig port -> Map Text Text
waconfigArgs :: forall port. WebAppConfig port -> Vector Text
waconfigExec :: forall port. WebAppConfig port -> String
waconfigHosts :: forall port. WebAppConfig port -> Set Host
waconfigApprootHost :: forall port. WebAppConfig port -> Host
waconfigTimeout :: forall port. WebAppConfig port -> Maybe Int
waconfigPort :: forall port. WebAppConfig port -> port
waconfigSsl :: forall port. WebAppConfig port -> SSLConfig
..} RunningWebApp -> KeterM AppStartConfig a
f = do
AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
[(Text, Text)]
otherEnv <- IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)])
-> IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ascPlugins Text
name Object
bconfigPlugins
Map Text Text
forwardedEnv <- IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text))
-> IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text)
forall a b. (a -> b) -> a -> b
$ Set Text -> IO (Map Text Text)
getForwardedEnv Set Text
waconfigForwardEnv
let httpPort :: Int
httpPort = KeterConfig -> Int
kconfigExternalHttpPort KeterConfig
ascKeterConfig
httpsPort :: Int
httpsPort = KeterConfig -> Int
kconfigExternalHttpsPort KeterConfig
ascKeterConfig
(Text
scheme, String
extport) =
if SSLConfig
waconfigSsl SSLConfig -> SSLConfig -> Bool
forall a. Eq a => a -> a -> Bool
== SSLConfig
SSLFalse
then (Text
"http://", if Int
httpPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
80 then String
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
httpPort)
else (Text
"https://", if Int
httpsPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 then String
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
httpsPort)
env :: [(Text, Text)]
env = Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [Map Text Text] -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
[ Map Text Text
waconfigEnvironment
, Map Text Text
forwardedEnv
, [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
otherEnv
, KeterConfig -> Map Text Text
kconfigEnvironment KeterConfig
ascKeterConfig
, Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"PORT" (Text -> Map Text Text) -> Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
waconfigPort
, Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"APPROOT" (Text -> Map Text Text) -> Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Host -> Text
forall s. CI s -> s
CI.original Host
waconfigApprootHost Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
extport
]
String
exec <- IO String -> KeterM AppStartConfig String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> KeterM AppStartConfig String)
-> IO String -> KeterM AppStartConfig String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
waconfigExec
Loc -> Text -> LogLevel -> LogStr -> IO ()
mainLogger <- KeterM AppStartConfig (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> IO MonitoredProcess
-> (MonitoredProcess -> IO ())
-> (MonitoredProcess -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess)
-> KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess
forall a b. (a -> b) -> a -> b
$ ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> KeterM AppStartConfig MonitoredProcess
forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> m MonitoredProcess
monitorProcess
ProcessTracker
ascProcessTracker
(Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> ((Text, (UserID, GroupID)) -> Text)
-> (Text, (UserID, GroupID))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (UserID, GroupID)) -> Text
forall a b. (a, b) -> a
fst ((Text, (UserID, GroupID)) -> ByteString)
-> Maybe (Text, (UserID, GroupID)) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, (UserID, GroupID))
ascSetuid)
(Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
exec)
(ByteString -> (String -> ByteString) -> Maybe String -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) Maybe String
mdir)
((Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 ([Text] -> [ByteString]) -> [Text] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList Vector Text
waconfigArgs)
(((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
encodeUtf8) [(Text, Text)]
env)
(Logger -> forall a. ToLogStr a => a -> IO ()
Log.loggerLog Logger
appLogger (LogStr -> IO ()) -> (ByteString -> LogStr) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> LogType -> LogStr -> LogStr
formatAppLog AppId
aid (Logger -> LogType
Log.loggerType Logger
appLogger) (LogStr -> LogStr)
-> (ByteString -> LogStr) -> ByteString -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr)
(IO Bool -> ExitCode -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> ExitCode -> IO Bool) -> IO Bool -> ExitCode -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True))
MonitoredProcess -> IO ()
terminateMonitoredProcess
((MonitoredProcess -> IO a) -> IO a)
-> (MonitoredProcess -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \MonitoredProcess
mp -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ RunningWebApp -> KeterM AppStartConfig a
f RunningWebApp :: MonitoredProcess -> Int -> Int -> RunningWebApp
RunningWebApp
{ rwaProcess :: MonitoredProcess
rwaProcess = MonitoredProcess
mp
, rwaPort :: Int
rwaPort = Int
waconfigPort
, rwaEnsureAliveTimeOut :: Int
rwaEnsureAliveTimeOut = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int
90 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) Maybe Int
waconfigEnsureAliveTimeout
}
where
name :: Text
name =
case AppId
aid of
AppId
AIBuiltin -> Text
"__builtin__"
AINamed Text
x -> Text
x
killWebApp :: RunningWebApp -> KeterM cfg ()
killWebApp :: forall cfg. RunningWebApp -> KeterM cfg ()
killWebApp RunningWebApp {Int
MonitoredProcess
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..} = do
Text
status <- IO Text -> KeterM cfg Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> KeterM cfg Text) -> IO Text -> KeterM cfg Text
forall a b. (a -> b) -> a -> b
$ MonitoredProcess -> IO Text
printStatus MonitoredProcess
rwaProcess
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM cfg ()
(Text -> KeterM cfg ()) -> (Text -> Text) -> Text -> KeterM cfg ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo (Text -> KeterM cfg ()) -> Text -> KeterM cfg ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Killing " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
status String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" running on port: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rwaPort
IO () -> KeterM cfg ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM cfg ()) -> IO () -> KeterM cfg ()
forall a b. (a -> b) -> a -> b
$ MonitoredProcess -> IO ()
terminateMonitoredProcess MonitoredProcess
rwaProcess
ensureAlive :: RunningWebApp -> IO ()
ensureAlive :: RunningWebApp -> IO ()
ensureAlive RunningWebApp {Int
MonitoredProcess
rwaEnsureAliveTimeOut :: Int
rwaPort :: Int
rwaProcess :: MonitoredProcess
rwaEnsureAliveTimeOut :: RunningWebApp -> Int
rwaPort :: RunningWebApp -> Int
rwaProcess :: RunningWebApp -> MonitoredProcess
..} = do
Bool
didAnswer <- Int -> IO Bool
testApp Int
rwaPort
if Bool
didAnswer
then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ensureAlive failed, this means keter couldn't " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
String
"detect your app at port " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rwaPort String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
String
", check your app logs detailed errors. " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
String
" Also make sure your app binds to the PORT environment variable (not YESOD_PORT for example)."
where
testApp :: Port -> IO Bool
testApp :: Int -> IO Bool
testApp Int
port = do
Maybe Bool
res <- Int -> IO Bool -> IO (Maybe Bool)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
rwaEnsureAliveTimeOut IO Bool
testApp'
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
res
where
testApp' :: IO Bool
testApp' = do
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
Either IOException Handle
eres <- IO Handle -> IO (Either IOException Handle)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Handle -> IO (Either IOException Handle))
-> IO Handle -> IO (Either IOException Handle)
forall a b. (a -> b) -> a -> b
$ String -> String -> IO Handle
connectTo String
"127.0.0.1" (String -> IO Handle) -> String -> IO Handle
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
port
case Either IOException Handle
eres of
Left (IOException
_ :: IOException) -> IO Bool
testApp'
Right Handle
handle -> do
Handle -> IO ()
hClose Handle
handle
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
connectTo :: String -> String -> IO Handle
connectTo String
host String
serv = do
let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
, addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
[AddrInfo]
addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just String
serv)
[IO Handle] -> IO Handle
forall {b}. [IO b] -> IO b
firstSuccessful ([IO Handle] -> IO Handle) -> [IO Handle] -> IO Handle
forall a b. (a -> b) -> a -> b
$ (AddrInfo -> IO Handle) -> [AddrInfo] -> [IO Handle]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> IO Handle
tryToConnect [AddrInfo]
addrs
where
tryToConnect :: AddrInfo -> IO Handle
tryToConnect AddrInfo
addr =
IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Handle) -> IO Handle
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
(Socket -> IO ()
close)
(\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
go Maybe IOException
Nothing [] = IOException -> IO b
forall a. IOException -> IO a
ioError (IOException -> IO b) -> IOException -> IO b
forall a b. (a -> b) -> a -> b
$ String -> IOException
userError (String -> IOException) -> String -> IOException
forall a b. (a -> b) -> a -> b
$ String
"connectTo firstSuccessful: empty list"
go (Just IOException
e) [] = IOException -> IO b
forall e a. Exception e => e -> IO a
throwIO IOException
e
tryIO :: IO a -> IO (Either IOException a)
tryIO :: forall a. IO a -> IO (Either IOException a)
tryIO IO a
m = IO (Either IOException a)
-> (IOException -> IO (Either IOException a))
-> IO (Either IOException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((a -> Either IOException a) -> IO a -> IO (Either IOException a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Either IOException a
forall a b. b -> Either a b
Right IO a
m) (Either IOException a -> IO (Either IOException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOException a -> IO (Either IOException a))
-> (IOException -> Either IOException a)
-> IOException
-> IO (Either IOException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Either IOException a
forall a b. a -> Either a b
Left)
withBackgroundApps :: AppId
-> BundleConfig
-> Maybe FilePath
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps :: forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
aid BundleConfig
bconfig Maybe String
mdir Logger
appLogger [BackgroundConfig]
configs [RunningBackgroundApp] -> KeterM AppStartConfig a
f =
((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> (BackgroundConfig -> (RunningBackgroundApp -> IO a) -> IO a)
-> ([RunningBackgroundApp] -> IO a) -> [BackgroundConfig] -> IO a
forall a b c.
(a -> (b -> IO c) -> IO c) -> ([b] -> IO c) -> [a] -> IO c
bracketedMap (\BackgroundConfig
cfg RunningBackgroundApp -> IO a
f -> KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> KeterM AppStartConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ BackgroundConfig
-> (RunningBackgroundApp -> IO a) -> KeterM AppStartConfig a
alloc BackgroundConfig
cfg (IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a)
-> (RunningBackgroundApp -> IO a) -> RunningBackgroundApp -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunningBackgroundApp -> IO a
f)) (KeterM AppStartConfig a -> IO a
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig a -> IO a)
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> [RunningBackgroundApp]
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RunningBackgroundApp] -> KeterM AppStartConfig a
f) [BackgroundConfig]
configs
where
alloc :: BackgroundConfig
-> (RunningBackgroundApp -> IO a) -> KeterM AppStartConfig a
alloc = AppId
-> BundleConfig
-> Maybe String
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
launchBackgroundApp AppId
aid BundleConfig
bconfig Maybe String
mdir Logger
appLogger
launchBackgroundApp :: AppId
-> BundleConfig
-> Maybe FilePath
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
launchBackgroundApp :: forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> BackgroundConfig
-> (RunningBackgroundApp -> IO a)
-> KeterM AppStartConfig a
launchBackgroundApp AppId
aid BundleConfig {Object
Vector (Stanza ())
bconfigPlugins :: Object
bconfigStanzas :: Vector (Stanza ())
bconfigPlugins :: BundleConfig -> Object
bconfigStanzas :: BundleConfig -> Vector (Stanza ())
..} Maybe String
mdir Logger
appLogger BackgroundConfig {String
Word
Map Text Text
Set Text
Vector Text
RestartCount
bgconfigForwardEnv :: Set Text
bgconfigRestartDelaySeconds :: Word
bgconfigRestartCount :: RestartCount
bgconfigEnvironment :: Map Text Text
bgconfigArgs :: Vector Text
bgconfigExec :: String
bgconfigForwardEnv :: BackgroundConfig -> Set Text
bgconfigRestartDelaySeconds :: BackgroundConfig -> Word
bgconfigRestartCount :: BackgroundConfig -> RestartCount
bgconfigEnvironment :: BackgroundConfig -> Map Text Text
bgconfigArgs :: BackgroundConfig -> Vector Text
bgconfigExec :: BackgroundConfig -> String
..} RunningBackgroundApp -> IO a
f = do
AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
[(Text, Text)]
otherEnv <- IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)])
-> IO [(Text, Text)] -> KeterM AppStartConfig [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Plugins -> Text -> Object -> IO [(Text, Text)]
pluginsGetEnv Plugins
ascPlugins Text
name Object
bconfigPlugins
Map Text Text
forwardedEnv <- IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text))
-> IO (Map Text Text) -> KeterM AppStartConfig (Map Text Text)
forall a b. (a -> b) -> a -> b
$ Set Text -> IO (Map Text Text)
getForwardedEnv Set Text
bgconfigForwardEnv
let env :: [(Text, Text)]
env = Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [Map Text Text] -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
[ Map Text Text
bgconfigEnvironment
, Map Text Text
forwardedEnv
, [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
otherEnv
, KeterConfig -> Map Text Text
kconfigEnvironment KeterConfig
ascKeterConfig
]
String
exec <- IO String -> KeterM AppStartConfig String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> KeterM AppStartConfig String)
-> IO String -> KeterM AppStartConfig String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
bgconfigExec
let delay :: IO ()
delay = Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Word
bgconfigRestartDelaySeconds Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
1000 Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
1000
IO Bool
shouldRestart <-
case RestartCount
bgconfigRestartCount of
RestartCount
UnlimitedRestarts -> IO Bool -> KeterM AppStartConfig (IO Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO Bool -> KeterM AppStartConfig (IO Bool))
-> IO Bool -> KeterM AppStartConfig (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
IO ()
delay
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
LimitedRestarts Word
maxCount -> do
IORef Word
icount <- IO (IORef Word) -> KeterM AppStartConfig (IORef Word)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Word) -> KeterM AppStartConfig (IORef Word))
-> IO (IORef Word) -> KeterM AppStartConfig (IORef Word)
forall a b. (a -> b) -> a -> b
$ Word -> IO (IORef Word)
forall a. a -> IO (IORef a)
newIORef Word
0
IO Bool -> KeterM AppStartConfig (IO Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO Bool -> KeterM AppStartConfig (IO Bool))
-> IO Bool -> KeterM AppStartConfig (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
Bool
res <- IORef Word -> (Word -> (Word, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Word
icount ((Word -> (Word, Bool)) -> IO Bool)
-> (Word -> (Word, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Word
count ->
(Word
count Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1, Word
count Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
maxCount)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
res IO ()
delay
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
res
Loc -> Text -> LogLevel -> LogStr -> IO ()
mainLogger <- KeterM AppStartConfig (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO a)
-> KeterM AppStartConfig a
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio -> IO MonitoredProcess
-> (MonitoredProcess -> IO ())
-> (MonitoredProcess -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess)
-> KeterM AppStartConfig MonitoredProcess -> IO MonitoredProcess
forall a b. (a -> b) -> a -> b
$ ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> KeterM AppStartConfig MonitoredProcess
forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> m MonitoredProcess
monitorProcess
ProcessTracker
ascProcessTracker
(Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> ((Text, (UserID, GroupID)) -> Text)
-> (Text, (UserID, GroupID))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (UserID, GroupID)) -> Text
forall a b. (a, b) -> a
fst ((Text, (UserID, GroupID)) -> ByteString)
-> Maybe (Text, (UserID, GroupID)) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, (UserID, GroupID))
ascSetuid)
(Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
exec)
(ByteString -> (String -> ByteString) -> Maybe String -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/tmp" (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) Maybe String
mdir)
((Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 ([Text] -> [ByteString]) -> [Text] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList Vector Text
bgconfigArgs)
(((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
encodeUtf8) [(Text, Text)]
env)
(Logger -> forall a. ToLogStr a => a -> IO ()
Log.loggerLog Logger
appLogger (LogStr -> IO ()) -> (ByteString -> LogStr) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppId -> LogType -> LogStr -> LogStr
formatAppLog AppId
aid (Logger -> LogType
Log.loggerType Logger
appLogger) (LogStr -> LogStr)
-> (ByteString -> LogStr) -> ByteString -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr)
(IO Bool -> ExitCode -> IO Bool
forall a b. a -> b -> a
const IO Bool
shouldRestart))
MonitoredProcess -> IO ()
terminateMonitoredProcess
(RunningBackgroundApp -> IO a
f (RunningBackgroundApp -> IO a)
-> (MonitoredProcess -> RunningBackgroundApp)
-> MonitoredProcess
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonitoredProcess -> RunningBackgroundApp
RunningBackgroundApp)
where
name :: Text
name =
case AppId
aid of
AppId
AIBuiltin -> Text
"__builtin__"
AINamed Text
x -> Text
x
killBackgroundApp :: RunningBackgroundApp -> IO ()
killBackgroundApp :: RunningBackgroundApp -> IO ()
killBackgroundApp RunningBackgroundApp {MonitoredProcess
rbaProcess :: MonitoredProcess
rbaProcess :: RunningBackgroundApp -> MonitoredProcess
..} = do
MonitoredProcess -> IO ()
terminateMonitoredProcess MonitoredProcess
rbaProcess
reload :: AppInput -> KeterM App ()
reload :: AppInput -> KeterM App ()
reload AppInput
input = do
App{TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe String)
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe String)
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe String)
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} <- KeterM App App
forall r (m :: * -> *). MonadReader r m => m r
ask
(App -> AppStartConfig)
-> KeterM AppStartConfig () -> KeterM App ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (AppStartConfig -> App -> AppStartConfig
forall a b. a -> b -> a
const AppStartConfig
appAsc) (KeterM AppStartConfig () -> KeterM App ())
-> KeterM AppStartConfig () -> KeterM App ()
forall a b. (a -> b) -> a -> b
$
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> Maybe (TVar (Maybe Logger))
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withLogger AppId
appId (TVar (Maybe Logger) -> Maybe (TVar (Maybe Logger))
forall a. a -> Maybe a
Just TVar (Maybe Logger)
appLog) ((TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ())
-> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \TVar (Maybe Logger)
_ Logger
appLogger ->
AppId
-> AppInput
-> (Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> AppInput
-> (Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withConfig AppId
appId AppInput
input ((Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ())
-> (Maybe String
-> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \Maybe String
newdir BundleConfig
bconfig Maybe EpochTime
mmodtime ->
BundleConfig
-> KeterM AppStartConfig () -> KeterM AppStartConfig ()
forall a.
BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a
withSanityChecks BundleConfig
bconfig (KeterM AppStartConfig () -> KeterM AppStartConfig ())
-> KeterM AppStartConfig () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$
AppId
-> BundleConfig
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> BundleConfig
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withReservations AppId
appId BundleConfig
bconfig (([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig ())
-> KeterM AppStartConfig ())
-> ([WebAppConfig Int]
-> [BackgroundConfig]
-> Map Host (ProxyAction, Credentials)
-> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \[WebAppConfig Int]
webapps [BackgroundConfig]
backs Map Host (ProxyAction, Credentials)
actions ->
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [BackgroundConfig]
-> ([RunningBackgroundApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withBackgroundApps AppId
appId BundleConfig
bconfig Maybe String
newdir Logger
appLogger [BackgroundConfig]
backs (([RunningBackgroundApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ())
-> ([RunningBackgroundApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \[RunningBackgroundApp]
runningBacks ->
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a.
AppId
-> BundleConfig
-> Maybe String
-> Logger
-> [WebAppConfig Int]
-> ([RunningWebApp] -> KeterM AppStartConfig a)
-> KeterM AppStartConfig a
withWebApps AppId
appId BundleConfig
bconfig Maybe String
newdir Logger
appLogger [WebAppConfig Int]
webapps (([RunningWebApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ())
-> ([RunningWebApp] -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ \[RunningWebApp]
runningWebapps -> do
IO () -> KeterM AppStartConfig ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ (RunningWebApp -> IO ()) -> [RunningWebApp] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> IO ()
ensureAlive [RunningWebApp]
runningWebapps
IO (Set Host) -> KeterM AppStartConfig (Set Host)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar (Set Host) -> IO (Set Host)
forall a. TVar a -> IO a
readTVarIO TVar (Set Host)
appHosts) KeterM AppStartConfig (Set Host)
-> (Set Host -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Set Host
hosts ->
(AppStartConfig -> HostManager)
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> AppStartConfig -> HostManager
forall a b. a -> b -> a
const (HostManager -> AppStartConfig -> HostManager)
-> HostManager -> AppStartConfig -> HostManager
forall a b. (a -> b) -> a -> b
$ AppStartConfig -> HostManager
ascHostManager AppStartConfig
appAsc) (KeterM HostManager () -> KeterM AppStartConfig ())
-> KeterM HostManager () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$
AppId
-> Map Host (ProxyAction, Credentials)
-> Set Host
-> KeterM HostManager ()
reactivateApp AppId
appId Map Host (ProxyAction, Credentials)
actions Set Host
hosts
([RunningWebApp]
oldApps, [RunningBackgroundApp]
oldBacks, Maybe String
oldDir, Maybe Logger
oldRlog) <- IO
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> KeterM
AppStartConfig
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> KeterM
AppStartConfig
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger))
-> IO
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> KeterM
AppStartConfig
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall a b. (a -> b) -> a -> b
$ STM
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> IO
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall a. STM a -> IO a
atomically (STM
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> IO
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger))
-> STM
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> IO
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall a b. (a -> b) -> a -> b
$ do
[RunningWebApp]
oldApps <- TVar [RunningWebApp] -> STM [RunningWebApp]
forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
[RunningBackgroundApp]
oldBacks <- TVar [RunningBackgroundApp] -> STM [RunningBackgroundApp]
forall a. TVar a -> STM a
readTVar TVar [RunningBackgroundApp]
appBackgroundApps
Maybe String
oldDir <- TVar (Maybe String) -> STM (Maybe String)
forall a. TVar a -> STM a
readTVar TVar (Maybe String)
appDir
Maybe Logger
oldRlog <- TVar (Maybe Logger) -> STM (Maybe Logger)
forall a. TVar a -> STM a
readTVar TVar (Maybe Logger)
appLog
TVar (Maybe EpochTime) -> Maybe EpochTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe EpochTime)
appModTime Maybe EpochTime
mmodtime
TVar [RunningWebApp] -> [RunningWebApp] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningWebApp]
appRunningWebApps [RunningWebApp]
runningWebapps
TVar [RunningBackgroundApp] -> [RunningBackgroundApp] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningBackgroundApp]
appBackgroundApps [RunningBackgroundApp]
runningBacks
TVar (Set Host) -> Set Host -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Set Host)
appHosts (Set Host -> STM ()) -> Set Host -> STM ()
forall a b. (a -> b) -> a -> b
$ Map Host (ProxyAction, Credentials) -> Set Host
forall k a. Map k a -> Set k
Map.keysSet Map Host (ProxyAction, Credentials)
actions
TVar (Maybe String) -> Maybe String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe String)
appDir Maybe String
newdir
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> STM
([RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return ([RunningWebApp]
oldApps, [RunningBackgroundApp]
oldBacks, Maybe String
oldDir, Maybe Logger
oldRlog)
KeterM AppStartConfig ThreadId -> KeterM AppStartConfig ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KeterM AppStartConfig ThreadId -> KeterM AppStartConfig ())
-> KeterM AppStartConfig ThreadId -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ ((forall a. KeterM AppStartConfig a -> IO a) -> IO ThreadId)
-> KeterM AppStartConfig ThreadId
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppStartConfig a -> IO a) -> IO ThreadId)
-> KeterM AppStartConfig ThreadId)
-> ((forall a. KeterM AppStartConfig a -> IO a) -> IO ThreadId)
-> KeterM AppStartConfig ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppStartConfig a -> IO a
rio ->
IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ KeterM AppStartConfig () -> IO ()
forall a. KeterM AppStartConfig a -> IO a
rio (KeterM AppStartConfig () -> IO ())
-> KeterM AppStartConfig () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe String
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
appId [RunningWebApp]
oldApps [RunningBackgroundApp]
oldBacks Maybe String
oldDir Maybe Logger
oldRlog
terminate :: KeterM App ()
terminate :: KeterM App ()
terminate = do
App{TVar [RunningBackgroundApp]
TVar [RunningWebApp]
TVar (Maybe String)
TVar (Maybe EpochTime)
TVar (Maybe Logger)
TVar (Set Host)
AppId
AppStartConfig
appLog :: TVar (Maybe Logger)
appAsc :: AppStartConfig
appDir :: TVar (Maybe String)
appHosts :: TVar (Set Host)
appId :: AppId
appBackgroundApps :: TVar [RunningBackgroundApp]
appRunningWebApps :: TVar [RunningWebApp]
appModTime :: TVar (Maybe EpochTime)
appLog :: App -> TVar (Maybe Logger)
appAsc :: App -> AppStartConfig
appDir :: App -> TVar (Maybe String)
appHosts :: App -> TVar (Set Host)
appId :: App -> AppId
appBackgroundApps :: App -> TVar [RunningBackgroundApp]
appRunningWebApps :: App -> TVar [RunningWebApp]
appModTime :: App -> TVar (Maybe EpochTime)
..} <- KeterM App App
forall r (m :: * -> *). MonadReader r m => m r
ask
let AppStartConfig {Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} = AppStartConfig
appAsc
(Set Host
hosts, [RunningWebApp]
apps, [RunningBackgroundApp]
backs, Maybe String
mdir, Maybe Logger
appLogger) <- IO
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> KeterM
App
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> KeterM
App
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger))
-> IO
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> KeterM
App
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall a b. (a -> b) -> a -> b
$ STM
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> IO
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall a. STM a -> IO a
atomically (STM
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> IO
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger))
-> STM
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> IO
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall a b. (a -> b) -> a -> b
$ do
Set Host
hosts <- TVar (Set Host) -> STM (Set Host)
forall a. TVar a -> STM a
readTVar TVar (Set Host)
appHosts
[RunningWebApp]
apps <- TVar [RunningWebApp] -> STM [RunningWebApp]
forall a. TVar a -> STM a
readTVar TVar [RunningWebApp]
appRunningWebApps
[RunningBackgroundApp]
backs <- TVar [RunningBackgroundApp] -> STM [RunningBackgroundApp]
forall a. TVar a -> STM a
readTVar TVar [RunningBackgroundApp]
appBackgroundApps
Maybe String
mdir <- TVar (Maybe String) -> STM (Maybe String)
forall a. TVar a -> STM a
readTVar TVar (Maybe String)
appDir
Maybe Logger
appLogger <- TVar (Maybe Logger) -> STM (Maybe Logger)
forall a. TVar a -> STM a
readTVar TVar (Maybe Logger)
appLog
TVar (Maybe EpochTime) -> Maybe EpochTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe EpochTime)
appModTime Maybe EpochTime
forall a. Maybe a
Nothing
TVar [RunningWebApp] -> [RunningWebApp] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningWebApp]
appRunningWebApps []
TVar [RunningBackgroundApp] -> [RunningBackgroundApp] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [RunningBackgroundApp]
appBackgroundApps []
TVar (Set Host) -> Set Host -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Set Host)
appHosts Set Host
forall a. Set a
Set.empty
TVar (Maybe String) -> Maybe String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe String)
appDir Maybe String
forall a. Maybe a
Nothing
TVar (Maybe Logger) -> Maybe Logger -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Logger)
appLog Maybe Logger
forall a. Maybe a
Nothing
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
-> STM
(Set Host, [RunningWebApp], [RunningBackgroundApp], Maybe String,
Maybe Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Host
hosts, [RunningWebApp]
apps, [RunningBackgroundApp]
backs, Maybe String
mdir, Maybe Logger
appLogger)
(App -> HostManager) -> KeterM HostManager () -> KeterM App ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (HostManager -> App -> HostManager
forall a b. a -> b -> a
const HostManager
ascHostManager) (KeterM HostManager () -> KeterM App ())
-> KeterM HostManager () -> KeterM App ()
forall a b. (a -> b) -> a -> b
$
AppId -> Set Host -> KeterM HostManager ()
deactivateApp AppId
appId Set Host
hosts
KeterM App ThreadId -> KeterM App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KeterM App ThreadId -> KeterM App ())
-> KeterM App ThreadId -> KeterM App ()
forall a b. (a -> b) -> a -> b
$ ((forall a. KeterM App a -> IO a) -> IO ThreadId)
-> KeterM App ThreadId
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM App a -> IO a) -> IO ThreadId)
-> KeterM App ThreadId)
-> ((forall a. KeterM App a -> IO a) -> IO ThreadId)
-> KeterM App ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM App a -> IO a
rio ->
IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ KeterM App () -> IO ()
forall a. KeterM App a -> IO a
rio (KeterM App () -> IO ()) -> KeterM App () -> IO ()
forall a b. (a -> b) -> a -> b
$ (App -> AppStartConfig)
-> KeterM AppStartConfig () -> KeterM App ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (AppStartConfig -> App -> AppStartConfig
forall a b. a -> b -> a
const AppStartConfig
appAsc) (KeterM AppStartConfig () -> KeterM App ())
-> KeterM AppStartConfig () -> KeterM App ()
forall a b. (a -> b) -> a -> b
$
AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe String
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
appId [RunningWebApp]
apps [RunningBackgroundApp]
backs Maybe String
mdir Maybe Logger
appLogger
IO () -> KeterM App ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM App ()) -> IO () -> KeterM App ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Logger -> IO ()) -> Maybe Logger -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Logger -> IO ()
Log.loggerClose Maybe Logger
appLogger
terminateHelper :: AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe FilePath
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper :: AppId
-> [RunningWebApp]
-> [RunningBackgroundApp]
-> Maybe String
-> Maybe Logger
-> KeterM AppStartConfig ()
terminateHelper AppId
aid [RunningWebApp]
apps [RunningBackgroundApp]
backs Maybe String
mdir Maybe Logger
appLogger = do
AppStartConfig{Plugins
Maybe (Text, (UserID, GroupID))
ProcessTracker
TempFolder
KeterConfig
PortPool
HostManager
ascKeterConfig :: KeterConfig
ascPlugins :: Plugins
ascPortPool :: PortPool
ascHostManager :: HostManager
ascProcessTracker :: ProcessTracker
ascSetuid :: Maybe (Text, (UserID, GroupID))
ascTempFolder :: TempFolder
ascKeterConfig :: AppStartConfig -> KeterConfig
ascPlugins :: AppStartConfig -> Plugins
ascPortPool :: AppStartConfig -> PortPool
ascHostManager :: AppStartConfig -> HostManager
ascProcessTracker :: AppStartConfig -> ProcessTracker
ascSetuid :: AppStartConfig -> Maybe (Text, (UserID, GroupID))
ascTempFolder :: AppStartConfig -> TempFolder
..} <- KeterM AppStartConfig AppStartConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> KeterM AppStartConfig ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
String
"Sending old process TERM signal: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ case AppId
aid of { AINamed Text
t -> Text -> String
unpack Text
t; AppId
AIBuiltin -> String
"builtin" }
(RunningWebApp -> KeterM AppStartConfig ())
-> [RunningWebApp] -> KeterM AppStartConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningWebApp -> KeterM AppStartConfig ()
forall cfg. RunningWebApp -> KeterM cfg ()
killWebApp [RunningWebApp]
apps
IO () -> KeterM AppStartConfig ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM AppStartConfig ())
-> IO () -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ do
(RunningBackgroundApp -> IO ()) -> [RunningBackgroundApp] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunningBackgroundApp -> IO ()
killBackgroundApp [RunningBackgroundApp]
backs
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
case Maybe String
mdir of
Maybe String
Nothing -> () -> KeterM AppStartConfig ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just String
dir -> do
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Removing unneeded folder: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dir
Either SomeException ()
res <- IO (Either SomeException ())
-> KeterM AppStartConfig (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException ())
-> KeterM AppStartConfig (Either SomeException ()))
-> IO (Either SomeException ())
-> KeterM AppStartConfig (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
dir
case Either SomeException ()
res of
Left SomeException
e -> $Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppStartConfig ()
(Text -> KeterM AppStartConfig ())
-> (Text -> Text) -> Text -> KeterM AppStartConfig ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logError (Text -> KeterM AppStartConfig ())
-> Text -> KeterM AppStartConfig ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
Right () -> () -> KeterM AppStartConfig ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
getForwardedEnv :: Set Text -> IO (Map Text Text)
getForwardedEnv :: Set Text -> IO (Map Text Text)
getForwardedEnv Set Text
vars = [(String, String)] -> Map Text Text
filterEnv ([(String, String)] -> Map Text Text)
-> IO [(String, String)] -> IO (Map Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
where
filterEnv :: [(String, String)] -> Map Text Text
filterEnv = (Text -> Text -> Bool) -> Map Text Text -> Map Text Text
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Text
k Text
_ -> Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
k Set Text
vars)
(Map Text Text -> Map Text Text)
-> ([(String, String)] -> Map Text Text)
-> [(String, String)]
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
([(Text, Text)] -> Map Text Text)
-> ([(String, String)] -> [(Text, Text)])
-> [(String, String)]
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (Text, Text))
-> [(String, String)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
pack (String -> Text)
-> (String -> Text) -> (String, String) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
pack)