{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Keter.Main
    ( keter
    ) where

import Control.Concurrent.Async (waitAny, withAsync)
import Control.Exception (SomeException, bracket, throwIO, try)
import Control.Monad (forM, forM_, unless, void, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
import Control.Monad.Logger (LoggingT, logInfo, runLoggingT)
import Control.Monad.Logger qualified as L
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)
import Data.Map qualified as Map
import Data.String (fromString)
import Data.Text qualified as T
import Data.Text.Read qualified
import Data.Time (getCurrentTime)
import Data.Vector qualified as V
import Keter.App (AppStartConfig(..))
import Keter.AppManager qualified as AppMan
import Keter.Cli
import Keter.Common
import Keter.Conduit.Process.Unix (initProcessTracker)
import Keter.Config
import Keter.Config.V10
import Keter.Context
import Keter.HostManager qualified as HostMan
import Keter.Logger qualified as Log
import Keter.PortPool qualified as PortPool
import Keter.Proxy qualified as Proxy
import Keter.TempTarball qualified as TempFolder
import Keter.Yaml.FilePath
import Prelude hiding (FilePath, log)
import System.Directory
       ( createDirectoryIfMissing
       , doesDirectoryExist
       , doesFileExist
       , getDirectoryContents
       )
import System.FilePath (FilePath, takeExtension, (</>))
import System.FSNotify qualified as FSN
import System.Log.FastLogger qualified as FL
import System.Posix.Files (getFileStatus, modificationTime)
import System.Posix.Signals (Handler(Catch), installHandler, sigHUP)
import System.Posix.User
       (getUserEntryForID, getUserEntryForName, userGroupID, userID, userName)

keter :: FilePath -- ^ root directory or config file
      -> [FilePath -> IO Plugin]
      -> IO ()
keter :: FilePath -> [FilePath -> IO Plugin] -> IO ()
keter FilePath
input [FilePath -> IO Plugin]
mkPlugins =
    FilePath -> ReaderT KeterConfig IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
FilePath -> ReaderT KeterConfig m a -> m a
runKeterConfigReader FilePath
input (ReaderT KeterConfig IO () -> IO ())
-> (KeterM KeterConfig () -> ReaderT KeterConfig IO ())
-> KeterM KeterConfig ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggingT (ReaderT KeterConfig IO) () -> ReaderT KeterConfig IO ()
forall (m :: * -> *) a.
(MonadReader KeterConfig m, MonadIO m, MonadUnliftIO m) =>
LoggingT m a -> m a
runKeterLogger (LoggingT (ReaderT KeterConfig IO) () -> ReaderT KeterConfig IO ())
-> (KeterM KeterConfig () -> LoggingT (ReaderT KeterConfig IO) ())
-> KeterM KeterConfig ()
-> ReaderT KeterConfig IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeterM KeterConfig () -> LoggingT (ReaderT KeterConfig IO) ()
forall cfg a. KeterM cfg a -> LoggingT (ReaderT cfg IO) a
runKeterM (KeterM KeterConfig () -> IO ()) -> KeterM KeterConfig () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [FilePath -> IO Plugin]
-> (HostManager -> AppManager -> KeterM KeterConfig ())
-> KeterM KeterConfig ()
forall a.
[FilePath -> IO Plugin]
-> (HostManager -> AppManager -> KeterM KeterConfig a)
-> KeterM KeterConfig a
withManagers [FilePath -> IO Plugin]
mkPlugins ((HostManager -> AppManager -> KeterM KeterConfig ())
 -> KeterM KeterConfig ())
-> (HostManager -> AppManager -> KeterM KeterConfig ())
-> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ \HostManager
hostman AppManager
appMan -> do
            KeterConfig{Bool
Int
FilePath
Maybe Int
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigDir :: FilePath
kconfigPortPool :: PortSettings
kconfigListeners :: NonEmptyVector ListeningPort
kconfigSetuid :: Maybe Text
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigIpFromHeader :: Bool
kconfigExternalHttpPort :: Int
kconfigExternalHttpsPort :: Int
kconfigEnvironment :: Map Text Text
kconfigConnectionTimeBound :: Int
kconfigCliPort :: Maybe Int
kconfigUnknownHostResponse :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigProxyException :: Maybe FilePath
kconfigRotateLogs :: Bool
kconfigHealthcheckPath :: Maybe Text
kconfigDir :: KeterConfig -> FilePath
kconfigPortPool :: KeterConfig -> PortSettings
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigRotateLogs :: KeterConfig -> Bool
kconfigHealthcheckPath :: KeterConfig -> Maybe Text
..} <- KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
            $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM KeterConfig ()
(Text -> KeterM KeterConfig ())
-> (Text -> Text) -> Text -> KeterM KeterConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM KeterConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
logInfo Text
"Launching cli"
            Maybe Int
-> (Int -> KeterM KeterConfig ()) -> KeterM KeterConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
kconfigCliPort ((Int -> KeterM KeterConfig ()) -> KeterM KeterConfig ())
-> (Int -> KeterM KeterConfig ()) -> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ \Int
port ->
              (KeterConfig -> CliStates)
-> KeterM CliStates () -> KeterM KeterConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig
                  (CliStates -> KeterConfig -> CliStates
forall a b. a -> b -> a
const (CliStates -> KeterConfig -> CliStates)
-> CliStates -> KeterConfig -> CliStates
forall a b. (a -> b) -> a -> b
$ MkCliStates
                      { csAppManager :: AppManager
csAppManager = AppManager
appMan
                      , csPort :: Int
csPort       = Int
port
                      })
                  KeterM CliStates ()
launchCli
            $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM KeterConfig ()
(Text -> KeterM KeterConfig ())
-> (Text -> Text) -> Text -> KeterM KeterConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM KeterConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
logInfo Text
"Launching initial"
            AppManager -> KeterM KeterConfig ()
launchInitial AppManager
appMan
            $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM KeterConfig ()
(Text -> KeterM KeterConfig ())
-> (Text -> Text) -> Text -> KeterM KeterConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM KeterConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
logInfo Text
"Started watching"
            AppManager -> KeterM KeterConfig ()
startWatching AppManager
appMan
            $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM KeterConfig ()
(Text -> KeterM KeterConfig ())
-> (Text -> Text) -> Text -> KeterM KeterConfig ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM KeterConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
logInfo Text
"Started listening"
            HostManager -> KeterM KeterConfig ()
startListening HostManager
hostman

-- | Load up Keter config and evaluate a ReaderT context with it
runKeterConfigReader :: MonadIO m
                     => FilePath
                     -> ReaderT KeterConfig m a
                     -> m a
runKeterConfigReader :: forall (m :: * -> *) a.
MonadIO m =>
FilePath -> ReaderT KeterConfig m a -> m a
runKeterConfigReader FilePath
input ReaderT KeterConfig m a
ctx = do
    Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
input
    KeterConfig
config <- IO KeterConfig -> m KeterConfig
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KeterConfig -> m KeterConfig)
-> IO KeterConfig -> m KeterConfig
forall a b. (a -> b) -> a -> b
$
        if Bool
