hascat (empty) → 0.2
raw patch · 7 files changed
+282/−0 lines, 7 filesdep +HTTPdep +HaXmldep +basesetup-changed
Dependencies added: HTTP, HaXml, base, bytestring, hascat-lib, hascat-setup, hascat-system, haxr, html, network, unix
Files
- ConfigReader.hs +10/−0
- HttpImpl.hs +136/−0
- LICENSE +0/−0
- Logger.hs +9/−0
- Main.hs +72/−0
- Setup.hs +7/−0
- hascat.cabal +48/−0
+ ConfigReader.hs view
@@ -0,0 +1,10 @@+module ConfigReader+ ( readConfig )+where++import Hascat.Config+import Text.XML.HaXml.Xml2Haskell+++readConfig :: FilePath -> IO Config+readConfig path = fReadXml path
+ HttpImpl.hs view
@@ -0,0 +1,136 @@+module HttpImpl+ ( startServer )+where++import Control.Concurrent+import Control.OldException as Exception+import Data.Maybe+import Hascat.App+import Hascat.Config+import qualified Hascat.Protocol as HP+import Hascat.System.App+import Hascat.System.Controller+import Hascat.Toolkit hiding (rqMethod, rqURI, rqInputs)+import Network.BSD+import Network.HTTP as HTTP+import Network.Socket --hiding (listen)+import Network.URI+import Network.TCP+import Text.Html+import Prelude hiding ( log )+import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span )+import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span )++import Logger++++startServer :: StateVar -> IO ()+startServer stateVar =+ Exception.catch+ (runServer stateVar)+ (\e -> case e of+ IOException io -> do+ log (show io)+ --startServer stateVar+ _ -> do+ log (show e)+ startServer stateVar)+++runServer :: StateVar -> IO ()+runServer stateVar = withSocketsDo $ do+ (State _ general _) <- readMVar stateVar+ let portNumber = fromIntegral (getPort general)+ proto <- getProtocolNumber "tcp"+ Exception.bracket+ (socket AF_INET Stream proto)+ sClose+ (\server -> do+ setSocketOption server ReuseAddr 1+ --setSocketOption server NoDelay 1+ bindSocket server (SockAddrInet portNumber iNADDR_ANY)+ listen server maxListenQueue+ log ("Waiting for connections on port " ++ show portNumber)+ acceptConnections stateVar server)+++acceptConnections :: StateVar -> Socket -> IO ()+acceptConnections stateVar server = do+ (client, addr@(SockAddrInet port haddr)) <- accept server --wartet bis Client verbindet+ --(handle, hostname, port) <- accept server+ --handle <- socketToHandle client ReadWriteMode+ {-- hostName <- Exception.catchJust+ ioErrors+ (do+ (HostEntry hostName _ _ _) <- getHostByAddr AF_INET haddr+ return hostName) + (\e -> inet_ntoa haddr)--}+-- log ("Accepted connection from " ++ hostname ++ " on port " ++ show port)+-- conn <- newIORef (MkConn client addr [] "")+-- let stream = ConnRef conn+ + forkIO (do+ state <- readMVar stateVar+ handleStream <- socketConnection "" client+ handleConnection state handleStream+ HTTP.close handleStream)+ acceptConnections stateVar server+++handleConnection :: State -> HandleStream Lazy.ByteString -> IO ()+handleConnection state stream = do+ requestResult <- receiveHTTP stream+ response <- case requestResult of+ Left error ->+ return getResponse400+ Right request ->+ respondRequest state request+ respondHTTP stream response+ HTTP.close stream+++respondRequest :: State -> Request Lazy.ByteString -> IO (Response Lazy.ByteString)+respondRequest state request = do+ let method = rqMethod request+ log (show (rqMethod request) ++ " " ++ show (rqURI request))+ if method `elem` [HEAD, GET, POST]+ then do+ response <- Exception.catch+ (respondRequest' state request)+ (\e -> return $ getResponse500 $ ": " ++ show e)+ case rspCode response of+ (2, _, _) | method == HEAD -> return response { rspBody = Lazy.pack "" }+ _ -> return response+ else+ return (getResponse405 method)+++respondRequest' :: State -> Request Lazy.ByteString -> IO (Response Lazy.ByteString)+respondRequest' (State _ _ apps) request = do+ let path = normalizeCase $+ normalizeEscape $+ normalizePathSegments $+ uriPath (rqURI request)+ appMB = findApp apps (predicate path)+ case appMB of+ Nothing -> return (getResponse404 path)+ Just app ->+ let (ContextPath contextPath) = getAppContextPath (appConfig app)+ in+ if isRunning app then do+ let appPath = fromJust $+ getRelativePath path contextPath+ request' = HP.decodeInput $ request { rqURI = (rqURI request)+ { uriPath = appPath } }+ -- putStrLn $ "uriPath: " ++ show (uriPath (rqURI request))+ -- putStrLn $ "path: " ++ path+ -- putStrLn $ "appPath: " ++ appPath+ use app request'+ else+ return (getResponse503 contextPath)+ where+ predicate :: String -> App -> Bool+ predicate path app =+ let (ContextPath contextPath) = getAppContextPath (appConfig app) in+ getRelativePath path contextPath /= Nothing
+ LICENSE view
+ Logger.hs view
@@ -0,0 +1,9 @@+module Logger+ ( log )+where++import Prelude hiding ( log )+++log :: String -> IO ()+log s = putStrLn s
+ Main.hs view
@@ -0,0 +1,72 @@+module Main where++import Control.Concurrent.MVar+import Control.OldException as Exception+import Control.Monad+import Hascat.App+import Hascat.Config+import Hascat.System.App+import Hascat.System.Controller+import Prelude hiding ( log )+import System.Environment+import System.Posix.Process+import System.Posix.Types++import ConfigReader+import HttpImpl+import Logger+++main :: IO ()+main = do+ configFile <- parseArgs+ config <- readConfig configFile+ stateVar <- createState config+ startServer stateVar+++parseArgs :: IO FilePath+parseArgs = do+ args <- getArgs+ case args of+ [configFile] -> return configFile+ _ -> error "hascat <config-file>"+++createState :: Config -> IO StateVar+createState (Config _ general (AppController appConfigs)) = do+ processID <- getProcessID+ let state = (State processID general [])+ stateVar <- newEmptyMVar+ putMVar stateVar state+ --foldM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a+ --foldr :: (a -> b -> b) -> b -> [a] -> b+ foldM_ loadApp' stateVar appConfigs+ state' <- readMVar stateVar+ foldM startApp' stateVar (map appConfig (stApps state'))+ --return stateVar+ where+ loadApp' :: StateVar -> AppConfig -> IO StateVar+ loadApp' stateVar config = do+ Exception.catch+ (do log ("Installing \"" ++ getAppName config ++ "\""+ ++ " at " ++ (show $ getAppContextPath config))+ loadApp stateVar config >> return stateVar)+ (\e -> log (show e) >> return stateVar)++ startApp' :: StateVar -> AppConfig -> IO StateVar+ startApp' stateVar config =+ if (getAppAutoStart config == AppConfig_autoStart_yes+ || getAppType config == AppConfig_type_system) then+ do+ --state <- takeMVar stateVar+ Exception.catch+ (do + log ("Starting \"" ++ getAppName config ++ "\""+ ++ " at " ++ (show $ getAppContextPath config))+ startApp stateVar (getAppContextPath config)+-- putMVar stateVar state'+ return stateVar)+ (\e -> log (show e) >> return stateVar)+ else+ return stateVar
+ Setup.hs view
@@ -0,0 +1,7 @@+module Main where++import Distribution.Simple+++main :: IO ()+main = defaultMain
+ hascat.cabal view
@@ -0,0 +1,48 @@+name: hascat+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 Web Server+description: Hascat Web Server+ .+ How to install:+ .+ 1. install with cabal-install+ .+ 2. make a directory where you want the hascat-apps (hasclets) to be installed+ .+ 3. run + .+ $ hascat-setup \<directory\>+ .+ 4. in that directory run:+ .+ $ hascat config.xml+ .+ .+ For more information check my bachelor thesis:+ .+ <http://www.informatik.uni-kiel.de/~fmi/bachelor.pdf>+category: Network+tested-with: GHC+build-depends: + base >=4 && <5,+ hascat-lib ==0.2,+ hascat-system ==0.2,+ network,+ HTTP,+ HaXml <=1.13.3,+ haxr ==3000.2.1,+ HTTP,+ unix,+ html,+ bytestring,+ hascat-setup+executable: hascat+main-is: Main.hs+ghc-options: -fglasgow-exts -threaded