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

module Keter.Main
    ( keter
    ) where

import Keter.Common
import           System.FilePath            (FilePath)
import qualified Keter.TempTarball as TempFolder
import           Control.Concurrent.Async  (waitAny, withAsync)
import           Control.Monad             (unless)
import qualified Keter.Logger              as Log
import           Data.Monoid               (mempty)
import           Data.String               (fromString)
import qualified Data.Vector               as V
import           Keter.App                 (AppStartConfig (..))
import qualified Keter.AppManager          as AppMan
import qualified Keter.HostManager         as HostMan
import qualified Keter.PortPool            as PortPool
import qualified Keter.Proxy               as Proxy
import           Keter.Config
import           Keter.Config.V10
import           System.Posix.Files        (getFileStatus, modificationTime)
import           System.Posix.Signals      (Handler (Catch), installHandler,
                                            sigHUP)

import           Control.Applicative       ((<$>))
import           Control.Exception         (throwIO, try, bracket, SomeException)
import           Control.Monad             (forM, void, when)
import           Control.Monad.IO.Class    (MonadIO, liftIO)
import           Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Control.Monad.Logger      as L
import           Control.Monad.Logger      (MonadLogger, MonadLoggerIO, LoggingT, 
                                            runLoggingT, askLoggerIO, logInfo, logDebug)
import           Control.Monad.Reader      (MonadReader, ReaderT, runReaderT, ask)
import           Control.Monad.IO.Unlift   (MonadUnliftIO, withRunInIO)
import           Keter.Conduit.Process.Unix (initProcessTracker)
import qualified Data.Map                  as Map
import qualified Data.Text                 as T
import           Data.Text.Encoding        (encodeUtf8)
import qualified Data.Text.Read
import           Data.Time                 (getCurrentTime)
import           Keter.Yaml.FilePath
import           Prelude                   hiding (FilePath, log)
import           System.Directory          (createDirectoryIfMissing,
                                            createDirectoryIfMissing,
                                            doesDirectoryExist, doesFileExist,
                                            getDirectoryContents)
import           System.FilePath           (takeExtension, takeDirectory, (</>))
import qualified System.FSNotify           as FSN
import qualified System.Log.FastLogger     as FL
import           System.Posix.User         (getUserEntryForID,
                                            getUserEntryForName, userGroupID,
                                            userID, userName)
#ifdef SYSTEM_FILEPATH
import qualified Filesystem.Path as FP (FilePath)
import           Filesystem.Path.CurrentOS (encodeString)
#endif
import Keter.Cli
import Keter.Context

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
            cfg :: KeterConfig
cfg@KeterConfig{Bool
Int
FilePath
Maybe Int
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigRotateLogs :: KeterConfig -> Bool
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigPortPool :: KeterConfig -> PortSettings
kconfigDir :: KeterConfig -> FilePath
kconfigRotateLogs :: Bool
kconfigProxyException :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigUnknownHostResponse :: Maybe FilePath
kconfigCliPort :: Maybe Int
kconfigConnectionTimeBound :: Int
kconfigEnvironment :: Map Text Text
kconfigExternalHttpsPort :: Int
kconfigExternalHttpPort :: Int
kconfigIpFromHeader :: Bool
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigSetuid :: Maybe Text
kconfigListeners :: NonEmptyVector ListeningPort
kconfigPortPool :: PortSettings
kconfigDir :: FilePath
..} <- 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 b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
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
logInfo Text
"Launching cli"
            KeterM KeterConfig (Maybe ()) -> KeterM KeterConfig ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KeterM KeterConfig (Maybe ()) -> KeterM KeterConfig ())
-> KeterM KeterConfig (Maybe ()) -> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ Maybe Int
-> (Int -> KeterM KeterConfig ()) -> KeterM KeterConfig (Maybe ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Int
kconfigCliPort ((Int -> KeterM KeterConfig ()) -> KeterM KeterConfig (Maybe ()))
-> (Int -> KeterM KeterConfig ()) -> KeterM KeterConfig (Maybe ())
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 :: AppManager -> Int -> CliStates
MkCliStates
                      { csAppManager :: AppManager
csAppManager = AppManager
appMan
                      , csPort :: Int
csPort       = Int
port
                      })
                  (KeterM CliStates () -> KeterM KeterConfig ())
-> KeterM CliStates () -> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ 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 b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
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
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 b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
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
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 b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
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
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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return KeterConfig
x
            else KeterConfig -> IO KeterConfig