exists
            then do
                Either ParseException KeterConfig
eres <- FilePath -> IO (Either ParseException KeterConfig)
forall a.
ParseYamlFile a =>
FilePath -> IO (Either ParseException a)
decodeFileRelative FilePath
input
                case Either ParseException KeterConfig
eres of
                    Left ParseException
e -> KeterException -> IO KeterConfig
forall e a. Exception e => e -> IO a
throwIO (KeterException -> IO KeterConfig)
-> KeterException -> IO KeterConfig
forall a b. (a -> b) -> a -> b
$ FilePath -> ParseException -> KeterException
InvalidKeterConfigFile FilePath
input ParseException
e
                    Right KeterConfig
x -> KeterConfig -> IO KeterConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return KeterConfig
x
            else KeterConfig -> IO KeterConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return KeterConfig
defaultKeterConfig { kconfigDir = input }
    ReaderT KeterConfig m a -> KeterConfig -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT KeterConfig m a
ctx KeterConfig
config

-- | Running the Keter logger requires a context with access to a KeterConfig, hence the
-- MonadReader constraint. This is versatile: 'runKeterConfigReader', or use the free
-- ((->) KeterConfig) instance.
runKeterLogger :: (MonadReader KeterConfig m, MonadIO m, MonadUnliftIO m)
               => LoggingT m a
               -> m a
runKeterLogger :: forall (m :: * -> *) a.
(MonadReader KeterConfig m, MonadIO m, MonadUnliftIO m) =>
LoggingT m a -> m a
runKeterLogger LoggingT m a
ctx = do
    KeterConfig
