Beginning of AppManager

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)
+    -}

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
+            -}

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
+    appMan <- AppMan.initialize
-    let removeApp appname = Keter.Prelude.modifyMVar_ mappMap $ return . Map.delete appname
+    let addApp bundle = AppMan.perform
-        addApp bundle = do
+            appMan
-            let appname = getAppname bundle
+            (AppMan.AINamed $ getAppname bundle)
-            rest <- modifyMVar mappMap $ \appMap ->
+            (AppMan.Reload AppMan.AIBundle)
-                case Map.lookup appname appMap of
+        terminateApp appname = AppMan.perform appMan (AppMan.AINamed appname) AppMan.Terminate
-                    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
 
     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
+    unless (V.null kconfigBuiltinStanzas) $ AppMan.perform
-    let staticReverse r = do
+        appMan
-            HostMan.addEntry hostman (ReverseProxy.reversingHost r)
+        AppMan.AIBuiltin
-                $ HostMan.PEReverseProxy
+        (AppMan.Reload $ AppMan.AIData $ BundleConfig kconfigBuiltinStanzas mempty)
-                $ ReverseProxy.RPEntry r manager
-    runKIO' $ mapM_ staticReverse (Set.toList kconfigReverseProxy)
-    -}
 
     -- 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)
+            current <- getAllApps appMan
-                        `Set.union` Set.fromList (Map.keys appMap)
+            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
+                case (Set.member appname current, Map.lookup appname newMap) of
-                    (Nothing, Nothing) -> Nothing -- should never happen
+                    (False, Nothing) -> Nothing -- should never happen
-                    (Just _, Nothing) -> Just $ terminateApp appname
+                    (True, Nothing) -> Just $ terminateApp appname
-                    (Nothing, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle
+                    (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

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))

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