webserver 0.3.0 → 0.4.0
raw patch · 8 files changed
+62/−43 lines, 8 filesdep ~base
Dependency ranges changed: base
Files
- Network/Web/HTTP.hs +1/−4
- Network/Web/Params.hs +2/−0
- Network/Web/Server.hs +0/−3
- Network/Web/Server/Basic.hs +8/−8
- Network/Web/Server/CGI.hs +12/−16
- Network/Web/Server/Params.hs +13/−8
- Network/Web/URI.hs +20/−1
- webserver.cabal +6/−3
Network/Web/HTTP.hs view
@@ -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
Network/Web/Params.hs view
@@ -283,6 +283,8 @@ contentTypeDB :: [(FilePath,CT)] contentTypeDB = [ (".html", textHtml)+ , (".en", textHtml) -- xxx+ , (".ja", textHtml) -- xxx , (".txt", textPlain) , (".css", "text/css") , (".js", "application/javascript")
Network/Web/Server.hs view
@@ -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 ----------------------------------------------------------------
Network/Web/Server/Basic.hs view
@@ -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 []
Network/Web/Server/CGI.hs view
@@ -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
Network/Web/Server/Params.hs view
@@ -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)
Network/Web/URI.hs view
@@ -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.
webserver.cabal view
@@ -1,5 +1,5 @@ Name: webserver-Version: 0.3.0+Version: 0.4.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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