Controller.hs

module Hascat.System.Controller
  ( loadApp,
    insertApp,
    startApp,
    stopApp,
    reloadApp, 
    pauseApp,
    resumeApp,
    undeployApp,
    findApp,
    State(..),
    StateVar )
where

import Control.Concurrent.MVar
import Control.OldException
import Data.List
import Hascat.App
import Hascat.Config
import Hascat.System.App
import Hascat.Toolkit
import Network.URI
import System.Time
import System.Posix.Types
import Control.Concurrent.MVar
import Data.IORef


type StateVar = MVar State

data State = State {
                   stProcessID :: ProcessID,
                   stGeneral   :: General,
                   stApps      :: [App] }


reloadApp :: StateVar -> ContextPath -> IO StateVar
reloadApp stateVar contextPath = 
  blockAndModifyApp stateVar contextPath (\app -> (reload app >>=  start))

startApp :: StateVar -> ContextPath -> IO StateVar
startApp stateVar contextPath = 
  blockAndModifyApp stateVar contextPath start

stopApp :: StateVar -> ContextPath -> IO StateVar
stopApp stateVar contextPath = 
  blockAndModifyApp stateVar contextPath stop

pauseApp :: StateVar -> ContextPath -> IO StateVar
pauseApp stateVar contextPath = 
  blockAndModifyApp stateVar contextPath pause

resumeApp :: StateVar -> ContextPath -> IO StateVar
resumeApp stateVar contextPath = 
  blockAndModifyApp stateVar contextPath resume

loadApp :: StateVar -> AppConfig -> IO StateVar
loadApp stateVar config = do  
  bracketOnError
    (takeMVar stateVar)
    (putMVar stateVar)
    (\state -> do
       state' <- loadApp' state stateVar config
       putMVar stateVar state')
  return stateVar
    where
    loadApp' :: State -> StateVar -> AppConfig -> IO State
    loadApp' state@(State conf 
             gen@(General _ (ServerRoot serverRoot) pluginLoader) apps)
             stateVar config = do
      let code = serverRoot // getAppRoot config // getAppCode config
      (modul,handlers) <- case getAppType config of
                    AppConfig_type_normal -> 
                      loadFromModule pluginLoader code "handlers"
                    AppConfig_type_system -> do
                      (modul, (SystemHandler respond)) 
                        <- loadFromModule pluginLoader code
                                                   "systemHandler"
                      return  (modul,(Handlers (systemInit stateVar) 
                              respond 
                              defaultDone))
      apps' <- insertApp' (App config modul handlers Nothing False) apps
      return (State conf gen apps')
      where
        systemInit :: StateVar -> InitHandler StateVar
        systemInit stateVar _ = return stateVar


undeployApp :: StateVar -> ContextPath -> IO StateVar
undeployApp stateVar contextPath =  do
  bracketOnError
    (takeMVar stateVar)
    (putMVar stateVar)
    (\(State conf gen apps) -> do 
       apps' <- undeployApp' contextPath apps
       putMVar stateVar (State conf gen apps'))
  return stateVar
  where
  undeployApp' :: ContextPath -> [App] -> IO [App]
  undeployApp' _ [] = fail "Not found"
  undeployApp' contextPath (app:apps) =
      if hasContextPath contextPath app then
        if isRunning app then fail "Application is running"
        else return apps
      else do
        apps' <- undeployApp' contextPath apps
        return (app:apps')


insertApp :: StateVar -> App -> IO StateVar
insertApp stateVar newApp = do
  bracketOnError
    (takeMVar stateVar)
    (putMVar stateVar)
      (\(State conf gen apps) -> do 
       apps' <- insertApp' newApp apps
       putMVar stateVar (State conf gen apps'))
  return stateVar
  
insertApp' :: App -> [App] -> IO [App]
insertApp' newApp apps = return (uniqueInsert apps)
  where
    uniqueInsert :: [App] -> [App]
    uniqueInsert [] = [newApp]
    uniqueInsert (app:apps) =
        let (ContextPath newContextPath) = getAppContextPath (appConfig newApp)
            (ContextPath appContextPath) = getAppContextPath (appConfig app)
        in case cmp newContextPath appContextPath of
             EQ -> fail ("Duplicate context path " ++ newContextPath)
             GT -> app:uniqueInsert apps
             LT -> newApp:app:apps

    cmp :: String -> String -> Ordering
    cmp a b = let n = min (length a) (length b)
              in case compare (take n a) (take n b) of
                   EQ -> compare (length b) (length a)
                   o  -> o

blockAndModifyApp :: StateVar -> ContextPath -> (App -> IO App) -> IO StateVar
blockAndModifyApp stateVar contextPath action = do
  bracketOnError
    (takeMVar stateVar)
    (putMVar stateVar)
    (\(State conf gen apps) -> do 
       apps' <- modifyApp contextPath action apps
       putMVar stateVar (State conf gen apps'))
  return stateVar
    where
    modifyApp :: ContextPath -> (App -> IO App) -> [App] -> IO [App]
    modifyApp _ _ [] = fail "Not found"
    modifyApp contextPath action (app:apps) =
        if hasContextPath contextPath app then do
          app' <- action app
          return (app':apps)
        else do
          apps' <- modifyApp contextPath action apps
          return (app:apps')
  

findApp :: [App] -> (App -> Bool) -> Maybe App
findApp apps pred = find pred apps