{-# 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
-> [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
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
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
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
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
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
#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
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