diff --git a/Network/Wai/Application/Classic.hs b/Network/Wai/Application/Classic.hs --- a/Network/Wai/Application/Classic.hs +++ b/Network/Wai/Application/Classic.hs @@ -23,24 +23,22 @@ , defaultCgiAppSpec , CgiRoute(..) , cgiApp -#ifdef REV_PROXY -- * Reverse Proxy , RevProxyAppSpec(..) , RevProxyRoute(..) , revProxyApp -#endif -- * Path , module Network.Wai.Application.Classic.Path -- * Misc , redirectHeader + , hostPort ) where import Network.Wai.Application.Classic.CGI +import Network.Wai.Application.Classic.Def import Network.Wai.Application.Classic.File +import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Redirect -import Network.Wai.Application.Classic.Types -import Network.Wai.Application.Classic.Def -#ifdef REV_PROXY import Network.Wai.Application.Classic.RevProxy -#endif +import Network.Wai.Application.Classic.Types diff --git a/Network/Wai/Application/Classic/CGI.hs b/Network/Wai/Application/Classic/CGI.hs --- a/Network/Wai/Application/Classic/CGI.hs +++ b/Network/Wai/Application/Classic/CGI.hs @@ -4,25 +4,22 @@ cgiApp ) where -import Control.Exception (SomeException, IOException, try) -import Control.Exception.Lifted as L (catch) +import Blaze.ByteString.Builder (Builder) +import qualified Control.Exception as E (SomeException, IOException, try, catch) import Control.Monad (when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource import Data.ByteString (ByteString) -import qualified Data.ByteString as BS hiding (unpack) -import qualified Data.ByteString.Char8 as BS (readInt, unpack) +import qualified Data.ByteString.Char8 as BS (readInt, unpack, tail) import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Network.HTTP.Types +import Network.SockAddr import Network.Wai import Network.Wai.Application.Classic.Conduit import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types -import Network.Wai.Logger.Utils import System.Environment import System.IO import System.Process @@ -52,35 +49,36 @@ method = parseMethod $ requestMethod req cgiApp' :: Bool -> ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application -cgiApp' body cspec spec cgii req = do - (rhdl,whdl,tellEOF) <- liftIO (execProcess cspec spec cgii req) >>= register3 - when body $ toCGI whdl req - tellEOF - fromCGI rhdl cspec req +cgiApp' body cspec spec cgii req = responseSourceBracket setup teardown cgi where - register3 (rhdl,whdl,pid) = do - _ <- register $ terminateProcess pid -- SIGTERM - _ <- register $ hClose rhdl - keyw <- register $ hClose whdl - return (rhdl,whdl,release keyw) + setup = execProcess cspec spec cgii req + teardown (rhdl,whdl,pid) = do + terminateProcess pid -- SIGTERM + hClose rhdl + hClose whdl + cgi (rhdl,whdl,_) = do + when body $ toCGI whdl req + hClose whdl -- telling EOF + fromCGI rhdl cspec req ---------------------------------------------------------------- -type TRYPATH = Either IOException String +type TRYPATH = Either E.IOException String -toCGI :: Handle -> Request -> ResourceT IO () +toCGI :: Handle -> Request -> IO () toCGI whdl req = requestBody req $$ CB.sinkHandle whdl -fromCGI :: Handle -> ClassicAppSpec -> Application +fromCGI :: Handle -> ClassicAppSpec -> Request -> IO (Status, RequestHeaders, Source IO (Flush Builder)) fromCGI rhdl cspec req = do - (src', hs) <- cgiHeader `L.catch` recover + (src', hs) <- cgiHeader `E.catch` recover let (st, hdr, hasBody) = case check hs of Nothing -> (internalServerError500,[],False) Just (s,h) -> (s,h,True) hdr' = addServer cspec hdr - liftIO $ logger cspec req st Nothing - let src = if hasBody then src' else CL.sourceNull - return $ ResponseSource st hdr' src + logger cspec req st Nothing + let src | hasBody = src' + | otherwise = CL.sourceNull + return (st, hdr', src) where check hs = lookup hContentType hs >> case lookup hStatus hs of Nothing -> Just (ok200, hs) @@ -89,7 +87,7 @@ hs' = filter (\(k,_) -> k /= hStatus) hs toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s) emptyHeader = [] - recover (_ :: SomeException) = return (CL.sourceNull, emptyHeader) + recover (_ :: E.SomeException) = return (CL.sourceNull, emptyHeader) cgiHeader = do (rsrc,hs) <- CB.sourceHandle rhdl $$+ parseHeader src <- toResponseSource rsrc @@ -100,7 +98,7 @@ execProcess :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Request -> IO (Handle, Handle, ProcessHandle) execProcess cspec spec cgii req = do let naddr = showSockAddr . remoteHost $ req - epath <- try (getEnv "PATH") :: IO TRYPATH + epath <- E.try (getEnv "PATH") :: IO TRYPATH (Just whdl,Just rhdl,_,pid) <- createProcess $ proSpec naddr epath hSetEncoding rhdl latin1 hSetEncoding whdl latin1 @@ -117,6 +115,9 @@ #if __GLASGOW_HASKELL__ >= 702 , create_group = True #endif +#if __GLASGOW_HASKELL__ >= 707 + , delegate_ctlc = False +#endif } (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii) @@ -124,7 +125,7 @@ (fromByteString (rawPathInfo req)) (indexCgi spec) -makeEnv :: Request -> NumericAddress -> String -> String -> ByteString -> +makeEnv :: Request -> String -> String -> String -> ByteString -> TRYPATH -> ENVVARS makeEnv req naddr scriptName pathinfo sname epath = addPath epath . addLen . addType . addCookie $ baseEnv where @@ -132,8 +133,8 @@ ("GATEWAY_INTERFACE", gatewayInterface) , ("SCRIPT_NAME", scriptName) , ("REQUEST_METHOD", BS.unpack . requestMethod $ req) - , ("SERVER_NAME", BS.unpack . serverName $ req) - , ("SERVER_PORT", show . serverPort $ req) + , ("SERVER_NAME", BS.unpack host) + , ("SERVER_PORT", BS.unpack port) , ("REMOTE_ADDR", naddr) , ("SERVER_PROTOCOL", show . httpVersion $ req) , ("SERVER_SOFTWARE", BS.unpack sname) @@ -141,7 +142,7 @@ , ("QUERY_STRING", query req) ] headers = requestHeaders req - addLen = addEnv "CONTENT_LENGTH" $ lookup hContentLength headers + addLen = addLength "CONTENT_LENGTH" $ requestBodyLength req addType = addEnv "CONTENT_TYPE" $ lookup hContentType headers addCookie = addEnv "HTTP_COOKIE" $ lookup hCookie headers addPath (Left _) ev = ev @@ -150,10 +151,15 @@ where safeTail "" = "" safeTail bs = BS.tail bs + (host, port) = hostPort req addEnv :: String -> Maybe ByteString -> ENVVARS -> ENVVARS addEnv _ Nothing envs = envs addEnv key (Just val) envs = (key,BS.unpack val) : envs + +addLength :: String -> RequestBodyLength -> ENVVARS -> ENVVARS +addLength _ ChunkedBody envs = envs +addLength key (KnownLength len) envs = (key, show len) : envs {-| diff --git a/Network/Wai/Application/Classic/Conduit.hs b/Network/Wai/Application/Classic/Conduit.hs --- a/Network/Wai/Application/Classic/Conduit.hs +++ b/Network/Wai/Application/Classic/Conduit.hs @@ -25,15 +25,15 @@ ---------------------------------------------------------------- -toResponseSource :: ResumableSource (ResourceT IO) ByteString - -> (ResourceT IO) (Source (ResourceT IO) (Flush Builder)) +toResponseSource :: ResumableSource IO ByteString + -> IO (Source IO (Flush Builder)) toResponseSource rsrc = do (src,_) <- unwrapResumable rsrc return $ src $= CL.map (Chunk . byteStringToBuilder) ---------------------------------------------------------------- -parseHeader :: Sink ByteString (ResourceT IO) RequestHeaders +parseHeader :: Sink ByteString IO RequestHeaders parseHeader = sinkParser parseHeader' parseHeader' :: Parser RequestHeaders diff --git a/Network/Wai/Application/Classic/Def.hs b/Network/Wai/Application/Classic/Def.hs --- a/Network/Wai/Application/Classic/Def.hs +++ b/Network/Wai/Application/Classic/Def.hs @@ -2,13 +2,12 @@ module Network.Wai.Application.Classic.Def where -import Control.Applicative import Control.Exception -import Data.ByteString (ByteString) import Network.HTTP.Date +import Network.HTTP.Types +import Network.Wai import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types -import Network.Wai.Logger import System.Posix -- | @@ -17,15 +16,11 @@ defaultClassicAppSpec = ClassicAppSpec { softwareName = "Classic" , logger = defaultLogger - , dater = defaultDater , statusFileDir = "/usr/local/share/html/status/" } -defaultLogger :: ApacheLogger +defaultLogger :: Request -> Status -> Maybe Integer -> IO () defaultLogger _ _ _ = return () - -defaultDater :: IO ByteString -defaultDater = formatHTTPDate . epochTimeToHTTPDate <$> epochTime ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/EventSource.hs b/Network/Wai/Application/Classic/EventSource.hs --- a/Network/Wai/Application/Classic/EventSource.hs +++ b/Network/Wai/Application/Classic/EventSource.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.EventSource ( - toResponseEventSource + bodyToEventSource ) where import Blaze.ByteString.Builder @@ -10,6 +10,8 @@ import Data.ByteString.Char8 () import Data.Conduit import qualified Data.Conduit.List as CL +import qualified Network.HTTP.Client.Body as H +import qualified Network.HTTP.Client.Conduit as HC lineBreak :: ByteString -> Int -> Maybe Int lineBreak bs n = go @@ -44,7 +46,7 @@ in xs:go ys 0 | otherwise = [bs] -eventSourceConduit :: Conduit ByteString (ResourceT IO) (Flush Builder) +eventSourceConduit :: Conduit ByteString IO (Flush Builder) eventSourceConduit = CL.concatMapAccum f "" where f input rest = (last xs, concatMap addFlush $ init xs) @@ -53,8 +55,5 @@ xs = splitDoubleLineBreak (rest `BS.append` input) -- insert Flush if exists a double line-break -toResponseEventSource :: ResumableSource (ResourceT IO) ByteString - -> (ResourceT IO) (Source (ResourceT IO) (Flush Builder)) -toResponseEventSource rsrc = do - (src,_) <- unwrapResumable rsrc - return $ src $= eventSourceConduit +bodyToEventSource :: H.BodyReader -> Source IO (Flush Builder) +bodyToEventSource br = HC.bodyReaderSource br $= eventSourceConduit diff --git a/Network/Wai/Application/Classic/Field.hs b/Network/Wai/Application/Classic/Field.hs --- a/Network/Wai/Application/Classic/Field.hs +++ b/Network/Wai/Application/Classic/Field.hs @@ -4,41 +4,37 @@ import Control.Arrow (first) import Control.Monad (mplus) +import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS hiding (pack) import Data.ByteString.Char8 as BS (pack) import qualified Data.Map as Map (toList) import Data.Maybe import Data.StaticHash (StaticHash) -import Data.List (delete) import qualified Data.StaticHash as SH import qualified Data.Text as T import Network.HTTP.Date import Network.HTTP.Types import Network.Mime (defaultMimeMap, defaultMimeType, MimeType) +import Network.SockAddr import Network.Wai import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Lang import Network.Wai.Application.Classic.Types -import Network.Wai.Logger.Utils -import System.Date.Cache ---------------------------------------------------------------- -languages :: Request -> [ByteString] -languages req = maybe [] parseLang $ lookupRequestField hAcceptLanguage req - -ifModifiedSince :: Request -> Maybe HTTPDate -ifModifiedSince = lookupAndParseDate hIfModifiedSince +languages :: IndexedHeader -> [ByteString] +languages reqidx = maybe [] parseLang $ reqidx ! idxAcceptLanguage -ifUnmodifiedSince :: Request -> Maybe HTTPDate -ifUnmodifiedSince = lookupAndParseDate hIfUnmodifiedSince +ifModifiedSince :: IndexedHeader -> Maybe HTTPDate +ifModifiedSince reqidx = reqidx ! idxIfModifiedSince >>= parseHTTPDate -ifRange :: Request -> Maybe HTTPDate -ifRange = lookupAndParseDate hIfRange +ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate +ifUnmodifiedSince reqidx = reqidx ! idxIfUnmodifiedSince >>= parseHTTPDate -lookupAndParseDate :: HeaderName -> Request -> Maybe HTTPDate -lookupAndParseDate key req = lookupRequestField key req >>= parseHTTPDate +ifRange :: IndexedHeader -> Maybe HTTPDate +ifRange reqidx = reqidx ! idxIfRange >>= parseHTTPDate ---------------------------------------------------------------- @@ -64,23 +60,18 @@ , "." , showBS (httpMinor ver) , " " - , serverName req + , host , " (" , softwareName cspec , ")" ] - -deleteTransferEncoding :: ResponseHeaders -> ResponseHeaders -deleteTransferEncoding hdr = delete ("Transfer-Encoding", "chunked") hdr + host = fromMaybe "" $ requestHeaderHost req addForwardedFor :: Request -> ResponseHeaders -> ResponseHeaders addForwardedFor req hdr = (hXForwardedFor, addr) : hdr where addr = BS.pack . showSockAddr . remoteHost $ req -addLength :: Integer -> ResponseHeaders -> ResponseHeaders -addLength len hdr = (hContentLength, BS.pack (show len)) : hdr - newHeader :: Bool -> ByteString -> ByteString -> ResponseHeaders newHeader ishtml file date | ishtml = lastMod : textHtmlHeader @@ -104,23 +95,6 @@ defaultMimeTypes' :: StaticHash ByteString MimeType defaultMimeTypes' = SH.fromList $ map (first (BS.pack . T.unpack)) $ Map.toList defaultMimeMap - -addDate :: DateCacheGetter -> ResponseHeaders -> IO ResponseHeaders -addDate zdater hdr = do - date <- zdater - return $ (hDate,date) : hdr - -addContentRange :: Integer -> Integer -> Integer -> ResponseHeaders -> ResponseHeaders -addContentRange off len size hdr = (hContentRange, val) : hdr - where - val = BS.concat [ - "bytes " - , showBS off - , "-" - , showBS (off + len - 1) - , "/" - , showBS size - ] showBS :: Show a => a -> ByteString showBS = BS.pack . show diff --git a/Network/Wai/Application/Classic/File.hs b/Network/Wai/Application/Classic/File.hs --- a/Network/Wai/Application/Classic/File.hs +++ b/Network/Wai/Application/Classic/File.hs @@ -9,29 +9,31 @@ import Control.Exception.IOChoice.Lifted import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS (pack, concat) +import Data.Maybe +import qualified Data.ByteString.Char8 as BS (concat) import qualified Data.ByteString.Lazy.Char8 as BL (length) -import Data.Conduit import Network.HTTP.Types import Network.Wai +import Network.Wai.Internal import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.FileInfo +import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Status import Network.Wai.Application.Classic.Types ---------------------------------------------------------------- -type Rsp = ResourceT IO RspSpec +type Rsp = IO RspSpec ---------------------------------------------------------------- -data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang] +data HandlerInfo = HandlerInfo FileAppSpec Request IndexedHeader Path [Lang] -langSuffixes :: Request -> [Lang] -langSuffixes req = map (\x -> (<.> x)) langs ++ [id, (<.> "en")] +langSuffixes :: IndexedHeader -> [Lang] +langSuffixes reqidx = map (\x -> (<.> x)) langs ++ [id, (<.> "en")] where - langs = map fromByteString $ languages req + langs = map fromByteString $ languages reqidx ---------------------------------------------------------------- @@ -68,42 +70,38 @@ liftIO $ logger cspec req st mlen return response where - hinfo = HandlerInfo spec req file langs + reqidx = indexRequestHeader (requestHeaders req) + hinfo = HandlerInfo spec req reqidx file langs method = parseMethod $ requestMethod req path = pathinfoToFilePath req filei file = addIndex spec path ishtml = isHTML spec file rfile = redirectPath spec path - langs = langSuffixes req - zdater = dater cspec - noBody st = do - hdr <- liftIO . addDate zdater $ addServer cspec [] - return (responseLBS st hdr "", Nothing) + langs = langSuffixes reqidx + noBody st = return (responseLBS st (addServer cspec []) "", Nothing) bodyStatus st = liftIO (getStatusInfo cspec spec langs st) >>= statusBody st statusBody st StatusNone = noBody st - statusBody st (StatusByteString bd) = do - hdr <- liftIO . addDate zdater $ addServer cspec textPlainHeader + statusBody st (StatusByteString bd) = return (responseLBS st hdr bd, Just (len bd)) where len = fromIntegral . BL.length - statusBody st (StatusFile afile len) = do - hdr <- liftIO . addDate zdater $ addServer cspec textHtmlHeader + hdr = addServer cspec textPlainHeader + statusBody st (StatusFile afile len) = return (ResponseFile st hdr fl mfp, Just len) where - mfp = Just (FilePart 0 len) + mfp = Just (FilePart 0 len len) fl = pathString afile - bodyFileNoBody st hdr = do - hdr' <- liftIO . addDate zdater $ addServer cspec hdr - return (responseLBS st hdr' "", Nothing) - bodyFile st hdr afile rng = do - hdr' <- liftIO . addDate zdater $ addLength len $ addServer cspec hdr - return (ResponseFile st hdr' fl mfp, Just len) + hdr = addServer cspec textHtmlHeader + bodyFileNoBody st hdr = + return (responseLBS st (addServer cspec hdr) "", Nothing) + bodyFile st hdr afile rng = + return (ResponseFile st (addServer cspec hdr) fl mfp, Just len) where (len, mfp) = case rng of -- sendfile of Linux does not support the entire file - Entire bytes -> (bytes, Just (FilePart 0 bytes)) - Part skip bytes -> (bytes, Just (FilePart skip bytes)) + Entire bytes -> (bytes, Just (FilePart 0 bytes bytes)) + Part skip bytes total -> (bytes, Just (FilePart skip bytes total)) fl = pathString afile ---------------------------------------------------------------- @@ -114,27 +112,28 @@ ||> return notFound tryGet :: HandlerInfo -> Bool -> Rsp -tryGet hinfo@(HandlerInfo _ _ _ langs) True = +tryGet hinfo@(HandlerInfo _ _ _ _ langs) True = runAnyOne $ map (tryGetFile hinfo True) langs tryGet hinfo False = tryGetFile hinfo False id tryGetFile :: HandlerInfo -> Bool -> Lang -> Rsp -tryGetFile (HandlerInfo spec req file _) ishtml lang = do +tryGetFile (HandlerInfo spec req reqidx file _) ishtml lang = do finfo <- liftIO $ getFileInfo spec (lang file) let mtime = fileInfoTime finfo - size = fileInfoSize finfo + size = fileInfoSize finfo sfile = fileInfoName finfo - date = fileInfoDate finfo + date = fileInfoDate finfo + mrange = requestHeaderRange req hdr = newHeader ishtml (pathByteString file) date - Just pst = ifmodified req size mtime -- never Nothing - <|> ifunmodified req size mtime - <|> ifrange req size mtime - <|> unconditional req size mtime + Just pst = ifmodified reqidx size mtime mrange + <|> ifunmodified reqidx size mtime mrange + <|> ifrange reqidx size mtime mrange + <|> unconditional reqidx size mtime mrange case pst of Full st | st == ok200 -> return $ RspSpec ok200 (BodyFile hdr sfile (Entire size)) | otherwise -> return $ RspSpec st (BodyFileNoBody hdr) - Partial skip len -> return $ RspSpec partialContent206 (BodyFile (addContentRange skip len size hdr) sfile (Part skip len)) + Partial skip len -> return $ RspSpec partialContent206 (BodyFile hdr sfile (Part skip len size)) ---------------------------------------------------------------- @@ -144,18 +143,19 @@ ||> return notFoundNoBody tryHead :: HandlerInfo -> Bool -> Rsp -tryHead hinfo@(HandlerInfo _ _ _ langs) True = +tryHead hinfo@(HandlerInfo _ _ _ _ langs) True = runAnyOne $ map (tryHeadFile hinfo True) langs tryHead hinfo False= tryHeadFile hinfo False id tryHeadFile :: HandlerInfo -> Bool -> Lang -> Rsp -tryHeadFile (HandlerInfo spec req file _) ishtml lang = do +tryHeadFile (HandlerInfo spec req reqidx file _) ishtml lang = do finfo <- liftIO $ getFileInfo spec (lang file) let mtime = fileInfoTime finfo - size = fileInfoSize finfo - date = fileInfoDate finfo + size = fileInfoSize finfo + date = fileInfoDate finfo hdr = newHeader ishtml (pathByteString file) date - Just pst = ifmodified req size mtime -- never Nothing + mrange = requestHeaderRange req + Just pst = ifmodified reqidx size mtime mrange <|> Just (Full ok200) case pst of Full st -> return $ RspSpec st (BodyFileNoBody hdr) @@ -165,13 +165,13 @@ tryRedirect :: HandlerInfo -> Maybe Path -> Rsp tryRedirect _ Nothing = goNext -tryRedirect (HandlerInfo spec req _ langs) (Just file) = +tryRedirect (HandlerInfo spec req reqidx _ langs) (Just file) = runAnyOne $ map (tryRedirectFile hinfo) langs where - hinfo = HandlerInfo spec req file langs + hinfo = HandlerInfo spec req reqidx file langs tryRedirectFile :: HandlerInfo -> Lang -> Rsp -tryRedirectFile (HandlerInfo spec req file _) lang = do +tryRedirectFile (HandlerInfo spec req _ file _) lang = do _ <- liftIO $ getFileInfo spec (lang file) return $ RspSpec movedPermanently301 (BodyFileNoBody hdr) where @@ -183,12 +183,13 @@ redirectURL :: Request -> ByteString redirectURL req = BS.concat [ "http://" - , serverName req - , ":" - , (BS.pack . show . serverPort) req + -- Host includes ":" if it is not 80. + , host , rawPathInfo req , "/" ] + where + host = fromMaybe "" $ requestHeaderHost req ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/FileInfo.hs b/Network/Wai/Application/Classic/FileInfo.hs --- a/Network/Wai/Application/Classic/FileInfo.hs +++ b/Network/Wai/Application/Classic/FileInfo.hs @@ -14,36 +14,36 @@ data StatusAux = Full Status | Partial Integer Integer deriving Show -ifmodified :: Request -> Integer -> HTTPDate -> Maybe StatusAux -ifmodified req size mtime = do - date <- ifModifiedSince req +ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux +ifmodified reqidx size mtime mrange = do + date <- ifModifiedSince reqidx if date /= mtime - then unconditional req size mtime + then unconditional reqidx size mtime mrange else Just (Full notModified304) -ifunmodified :: Request -> Integer -> HTTPDate -> Maybe StatusAux -ifunmodified req size mtime = do - date <- ifUnmodifiedSince req +ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux +ifunmodified reqidx size mtime mrange = do + date <- ifUnmodifiedSince reqidx if date == mtime - then unconditional req size mtime + then unconditional reqidx size mtime mrange else Just (Full preconditionFailed412) -ifrange :: Request -> Integer -> HTTPDate -> Maybe StatusAux -ifrange req size mtime = do - date <- ifRange req - rng <- lookupRequestField hRange req +ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux +ifrange reqidx size mtime mrange = do + date <- ifRange reqidx + rng <- mrange if date == mtime - then range size rng + then parseRange size rng else Just (Full ok200) -unconditional :: Request -> Integer -> HTTPDate -> Maybe StatusAux -unconditional req size _ = - maybe (Just (Full ok200)) (range size) $ lookupRequestField hRange req +unconditional :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux +unconditional reqidx size _ mrange = + maybe (Just (Full ok200)) (parseRange size) mrange -range :: Integer -> ByteString -> Maybe StatusAux -range size rng = case skipAndSize rng size of - Nothing -> Just (Full requestedRangeNotSatisfiable416) - Just (skip,len) -> Just (Partial skip len) +parseRange :: Integer -> ByteString -> Maybe StatusAux +parseRange size rng = case skipAndSize rng size of + Nothing -> Just (Full requestedRangeNotSatisfiable416) + Just (skip,len) -> Just (Partial skip len) ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Header.hs b/Network/Wai/Application/Classic/Header.hs --- a/Network/Wai/Application/Classic/Header.hs +++ b/Network/Wai/Application/Classic/Header.hs @@ -2,8 +2,10 @@ module Network.Wai.Application.Classic.Header where +import Data.Array +import Data.Array.ST import Data.ByteString (ByteString) -import Data.Maybe +import qualified Data.ByteString.Char8 as BS (tail,break) import Network.HTTP.Types.Header import Network.Wai @@ -25,25 +27,58 @@ hVia :: HeaderName hVia = "via" --- | Look-up key for Content-Range. -hContentRange :: HeaderName -hContentRange = "content-range" +-- | Lookup key for Transfer-Encoding. +hTransferEncoding :: HeaderName +hTransferEncoding = "transfer-encoding" ---------------------------------------------------------------- -{-| - Looking up a header in 'Request'. --} -lookupRequestField :: HeaderName -> Request -> Maybe ByteString -lookupRequestField x req = lookup x hdrs - where - hdrs = requestHeaders req +hostPort :: Request -> (ByteString, ByteString) +hostPort req = case requestHeaderHost req of + Nothing -> ("Unknown","80") + Just hostport -> case BS.break (== ':') hostport of + (host,"") -> (host,"80") + (host,port) -> (host, BS.tail port) -{-| - Looking up a header in 'Request'. If the header does not exist, - empty 'Ascii' is returned. --} -lookupRequestField' :: HeaderName -> Request -> ByteString -lookupRequestField' x req = fromMaybe "" $ lookup x hdrs +---------------------------------------------------------------- + +-- | Array for a set of HTTP headers. +type IndexedHeader = Array Int (Maybe ByteString) + +---------------------------------------------------------------- + +indexRequestHeader :: RequestHeaders -> IndexedHeader +indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex + +idxAcceptLanguage,idxIfModifiedSince,idxIfUnmodifiedSince,idxIfRange :: Int +idxAcceptLanguage = 0 +idxIfModifiedSince = 1 +idxIfUnmodifiedSince = 2 +idxIfRange = 3 + +requestMaxIndex :: Int +requestMaxIndex = 3 + +requestKeyIndex :: HeaderName -> Int +requestKeyIndex "accept-language" = idxAcceptLanguage +requestKeyIndex "if-modified-since" = idxIfModifiedSince +requestKeyIndex "if-unmodified-since" = idxIfUnmodifiedSince +requestKeyIndex "if-range" = idxIfRange +requestKeyIndex _ = -1 + +defaultIndexRequestHeader :: IndexedHeader +defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]] + +---------------------------------------------------------------- + +traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader +traverseHeader hdr maxidx getIndex = runSTArray $ do + arr <- newArray (0,maxidx) Nothing + mapM_ (insert arr) hdr + return arr where - hdrs = requestHeaders req + insert arr (key,val) + | idx == -1 = return () + | otherwise = writeArray arr idx (Just val) + where + idx = getIndex key diff --git a/Network/Wai/Application/Classic/RevProxy.hs b/Network/Wai/Application/Classic/RevProxy.hs --- a/Network/Wai/Application/Classic/RevProxy.hs +++ b/Network/Wai/Application/Classic/RevProxy.hs @@ -2,107 +2,116 @@ module Network.Wai.Application.Classic.RevProxy (revProxyApp) where +import Blaze.ByteString.Builder (Builder) import Control.Applicative -import Control.Exception (SomeException) -import Control.Exception.Lifted as L (catch) +import Control.Monad import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteString.Char8 as BS hiding (uncons) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS (uncons) +import qualified Data.ByteString.Char8 as BS hiding (uncons) import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Int -import Data.Maybe -import qualified Network.HTTP.Conduit as H +import Data.Default +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Client.Body as H +import qualified Network.HTTP.Client.Conduit as H +import qualified Network.HTTP.Client.Types as H import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Conduit import Network.Wai.Application.Classic.EventSource import Network.Wai.Application.Classic.Field +import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types -import Blaze.ByteString.Builder (Builder) -toHTTPRequest :: Request -> RevProxyRoute -> Int64 -> H.Request (ResourceT IO) -toHTTPRequest req route len = H.def { - H.host = revProxyDomain route - , H.port = revProxyPort route - , H.secure = isSecure req - , H.requestHeaders = addForwardedFor req $ requestHeaders req - , H.path = pathByteString path' - , H.queryString = dropQuestion $ rawQueryString req - , H.requestBody = getBody req len - , H.method = requestMethod req - , H.proxy = Nothing - , H.rawBody = False - , H.decompress = H.alwaysDecompress - , H.checkStatus = \_ _ _ -> Nothing - , H.redirectCount = 0 +---------------------------------------------------------------- + +-- | Relaying any requests as reverse proxy. + +revProxyApp :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application +revProxyApp cspec spec route req = responseSourceBracket setup teardown proxy + where + setup = H.responseOpen httpClientRequest mgr + teardown = H.responseClose + proxy hrsp = do + let status = H.responseStatus hrsp + hdr = fixHeader $ H.responseHeaders hrsp + clientBody = H.responseBody hrsp + ct = lookup hContentType hdr + src = toSource ct clientBody + logger cspec req status (fromIntegral <$> mlen) + return (status, hdr, src) + + httpClientRequest = reqToHReq req route + mgr = revProxyManager spec + mlen = case requestBodyLength req of + ChunkedBody -> Nothing + KnownLength len -> Just len + fixHeader = addVia cspec req . filter p + p (k,_) + | k == hTransferEncoding = False + | k == hContentLength = False + | k == hContentEncoding = False -- See H.decompress. + | otherwise = True + +---------------------------------------------------------------- + +reqToHReq :: Request -> RevProxyRoute -> H.Request +reqToHReq req route = def { + H.host = revProxyDomain route + , H.port = revProxyPort route + , H.secure = isSecure req + , H.requestHeaders = addForwardedFor req hdr + , H.path = pathByteString path' + , H.queryString = dropQuestion query + , H.requestBody = bodyToHBody len body + , H.method = requestMethod req + , H.proxy = Nothing + , H.rawBody = False + , H.decompress = const True + , H.checkStatus = \_ _ _ -> Nothing -- FIXME + , H.redirectCount = 0 } where path = fromByteString $ rawPathInfo req src = revProxySrc route dst = revProxyDst route + hdr = requestHeaders req + query = rawQueryString req + len = requestBodyLength req + body = requestBody req path' = dst (path <\> src) dropQuestion q = case BS.uncons q of Just (63, q') -> q' -- '?' is 63 _ -> q -getBody :: Request -> Int64 -> H.RequestBody (ResourceT IO) -getBody req len = H.RequestBodySource len (toBodySource req) - where - toBodySource r = requestBody r $= CL.map byteStringToBuilder - -getLen :: Request -> Maybe Int64 -getLen req = do - len' <- lookup hContentLength $ requestHeaders req - case reads $ BS.unpack len' of - [] -> Nothing - (i, _):_ -> Just i +bodyToHBody :: RequestBodyLength -> Source IO ByteString -> H.RequestBody +bodyToHBody ChunkedBody src = H.requestBodySourceChunkedIO src +bodyToHBody (KnownLength len) src = H.requestBodySourceIO (fromIntegral len) src -{-| - Relaying any requests as reverse proxy. --} +---------------------------------------------------------------- -revProxyApp :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application -revProxyApp cspec spec route req = - revProxyApp' cspec spec route req - `L.catch` badGateway cspec req +toSource :: Maybe ByteString -> H.BodyReader -> Source IO (Flush Builder) +toSource (Just "text/event-stream") = bodyToEventSource +toSource _ = bodyToSource -revProxyApp' :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application -revProxyApp' cspec spec route req = do - let mlen = getLen req - len = fromMaybe 0 mlen - httpReq = toHTTPRequest req route len - res <- http httpReq mgr - let status = H.responseStatus res - hdr = fixHeader $ H.responseHeaders res - rdownbody = H.responseBody res - liftIO $ logger cspec req status (fromIntegral <$> mlen) - ResponseSource status hdr <$> toSource (lookup hContentType hdr) rdownbody +bodyToSource :: H.BodyReader -> Source IO (Flush Builder) +bodyToSource br = loop where - mgr = revProxyManager spec - fixHeader = deleteTransferEncoding . addVia cspec req . filter p - p (k,_) - | k == hContentEncoding = False - | k == hContentLength = False - | otherwise = True - -toSource :: Maybe BS.ByteString - -> ResumableSource (ResourceT IO) BS.ByteString - -> (ResourceT IO) (Source (ResourceT IO) (Flush Builder)) -toSource (Just "text/event-stream") = toResponseEventSource -toSource _ = toResponseSource - -type Resp = ResourceT IO (H.Response (ResumableSource (ResourceT IO) BS.ByteString)) - -http :: H.Request (ResourceT IO) -> H.Manager -> Resp -http req mgr = H.http req mgr + loop = do + bs <- liftIO $ H.brRead br + unless (BS.null bs) $ do + yield $ Chunk $ byteStringToBuilder bs + loop +{- -badGateway :: ClassicAppSpec -> Request-> SomeException -> ResourceT IO Response +FIXME: +badGateway :: ClassicAppSpec -> Request-> SomeException -> IO Response badGateway cspec req _ = do - liftIO $ logger cspec req st Nothing -- FIXME body length - return $ ResponseBuilder st hdr bdy + logger cspec req st Nothing -- FIXME body length + return $ responseBuilder st hdr bdy where hdr = addServer cspec textPlainHeader bdy = byteStringToBuilder "Bad Gateway\r\n" st = badGateway502 +-} diff --git a/Network/Wai/Application/Classic/Types.hs b/Network/Wai/Application/Classic/Types.hs --- a/Network/Wai/Application/Classic/Types.hs +++ b/Network/Wai/Application/Classic/Types.hs @@ -4,13 +4,11 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) +import qualified Network.HTTP.Client.Manager as H import Network.HTTP.Date import Network.HTTP.Types +import Network.Wai import Network.Wai.Application.Classic.Path -import Network.Wai.Logger -#ifdef REV_PROXY -import qualified Network.HTTP.Conduit as H -#endif ---------------------------------------------------------------- @@ -18,10 +16,8 @@ -- | Name specified to Server: in HTTP response. softwareName :: ByteString -- | A function for logging. The third argument is a body size. - , logger :: ApacheLogger + , logger :: Request -> Status -> Maybe Integer -> IO () -- | A function to get HTTP's GMT Date. - , dater :: IO ByteString - -- | A function to get the HTTP body of status. , statusFileDir :: Path } @@ -85,7 +81,6 @@ ---------------------------------------------------------------- -#ifdef REV_PROXY data RevProxyAppSpec = RevProxyAppSpec { -- | Connection manager revProxyManager :: H.Manager @@ -101,7 +96,6 @@ -- | Destination port number. , revProxyPort :: Int } deriving (Eq,Show) -#endif ---------------------------------------------------------------- @@ -123,7 +117,9 @@ -- | Entire file showing its file size Entire Integer -- | A part of a file taking offset and length - | Part Integer Integer + | Part Integer -- offset + Integer -- length + Integer -- total deriving (Eq,Show) ---------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,9 +12,11 @@ import System.Directory import System.FilePath import Test.Hspec +import System.Posix main :: IO () main = do + void $ installHandler sigCHLD Ignore Nothing void $ forkIO testServer threadDelay 100000 hspec spec diff --git a/wai-app-file-cgi.cabal b/wai-app-file-cgi.cabal --- a/wai-app-file-cgi.cabal +++ b/wai-app-file-cgi.cabal @@ -1,27 +1,21 @@ Name: wai-app-file-cgi -Version: 0.8.7 +Version: 2.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: File/CGI/Rev Proxy App of WAI Description: This WAI application library handles static files, - executes CGI scripts, and serves as a reverse proxy. + executes CGI scripts, and serves as a reverse proxy + (including EventSource). Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Web, Yesod Cabal-Version: >= 1.10 Build-Type: Simple -Flag rev-proxy - Description: Support reverse proxy wish http-conduit. - This requires unnecessary crypt libraries. - Default: True - Library Default-Language: Haskell2010 GHC-Options: -Wall - if flag(rev-proxy) - Cpp-Options: -DREV_PROXY Exposed-Modules: Network.Wai.Application.Classic Other-Modules: Network.Wai.Application.Classic.CGI Network.Wai.Application.Classic.Conduit @@ -37,10 +31,10 @@ Network.Wai.Application.Classic.Redirect Network.Wai.Application.Classic.Status Network.Wai.Application.Classic.Types - if flag(rev-proxy) - Other-Modules: Network.Wai.Application.Classic.RevProxy + Network.Wai.Application.Classic.RevProxy Build-Depends: base >= 4 && < 5 + , array , attoparsec >= 0.10.0.0 , attoparsec-conduit , blaze-builder @@ -49,9 +43,11 @@ , case-insensitive , conduit >= 0.5 , containers - , date-cache + , data-default , directory , filepath + , http-client + , http-client-conduit , http-date , http-types >= 0.7 , io-choice @@ -59,16 +55,13 @@ , mime-types , network , process - , resourcet + , sockaddr , static-hash , text , transformers , unix - , wai >= 1.2 - , wai-logger + , wai >= 2.0 , word8 - if flag(rev-proxy) - Build-Depends: http-conduit >= 1.9 Test-Suite doctest Type: exitcode-stdio-1.0 @@ -94,9 +87,9 @@ , hspec >= 1.3 , http-types , unix - , wai + , wai >= 2.0 , wai-app-file-cgi - , warp + , warp >= 2.0 , HTTP Source-Repository head