cfg <- m KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m 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
bracket (KeterConfig -> FilePath -> IO Logger
Log.createLoggerViaConfig KeterConfig
cfg FilePath
"keter") Logger -> IO ()
Log.loggerClose ((Logger -> IO a) -> IO a) -> (Logger -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
        m a -> IO a
forall a. m a -> IO a
rio (m a -> IO a) -> (Logger -> m a) -> Logger -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT m a
ctx ((Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Logger
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
forall {a} {p}.
Show a =>
Logger -> Loc -> p -> a -> LogStr -> IO ()
formatLog
    where
        formatLog :: Logger -> Loc -> p -> a -> LogStr -> IO ()
formatLog Logger
logger Loc
loc p
_ a
lvl LogStr
msg = do
            UTCTime
now <- IO UTCTime -> IO UTCTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            -- Format: "{keter|}$time|$module$:$line_num|$log_level> $msg"
            let tag :: LogStr
tag = case Logger -> LogType
Log.loggerType Logger
logger of { FL.LogStderr Int
_ -> LogStr
"keter|"; LogType
_ -> LogStr
forall a. Monoid a => a
mempty }
            let bs :: LogStr
bs = [LogStr] -> LogStr
forall a. Monoid a => [a] -> a
mconcat
                    [ LogStr
tag
                    , FilePath -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
L.toLogStr (FilePath -> LogStr) -> FilePath -> LogStr
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
22 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
now
                    , LogStr
"|"
                    , FilePath -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
L.toLogStr (Loc -> FilePath
L.loc_module Loc
loc)
                    , LogStr
":"
                    , Int -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
L.toLogStr (CharPos -> Int
forall a b. (a, b) -> a
fst (CharPos -> Int) -> CharPos -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
L.loc_start Loc
loc)
                    , LogStr
"|"
                    , FilePath -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
L.toLogStr (FilePath -> LogStr) -> FilePath -> LogStr
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
5 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show a
lvl
                    , LogStr
"> "
                    , LogStr
msg
                    , LogStr
"\n"
                    ]
            Logger -> forall a. ToLogStr a => a -> IO ()
Log.loggerLog Logger
logger LogStr
bs

withManagers :: [FilePath -> IO Plugin]
             -> (HostMan.HostManager -> AppMan.AppManager -> KeterM KeterConfig a)
             -> KeterM KeterConfig a
withManagers :: forall a.
[FilePath -> IO Plugin]
-> (HostManager -> AppManager -> KeterM KeterConfig a)
-> KeterM KeterConfig a
withManagers [FilePath -> IO Plugin]
mkPlugins HostManager -> AppManager -> KeterM KeterConfig a
f = do
    cfg :: KeterConfig
cfg@KeterConfig{Bool
Int
FilePath
Maybe Int
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigDir :: KeterConfig -> FilePath
kconfigPortPool :: KeterConfig -> PortSettings
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigRotateLogs :: KeterConfig -> Bool
kconfigHealthcheckPath :: KeterConfig -> Maybe Text
kconfigDir :: FilePath
kconfigPortPool :: PortSettings
kconfigListeners :: NonEmptyVector ListeningPort
kconfigSetuid :: Maybe Text
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigIpFromHeader :: Bool
kconfigExternalHttpPort :: Int
kconfigExternalHttpsPort :: Int
kconfigEnvironment :: Map Text Text
kconfigConnectionTimeBound :: Int
kconfigCliPort :: Maybe Int
kconfigUnknownHostResponse :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigProxyException :: Maybe FilePath
kconfigRotateLogs :: Bool
kconfigHealthcheckPath :: Maybe Text
..} <- KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ProcessTracker
processTracker <- IO ProcessTracker -> KeterM KeterConfig ProcessTracker
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProcessTracker
initProcessTracker
    HostManager
hostman <- IO HostManager -> KeterM KeterConfig HostManager
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO HostManager
HostMan.start
    PortPool
portpool <- IO PortPool -> KeterM KeterConfig PortPool
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PortPool -> KeterM KeterConfig PortPool)
-> IO PortPool -> KeterM KeterConfig PortPool
forall a b. (a -> b) -> a -> b
$ PortSettings -> IO PortPool
PortPool.start PortSettings
kconfigPortPool
    TempFolder
tf <- IO TempFolder -> KeterM KeterConfig TempFolder
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TempFolder -> KeterM KeterConfig TempFolder)
-> IO TempFolder -> KeterM KeterConfig TempFolder
forall a b. (a -> b) -> a -> b
$ FilePath -> IO TempFolder
TempFolder.setup (FilePath -> IO TempFolder) -> FilePath -> IO TempFolder
forall a b. (a -> b) -> a -> b
$ FilePath
kconfigDir FilePath -> FilePath -> FilePath
</> FilePath
"temp"
    [Plugin]
plugins <- ((FilePath -> IO Plugin) -> KeterM KeterConfig Plugin)
-> [FilePath -> IO Plugin] -> KeterM KeterConfig [Plugin]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO Plugin -> KeterM KeterConfig Plugin
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Plugin -> KeterM KeterConfig Plugin)
-> ((FilePath -> IO Plugin) -> IO Plugin)
-> (FilePath -> IO Plugin)
-> KeterM KeterConfig Plugin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath -> IO Plugin) -> FilePath -> IO Plugin
forall a b. (a -> b) -> a -> b
$ FilePath
kconfigDir)) [FilePath -> IO Plugin]
mkPlugins
    Maybe (Text, (UserID, GroupID))
