diff --git a/ConfigReader.hs b/ConfigReader.hs new file mode 100644 --- /dev/null +++ b/ConfigReader.hs @@ -0,0 +1,10 @@ +module ConfigReader + ( readConfig ) +where + +import Hascat.Config +import Text.XML.HaXml.Xml2Haskell + + +readConfig :: FilePath -> IO Config +readConfig path = fReadXml path diff --git a/HttpImpl.hs b/HttpImpl.hs new file mode 100644 --- /dev/null +++ b/HttpImpl.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/Logger.hs b/Logger.hs new file mode 100644 --- /dev/null +++ b/Logger.hs @@ -0,0 +1,9 @@ +module Logger + ( log ) +where + +import Prelude hiding ( log ) + + +log :: String -> IO () +log s = putStrLn s diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 " + + +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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple + + +main :: IO () +main = defaultMain diff --git a/hascat.cabal b/hascat.cabal new file mode 100644 --- /dev/null +++ b/hascat.cabal @@ -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 \ + . + 4. in that directory run: + . + $ hascat config.xml + . + . + For more information check my bachelor thesis: + . + +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