hascat-0.2: HttpImpl.hs

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