muid <-
        case Maybe Text
kconfigSetuid of
            Maybe Text
Nothing -> Maybe (Text, (UserID, GroupID))
-> KeterM KeterConfig (Maybe (Text, (UserID, GroupID)))
forall a. a -> KeterM KeterConfig a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, (UserID, GroupID))
forall a. Maybe a
Nothing
            Just Text
t -> do
                Either SomeException UserEntry
x <- IO (Either SomeException UserEntry)
-> KeterM KeterConfig (Either SomeException UserEntry)
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException UserEntry)
 -> KeterM KeterConfig (Either SomeException UserEntry))
-> IO (Either SomeException UserEntry)
-> KeterM KeterConfig (Either SomeException UserEntry)
forall a b. (a -> b) -> a -> b
$ IO UserEntry -> IO (Either SomeException UserEntry)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO UserEntry -> IO (Either SomeException UserEntry))
-> IO UserEntry -> IO (Either SomeException UserEntry)
forall a b. (a -> b) -> a -> b
$
                    case Reader UserID
forall a. Integral a => Reader a
Data.Text.Read.decimal Text
t of
                        Right (UserID
i, Text
"") -> UserID -> IO UserEntry
getUserEntryForID UserID
i
                        Either FilePath (UserID, Text)
_ -> FilePath -> IO UserEntry
getUserEntryForName (FilePath -> IO UserEntry) -> FilePath -> IO UserEntry
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
t
                case Either SomeException UserEntry
x of
                    Left (SomeException
_ :: SomeException) -> FilePath -> KeterM KeterConfig (Maybe (Text, (UserID, GroupID)))
forall a. HasCallStack => FilePath -> a
error (FilePath -> KeterM KeterConfig (Maybe (Text, (UserID, GroupID))))
-> FilePath -> KeterM KeterConfig (Maybe (Text, (UserID, GroupID)))
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid user ID: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
t
                    Right UserEntry
ue -> Maybe (Text, (UserID, GroupID))
-> KeterM KeterConfig (Maybe (Text, (UserID, GroupID)))
forall a. a -> KeterM KeterConfig a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, (UserID, GroupID))
 -> KeterM KeterConfig (Maybe (Text, (UserID, GroupID))))
-> Maybe (Text, (UserID, GroupID))
-> KeterM KeterConfig (Maybe (Text, (UserID, GroupID)))
forall a b. (a -> b) -> a -> b
$ (Text, (UserID, GroupID)) -> Maybe (Text, (UserID, GroupID))
forall a. a -> Maybe a
Just (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ UserEntry -> FilePath
userName UserEntry
ue, (UserEntry -> UserID
userID UserEntry
ue, UserEntry -> GroupID
userGroupID UserEntry
ue))

    let appStartConfig :: AppStartConfig
