diff --git a/Network/Web/HTTP.hs b/Network/Web/HTTP.hs --- a/Network/Web/HTTP.hs +++ b/Network/Web/HTTP.hs @@ -20,7 +20,6 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Char -import Data.List import qualified Data.Map as M import Data.Maybe import IO hiding (try) @@ -232,9 +231,7 @@ sendResponseFields hdl ver persist rsp S.hPutStr hdl crlf sendResponseBody hdl ver rsp - hFlush hdl `catch` ignore - where - ignore _ = return () + hFlush hdl sendStatusLine :: Handle -> Version -> Response -> IO () sendStatusLine hdl ver rsp = do diff --git a/Network/Web/Params.hs b/Network/Web/Params.hs --- a/Network/Web/Params.hs +++ b/Network/Web/Params.hs @@ -283,6 +283,8 @@ contentTypeDB :: [(FilePath,CT)] contentTypeDB = [ (".html", textHtml) + , (".en", textHtml) -- xxx + , (".ja", textHtml) -- xxx , (".txt", textPlain) , (".css", "text/css") , (".js", "application/javascript") diff --git a/Network/Web/Server.hs b/Network/Web/Server.hs --- a/Network/Web/Server.hs +++ b/Network/Web/Server.hs @@ -4,17 +4,14 @@ module Network.Web.Server (connection, WebServer, WebConfig(..)) where import Control.Exception -import Control.Monad import Control.Applicative import qualified Data.ByteString.Char8 as S -import Data.Char import Data.Maybe import Data.Time import IO import Network.Web.HTTP hiding (receive,respond) import qualified Network.Web.HTTP as HTTP (receive,respond) import Network.Web.Date -import Network.Web.Params import System.Timeout ---------------------------------------------------------------- diff --git a/Network/Web/Server/Basic.hs b/Network/Web/Server/Basic.hs --- a/Network/Web/Server/Basic.hs +++ b/Network/Web/Server/Basic.hs @@ -138,9 +138,9 @@ tryGet :: BasicConfig -> Request -> URI -> [String] -> IO (Maybe Response) tryGet cnf req uri langs = tryGet' $ mapper cnf uri where - tryGet' None = return Nothing - tryGet' (CGI cgi param snm) = tryGetCGI cnf req cgi param snm - tryGet' (File file) = tryGetFile cnf req file langs + tryGet' None = return Nothing + tryGet' (File file) = tryGetFile cnf req file langs + tryGet' (PathCGI cgi) = tryGetCGI cnf req cgi tryGetFile :: BasicConfig -> Request -> FilePath -> [String] -> IO (Maybe Response) tryGetFile cnf req file langs @@ -206,7 +206,7 @@ tryHead cnf uri langs = tryHead' (mapper cnf uri) where tryHead' None = return Nothing - tryHead' (CGI _ _ _) = return Nothing + tryHead' (PathCGI _) = return Nothing tryHead' (File file) = tryHeadFile cnf file langs tryHeadFile :: BasicConfig -> FilePath -> [String] -> IO (Maybe Response) @@ -238,7 +238,7 @@ redirectURI uri >>| \ruri -> tryRedirect' (mapper cnf ruri) ruri where tryRedirect' None _ = return Nothing - tryRedirect' (CGI _ _ _) _ = return Nothing + tryRedirect' (PathCGI _) _ = return Nothing tryRedirect' (File file) ruri = runAnyMaybeIO $ map (tryRedirectFile cnf ruri file) langs tryRedirectFile :: BasicConfig -> URI -> FilePath -> String -> IO (Maybe Response) @@ -253,8 +253,8 @@ tryPost :: BasicConfig -> Request -> IO Response tryPost cnf req = case mapper cnf (reqURI req) of - CGI cgi param snm -> do - mres <- tryGetCGI cnf req cgi param snm + PathCGI cgi -> do + mres <- tryGetCGI cnf req cgi case mres of Nothing -> undefined -- never reached Just res -> return res @@ -280,7 +280,7 @@ kvs = [(FkContentType,ct),(FkLastModified,modified)] responseRedirect :: URI -> Response -responseRedirect rurl = makeResponse MovedPermanently [(FkLocation,S.pack . show $ rurl)] +responseRedirect rurl = makeResponse MovedPermanently [(FkLocation, toURL rurl)] responseNotFound :: Response responseNotFound = makeResponse NotFound [] diff --git a/Network/Web/Server/CGI.hs b/Network/Web/Server/CGI.hs --- a/Network/Web/Server/CGI.hs +++ b/Network/Web/Server/CGI.hs @@ -6,7 +6,6 @@ import Control.Concurrent import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import Data.Char import Network.TCPInfo import Network.Web.HTTP import Network.Web.Server.Params @@ -21,14 +20,14 @@ ---------------------------------------------------------------- -tryGetCGI :: BasicConfig -> Request -> FilePath -> URLParameter -> ScriptName -> IO (Maybe Response) -tryGetCGI cnf req prog param snm = processCGI `catch` const internalError +tryGetCGI :: BasicConfig -> Request -> CGI -> IO (Maybe Response) +tryGetCGI cnf req cgi = processCGI `catch` const internalError where processCGI = do (mrhdl0,mhb) <- maybeCreateHandle (rhdl1,whdl1) <- createHandle - let envVars = makeEnv cnf req param snm - forkIO $ execCGI prog envVars mrhdl0 (Just whdl1) mhb + let envVars = makeEnv cnf req cgi + forkIO $ execCGI (progPath cgi) envVars mrhdl0 (Just whdl1) mhb mrsp <- timeout (10 * 1000000) $ processCGIoutput rhdl1 maybe internalError (return . Just) mrsp maybeCreateHandle = case reqBody req of @@ -56,29 +55,26 @@ L.hPut whdl body hClose whdl -makeEnv :: BasicConfig -> Request -> URLParameter -> ScriptName -> ENVVARS -makeEnv cnf req param snm = addLength . addType . addCookie $ pathOrQuery param ++ baseEnv +makeEnv :: BasicConfig -> Request -> CGI -> ENVVARS +makeEnv cnf req cgi = addLength . addType . addCookie $ baseEnv where baseEnv = [("GATEWAY_INTERFACE", gatewayInterface) - ,("SCRIPT_NAME", snm) + ,("SCRIPT_NAME", scriptName cgi) ,("REQUEST_METHOD", show (reqMethod req)) ,("SERVER_NAME", S.unpack . uriHostName . reqURI $ req) ,("SERVER_PORT", myPort (tcpInfo cnf)) ,("REMOTE_ADDR", peerAddr (tcpInfo cnf)) ,("SERVER_PROTOCOL", show (reqVersion req)) - ,("SERVER_SOFTWARE", S.unpack . serverName $ cnf)] - pathOrQuery par - | par == "" = [("QUERY_STRING","") - ,("PATH_INFO", "")] - | head par == '?' = [("QUERY_STRING", unEscapeString . tail $ par) - ,("PATH_INFO", "")] - | otherwise = [("QUERY_STRING","") - ,("PATH_INFO", unEscapeString $ par)] + ,("SERVER_SOFTWARE", S.unpack . serverName $ cnf) + ,("PATH_INFO", unEscapeString . pathInfo $ cgi) + ,("QUERY_STRING", unEscapeString . safeTail . queryString $ cgi)] addLength = add "CONTENT_LENGTH" (lookupField FkContentLength req) addType = add "CONTENT_TYPE" (lookupField FkContentType req) addCookie = add "HTTP_COOKIE" (lookupField FkCookie req) add _ Nothing envs = envs add key (Just val) envs = (key,S.unpack val) : envs + safeTail "" = "" + safeTail xs = tail xs processCGIoutput :: Handle -> IO Response processCGIoutput rhdl = do diff --git a/Network/Web/Server/Params.hs b/Network/Web/Server/Params.hs --- a/Network/Web/Server/Params.hs +++ b/Network/Web/Server/Params.hs @@ -33,14 +33,19 @@ -- | 'URI' is converted into a resource (typically a file). | File FilePath -- | 'URI' is converted into CGI. - | CGI FilePath URLParameter ScriptName deriving (Eq,Show) - -{-| - A type for URL parameter. --} -type URLParameter = String + | PathCGI CGI + deriving (Eq,Show) {-| - A type for script name. + Internal information of CGI converted from 'URI'. -} -type ScriptName = String +data CGI = CGI { + -- | A porgram path to be executed. + progPath :: FilePath + -- | A script name. + , scriptName :: String + -- | A path information. + , pathInfo :: String + -- | A query string. + , queryString :: String + } deriving (Eq,Show) diff --git a/Network/Web/URI.hs b/Network/Web/URI.hs --- a/Network/Web/URI.hs +++ b/Network/Web/URI.hs @@ -8,7 +8,7 @@ URI, uriScheme, uriAuthority, uriPath, uriQuery, uriFragment , URIAuth, uriUserInfo, uriRegName, uriPort , parseURI - , uriHostName, toURLwoPort + , uriHostName, uriPortNumber, toURL, toURLwoPort , isAbsoluteURI, unEscapeString, unEscapeByteString ) where @@ -81,6 +81,25 @@ -} uriHostName :: URI -> S.ByteString uriHostName uri = maybe "" uriRegName $ uriAuthority uri + +{-| + Getting a port number from 'URI'. +-} +uriPortNumber :: URI -> S.ByteString +uriPortNumber uri = maybe "" uriPort $ uriAuthority uri + +{-| + Making a URL string from 'URI'. +-} +toURL :: URI -> S.ByteString +toURL uri = uriScheme uri +++ "//" +++ hostServ +++ uriPath uri +++ uriQuery uri + where + host = uriHostName uri + serv = uriPortNumber uri + hostServ = if S.null serv + then host + else host +++ ":" +++ serv + (+++) = S.append {-| Making a URL string from 'URI' without port. diff --git a/webserver.cabal b/webserver.cabal --- a/webserver.cabal +++ b/webserver.cabal @@ -1,5 +1,5 @@ Name: webserver -Version: 0.3.0 +Version: 0.4.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -10,7 +10,10 @@ Cabal-Version: >= 1.6 Build-Type: Simple library - GHC-Options: -Wall -O2 + if impl(ghc >= 6.12) + GHC-Options: -Wall -O2 -fno-warn-unused-do-bind + else + GHC-Options: -Wall -O2 Exposed-Modules: Network.Web.HTTP Network.Web.Server Network.Web.Server.Basic @@ -21,7 +24,7 @@ Network.Web.Server.Lang Network.Web.Server.Params Network.Web.Server.Range - Build-Depends: base >= 4 && < 10, parsec >= 3, + Build-Depends: base >= 4 && < 5, parsec >= 3, haskell98, network, bytestring, containers, filepath, time, unix, process, c10k Source-Repository head