Main.hs

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

module Keter.Main
    ( keter
    ) where

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

keter :: FilePath -- ^ root directory or config file
      -> [FilePath -> IO Plugin]
      -> IO ()
keter input mkPlugins =
    runKeterConfigReader input . runKeterLogger . runKeterM $
        withManagers mkPlugins $ \hostman appMan -> do
            KeterConfig{..} <- ask
            $logInfo "Launching cli"
            forM_ kconfigCliPort $ \port ->
              withMappedConfig
                  (const $ MkCliStates
                      { csAppManager = appMan
                      , csPort       = port
                      })
                  launchCli
            $logInfo "Launching initial"
            launchInitial appMan
            $logInfo "Started watching"
            startWatching appMan
            $logInfo "Started listening"
            startListening hostman

-- | Load up Keter config and evaluate a ReaderT context with it
runKeterConfigReader :: MonadIO m
                     => FilePath
                     -> ReaderT KeterConfig m a
                     -> m a
runKeterConfigReader input ctx = do
    exists <- liftIO $ doesFileExist input
    config <- liftIO $
        if exists
            then do
                eres <- decodeFileRelative input
                case eres of
                    Left e -> throwIO $ InvalidKeterConfigFile input e
                    Right x -> return x
            else return defaultKeterConfig { kconfigDir = input }
    runReaderT ctx 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 ctx = do
    cfg <- ask
    withRunInIO $ \rio -> bracket (Log.createLoggerViaConfig cfg "keter") Log.loggerClose $
        rio . runLoggingT ctx . formatLog
    where
        formatLog logger loc _ lvl msg = do
            now <- liftIO getCurrentTime
            -- Format: "{keter|}$time|$module$:$line_num|$log_level> $msg"
            let tag = case Log.loggerType logger of { FL.LogStderr _ -> "keter|"; _ -> mempty }
            let bs = mconcat
                    [ tag
                    , L.toLogStr $ take 22 $ show now
                    , "|"
                    , L.toLogStr (L.loc_module loc)
                    , ":"
                    , L.toLogStr (fst $ L.loc_start loc)
                    , "|"
                    , L.toLogStr $ drop 5 $ show lvl
                    , "> "
                    , msg
                    , "\n"
                    ]
            Log.loggerLog logger bs

withManagers :: [FilePath -> IO Plugin]
             -> (HostMan.HostManager -> AppMan.AppManager -> KeterM KeterConfig a)
             -> KeterM KeterConfig a
withManagers mkPlugins f = do
    cfg@KeterConfig{..} <- ask
    processTracker <- liftIO initProcessTracker
    hostman <- liftIO HostMan.start
    portpool <- liftIO $ PortPool.start kconfigPortPool
    tf <- liftIO $ TempFolder.setup $ kconfigDir </> "temp"
    plugins <- mapM (liftIO . ($ kconfigDir)) mkPlugins
    muid <-
        case kconfigSetuid of
            Nothing -> return Nothing
            Just t -> do
                x <- liftIO $ try $
                    case Data.Text.Read.decimal t of
                        Right (i, "") -> getUserEntryForID i
                        _ -> getUserEntryForName $ T.unpack t
                case x of
                    Left (_ :: SomeException) -> error $ "Invalid user ID: " ++ T.unpack t
                    Right ue -> return $ Just (T.pack $ userName ue, (userID ue, userGroupID ue))

    let appStartConfig = AppStartConfig
            { ascTempFolder = tf
            , ascSetuid = muid
            , ascProcessTracker = processTracker
            , ascHostManager = hostman
            , ascPortPool = portpool
            , ascPlugins = plugins
            , ascKeterConfig = cfg
            }
    appMan <- withMappedConfig (const appStartConfig) AppMan.initialize
    f hostman appMan

launchInitial :: AppMan.AppManager -> KeterM KeterConfig ()
launchInitial appMan = do
    kc@KeterConfig{..} <- ask
    let incoming = getIncoming kc
    liftIO $ createDirectoryIfMissing True incoming
    bundles0 <- liftIO $ filter isKeter <$> listDirectoryTree incoming
    withMappedConfig (const appMan) $ do
        mapM_ AppMan.addApp bundles0
        unless (V.null kconfigBuiltinStanzas) $ AppMan.perform
            AIBuiltin
            (AppMan.Reload $ AIData $ BundleConfig kconfigBuiltinStanzas mempty)

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

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

startWatching :: AppMan.AppManager -> KeterM KeterConfig ()
startWatching appMan = do
    incoming <- asks getIncoming
    -- File system watching
    wm <- liftIO FSN.startManager
    withMappedConfig (const appMan) $ withRunInIO $ \rio -> do
        _ <- FSN.watchTree wm (fromString incoming) (const True) $ \e -> do
                e' <-
                    case e of
                        FSN.Removed fp _ _ -> do
                            rio $ $logInfo $ "Watched file removed: " <> T.pack fp
                            return $ Left fp
                        FSN.Added fp _ _ -> do
                            rio $ $logInfo $ "Watched file added: " <> T.pack fp
                            return $ Right fp
                        FSN.Modified fp _ _ -> do
                            rio $ $logInfo $ "Watched file modified: " <> T.pack fp
                            return $ Right fp
                        _ -> do
                            rio $ $logInfo $ "Watched file unknown" <> T.pack mempty
                            return $ Left []
                rio $ case e' of
                    Left fp -> when (isKeter fp) $ AppMan.terminateApp $ getAppname fp
                    Right fp -> when (isKeter fp) $ AppMan.addApp $ incoming </> fp
        -- Install HUP handler for cases when inotify cannot be used.
        void $ flip (installHandler sigHUP) Nothing $ Catch $ do
            bundles <- filter isKeter <$> listDirectoryTree incoming
            newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do
                time <- modificationTime <$> getFileStatus bundle
                return (getAppname bundle, (bundle, time))
            rio $ AppMan.reloadAppList newMap

listDirectoryTree :: FilePath -> IO [FilePath]
listDirectoryTree fp = do
       dir <- getDirectoryContents fp
       concat <$> mapM (\fpRel -> do
          let fp1 = fp </> fpRel
          isDir <- doesDirectoryExist fp1
          if isDir
           then
             listDirectoryTree fp1
           else
             return [fp1]
           ) (filter (\x -> x /= "." && x /= "..") dir)

startListening :: HostMan.HostManager -> KeterM KeterConfig ()
startListening hostman = do
    KeterConfig{..} <- ask
    settings <- Proxy.makeSettings hostman
    withMappedConfig (const settings) $ withRunInIO $ \rio ->
        liftIO $ runAndBlock kconfigListeners $ \ls ->
            rio $ Proxy.reverseProxy ls

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

    loop (x:xs) asyncs = withAsync (f x) $ \async -> loop xs $ 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 [] asyncs = void $ waitAny asyncs