{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

module Keter.Main
    ( keter
    ) where

import qualified Codec.Archive.TempTarball as TempFolder
import           Control.Concurrent.Async  (waitAny, withAsync)
import           Control.Monad             (unless)
import qualified Data.Conduit.LogFile      as LogFile
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.Types
import           System.Posix.Files        (getFileStatus, modificationTime)
import           System.Posix.Signals      (Handler (Catch), installHandler,
                                            sigHUP)

import           Control.Applicative       ((<$>))
import           Control.Exception         (throwIO, try)
import           Control.Monad             (forM)
import           Control.Monad             (void, when)
import           Data.Conduit.Process.Unix (initProcessTracker)
import           Data.Default              (def)
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           Data.Yaml.FilePath
import           Prelude                   hiding (FilePath, log)
import           System.Directory          (createDirectoryIfMissing,
                                            createDirectoryIfMissing,
                                            doesDirectoryExist, doesFileExist,
                                            getDirectoryContents)
import           System.FilePath           (takeExtension, (</>))
import qualified System.FSNotify           as FSN
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

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
-> [FilePath -> IO Plugin]
-> (KeterConfig
    -> HostManager -> AppManager -> (LogMessage -> IO ()) -> IO ())
-> IO ()
forall a.
FilePath
-> [FilePath -> IO Plugin]
-> (KeterConfig
    -> HostManager -> AppManager -> (LogMessage -> IO ()) -> IO a)
-> IO a
withManagers FilePath
input [FilePath -> IO Plugin]
mkPlugins ((KeterConfig
  -> HostManager -> AppManager -> (LogMessage -> IO ()) -> IO ())
 -> IO ())
-> (KeterConfig
    -> HostManager -> AppManager -> (LogMessage -> IO ()) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \KeterConfig
kc HostManager
hostman AppManager
appMan LogMessage -> IO ()
log -> do
    LogMessage -> IO ()
log LogMessage
LaunchCli
    IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Port -> (Port -> IO ()) -> IO (Maybe ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (KeterConfig -> Maybe Port
kconfigCliPort KeterConfig
kc) ((Port -> IO ()) -> IO (Maybe ()))
-> (Port -> IO ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \Port
port ->
      CliStates -> IO ()
launchCli (MkCliStates :: AppManager -> (LogMessage -> IO ()) -> Port -> CliStates
MkCliStates
                { csAppManager :: AppManager
csAppManager = AppManager
appMan
                , csLog :: LogMessage -> IO ()
csLog        = LogMessage -> IO ()
log
                , csPort :: Port
csPort       = Port
port
                })
    LogMessage -> IO ()
log LogMessage
LaunchInitial
    KeterConfig -> AppManager -> IO ()
launchInitial KeterConfig
kc AppManager
appMan
    LogMessage -> IO ()
log LogMessage
StartWatching
    KeterConfig -> AppManager -> (LogMessage -> IO ()) -> IO ()
startWatching KeterConfig
kc AppManager
appMan LogMessage -> IO ()
log
    LogMessage -> IO ()
log LogMessage
StartListening
    (LogMessage -> IO ()) -> KeterConfig -> HostManager -> IO ()
startListening LogMessage -> IO ()
log KeterConfig
kc HostManager
hostman

-- | Load up Keter config.
withConfig :: FilePath
           -> (KeterConfig -> IO a)
           -> IO a
withConfig :: FilePath -> (KeterConfig -> IO a) -> IO a
withConfig FilePath
input KeterConfig -> IO a
f = do
    Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
input
    KeterConfig
config <-
        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
forall a. Default a => a
def { kconfigDir :: FilePath
kconfigDir = FilePath
input }
    KeterConfig -> IO a
f KeterConfig
config

withLogger :: FilePath
           -> (KeterConfig -> (LogMessage -> IO ()) -> IO a)
           -> IO a
withLogger :: FilePath -> (KeterConfig -> (LogMessage -> IO ()) -> IO a) -> IO a
withLogger FilePath
fp KeterConfig -> (LogMessage -> IO ()) -> IO a
f = FilePath -> (KeterConfig -> IO a) -> IO a
forall a. FilePath -> (KeterConfig -> IO a) -> IO a
withConfig FilePath
fp ((KeterConfig -> IO a) -> IO a) -> (KeterConfig -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \KeterConfig
config -> do
    RotatingLog
mainlog <- FilePath -> Word -> IO RotatingLog
LogFile.openRotatingLog
        (KeterConfig -> FilePath
kconfigDir KeterConfig
config FilePath -> FilePath -> FilePath
</> FilePath
"log" FilePath -> FilePath -> FilePath
</> FilePath
"keter")
        Word
LogFile.defaultMaxTotal

    KeterConfig -> (LogMessage -> IO ()) -> IO a
f KeterConfig
config ((LogMessage -> IO ()) -> IO a) -> (LogMessage -> IO ()) -> IO a
forall a b. (a -> b) -> a -> b
$ \LogMessage
ml -> do
        UTCTime
now <- IO UTCTime
getCurrentTime
        let bs :: ByteString
bs = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ Port -> FilePath -> FilePath
forall a. Port -> [a] -> [a]
take Port
22 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
now
                , FilePath
": "
                , LogMessage -> FilePath
forall a. Show a => a -> FilePath
show LogMessage
ml
                , FilePath
"\n"
                ]
        RotatingLog -> ByteString -> IO ()
LogFile.addChunk RotatingLog
mainlog ByteString
bs

withManagers :: FilePath
             -> [FilePath -> IO Plugin]
             -> (KeterConfig -> HostMan.HostManager -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO a)
             -> IO a
withManagers :: FilePath
-> [FilePath -> IO Plugin]
-> (KeterConfig
    -> HostManager -> AppManager -> (LogMessage -> IO ()) -> IO a)
-> IO a
withManagers FilePath
input [FilePath -> IO Plugin]
mkPlugins KeterConfig
-> HostManager -> AppManager -> (LogMessage -> IO ()) -> IO a
f = FilePath -> (KeterConfig -> (LogMessage -> IO ()) -> IO a) -> IO a
forall a.
FilePath -> (KeterConfig -> (LogMessage -> IO ()) -> IO a) -> IO a
withLogger FilePath
input ((KeterConfig -> (LogMessage -> IO ()) -> IO a) -> IO a)
-> (KeterConfig -> (LogMessage -> IO ()) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \kc :: KeterConfig
kc@KeterConfig {Bool
Port
FilePath
Maybe Port
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigConnectionTimeBound :: KeterConfig -> Port
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigExternalHttpsPort :: KeterConfig -> Port
kconfigExternalHttpPort :: KeterConfig -> Port
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigPortPool :: KeterConfig -> PortSettings
kconfigProxyException :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigUnknownHostResponse :: Maybe FilePath
kconfigCliPort :: Maybe Port
kconfigConnectionTimeBound :: Port
kconfigEnvironment :: Map Text Text
kconfigExternalHttpsPort :: Port
kconfigExternalHttpPort :: Port
kconfigIpFromHeader :: Bool
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigSetuid :: Maybe Text
kconfigListeners :: NonEmptyVector ListeningPort
kconfigPortPool :: PortSettings
kconfigDir :: FilePath
kconfigDir :: KeterConfig -> FilePath
kconfigCliPort :: KeterConfig -> Maybe Port
..} LogMessage -> IO ()
log -> do
    ProcessTracker
processTracker <- IO ProcessTracker
initProcessTracker
    HostManager
hostman <- IO HostManager
HostMan.start
    PortPool
portpool <- PortSettings -> IO PortPool
PortPool.start PortSettings
kconfigPortPool
    TempFolder
tf <- 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) -> IO Plugin)
-> [FilePath -> IO Plugin] -> IO [Plugin]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((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))
-> IO (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 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 -> IO (Maybe (Text, (UserID, GroupID)))
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Maybe (Text, (UserID, GroupID))))
-> FilePath -> IO (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))
-> IO (Maybe (Text, (UserID, GroupID)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, (UserID, GroupID))
 -> IO (Maybe (Text, (UserID, GroupID))))
-> Maybe (Text, (UserID, GroupID))
-> IO (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]
-> (LogMessage -> IO ())
-> 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
            , ascLog :: LogMessage -> IO ()
ascLog = LogMessage -> IO ()
log
            , ascKeterConfig :: KeterConfig
ascKeterConfig = KeterConfig
kc
            }
    AppManager