appStartConfig = AppStartConfig
            { ascTempFolder :: TempFolder
ascTempFolder = TempFolder
tf
            , ascSetuid :: Maybe (Text, (UserID, GroupID))
ascSetuid = Maybe (Text, (UserID, GroupID))
muid
            , ascProcessTracker :: ProcessTracker
ascProcessTracker = ProcessTracker
processTracker
            , ascHostManager :: HostManager
ascHostManager = HostManager
hostman
            , ascPortPool :: PortPool
ascPortPool = PortPool
portpool
            , ascPlugins :: [Plugin]
ascPlugins = [Plugin]
plugins
            , ascKeterConfig :: KeterConfig
ascKeterConfig = KeterConfig
cfg
            }
    AppManager
appMan <- (KeterConfig -> AppStartConfig)
-> KeterM AppStartConfig AppManager
-> KeterM KeterConfig AppManager
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (AppStartConfig -> KeterConfig -> AppStartConfig
forall a b. a -> b -> a
const AppStartConfig
appStartConfig) KeterM AppStartConfig AppManager
AppMan.initialize
    HostManager -> AppManager -> KeterM KeterConfig a
f HostManager
hostman AppManager
appMan

launchInitial :: AppMan.AppManager -> KeterM KeterConfig ()
launchInitial :: AppManager -> KeterM KeterConfig ()
launchInitial AppManager
appMan = do
    kc :: KeterConfig
kc@KeterConfig{Bool
Int
FilePath
Maybe Int
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigDir :: KeterConfig -> FilePath
kconfigPortPool :: KeterConfig -> PortSettings
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigRotateLogs :: KeterConfig -> Bool
kconfigHealthcheckPath :: KeterConfig -> Maybe Text
kconfigDir :: FilePath
kconfigPortPool :: PortSettings
kconfigListeners :: NonEmptyVector ListeningPort
kconfigSetuid :: Maybe Text
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigIpFromHeader :: Bool
kconfigExternalHttpPort :: Int
kconfigExternalHttpsPort :: Int
kconfigEnvironment :: Map Text Text
kconfigConnectionTimeBound :: Int
kconfigCliPort :: Maybe Int
kconfigUnknownHostResponse :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigProxyException :: Maybe FilePath
kconfigRotateLogs :: Bool
kconfigHealthcheckPath :: Maybe Text
..} <- KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    let incoming :: FilePath
incoming = KeterConfig -> FilePath
getIncoming KeterConfig
kc
    IO () -> KeterM KeterConfig ()
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM KeterConfig ()) -> IO () -> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
incoming
    [FilePath]
bundles0 <- IO [FilePath] -> KeterM KeterConfig [FilePath]
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> KeterM KeterConfig [FilePath])
-> IO [FilePath] -> KeterM KeterConfig [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isKeter ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectoryTree FilePath
incoming
    (KeterConfig -> AppManager)
-> KeterM AppManager () -> KeterM KeterConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (AppManager -> KeterConfig -> AppManager
forall a b. a -> b -> a
const AppManager
appMan) (KeterM AppManager () -> KeterM KeterConfig ())
-> KeterM AppManager () -> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ do
        (FilePath -> KeterM AppManager ())
-> [FilePath] -> KeterM AppManager ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> KeterM AppManager ()
AppMan.addApp [FilePath]
bundles0
        Bool -> KeterM AppManager () -> KeterM AppManager ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Vector (Stanza ()) -> Bool
forall a. Vector a -> Bool
V.null Vector (Stanza ())
kconfigBuiltinStanzas) (KeterM AppManager () -> KeterM AppManager ())
-> KeterM AppManager () -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ AppId -> Action -> KeterM AppManager ()
AppMan.perform
            AppId
AIBuiltin
            (AppInput -> Action
AppMan.Reload (AppInput -> Action) -> AppInput -> Action
forall a b. (a -> b) -> a -> b
$ BundleConfig -> AppInput
AIData (BundleConfig -> AppInput) -> BundleConfig -> AppInput
forall a b. (a -> b) -> a -> b
$ Vector (Stanza ()) -> Object -> BundleConfig
BundleConfig Vector (Stanza ())
kconfigBuiltinStanzas Object
forall a. Monoid a => a
mempty)

getIncoming :: KeterConfig -> FilePath
getIncoming :: KeterConfig -> FilePath
getIncoming KeterConfig
kc = KeterConfig -> FilePath
kconfigDir KeterConfig
kc FilePath -> FilePath -> FilePath
</> FilePath
"incoming"