forall (m :: * -> *) a. Monad m => a -> m a
return KeterConfig
defaultKeterConfig { kconfigDir :: FilePath
kconfigDir = FilePath
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
    cfg :: KeterConfig
cfg@KeterConfig{Bool
Int
FilePath
Maybe Int
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigRotateLogs :: Bool
kconfigProxyException :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigUnknownHostResponse :: Maybe FilePath
kconfigCliPort :: Maybe Int
kconfigConnectionTimeBound :: Int
kconfigEnvironment :: Map Text Text
kconfigExternalHttpsPort :: Int
kconfigExternalHttpPort :: Int
kconfigIpFromHeader :: Bool
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigSetuid :: Maybe Text
kconfigListeners :: NonEmptyVector ListeningPort
kconfigPortPool :: PortSettings
kconfigDir :: FilePath
kconfigRotateLogs :: KeterConfig -> Bool
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigPortPool :: KeterConfig -> PortSettings
kconfigDir :: KeterConfig -> FilePath
..} <- m KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ((forall a. m a -> IO a) -> IO a) -> m a
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 (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
kconfigRotateLogs :: Bool
kconfigProxyException :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigUnknownHostResponse :: Maybe FilePath
kconfigCliPort :: Maybe Int
kconfigConnectionTimeBound :: Int
kconfigEnvironment :: Map Text Text
kconfigExternalHttpsPort :: Int
kconfigExternalHttpPort :: Int
kconfigIpFromHeader :: Bool
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigSetuid :: Maybe Text
kconfigListeners :: NonEmptyVector ListeningPort
kconfigPortPool :: PortSettings
kconfigDir :: FilePath
kconfigRotateLogs :: KeterConfig -> Bool
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigPortPool :: KeterConfig -> PortSettings
kconfigDir :: KeterConfig -> FilePath
..} <- KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    ProcessTracker
processTracker <- IO ProcessTracker -> KeterM KeterConfig ProcessTracker
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProcessTracker
initProcessTracker
    HostManager
hostman <- IO HostManager -> KeterM KeterConfig HostManager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO HostManager
HostMan.start
    PortPool
portpool <- IO PortPool -> KeterM KeterConfig PortPool
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 (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)
mapM (IO Plugin -> KeterM KeterConfig Plugin
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 (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 (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 (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 :: TempFolder
-> Maybe (Text, (UserID, GroupID))
-> ProcessTracker
-> HostManager
-> PortPool
-> [Plugin]
-> KeterConfig
-> 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 -> KeterM KeterConfig AppManager)
-> KeterM AppStartConfig AppManager
-> KeterM KeterConfig AppManager
forall a b. (a -> b) -> a -> b
$ 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
kconfigRotateLogs :: Bool
kconfigProxyException :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigUnknownHostResponse :: Maybe FilePath
kconfigCliPort :: Maybe Int
kconfigConnectionTimeBound :: Int
kconfigEnvironment :: Map Text Text
kconfigExternalHttpsPort :: Int
kconfigExternalHttpPort :: Int
kconfigIpFromHeader :: Bool
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigSetuid :: Maybe Text
kconfigListeners :: NonEmptyVector ListeningPort
kconfigPortPool :: PortSettings
kconfigDir :: FilePath
kconfigRotateLogs :: KeterConfig -> Bool
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigPortPool :: KeterConfig -> PortSettings
kconfigDir :: KeterConfig -> FilePath
..} <- 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 (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 (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
getIncoming (KeterConfig -> FilePath)
-> KeterM KeterConfig KeterConfig -> KeterM KeterConfig FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    -- File system watching
    WatchManager
wm <- IO WatchManager -> KeterM KeterConfig WatchManager
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 (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
_ Bool
_ -> 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 b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
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
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 -> FilePath
forall a. a -> a
fromFilePath FilePath
fp)
                            Either FilePath FilePath -> IO (Either FilePath FilePath)
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 -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. a -> a
fromFilePath FilePath
fp
                        FSN.Added FilePath
fp UTCTime
_ Bool
_ -> 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 b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
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
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 -> FilePath
forall a. a -> a
fromFilePath FilePath
fp)
                            Either FilePath FilePath -> IO (Either FilePath FilePath)
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 -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. a -> a
fromFilePath FilePath
fp
                        FSN.Modified FilePath
fp UTCTime
_ Bool
_ -> 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 b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
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
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 -> FilePath
forall a. a -> a
fromFilePath FilePath
fp)
                            Either FilePath FilePath -> IO (Either FilePath FilePath)
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 -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. a -> a
fromFilePath 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 b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
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
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 (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] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isKeter) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> 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 (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 (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


-- compatibility with older versions of fsnotify which used
-- 'Filesystem.Path'
#ifdef SYSTEM_FILEPATH
fromFilePath :: FP.FilePath -> String
fromFilePath = encodeString
#else
fromFilePath :: forall a. a -> a
fromFilePath :: forall a. a -> a
fromFilePath = a -> a
forall a. a -> a
id
#endif

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)
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 (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
    cfg :: KeterConfig
cfg@KeterConfig{Bool
Int
FilePath
Maybe Int
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigRotateLogs :: Bool
kconfigProxyException :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigUnknownHostResponse :: Maybe FilePath
kconfigCliPort :: Maybe Int
kconfigConnectionTimeBound :: Int
kconfigEnvironment :: Map Text Text
kconfigExternalHttpsPort :: Int
kconfigExternalHttpPort :: Int
kconfigIpFromHeader :: Bool
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigSetuid :: Maybe Text
kconfigListeners :: NonEmptyVector ListeningPort
kconfigPortPool :: PortSettings
kconfigDir :: FilePath
kconfigRotateLogs :: KeterConfig -> Bool
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigPortPool :: KeterConfig -> PortSettings
kconfigDir :: KeterConfig -> FilePath
..} <- KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    Loc -> Text -> LogLevel -> LogStr -> IO ()
logger <- KeterM KeterConfig (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
    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 (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 (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