appMan <- (LogMessage -> IO ()) -> AppStartConfig -> IO AppManager
AppMan.initialize LogMessage -> IO ()
log AppStartConfig
appStartConfig
    KeterConfig
-> HostManager -> AppManager -> (LogMessage -> IO ()) -> IO a
f KeterConfig
kc HostManager
hostman AppManager
appMan LogMessage -> IO ()
log

launchInitial :: KeterConfig -> AppMan.AppManager -> IO ()
launchInitial :: KeterConfig -> AppManager -> IO ()
launchInitial kc :: KeterConfig
kc@KeterConfig {Bool
Port
FilePath
Maybe Port
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigProxyException :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigUnknownHostResponse :: Maybe FilePath
kconfigCliPort :: Maybe Port
kconfigConnectionTimeBound :: Port
kconfigEnvironment :: Map Text Text
kconfigExternalHttpsPort :: Port
kconfigExternalHttpPort :: Port
kconfigIpFromHeader :: Bool
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigSetuid :: Maybe Text
kconfigListeners :: NonEmptyVector ListeningPort
kconfigPortPool :: PortSettings
kconfigDir :: FilePath
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
kconfigConnectionTimeBound :: KeterConfig -> Port
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigExternalHttpsPort :: KeterConfig -> Port
kconfigExternalHttpPort :: KeterConfig -> Port
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigPortPool :: KeterConfig -> PortSettings
kconfigDir :: KeterConfig -> FilePath
kconfigCliPort :: KeterConfig -> Maybe Port
..} AppManager
appMan = do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
incoming
    [FilePath]
