{-# 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 =
    forall (m :: * -> *) a.
MonadIO m =>
FilePath -> ReaderT KeterConfig m a -> m a
runKeterConfigReader FilePath
input forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadReader KeterConfig m, MonadIO m, MonadUnliftIO m) =>
LoggingT m a -> m a
runKeterLogger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall cfg a. KeterM cfg a -> LoggingT (ReaderT cfg IO) a
runKeterM forall a b. (a -> b) -> a -> b
$
        forall a.
[FilePath -> IO Plugin]
-> (HostManager -> AppManager -> KeterM KeterConfig a)
-> KeterM KeterConfig a
withManagers [FilePath -> IO Plugin]
mkPlugins 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
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
            $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
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"
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Int
kconfigCliPort forall a b. (a -> b) -> a -> b
$ \Int
port ->
              forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig
                  (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ MkCliStates
                      { csAppManager :: AppManager
csAppManager = AppManager
appMan
                      , csPort :: Int
csPort       = Int
port
                      })
                  forall a b. (a -> b) -> a -> b
$ KeterM CliStates ()
launchCli
            $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
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 -> 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 -> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
input
    KeterConfig
config <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        if Bool
exists
            then do
                Either ParseException KeterConfig
eres <- forall a.
ParseYamlFile a =>
FilePath -> IO (Either ParseException a)
decodeFileRelative FilePath
input
                case Either ParseException KeterConfig
eres of
                    Left ParseException
e -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> ParseException -> KeterException
InvalidKeterConfigFile FilePath
input ParseException
e
                    Right KeterConfig
x -> forall (m :: * -> *) a. Monad m => a -> m a
return KeterConfig
x
            else forall (m :: * -> *) a. Monad m => a -> m a
return KeterConfig
defaultKeterConfig { kconfigDir :: FilePath
kconfigDir = FilePath
input }
    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
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
rio -> 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 forall a b. (a -> b) -> a -> b
$
        forall a. m a -> IO a
rio forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT m a
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- 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
_ -> forall a. Monoid a => a
mempty }
            let bs :: LogStr
bs = forall a. Monoid a => [a] -> a
mconcat
                    [ LogStr
tag
                    , forall msg. ToLogStr msg => msg -> LogStr
L.toLogStr forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
22 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show UTCTime
now
                    , LogStr
"|"
                    , forall msg. ToLogStr msg => msg -> LogStr
L.toLogStr (Loc -> FilePath
L.loc_module Loc
loc)
                    , LogStr
":"
                    , forall msg. ToLogStr msg => msg -> LogStr
L.toLogStr (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
L.loc_start Loc
loc)
                    , LogStr
"|"
                    , forall msg. ToLogStr msg => msg -> LogStr
L.toLogStr forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
5 forall a b. (a -> b) -> a -> b
$ 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
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    ProcessTracker
processTracker <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProcessTracker
initProcessTracker
    HostManager
hostman <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO HostManager
HostMan.start
    PortPool
portpool <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PortSettings -> IO PortPool
PortPool.start PortSettings
kconfigPortPool
    TempFolder
tf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO TempFolder
TempFolder.setup forall a b. (a -> b) -> a -> b
$ FilePath
kconfigDir FilePath -> FilePath -> FilePath
</> FilePath
"temp"
    [Plugin]
plugins <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just Text
t -> do
                Either SomeException UserEntry
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$
                    case 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 forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
t
                case Either SomeException UserEntry
x of
                    Left (SomeException
_ :: SomeException) -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid user ID: " forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
t
                    Right UserEntry
ue -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ UserEntry -> FilePath
userName UserEntry
ue, (UserEntry -> UserID
userID UserEntry
ue, UserEntry -> GroupID
userGroupID UserEntry
ue))

    let appStartConfig :: AppStartConfig
appStartConfig = AppStartConfig
            { ascTempFolder :: TempFolder
ascTempFolder = TempFolder
tf
            , ascSetuid :: Maybe (Text, (UserID, GroupID))
ascSetuid = Maybe (Text, (UserID, GroupID))
muid
            , ascProcessTracker :: ProcessTracker
ascProcessTracker = ProcessTracker
processTracker
            , ascHostManager :: HostManager
ascHostManager = HostManager
hostman
            , ascPortPool :: PortPool
ascPortPool = PortPool
portpool
            , ascPlugins :: [Plugin]
ascPlugins = [Plugin]
plugins
            , ascKeterConfig :: KeterConfig
ascKeterConfig = KeterConfig
cfg
            }
    AppManager
appMan <- forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const AppStartConfig
appStartConfig) 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
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let incoming :: FilePath
incoming = KeterConfig -> FilePath
getIncoming KeterConfig
kc
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
incoming
    [FilePath]
bundles0 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isKeter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectoryTree FilePath
incoming
    forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const AppManager
appMan) forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> KeterM AppManager ()
AppMan.addApp [FilePath]
bundles0
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Vector a -> Bool
V.null Vector (Stanza ())
kconfigBuiltinStanzas) forall a b. (a -> b) -> a -> b
$ AppId -> Action -> KeterM AppManager ()
AppMan.perform
            AppId
