Main.hs

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

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.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.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, SomeException)
import           Control.Monad             (forM)
import           Control.Monad             (void, when)
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, (</>))
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 input mkPlugins = withManagers input mkPlugins $ \kc hostman appMan log -> do
    log LaunchCli
    void $ forM (kconfigCliPort kc) $ \port ->
      launchCli (MkCliStates
                { csAppManager = appMan
                , csLog        = log
                , csPort       = port
                })
    log LaunchInitial
    launchInitial kc appMan
    log StartWatching
    startWatching kc appMan log
    log StartListening
    startListening log kc hostman

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

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

    f config $ \ml -> do
        now <- getCurrentTime
        let bs = encodeUtf8 $ T.pack $ concat
                [ take 22 $ show now
                , ": "
                , show ml
                , "\n"
                ]
        LogFile.addChunk mainlog bs

withManagers :: FilePath
             -> [FilePath -> IO Plugin]
             -> (KeterConfig -> HostMan.HostManager -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO a)
             -> IO a
withManagers input mkPlugins f = withLogger input $ \kc@KeterConfig {..} log -> do
    processTracker <- initProcessTracker
    hostman <- HostMan.start
    portpool <- PortPool.start kconfigPortPool
    tf <- TempFolder.setup $ kconfigDir </> "temp"
    plugins <- mapM ($ kconfigDir) mkPlugins
    muid <-
        case kconfigSetuid of
            Nothing -> return Nothing
            Just t -> do
                x <- 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
            , ascLog = log
            , ascKeterConfig = kc
            }
    appMan <- AppMan.initialize log appStartConfig
    f kc hostman appMan log

launchInitial :: KeterConfig -> AppMan.AppManager -> IO ()
launchInitial kc@KeterConfig {..} appMan = do
    createDirectoryIfMissing True incoming
    bundles0 <- filter isKeter <$> listDirectoryTree incoming
    mapM_ (AppMan.addApp appMan) bundles0

    unless (V.null kconfigBuiltinStanzas) $ AppMan.perform
        appMan
        AIBuiltin
        (AppMan.Reload $ AIData $ BundleConfig kconfigBuiltinStanzas mempty)
  where
    incoming = getIncoming kc

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

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

startWatching :: KeterConfig -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO ()
startWatching kc appMan log = do
    -- File system watching
    wm <- FSN.startManager
    _ <- FSN.watchTree wm (fromString incoming) (const True) $ \e -> do
        e' <-
            case e of
                FSN.Removed fp _ _ -> do
                    log $ WatchedFile "removed" (fromFilePath fp)
                    return $ Left $ fromFilePath fp
                FSN.Added fp _ _ -> do
                    log $ WatchedFile "added" (fromFilePath fp)
                    return $ Right $ fromFilePath fp
                FSN.Modified fp _ _ -> do
                    log $ WatchedFile "modified" (fromFilePath fp)
                    return $ Right $ fromFilePath fp
                _ -> do
                    log $ WatchedFile "unknown" []
                    return $ Left []
        case e' of
            Left fp -> when (isKeter fp) $ AppMan.terminateApp appMan $ getAppname fp
            Right fp -> when (isKeter fp) $ AppMan.addApp appMan $ incoming </> fp

    -- Install HUP handler for cases when inotify cannot be used.
    void $ flip (installHandler sigHUP) Nothing $ Catch $ do
        bundles <- fmap (filter isKeter) $ listDirectoryTree incoming
        newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do
            time <- modificationTime <$> getFileStatus bundle
            return (getAppname bundle, (bundle, time))
        AppMan.reloadAppList appMan newMap
  where
    incoming = getIncoming 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 = id
#endif

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

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