hascat-system (empty) → 0.2
raw patch · 5 files changed
+327/−0 lines, 5 filesdep +HTTPdep +HaXmldep +basesetup-changed
Dependencies added: HTTP, HaXml, base, bytestring, containers, hascat-lib, mtl, network, old-time, parsec, plugins, unix
Files
- Hascat/System/App.hs +129/−0
- Hascat/System/Controller.hs +162/−0
- LICENSE +0/−0
- Setup.hs +7/−0
- hascat-system.cabal +29/−0
+ Hascat/System/App.hs view
@@ -0,0 +1,129 @@+module Hascat.System.App+ ( isRunning,+ isPaused,+ hasContextPath,+ start,+ use,+ stop,+ pause,+ resume,+ reload,+ defaultInit,+ loadFromModule,+ reloadFromModule,+ defaultDone )+where++import Data.Maybe+import qualified System.Plugins as Plugins+import System.Plugins hiding ( load, reload )+import Hascat.App+import Hascat.Config+import Hascat.Protocol+import Network.HTTP+import Data.ByteString.Lazy+import System.Timeout+++isRunning :: App -> Bool+isRunning (App _ _ _ stateMB _) = isJust stateMB++isPaused :: App -> Bool+isPaused (App _ _ _ _ unpaused) = not unpaused++hasContextPath :: ContextPath -> App -> Bool+hasContextPath contextPath app =+ getAppContextPath (appConfig app) == contextPath+++start :: App -> IO App+start (App config m handlers@(Handlers init _ _) stateMB _) =+ case stateMB of+ Nothing -> do+ state <- timeout' (getAppInitTimeout config)+ (init config)+ (fail "Timeout")+ return (App config m handlers (Just state) True)+ Just _ -> fail "Application is already started"+++use :: App -> ServletRequest -> IO (Response ByteString)+use (App config _ (Handlers _ respond _) stateMB unpaused) request =+ case stateMB of+ Nothing -> fail "Application is not started"+ Just state -> + if unpaused then + timeout' (getAppRespondTimeout config)+ (respond config state request)+ (fail "Timeout")+ else+ fail "Application is paused"+++stop :: App -> IO App+stop (App config m handlers@(Handlers _ _ done) stateMB _) =+ case stateMB of+ Nothing -> fail "Application is not started"+ Just state -> do+ timeout' (getAppDoneTimeout config)+ (done config state)+ (fail "Timeout")+ return (App config m handlers Nothing False)++pause :: App -> IO App+pause (App config m handlers stateMB True) =+ return (App config m handlers stateMB False)+pause (App config m handlers stateMB False) =+ fail "Application is already paused"+-- return app {appPaused = False}+-- ghc 6.10.4 complains:+-- Record update for the non-Haskell-98 data type `App' is not (yet) supported++++resume :: App -> IO App+resume (App config m handlers stateMB False) =+ return (App config m handlers stateMB True)+resume (App config m handlers stateMB True) =+ fail "Application is not paused"++reload :: App -> IO App+reload app@(App config modul _ _ _) =+ if isRunning app then fail "Application is running"+ else do+ (modul',handlers) <- reloadFromModule modul "handlers" + return (App config modul' handlers Nothing True)+++++loadFromModule :: PluginLoader -> FilePath -> String -> IO (Plugins.Module, a)+loadFromModule pluginLoader file name = do+-- let includePaths = getIncludePaths pluginLoader+-- pkgConfFiles = getPkgConfFiles pluginLoader+ status <- Plugins.load_ file+ []--includePaths+ --pkgConfFiles+ name+ case status of+ LoadFailure _ -> error ("Could not load " ++ name+ ++ " from " ++ file)+ LoadSuccess m h -> return (m,h)++reloadFromModule :: Plugins.Module -> String -> IO (Plugins.Module, a)+reloadFromModule modul name = do+ status <- Plugins.reload modul name+ case status of+ LoadSuccess m h -> return (m,h)+ LoadFailure _ -> error ("Could not load " ++ name)+++timeout' :: Int -- ^ time limit+ -> IO a -- ^ computation to run+ -> IO a -- ^ computation on timeout+ -> IO a+timeout' t a b = do+ mb <- timeout (max 10000 (t * 1000000)) a+ case mb of+ Nothing -> b+ Just result -> return result
+ Hascat/System/Controller.hs view
@@ -0,0 +1,162 @@+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+
+ LICENSE view
+ Setup.hs view
@@ -0,0 +1,7 @@+module Main where++import Distribution.Simple+++main :: IO ()+main = defaultMain
+ hascat-system.cabal view
@@ -0,0 +1,29 @@+name: hascat-system+version: 0.2+license: OtherLicense+Build-Type: Simple+license-file: LICENSE+copyright: Björn Teegen 2006, Florian Micheler 2010+author: Björn Teegen, Florian Micheler+maintainer: fmi@informatik.uni-kiel.de+stability: experimental+synopsis: Hascat System Package+description: Modules for programming Hascat system applications+category: Network+tested-with: GHC+build-depends:+ base >=4 && <5,+ hascat-lib ==0.2,+ network ,+ plugins,+ HaXml ==1.13.3,+ HTTP,+ old-time,+ bytestring,+ containers,+ mtl,+ parsec,+ unix+ghc-options: -fglasgow-exts+exposed-modules: Hascat.System.App,+ Hascat.System.Controller