isKeter :: FilePath -> Bool
isKeter :: FilePath -> Bool
isKeter FilePath
fp = FilePath -> FilePath
takeExtension FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".keter"

startWatching :: AppMan.AppManager -> KeterM KeterConfig ()
startWatching :: AppManager -> KeterM KeterConfig ()
startWatching AppManager
appMan = do
    FilePath
incoming <- (KeterConfig -> FilePath) -> KeterM KeterConfig FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks KeterConfig -> FilePath
getIncoming
    -- File system watching
    WatchManager
wm <- IO WatchManager -> KeterM KeterConfig WatchManager
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO WatchManager
FSN.startManager
    (KeterConfig -> AppManager)
-> KeterM AppManager () -> KeterM KeterConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (AppManager -> KeterConfig -> AppManager
forall a b. a -> b -> a
const AppManager
appMan) (KeterM AppManager () -> KeterM KeterConfig ())
-> KeterM AppManager () -> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ ((forall a. KeterM AppManager a -> IO a) -> IO ())
-> KeterM AppManager ()
forall b.
((forall a. KeterM AppManager a -> IO a) -> IO b)
-> KeterM AppManager b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM AppManager a -> IO a) -> IO ())
 -> KeterM AppManager ())
-> ((forall a. KeterM AppManager a -> IO a) -> IO ())
-> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM AppManager a -> IO a
rio -> do
        IO ()
_ <- WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
FSN.watchTree WatchManager
wm (FilePath -> FilePath
forall a. IsString a => FilePath -> a
fromString FilePath
incoming) (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True) (Action -> IO (IO ())) -> Action -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Event
e -> do
                Either FilePath FilePath
e' <-
                    case Event
e of
                        FSN.Removed FilePath
fp UTCTime
_ EventIsDirectory
_ -> do
                            KeterM AppManager () -> IO ()
forall a. KeterM AppManager a -> IO a
rio (KeterM AppManager () -> IO ()) -> KeterM AppManager () -> IO ()
forall a b. (a -> b) -> a -> b
$ $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppManager ()
(Text -> KeterM AppManager ())
-> (Text -> Text) -> Text -> KeterM AppManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
logInfo (Text -> KeterM AppManager ()) -> Text -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ Text
"Watched file removed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp
                            Either FilePath FilePath -> IO (Either FilePath FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath FilePath -> IO (Either FilePath FilePath))