AIBuiltin
            (AppInput -> Action
AppMan.Reload forall a b. (a -> b) -> a -> b
$ BundleConfig -> AppInput
AIData forall a b. (a -> b) -> a -> b
$ Vector (Stanza ()) -> Object -> BundleConfig
BundleConfig Vector (Stanza ())
kconfigBuiltinStanzas 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
    -- File system watching
    WatchManager
wm <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO WatchManager
FSN.startManager
    forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const AppManager
appMan) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO 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 (forall a. IsString a => FilePath -> a
fromString FilePath
incoming) (forall a b. a -> b -> a
const Bool
True) forall a b. (a -> b) -> a -> b
$ \Event
e -> do
                Either FilePath FilePath
e' <-
                    case Event
e of
                        FSN.Removed FilePath
fp UTCTime
_ EventIsDirectory
_ -> do
                            forall a. KeterM AppManager a -> IO a
rio forall a b. (a -> b) -> a -> b
$ $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
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 forall a b. (a -> b) -> a -> b
$ Text
"Watched file removed: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. a -> a
fromFilePath FilePath
fp)
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> a
fromFilePath FilePath
fp
                        FSN.Added FilePath
fp UTCTime
_ EventIsDirectory
_ -> do
                            forall a. KeterM AppManager a -> IO a
rio forall a b. (a -> b) -> a -> b
$ $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
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 forall a b. (a -> b) -> a -> b
$ Text
"Watched file added: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. a -> a
fromFilePath FilePath
fp)
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> a
fromFilePath FilePath
fp
                        FSN.Modified FilePath
fp UTCTime
_ EventIsDirectory
_ -> do
                            forall a. KeterM AppManager a -> IO a
rio forall a b. (a -> b) -> a -> b
$ $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
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 forall a b. (a -> b) -> a -> b
$ Text
"Watched file modified: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. a -> a
fromFilePath FilePath
fp)
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> a
fromFilePath FilePath
fp
                        Event
_ -> do
                            forall a. KeterM AppManager a -> IO a
rio forall a b. (a -> b) -> a -> b
$ $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
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 forall a b. (a -> b) -> a -> b
$ Text
"Watched file unknown" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack forall a. Monoid a => a
mempty
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left []
                forall a. KeterM AppManager a -> IO a
rio forall a b. (a -> b) -> a -> b
$ case Either FilePath FilePath
e' of
                    Left FilePath
fp -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isKeter FilePath
fp) forall a b. (a -> b) -> a -> b
$ Text -> KeterM AppManager ()
AppMan.terminateApp forall a b. (a -> b) -> a -> b
$ FilePath -> Text
getAppname FilePath
fp
                    Right FilePath
fp -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isKeter FilePath
fp) forall a b. (a -> b) -> a -> b
$ FilePath -> KeterM AppManager ()
AppMan.addApp forall a b. (a -> b) -> a -> b
$ FilePath
incoming FilePath -> FilePath -> FilePath
</> FilePath
fp
        -- Install HUP handler for cases when inotify cannot be used.
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigHUP) forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ IO () -> Handler
Catch forall a b. (a -> b) -> a -> b
$ do
            [FilePath]
bundles <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isKeter) forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectoryTree FilePath
incoming
            Map Text (FilePath, EpochTime)
newMap <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
bundles forall a b. (a -> b) -> a -> b
$ \FilePath
bundle -> do
                EpochTime
time <- FileStatus -> EpochTime
modificationTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
getFileStatus FilePath
bundle
                forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Text
getAppname FilePath
bundle, (FilePath
bundle, EpochTime
time))
            forall a. KeterM AppManager a -> IO a
rio 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 = 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
       forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
             forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
fp1]
           ) (forall a. (a -> Bool) -> [a] -> [a]
filter (\FilePath
x -> FilePath
x forall a. Eq a => a -> a -> Bool
/= FilePath
"." Bool -> Bool -> Bool
&& FilePath
x 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
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Loc -> Text -> LogLevel -> LogStr -> IO ()
logger <- forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
    ProxySettings
settings <- HostManager -> KeterM KeterConfig ProxySettings
Proxy.makeSettings HostManager
hostman
    forall cfg cfg' a. (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a
withMappedConfig (forall a b. a -> b -> a
const ProxySettings
settings) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM ProxySettings a -> IO a
rio ->
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. NonEmptyVector a -> (a -> IO ()) -> IO ()
runAndBlock NonEmptyVector ListeningPort
kconfigListeners forall a b. (a -> b) -> a -> b
$ \ListeningPort
ls -> 
            forall a. KeterM ProxySettings a -> IO a
rio 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 forall a. a -> [a] -> [a]
: forall a. Vector a -> [a]
V.toList Vector a
v

    loop :: [a] -> [Async ()] -> IO ()
loop (a
x:[a]
xs) [Async ()]
asyncs = forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (a -> IO ()
f a
x) forall a b. (a -> b) -> a -> b
$ \Async ()
async -> [a] -> [Async ()] -> IO ()
loop [a]
xs forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. [Async a] -> IO (Async a, a)
waitAny [Async ()]
asyncs