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 @@ -45,11 +45,11 @@ -} cgiApp :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application cgiApp cspec spec cgii req = case method of - "GET" -> cgiApp' False cspec spec cgii req - "POST" -> cgiApp' True cspec spec cgii req - _ -> return $ responseLBS methodNotAllowed405 textPlainHeader "Method Not Allowed\r\n" -- xxx + Right GET -> cgiApp' False cspec spec cgii req + Right POST -> cgiApp' True cspec spec cgii req + _ -> return $ responseLBS methodNotAllowed405 textPlainHeader "Method Not Allowed\r\n" -- xxx where - method = requestMethod req + method = parseMethod $ requestMethod req cgiApp' :: Bool -> ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application cgiApp' body cspec spec cgii req = do @@ -71,23 +71,27 @@ fromCGI :: Handle -> ClassicAppSpec -> Application fromCGI rhdl cspec req = do - (src', hs) <- (CB.sourceHandle rhdl $$+ parseHeader) `catch` recover + (src', hs) <- cgiHeader `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' (toResponseSource src) + return $ ResponseSource st hdr' src where - check hs = lookup fkContentType hs >> case lookup "status" hs of + check hs = lookup hContentType hs >> case lookup hStatus hs of Nothing -> Just (ok200, hs) Just l -> toStatus l >>= \s -> Just (s,hs') where - hs' = filter (\(k,_) -> k /= "status") hs + hs' = filter (\(k,_) -> k /= hStatus) hs toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s) emptyHeader = [] recover (_ :: SomeException) = return (CL.sourceNull, emptyHeader) + cgiHeader = do + (rsrc,hs) <- CB.sourceHandle rhdl $$+ parseHeader + src <- toResponseSource rsrc + return (src,hs) ---------------------------------------------------------------- @@ -133,9 +137,9 @@ , ("QUERY_STRING", query req) ] headers = requestHeaders req - addLen = addEnv "CONTENT_LENGTH" $ lookup fkContentLength headers - addType = addEnv "CONTENT_TYPE" $ lookup fkContentType headers - addCookie = addEnv "HTTP_COOKIE" $ lookup fkCookie headers + addLen = addEnv "CONTENT_LENGTH" $ lookup hContentLength headers + addType = addEnv "CONTENT_TYPE" $ lookup hContentType headers + addCookie = addEnv "HTTP_COOKIE" $ lookup hCookie headers query = BS.unpack . safeTail . rawQueryString where safeTail "" = "" 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,9 +25,11 @@ ---------------------------------------------------------------- -toResponseSource :: Source (ResourceT IO) ByteString - -> Source (ResourceT IO) (Flush Builder) -toResponseSource = ($= CL.map (Chunk . byteStringToBuilder)) +toResponseSource :: ResumableSource (ResourceT IO) ByteString + -> (ResourceT IO) (Source (ResourceT IO) (Flush Builder)) +toResponseSource rsrc = do + (src,_) <- unwrapResumable rsrc + return $ src $= CL.map (Chunk . byteStringToBuilder) ---------------------------------------------------------------- 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 @@ -2,6 +2,7 @@ module Network.Wai.Application.Classic.Field where +import Control.Applicative import Control.Arrow (first) import Control.Monad (mplus) import Data.ByteString (ByteString) @@ -11,49 +12,52 @@ import Data.Maybe import Data.StaticHash (StaticHash) import qualified Data.StaticHash as SH +import qualified Data.Text as T import Network.HTTP.Date import Network.HTTP.Types +import Network.HTTP.Types.Header +import Network.Mime (defaultMimeMap, defaultMimeType, MimeType) import Network.Wai import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Lang import Network.Wai.Application.Classic.Types -import Network.Wai.Application.Static (defaultMimeTypes, defaultMimeType, MimeType, fromFilePath) import Network.Wai.Logger.Utils +import System.Posix.Time ---------------------------------------------------------------- -languages :: Request -> [Ascii] -languages req = maybe [] parseLang $ lookupRequestField fkAcceptLanguage req +languages :: Request -> [ByteString] +languages req = maybe [] parseLang $ lookupRequestField hAcceptLanguage req ifModifiedSince :: Request -> Maybe HTTPDate -ifModifiedSince = lookupAndParseDate fkIfModifiedSince +ifModifiedSince = lookupAndParseDate hIfModifiedSince ifUnmodifiedSince :: Request -> Maybe HTTPDate -ifUnmodifiedSince = lookupAndParseDate fkIfUnmodifiedSince +ifUnmodifiedSince = lookupAndParseDate hIfUnmodifiedSince ifRange :: Request -> Maybe HTTPDate -ifRange = lookupAndParseDate fkIfRange +ifRange = lookupAndParseDate hIfRange -lookupAndParseDate :: FieldKey -> Request -> Maybe HTTPDate +lookupAndParseDate :: HeaderName -> Request -> Maybe HTTPDate lookupAndParseDate key req = lookupRequestField key req >>= parseHTTPDate ---------------------------------------------------------------- textPlainHeader :: ResponseHeaders -textPlainHeader = [("Content-Type", "text/plain")] +textPlainHeader = [(hContentType,"text/plain")] textHtmlHeader :: ResponseHeaders -textHtmlHeader = [("Content-Type", "text/html")] +textHtmlHeader = [(hContentType,"text/html")] locationHeader :: ByteString -> ResponseHeaders -locationHeader url = [("Location", url)] +locationHeader url = [(hLocation, url)] addServer :: ClassicAppSpec -> ResponseHeaders -> ResponseHeaders -addServer cspec hdr = ("Server", softwareName cspec) : hdr +addServer cspec hdr = (hServer, softwareName cspec) : hdr -- FIXME: the case where "Via:" already exists addVia :: ClassicAppSpec -> Request -> ResponseHeaders -> ResponseHeaders -addVia cspec req hdr = ("Via", val) : hdr +addVia cspec req hdr = (hVia, val) : hdr where ver = httpVersion req showBS = BS.pack . show @@ -69,19 +73,19 @@ ] addForwardedFor :: Request -> ResponseHeaders -> ResponseHeaders -addForwardedFor req hdr = ("X-Forwarded-For", addr) : hdr +addForwardedFor req hdr = (hXForwardedFor, addr) : hdr where addr = BS.pack . showSockAddr . remoteHost $ req addLength :: Integer -> ResponseHeaders -> ResponseHeaders -addLength len hdr = ("Content-Length", BS.pack . show $ len) : hdr +addLength len hdr = (hContentLength, BS.pack (show len)) : hdr newHeader :: Bool -> ByteString -> HTTPDate -> ResponseHeaders newHeader ishtml file mtime | ishtml = lastMod : textHtmlHeader - | otherwise = lastMod : [("Content-Type", mimeType file)] + | otherwise = lastMod : (hContentType, mimeType file) : [] where - lastMod = ("Last-Modified", formatHTTPDate mtime) + lastMod = (hLastModified, formatHTTPDate mtime) mimeType :: ByteString -> MimeType mimeType file =fromMaybe defaultMimeType . foldr1 mplus . map lok $ targets @@ -98,4 +102,9 @@ exts = if entire == "" then [] else entire : BS.split 46 file defaultMimeTypes' :: StaticHash ByteString MimeType -defaultMimeTypes' = SH.fromList $ map (first (BS.pack.fromFilePath)) $ Map.toList defaultMimeTypes +defaultMimeTypes' = SH.fromList $ map (first (BS.pack . T.unpack)) $ Map.toList defaultMimeMap + +addDate :: ResponseHeaders -> IO ResponseHeaders +addDate hdr = do + date <- formatHTTPDate . epochTimeToHTTPDate <$> epochTime + return $ (hDate,date) : hdr 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 @@ -58,47 +58,52 @@ fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application fileApp cspec spec filei req = do RspSpec st body <- case method of - "GET" -> processGET hinfo ishtml rfile - "HEAD" -> processHEAD hinfo ishtml rfile - _ -> return notAllowed + Right GET -> processGET hinfo ishtml rfile + Right HEAD -> processHEAD hinfo ishtml rfile + _ -> return notAllowed (response, mlen) <- case body of - NoBody -> return $ noBody st - BodyStatus -> statusBody st <$> liftIO (getStatusInfo cspec spec langs st) - BodyFileNoBody hdr -> return $ bodyFileNoBody st hdr - BodyFile hdr afile rng -> return $ bodyFile st hdr afile rng + NoBody -> noBody st + BodyStatus -> bodyStatus st + BodyFileNoBody hdr -> bodyFileNoBody st hdr + BodyFile hdr afile rng -> bodyFile st hdr afile rng liftIO $ logger cspec req st mlen return response where hinfo = HandlerInfo spec req file langs - method = requestMethod req + method = parseMethod $ requestMethod req path = pathinfoToFilePath req filei file = addIndex spec path ishtml = isHTML spec file rfile = redirectPath spec path langs = langSuffixes req - noBody st = (responseLBS st hdr "", Nothing) - where - hdr = addServer cspec [] + noBody st = do + hdr <- liftIO . addDate $ addServer cspec [] + return (responseLBS st hdr "", Nothing) + bodyStatus st = liftIO (getStatusInfo cspec spec langs st) + >>= statusBody st statusBody st StatusNone = noBody st - statusBody st (StatusByteString bd) = (responseLBS st hdr bd, Just (len bd)) + statusBody st (StatusByteString bd) = do + hdr <- liftIO . addDate $ addServer cspec textPlainHeader + return (responseLBS st hdr bd, Just (len bd)) where len = fromIntegral . BL.length - hdr = addServer cspec textPlainHeader - statusBody st (StatusFile afile len) = (ResponseFile st hdr fl mfp, Just len) + statusBody st (StatusFile afile len) = do + hdr <- liftIO . addDate $ addServer cspec textHtmlHeader + return (ResponseFile st hdr fl mfp, Just len) where - hdr = addServer cspec textHtmlHeader mfp = Just (FilePart 0 len) fl = pathString afile - bodyFileNoBody st hdr = (responseLBS st hdr' "", Nothing) - where - hdr' = addServer cspec hdr - bodyFile st hdr afile rng = (ResponseFile st hdr' fl mfp, Just len) + bodyFileNoBody st hdr = do + hdr' <- liftIO . addDate $ addServer cspec hdr + return (responseLBS st hdr' "", Nothing) + bodyFile st hdr afile rng = do + hdr' <- liftIO . addDate $ addLength len $ addServer cspec hdr + return (ResponseFile st 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)) - hdr' = addLength len $ addServer cspec hdr fl = pathString afile ---------------------------------------------------------------- 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 @@ -31,14 +31,14 @@ ifrange :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifrange req size mtime = do date <- ifRange req - rng <- lookupRequestField fkRange req + rng <- lookupRequestField hRange req if date == mtime then Just (Full ok200) else range size rng unconditional :: Request -> Integer -> HTTPDate -> Maybe StatusAux unconditional req size _ = - maybe (Just (Full ok200)) (range size) $ lookupRequestField fkRange req + maybe (Just (Full ok200)) (range size) $ lookupRequestField hRange req range :: Integer -> ByteString -> Maybe StatusAux range size rng = case skipAndSize rng size of 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,66 +2,35 @@ module Network.Wai.Application.Classic.Header where -import Data.CaseInsensitive +import Data.ByteString (ByteString) import Data.Maybe -import Network.HTTP.Types +import Network.HTTP.Types.Header import Network.Wai ---------------------------------------------------------------- --- | Header field key. This must be lower case. -type FieldKey = CI Ascii - --- | A type for look-up key. -fkAcceptLanguage :: FieldKey -fkAcceptLanguage = "accept-language" - --- | Look-up key for Range:. -fkRange :: FieldKey -fkRange = "range" - --- | Look-up key for If-Range:. -fkIfRange :: FieldKey -fkIfRange = "if-range" - --- | Look-up key for Last-Modified:. -fkLastModified :: FieldKey -fkLastModified = "last-modified" - --- | Look-up key for If-Modified-Since:. -fkIfModifiedSince :: FieldKey -fkIfModifiedSince = "if-modified-since" - -- | Look-up key for If-Unmodified-Since:. -fkIfUnmodifiedSince :: FieldKey -fkIfUnmodifiedSince = "if-unmodified-since" - --- | Look-up key for Content-Length:. -fkContentLength :: FieldKey -fkContentLength = "content-length" - --- | Look-up key for Content-Type:. -fkContentType :: FieldKey -fkContentType = "content-type" +hIfUnmodifiedSince :: HeaderName +hIfUnmodifiedSince = "if-unmodified-since" --- | Look-up key for Cookie:. -fkCookie :: FieldKey -fkCookie = "cookie" +-- | Look-up key for Status. +hStatus :: HeaderName +hStatus = "status" --- | Look-up key for User-Agent:. -fkUserAgent :: FieldKey -fkUserAgent = "user-agent" +-- | Look-up key for X-Forwarded-For. +hXForwardedFor :: HeaderName +hXForwardedFor = "x-forwarded-for" --- | Look-up key for Referer:. -fkReferer :: FieldKey -fkReferer = "referer" +-- | Look-up key for Via. +hVia :: HeaderName +hVia = "via" ---------------------------------------------------------------- {-| Looking up a header in 'Request'. -} -lookupRequestField :: FieldKey -> Request -> Maybe Ascii +lookupRequestField :: HeaderName -> Request -> Maybe ByteString lookupRequestField x req = lookup x hdrs where hdrs = requestHeaders req @@ -70,7 +39,7 @@ Looking up a header in 'Request'. If the header does not exist, empty 'Ascii' is returned. -} -lookupRequestField' :: FieldKey -> Request -> Ascii +lookupRequestField' :: HeaderName -> Request -> ByteString lookupRequestField' x req = fromMaybe "" $ lookup x hdrs where hdrs = requestHeaders req diff --git a/Network/Wai/Application/Classic/Range.hs b/Network/Wai/Application/Classic/Range.hs --- a/Network/Wai/Application/Classic/Range.hs +++ b/Network/Wai/Application/Classic/Range.hs @@ -6,6 +6,7 @@ import Data.Attoparsec.ByteString hiding (satisfy) import Data.Attoparsec.ByteString.Char8 hiding (take) import Data.ByteString.Char8 hiding (map, count, take, elem) +import Network.HTTP.Types -- | -- >>> skipAndSize "bytes=0-399" 10000 @@ -18,40 +19,38 @@ -- Just (9500,500) skipAndSize :: ByteString -> Integer -> Maybe (Integer,Integer) skipAndSize bs size = case parseRange bs of - Just [(mbeg,mend)] -> adjust mbeg mend size - _ -> Nothing + Just [rng] -> adjust rng size + _ -> Nothing -adjust :: Maybe Integer -> Maybe Integer -> Integer -> Maybe (Integer,Integer) -adjust (Just beg) (Just end) siz +adjust :: ByteRange -> Integer -> Maybe (Integer,Integer) +adjust (ByteRangeFromTo beg end) siz | beg <= end && end <= siz = Just (beg, end - beg + 1) | otherwise = Nothing -adjust (Just beg) Nothing siz +adjust (ByteRangeFrom beg) siz | beg <= siz = Just (beg, siz - beg) | otherwise = Nothing -adjust Nothing (Just end) siz +adjust (ByteRangeSuffix end) siz | end <= siz = Just (siz - end, end) | otherwise = Nothing -adjust Nothing Nothing _ = Nothing -type Range = (Maybe Integer, Maybe Integer) - -parseRange :: ByteString -> Maybe [Range] +parseRange :: ByteString -> Maybe [ByteRange] parseRange bs = case parseOnly byteRange bs of Right x -> Just x _ -> Nothing -byteRange :: Parser [Range] +byteRange :: Parser [ByteRange] byteRange = string "bytes=" *> (ranges <* endOfInput) -ranges :: Parser [Range] +ranges :: Parser [ByteRange] ranges = sepBy1 (range <|> suffixRange) (spcs >> char ',' >> spcs) -range :: Parser Range -range = (,) <$> ((Just <$> num) <* char '-') - <*> option Nothing (Just <$> num) +range :: Parser ByteRange +range = do + beg <- num <* char '-' + (ByteRangeFromTo beg <$> num) <|> return (ByteRangeFrom beg) -suffixRange :: Parser Range -suffixRange = (,) Nothing <$> (char '-' *> (Just <$> num)) +suffixRange :: Parser ByteRange +suffixRange = ByteRangeSuffix <$> (char '-' *> num) num :: Parser Integer num = read <$> many1 digit 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 @@ -53,7 +53,7 @@ getLen :: Request -> Maybe Int64 getLen req = do - len' <- lookup "content-length" $ requestHeaders req + len' <- lookup hContentLength $ requestHeaders req case reads $ BS.unpack len' of [] -> Nothing (i, _):_ -> Just i @@ -72,18 +72,19 @@ let mlen = getLen req len = fromMaybe 0 mlen httpReq = toHTTPRequest req route len - H.Response status _ hdr downbody <- http httpReq mgr + H.Response status _ hdr rdownbody <- http httpReq mgr let hdr' = fixHeader hdr liftIO $ logger cspec req status (fromIntegral <$> mlen) - return $ ResponseSource status hdr' (toResponseSource downbody) + ResponseSource status hdr' <$> toResponseSource rdownbody where mgr = revProxyManager spec fixHeader = addVia cspec req . filter p - p ("Content-Encoding", _) = False - p ("Content-Length", _) = False - p _ = True + p (k,_) + | k == hContentEncoding = False + | k == hContentLength = False + | otherwise = True -type Resp = ResourceT IO (H.Response (Source (ResourceT IO) BS.ByteString)) +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 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,5 +1,5 @@ Name: wai-app-file-cgi -Version: 0.6.0 +Version: 0.7.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -32,27 +32,27 @@ , attoparsec >= 0.10.0.0 , attoparsec-conduit , blaze-builder + , blaze-html , bytestring , case-insensitive - , conduit >= 0.4 && < 0.5 + , conduit >= 0.5 && < 0.6 , containers , directory , filepath , http-conduit , http-date - , http-types >= 0.6.9 + , http-types >= 0.7 + , mime-types , io-choice , lifted-base , network , process , resourcet , static-hash + , text , transformers , unix , wai >= 1.2 - -- should be removed someday - , blaze-html >= 0.5 - , wai-app-static >= 1.2 , wai-logger Test-Suite test @@ -61,7 +61,7 @@ HS-Source-Dirs: test Build-Depends: base >= 4 && < 5 , bytestring - , conduit >= 0.4 && < 0.5 + , conduit >= 0.5 && < 0.6 , http-conduit , http-types , lifted-base