-> Either FilePath FilePath -> IO (Either FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left FilePath
fp
                        FSN.Added FilePath
fp UTCTime
_ EventIsDirectory
_ -> do
                            KeterM AppManager () -> IO ()
forall a. KeterM AppManager a -> IO a
rio (KeterM AppManager () -> IO ()) -> KeterM AppManager () -> IO ()
forall a b. (a -> b) -> a -> b
$ $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppManager ()
(Text -> KeterM AppManager ())
-> (Text -> Text) -> Text -> KeterM AppManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
logInfo (Text -> KeterM AppManager ()) -> Text -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ Text
"Watched file added: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp
                            Either FilePath FilePath -> IO (Either FilePath FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath FilePath -> IO (Either FilePath FilePath))
-> Either FilePath FilePath -> IO (Either FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right FilePath
fp
                        FSN.Modified FilePath
fp UTCTime
_ EventIsDirectory
_ -> do
                            KeterM AppManager () -> IO ()
forall a. KeterM AppManager a -> IO a
rio (KeterM AppManager () -> IO ()) -> KeterM AppManager () -> IO ()
forall a b. (a -> b) -> a -> b
$ $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppManager ()
(Text -> KeterM AppManager ())
-> (Text -> Text) -> Text -> KeterM AppManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
logInfo (Text -> KeterM AppManager ()) -> Text -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ Text
"Watched file modified: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp
                            Either FilePath FilePath -> IO (Either FilePath FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath FilePath -> IO (Either FilePath FilePath))
-> Either FilePath FilePath -> IO (Either FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right FilePath
fp
                        Event
_ -> do
                            KeterM AppManager () -> IO ()
forall a. KeterM AppManager a -> IO a
rio (KeterM AppManager () -> IO ()) -> KeterM AppManager () -> IO ()
forall a b. (a -> b) -> a -> b
$ $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM AppManager ()
(Text -> KeterM AppManager ())
-> (Text -> Text) -> Text -> KeterM AppManager ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> KeterM AppManager ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
logInfo (Text -> KeterM AppManager ()) -> Text -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ Text
"Watched file unknown" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
forall a. Monoid a => a
mempty
                            Either FilePath FilePath -> IO (Either FilePath FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath FilePath -> IO (Either FilePath FilePath))
-> Either FilePath FilePath -> IO (Either FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left []
                KeterM AppManager () -> IO ()
forall a. KeterM AppManager a -> IO a
rio (KeterM AppManager () -> IO ()) -> KeterM AppManager () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Either FilePath FilePath
e' of
                    Left FilePath
fp -> Bool -> KeterM AppManager () -> KeterM AppManager ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isKeter FilePath
fp) (KeterM AppManager () -> KeterM AppManager ())
-> KeterM AppManager () -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ Text -> KeterM AppManager ()
AppMan.terminateApp (Text -> KeterM AppManager ()) -> Text -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
getAppname FilePath
fp
                    Right FilePath
fp -> Bool -> KeterM AppManager () -> KeterM AppManager ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isKeter FilePath
fp) (KeterM AppManager () -> KeterM AppManager ())
-> KeterM AppManager () -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ FilePath -> KeterM AppManager ()
AppMan.addApp (FilePath -> KeterM AppManager ())
-> FilePath -> KeterM AppManager ()
forall a b. (a -> b) -> a -> b
$ FilePath
incoming FilePath -> FilePath -> FilePath
</> FilePath
fp
        -- Install HUP handler for cases when inotify cannot be used.
        IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ (Handler -> Maybe SignalSet -> IO Handler)
-> Maybe SignalSet -> Handler -> IO Handler
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigHUP) Maybe SignalSet
forall a. Maybe a
Nothing (Handler -> IO Handler) -> Handler -> IO Handler
forall a b. (a -> b) -> a -> b
$ IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
            [FilePath]
bundles <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isKeter ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectoryTree FilePath
incoming
            Map Text (FilePath, EpochTime)
newMap <- ([(Text, (FilePath, EpochTime))] -> Map Text (FilePath, EpochTime))
-> IO [(Text, (FilePath, EpochTime))]
-> IO (Map Text (FilePath, EpochTime))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, (FilePath, EpochTime))] -> Map Text (FilePath, EpochTime)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (IO [(Text, (FilePath, EpochTime))]
 -> IO (Map Text (FilePath, EpochTime)))
-> IO [(Text, (FilePath, EpochTime))]
-> IO (Map Text (FilePath, EpochTime))
forall a b. (a -> b) -> a -> b
$ [FilePath]
-> (FilePath -> IO (Text, (FilePath, EpochTime)))
-> IO [(Text, (FilePath, EpochTime))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
bundles ((FilePath -> IO (Text, (FilePath, EpochTime)))
 -> IO [(Text, (FilePath, EpochTime))])
-> (FilePath -> IO (Text, (FilePath, EpochTime)))
-> IO [(Text, (FilePath, EpochTime))]
forall a b. (a -> b) -> a -> b
$ \FilePath
bundle -> do
                EpochTime
time <- FileStatus -> EpochTime
modificationTime (FileStatus -> EpochTime) -> IO FileStatus -> IO EpochTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
getFileStatus FilePath
bundle
                (Text, (FilePath, EpochTime)) -> IO (Text, (FilePath, EpochTime))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Text
getAppname FilePath
bundle, (FilePath
bundle, EpochTime
time))
            KeterM AppManager () -> IO ()
forall a. KeterM AppManager a -> IO a
rio (KeterM AppManager () -> IO ()) -> KeterM AppManager () -> IO ()
forall a b. (a -> b) -> a -> b
$ Map Text (FilePath, EpochTime) -> KeterM AppManager ()
AppMan.reloadAppList Map Text (FilePath, EpochTime)
newMap

listDirectoryTree :: FilePath -> IO [FilePath]
listDirectoryTree :: FilePath -> IO [FilePath]
listDirectoryTree FilePath
fp = do
       [FilePath]
dir <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
fp
       [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\FilePath
fpRel -> do
          let fp1 :: FilePath
fp1 = FilePath
fp FilePath -> FilePath -> FilePath
</> FilePath
fpRel
          Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
fp1
          if Bool
isDir
           then
             FilePath -> IO [FilePath]
listDirectoryTree FilePath
fp1
           else
             [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
fp1]
           ) ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FilePath
