diff --git a/Keter/App.hs b/Keter/App.hs index c36d353..f86487a 100644 --- a/Keter/App.hs +++ b/Keter/App.hs @@ -222,3 +222,11 @@ terminate (App f) = f Terminate pluginsGetEnv :: Plugins -> Appname -> Object -> KIO [(Text, Text)] pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps + + {- FIXME handle static stanzas + let staticReverse r = do + HostMan.addEntry hostman (ReverseProxy.reversingHost r) + $ HostMan.PEReverseProxy + $ ReverseProxy.RPEntry r manager + runKIO' $ mapM_ staticReverse (Set.toList kconfigReverseProxy) + -} diff --git a/Keter/AppManager.hs b/Keter/AppManager.hs new file mode 100644 index 0000000..b3c6d43 --- /dev/null +++ b/Keter/AppManager.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +-- | Used for management of applications. +module Keter.AppManager + ( -- * Types + AppManager + , AppId (..) + , Action (..) + , AppInput (..) + -- * Actions + , perform + , getAllApps + -- * Initialize + , initialize + ) where + +import Control.Applicative +import Control.Concurrent (forkIO) +import Control.Concurrent.STM +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Keter.Prelude +import Keter.Types +import Prelude (Eq, IO, Ord) +import qualified Control.Exception as E + +data AppManager = AppManager + { apps :: TVar (Map AppId (TVar AppState)) + } + +data AppId = AIBuiltin | AINamed Appname + deriving (Eq, Ord) + +data AppState = ASRunning RunningApp + | ASStarting !(Maybe RunningApp) (TVar (Maybe Request)) -- ^ the next one to try + +data RunningApp = RunningApp + +data AppInput = AIBundle | AIData !BundleConfig + +data Action = Reload AppInput | Terminate + +data Request = Request Action (TMVar Result) + +data Result = ResultSuccess + | ResultFailure SomeException + | ResultCanceled + +initialize :: IO AppManager +initialize = AppManager + <$> newTVarIO Map.empty + +getAllApps :: AppManager -> IO (Set Appname) +getAllApps AppManager {..} = atomically $ do + m <- readTVar apps + return $ Set.fromList $ mapMaybe toAppName $ Map.keys m + where + toAppName AIBuiltin = Nothing + toAppName (AINamed x) = Just x + +perform :: AppManager -> AppId -> Action -> IO () +perform AppManager {..} aid action = E.mask_ $ do + (launchWorker', tresult) <- atomically $ do + tresult <- newEmptyTMVar + let request = Request action tresult + m <- readTVar apps + launchWorker' <- case Map.lookup aid m of + Just tstate -> do + state <- readTVar tstate + case state of + ASStarting mcurrent tmnext -> do + mnext <- readTVar tmnext + case mnext of + Nothing -> return () + Just (Request _ tresultOld) -> void $ tryPutTMVar tresultOld ResultCanceled + writeTVar tmnext $ Just request + -- use the previous worker, so nothing to do + return (return ()) + ASRunning runningApp -> do + tmnext <- newTVar Nothing + writeTVar tstate $ ASStarting (Just runningApp) tmnext + return launchWorker + Nothing -> do + case action of + Reload _ -> do + tmnext <- newTVar Nothing + tstate <- newTVar $ ASStarting Nothing tmnext + writeTVar apps $ Map.insert aid tstate m + return launchWorker + Terminate -> do + putTMVar tresult ResultSuccess + return (return ()) + return (launchWorker', tresult) + launchWorker' + void $ forkIO $ do + result <- atomically $ takeTMVar tresult + -- FIXME + return () + {- + case (aid, result) of + ResultSuccess -> log $ AppLoadedSuccessfully + -} + where + launchWorker = return () -- FIXME + +{- FIXME + rest <- + case Map.lookup appname appMap of + Just (app, _time) -> do + App.reload app + etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle) + let time = either (P.const 0) id etime + return (Map.insert appname (app, time) appMap, return ()) + Nothing -> do + mlogger <- do + let dirout = kconfigDir "log" fromText ("app-" ++ appname) + direrr = dirout "err" + erlog <- liftIO $ LogFile.openRotatingLog + (F.encodeString dirout) + LogFile.defaultMaxTotal + case erlog of + Left e -> do + $logEx e + return Nothing + Right rlog -> return (Just rlog) + let logger = fromMaybe LogFile.dummy mlogger + (app, rest) <- App.start + tf + muid + processTracker + hostman + plugins + logger + appname + bundle + (removeApp appname) + etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle) + let time = either (P.const 0) id etime + let appMap' = Map.insert appname (app, time) appMap + return (appMap', rest) + rest + -} diff --git a/Keter/Main.hs b/Keter/Main.hs index fa9ef9a..da1dc6f 100644 --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -19,6 +19,10 @@ import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite import System.Posix.Files (modificationTime, getFileStatus) import System.Posix.Signals (sigHUP, installHandler, Handler (Catch)) import qualified Data.Conduit.LogFile as LogFile +import qualified Keter.AppManager as AppMan +import Data.Monoid (mempty) +import Control.Monad (unless) +import qualified Data.Vector as V import Data.Yaml.FilePath import qualified Control.Concurrent.MVar as M @@ -106,65 +110,23 @@ keter (F.decodeString -> input) mkPlugins = do (runKIOPrint . HostMan.lookupAction hostman) return () - mappMap <- M.newMVar Map.empty - let removeApp appname = Keter.Prelude.modifyMVar_ mappMap $ return . Map.delete appname - addApp bundle = do - let appname = getAppname bundle - rest <- modifyMVar mappMap $ \appMap -> - case Map.lookup appname appMap of - Just (app, _time) -> do - App.reload app - etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle) - let time = either (P.const 0) id etime - return (Map.insert appname (app, time) appMap, return ()) - Nothing -> do - mlogger <- do - let dirout = kconfigDir "log" fromText ("app-" ++ appname) - direrr = dirout "err" - erlog <- liftIO $ LogFile.openRotatingLog - (F.encodeString dirout) - LogFile.defaultMaxTotal - case erlog of - Left e -> do - $logEx e - return Nothing - Right rlog -> return (Just rlog) - let logger = fromMaybe LogFile.dummy mlogger - (app, rest) <- App.start - tf - muid - processTracker - hostman - plugins - logger - appname - bundle - (removeApp appname) - etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle) - let time = either (P.const 0) id etime - let appMap' = Map.insert appname (app, time) appMap - return (appMap', rest) - rest - terminateApp appname = do - -- FIXME why not remove it from the map? - appMap <- M.readMVar mappMap - case Map.lookup appname appMap of - Nothing -> return () - Just (app, _) -> runKIO' $ App.terminate app + appMan <- AppMan.initialize + let addApp bundle = AppMan.perform + appMan + (AppMan.AINamed $ getAppname bundle) + (AppMan.Reload AppMan.AIBundle) + terminateApp appname = AppMan.perform appMan (AppMan.AINamed appname) AppMan.Terminate let incoming = kconfigDir "incoming" isKeter fp = hasExtension fp "keter" createTree incoming bundles0 <- fmap (filter isKeter) $ listDirectory incoming - runKIO' $ mapM_ addApp bundles0 + mapM_ addApp bundles0 - {- FIXME handle static stanzas - let staticReverse r = do - HostMan.addEntry hostman (ReverseProxy.reversingHost r) - $ HostMan.PEReverseProxy - $ ReverseProxy.RPEntry r manager - runKIO' $ mapM_ staticReverse (Set.toList kconfigReverseProxy) - -} + unless (V.null kconfigBuiltinStanzas) $ AppMan.perform + appMan + AppMan.AIBuiltin + (AppMan.Reload $ AppMan.AIData $ BundleConfig kconfigBuiltinStanzas mempty) -- File system watching wm <- FSN.startManager @@ -176,27 +138,29 @@ keter (F.decodeString -> input) mkPlugins = do FSN.Modified fp _ -> Right fp in case e' of Left fp -> when (isKeter fp) $ terminateApp $ getAppname fp - Right fp -> when (isKeter fp) $ runKIO' $ addApp $ incoming fp + Right fp -> when (isKeter fp) $ addApp $ incoming fp -- Install HUP handler for cases when inotify cannot be used. + {- FIXME _ <- flip (installHandler sigHUP) Nothing $ Catch $ do - actions <- M.withMVar mappMap $ \appMap -> do + actions <- do bundles <- fmap (filter isKeter) $ F.listDirectory incoming newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do time <- modificationTime <$> getFileStatus (F.encodeString bundle) return (getAppname' $ F.encodeString bundle, (bundle, time)) - let apps = Set.toList $ Set.fromList (Map.keys newMap) - `Set.union` Set.fromList (Map.keys appMap) + current <- getAllApps appMan + let apps = Set.toList $ Set.fromList (Map.keys newMap) `Set.union` current fmap catMaybes $ forM apps $ \appname -> return $ - case (Map.lookup appname appMap, Map.lookup appname newMap) of - (Nothing, Nothing) -> Nothing -- should never happen - (Just _, Nothing) -> Just $ terminateApp appname - (Nothing, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle + case (Set.member appname current, Map.lookup appname newMap) of + (False, Nothing) -> Nothing -- should never happen + (True, Nothing) -> Just $ terminateApp appname + (False, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle (Just (_, oldTime), Just (bundle, newTime)) | newTime /= oldTime -> Just $ runKIO' $ addApp bundle | otherwise -> Nothing P.sequence_ actions + -} runKIO' $ forever $ threadDelay $ 60 * 1000 * 1000 where diff --git a/Keter/Prelude.hs b/Keter/Prelude.hs index 1c04716..319c44a 100644 --- a/Keter/Prelude.hs +++ b/Keter/Prelude.hs @@ -88,6 +88,8 @@ module Keter.Prelude , takeMVar , tryTakeMVar , putMVar + -- * STM + , atomicallyK -- * IORef , I.IORef , newIORef @@ -97,6 +99,8 @@ module Keter.Prelude , newChan , readChan , writeChan + -- * Exception + , mask_ ) where import qualified Filesystem.Path.CurrentOS as F @@ -117,6 +121,7 @@ import Data.Monoid (Monoid, mappend) import qualified Data.Text.Lazy.Builder as B import Data.Typeable (Typeable) import qualified Control.Concurrent.Chan as C +import Control.Concurrent.STM (STM, atomically) import qualified System.Random as R import Data.Default (Default (..)) import System.Exit (ExitCode) @@ -264,6 +269,9 @@ tryTakeMVar = liftIO_ . M.tryTakeMVar putMVar :: M.MVar a -> a -> KIO () putMVar m = liftIO_ . M.putMVar m +atomicallyK :: STM a -> KIO a +atomicallyK = liftIO_ . atomically + forkKIO :: KIO () -> KIO () forkKIO = void . forkKIO' @@ -322,3 +330,6 @@ threadDelay = liftIO_ . Control.Concurrent.threadDelay getCurrentTime :: KIO Data.Time.UTCTime getCurrentTime = liftIO_ Data.Time.getCurrentTime + +mask_ :: KIO a -> KIO a +mask_ (KIO f) = KIO (\lm -> E.mask_ (f lm)) diff --git a/keter.cabal b/keter.cabal index 2531669..8e3c2a4 100644 --- a/keter.cabal +++ b/keter.cabal @@ -62,12 +62,14 @@ Library , aeson , unordered-containers , vector + , stm Exposed-Modules: Keter.Plugin.Postgres Keter.Types Keter.Types.V04 Keter.Types.V10 Keter.Types.Common Keter.App + Keter.AppManager Keter.Main Keter.PortPool Keter.Prelude