bundles0 <- (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
    (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AppManager -> FilePath -> IO ()
AppMan.addApp AppManager
appMan) [FilePath]
bundles0

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Vector (Stanza ()) -> Bool
forall a. Vector a -> Bool
V.null Vector (Stanza ())
kconfigBuiltinStanzas) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppManager -> AppId -> Action -> IO ()
AppMan.perform
        AppManager
appMan
        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)
  where
    incoming :: FilePath
incoming = KeterConfig -> FilePath
getIncoming KeterConfig
kc

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 :: KeterConfig -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO ()
startWatching :: KeterConfig -> AppManager -> (LogMessage -> IO ()) -> IO ()
startWatching KeterConfig
kc AppManager
appMan LogMessage -> IO ()
log = do
    -- File system watching
    WatchManager
wm <- IO WatchManager
FSN.startManager
    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
                    LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath -> LogMessage
WatchedFile Text
"removed" (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
                    LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath -> LogMessage
WatchedFile Text
"added" (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
                    LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath -> LogMessage
WatchedFile Text
"modified" (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
                    LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath -> LogMessage
WatchedFile Text
"unknown" []
                    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 []
        case Either FilePath FilePath
e' of
            Left FilePath
fp -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isKeter FilePath
fp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppManager -> Text -> IO ()
AppMan.terminateApp AppManager
appMan (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
getAppname FilePath
fp
            Right FilePath
fp -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isKeter FilePath
fp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppManager -> FilePath -> IO ()
AppMan.addApp AppManager
appMan (FilePath -> IO ()) -> FilePath -> IO ()
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))
        AppManager -> Map Text (FilePath, EpochTime) -> IO ()
AppMan.reloadAppList AppManager
appMan Map Text (FilePath, EpochTime)
newMap
  where
    incoming :: FilePath
incoming = KeterConfig -> FilePath
getIncoming KeterConfig
kc


-- 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 :: 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 :: (LogMessage -> IO ()) -> KeterConfig -> HostMan.HostManager -> IO ()
startListening :: (LogMessage -> IO ()) -> KeterConfig -> HostManager -> IO ()
startListening LogMessage -> IO ()
log KeterConfig
config HostManager
hostman = do
    ProxySettings
settings <- (LogMessage -> IO ())
-> KeterConfig -> HostManager -> IO ProxySettings
Proxy.makeSettings LogMessage -> IO ()
log KeterConfig
config HostManager
hostman
    NonEmptyVector ListeningPort -> (ListeningPort -> IO ()) -> IO ()
forall a. NonEmptyVector a -> (a -> IO ()) -> IO ()
runAndBlock (KeterConfig -> NonEmptyVector ListeningPort
kconfigListeners KeterConfig
config) ((ListeningPort -> IO ()) -> IO ())
-> (ListeningPort -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ProxySettings -> ListeningPort -> IO ()
Proxy.reverseProxy ProxySettings
settings

runAndBlock :: NonEmptyVector a
            -> (a -> IO ())
            -> IO ()
runAndBlock :: 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