x -> FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"." Bool -> Bool -> Bool
&& FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"..") [FilePath]
dir)

startListening :: HostMan.HostManager -> KeterM KeterConfig ()
startListening :: HostManager -> KeterM KeterConfig ()
startListening HostManager
hostman = do
    KeterConfig{Bool
Int
FilePath
Maybe Int
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigDir :: KeterConfig -> FilePath
kconfigPortPool :: KeterConfig -> PortSettings
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigRotateLogs :: KeterConfig -> Bool
kconfigHealthcheckPath :: KeterConfig -> Maybe Text
kconfigDir :: FilePath
kconfigPortPool :: PortSettings
kconfigListeners :: NonEmptyVector ListeningPort
kconfigSetuid :: Maybe Text
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigIpFromHeader :: Bool
kconfigExternalHttpPort :: Int
kconfigExternalHttpsPort :: Int
kconfigEnvironment :: Map Text Text
kconfigConnectionTimeBound :: Int
kconfigCliPort :: Maybe Int
kconfigUnknownHostResponse :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigProxyException :: Maybe FilePath
kconfigRotateLogs :: Bool
kconfigHealthcheckPath :: Maybe Text
..} <- KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ProxySettings
settings <- HostManager -> KeterM KeterConfig ProxySettings
Proxy.makeSettings HostManager
hostman
    (KeterConfig -> ProxySettings)
-> KeterM ProxySettings () -> KeterM KeterConfig ()
forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (ProxySettings -> KeterConfig -> ProxySettings
forall a b. a -> b -> a
const ProxySettings
settings) (KeterM ProxySettings () -> KeterM KeterConfig ())
-> KeterM ProxySettings () -> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ ((forall a. KeterM ProxySettings a -> IO a) -> IO ())
-> KeterM ProxySettings ()
forall b.
((forall a. KeterM ProxySettings a -> IO a) -> IO b)
-> KeterM ProxySettings b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM ProxySettings a -> IO a) -> IO ())
 -> KeterM ProxySettings ())
-> ((forall a. KeterM ProxySettings a -> IO a) -> IO ())
-> KeterM ProxySettings ()
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM ProxySettings a -> IO a
rio ->
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmptyVector ListeningPort -> (ListeningPort -> IO ()) -> IO ()
forall a. NonEmptyVector a -> (a -> IO ()) -> IO ()
runAndBlock NonEmptyVector ListeningPort
kconfigListeners ((ListeningPort -> IO ()) -> IO ())
-> (ListeningPort -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ListeningPort
ls ->
            KeterM ProxySettings () -> IO ()
forall a. KeterM ProxySettings a -> IO a
rio (KeterM ProxySettings () -> IO ())
-> KeterM ProxySettings () -> IO ()
forall a b. (a -> b) -> a -> b
$ ListeningPort -> KeterM ProxySettings ()
Proxy.reverseProxy ListeningPort
ls

runAndBlock :: NonEmptyVector a
            -> (a -> IO ())
            -> IO ()
runAndBlock :: forall a. NonEmptyVector a -> (a -> IO ()) -> IO ()
runAndBlock (NonEmptyVector a
x0 Vector a
v) a -> IO ()
f =
    [a] -> [Async ()] -> IO ()
loop [a]
l0 []
  where
    l0 :: [a]
l0 = a
x0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Vector a -> [a]
forall a. Vector a -> [a]
V.toList Vector a
v

    loop :: [a] -> [Async ()] -> IO ()
loop (a
x:[a]
xs) [Async ()]
asyncs = IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (a -> IO ()
f a
x) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
async -> [a] -> [Async ()] -> IO ()
loop [a]
xs ([Async ()] -> IO ()) -> [Async ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ Async ()
async Async () -> [Async ()] -> [Async ()]
forall a. a -> [a] -> [a]
: [Async ()]
asyncs
    -- Once we have all of our asyncs, we wait for /any/ of them to exit. If
    -- any listener thread exits, we kill the whole process.
    loop [] [Async ()]
asyncs = IO (Async (), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async (), ()) -> IO ()) -> IO (Async (), ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Async ()] -> IO (Async (), ())
forall a. [Async a] -> IO (Async a, a)
waitAny [Async ()]
asyncs