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 @@ -3,15 +3,24 @@ -} module Network.Wai.Application.Classic ( - -- * Types - AppSpec(..) - , FileInfo(..) + -- * Common + ClassicAppSpec(..) + , StatusInfo(..) -- * Files + , FileAppSpec(..) + , FileInfo(..) , FileRoute(..), fileApp -- * CGI , CgiRoute(..), cgiApp + -- * Reverse Proxy + , RevProxyAppSpec(..) + , RevProxyRoute(..), revProxyApp + -- * Path + , module Network.Wai.Application.Classic.Utils ) where import Network.Wai.Application.Classic.CGI import Network.Wai.Application.Classic.File +import Network.Wai.Application.Classic.RevProxy import Network.Wai.Application.Classic.Types +import Network.Wai.Application.Classic.Utils 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,7 +4,7 @@ cgiApp ) where -import Blaze.ByteString.Builder.ByteString +import qualified Blaze.ByteString.Builder as BB import Control.Applicative import Control.Exception import Control.Monad (when) @@ -43,17 +43,17 @@ > installHandler sigCHLD Ignore Nothing -} -cgiApp :: AppSpec -> CgiRoute -> Application -cgiApp spec cgii req = case method of - "GET" -> cgiApp' False spec cgii req - "POST" -> cgiApp' True spec cgii req - _ -> return $ responseLBS statusNotAllowed textPlain "Method Not Allowed\r\n" +cgiApp :: ClassicAppSpec -> CgiRoute -> Application +cgiApp cspec cgii req = case method of + "GET" -> cgiApp' False cspec cgii req + "POST" -> cgiApp' True cspec cgii req + _ -> return $ responseLBS statusNotAllowed textPlainHeader "Method Not Allowed\r\n" -- xxx where method = requestMethod req -cgiApp' :: Bool -> AppSpec -> CgiRoute -> Application -cgiApp' body spec cgii req = do - (rhdl,whdl,pid) <- liftIO $ execProcess spec cgii req +cgiApp' :: Bool -> ClassicAppSpec -> CgiRoute -> Application +cgiApp' body cspec cgii req = do + (rhdl,whdl,pid) <- liftIO $ execProcess cspec cgii req let cleanup = do hClose whdl hClose rhdl @@ -61,9 +61,9 @@ -- HTTP body can be obtained in this Iteratee level only toCGI whdl body `catchError` const (liftIO cleanup) liftIO $ hClose whdl - respEnumerator $ \hdrMaker -> + respEnumerator $ \respBuilder -> -- this is IO - fromCGI rhdl spec req hdrMaker `finally` cleanup + fromCGI rhdl cspec req respBuilder `finally` cleanup where respEnumerator = return . ResponseEnumerator @@ -72,31 +72,30 @@ toCGI :: Handle -> Bool -> Iteratee ByteString IO () toCGI whdl body = when body $ EL.consume >>= liftIO . mapM_ (BS.hPutStr whdl) -fromCGI :: Handle -> AppSpec -> Request -> ResponseEnumerator a -fromCGI rhdl spec req hdrMaker = run_ $ EB.enumHandle 4096 rhdl $$ do +fromCGI :: Handle -> ClassicAppSpec -> Request -> ResponseEnumerator a +fromCGI rhdl cspec req respBuilder = run_ $ EB.enumHandle 4096 rhdl $$ do -- consuming the header part of CGI output m <- (>>= check) <$> parseHeader let (st, hdr, hasBody) = case m of - Nothing -> (status500,[],False) + Nothing -> (statusServerError,[],False) Just (s,h) -> (s,h,True) - hdr' = addHeader hdr + hdr' = addServer cspec hdr -- logging - liftIO $ logger spec req st Nothing -- cannot know body length + liftIO $ logger cspec req st Nothing -- cannot know body length -- building HTTP header and optionally HTTP body if hasBody then {- Body -} response st hdr' else emptyBody $$ response st hdr' where - toBuilder = EL.map fromByteString + enumBody = EL.map BB.fromByteString emptyBody = enumEOF - response status hs = toBuilder =$ hdrMaker status hs + response status hs = enumBody =$ respBuilder status hs check hs = lookup fkContentType hs >> case lookup "status" hs of Nothing -> Just (status200, hs) Just l -> toStatus l >>= \s -> Just (s,hs') where hs' = filter (\(k,_) -> k /= "status") hs toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s) - addHeader hdr = ("Server", softwareName spec) : hdr ---------------------------------------------------------------- @@ -118,8 +117,8 @@ ---------------------------------------------------------------- -execProcess :: AppSpec -> CgiRoute -> Request -> IO (Handle, Handle, ProcessHandle) -execProcess spec cgii req = do +execProcess :: ClassicAppSpec -> CgiRoute -> Request -> IO (Handle, Handle, ProcessHandle) +execProcess cspec cgii req = do let naddr = showSockAddr . remoteHost $ req (Just whdl,Just rhdl,_,pid) <- createProcess . proSpec $ naddr hSetEncoding rhdl latin1 @@ -129,7 +128,7 @@ proSpec naddr = CreateProcess { cmdspec = RawCommand prog [] , cwd = Nothing - , env = Just (makeEnv req naddr scriptName pathinfo (softwareName spec)) + , env = Just (makeEnv req naddr scriptName pathinfo (softwareName cspec)) , std_in = CreatePipe , std_out = CreatePipe , std_err = Inherit @@ -140,10 +139,10 @@ } (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii) (cgiDst cgii) - (rawPathInfo req) + (fromByteString (rawPathInfo req)) makeEnv :: Request -> NumericAddress -> String -> String -> ByteString -> ENVVARS -makeEnv req naddr scriptName pathinfo sname = addLength . addType . addCookie $ baseEnv +makeEnv req naddr scriptName pathinfo sname = addLen . addType . addCookie $ baseEnv where baseEnv = [ ("GATEWAY_INTERFACE", gatewayInterface) @@ -158,7 +157,7 @@ , ("QUERY_STRING", query req) ] headers = requestHeaders req - addLength = addEnv "CONTENT_LENGTH" $ lookup fkContentLength headers + addLen = addEnv "CONTENT_LENGTH" $ lookup fkContentLength headers addType = addEnv "CONTENT_TYPE" $ lookup fkContentType headers addCookie = addEnv "HTTP_COOKIE" $ lookup fkCookie headers query = BS.unpack . safeTail . rawQueryString @@ -170,14 +169,14 @@ addEnv _ Nothing envs = envs addEnv key (Just val) envs = (key,BS.unpack val) : envs -pathinfoToCGI :: ByteString -> ByteString -> ByteString -> (FilePath, String, String) +pathinfoToCGI :: Path -> Path -> Path -> (FilePath, String, String) pathinfoToCGI src dst path = (prog, scriptName, pathinfo) where - path' = BS.drop (BS.length src) path - (prog',pathinfo') = BS.breakByte pathSep path' - prog = BS.unpack (dst prog') - scriptName = BS.unpack (src prog') - pathinfo = BS.unpack pathinfo' + path' = path <\> src + (prog',pathinfo') = breakAtSeparator path' + prog = pathString (dst prog') + scriptName = pathString (src prog') + pathinfo = pathString pathinfo' ---------------------------------------------------------------- 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 @@ -16,7 +16,9 @@ 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 ---------------------------------------------------------------- @@ -37,14 +39,49 @@ ---------------------------------------------------------------- -textPlain :: ResponseHeaders -textPlain = [("Content-Type", "text/plain")] +textPlainHeader :: ResponseHeaders +textPlainHeader = [("Content-Type", "text/plain")] +textHtmlHeader :: ResponseHeaders +textHtmlHeader = [("Content-Type", "text/html")] + +locationHeader :: ByteString -> ResponseHeaders +locationHeader url = [("Location", url)] + +addServer :: ClassicAppSpec -> ResponseHeaders -> ResponseHeaders +addServer cspec hdr = ("Server", softwareName cspec) : hdr + +-- FIXME: the case where "Via:" already exists +addVia :: ClassicAppSpec -> Request -> ResponseHeaders -> ResponseHeaders +addVia cspec req hdr = ("Via", val) : hdr + where + ver = httpVersion req + showBS = BS.pack . show + val = BS.concat [ + showBS (httpMajor ver) + , "." + , showBS (httpMinor ver) + , " " + , serverName req + , " (" + , softwareName cspec + , ")" + ] + +addForwardedFor :: Request -> ResponseHeaders -> ResponseHeaders +addForwardedFor req hdr = ("X-Forwarded-For", addr) : hdr + where + addr = BS.pack . showSockAddr . remoteHost $ req + +addLength :: Integer -> ResponseHeaders -> ResponseHeaders +addLength len hdr = ("Content-Length", BS.pack . show $ len) : hdr + newHeader :: Bool -> ByteString -> HTTPDate -> ResponseHeaders -newHeader ishtml file mtime = [ - ("Content-Type", if ishtml then "text/html" else mimeType file) - , ("Last-Modified", formatHTTPDate mtime) - ] +newHeader ishtml file mtime + | ishtml = lastMod : textHtmlHeader + | otherwise = lastMod : [("Content-Type", mimeType file)] + where + lastMod = ("Last-Modified", formatHTTPDate mtime) mimeType :: ByteString -> MimeType mimeType file =fromMaybe defaultMimeType . foldr1 mplus . map lok $ targets 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 @@ -4,21 +4,30 @@ fileApp ) where +import Control.Applicative import Control.Monad.IO.Class (liftIO) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS hiding (unpack, pack) -import qualified Data.ByteString.Char8 as BS (pack) +import qualified Data.ByteString.Char8 as BS (pack, concat) import qualified Data.ByteString.Lazy.Char8 as BL (length) import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.FileInfo import Network.Wai.Application.Classic.MaybeIter +import Network.Wai.Application.Classic.Status import Network.Wai.Application.Classic.Types import Network.Wai.Application.Classic.Utils ---------------------------------------------------------------- +data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang] + +langSuffixes :: Request -> [Lang] +langSuffixes req = map (\x -> (<.> x)) langs ++ [id, (<.> "en")] + where + langs = map fromByteString $ languages req + +---------------------------------------------------------------- + {-| Handle GET and HEAD for a static file. @@ -38,134 +47,145 @@ If-Modified-Since:, Range:, If-Range:, If-Unmodified-Since:. -} -fileApp :: AppSpec -> FileRoute -> Application -fileApp spec filei req = do - RspSpec st hdr body <- case method of - "GET" -> processGET spec req file ishtml rfile - "HEAD" -> processHEAD spec req file ishtml rfile +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 - let hdr'= addServer hdr - (response, mlen) = case body of - NoBody -> (responseLBS st hdr' "", Nothing) - BodyLBS bd -> - let len = fromIntegral $ BL.length bd - in (responseLBS st hdr' bd, Just len) - BodyFile afile rng -> - let (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 hdr' len - in (ResponseFile st hdr'' afile mfp, Just len) - liftIO $ logger spec req st mlen + (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 + liftIO $ logger cspec req st mlen return response where + hinfo = HandlerInfo spec req file langs method = requestMethod req path = pathinfoToFilePath req filei file = addIndex spec path ishtml = isHTML spec file rfile = redirectPath spec path - addServer hdr = ("Server", softwareName spec) : hdr - addLength hdr len = ("Content-Length", BS.pack . show $ len) : hdr - ----------------------------------------------------------------- - -type Lang = Maybe ByteString - -langSuffixes :: Request -> [Lang] -langSuffixes req = map (Just . BS.cons 46) (languages req) ++ [Nothing, Just ".en"] -- '.' + langs = langSuffixes req + noBody st = (responseLBS st hdr "", Nothing) + where + hdr = addServer cspec [] + statusBody st StatusNone = noBody st + statusBody st (StatusByteString bd) = (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) + 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) + 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 ---------------------------------------------------------------- -processGET :: AppSpec -> Request -> ByteString -> Bool -> Maybe ByteString -> Rsp -processGET spec req file ishtml rfile = runAny [ - tryGet spec req file ishtml - , tryRedirect spec req rfile +processGET :: HandlerInfo -> Bool -> Maybe Path -> Rsp +processGET hinfo ishtml rfile = runAny [ + tryGet hinfo ishtml + , tryRedirect hinfo rfile , just notFound ] -tryGet :: AppSpec -> Request -> ByteString -> Bool -> MRsp -tryGet spec req file True = runAnyMaybe $ map (tryGetFile spec req file True) langs - where - langs = langSuffixes req -tryGet spec req file False = tryGetFile spec req file False Nothing +tryGet :: HandlerInfo -> Bool -> MRsp +tryGet hinfo@(HandlerInfo _ _ _ langs) True = + runAnyMaybe $ map (tryGetFile hinfo True) langs +tryGet hinfo False = tryGetFile hinfo False id -tryGetFile :: AppSpec -> Request -> ByteString -> Bool -> Lang -> MRsp -tryGetFile spec req file ishtml mlang = do - let file' = maybe file (file +++) mlang +tryGetFile :: HandlerInfo -> Bool -> Lang -> MRsp +tryGetFile (HandlerInfo spec req file _) ishtml lang = do + let file' = lang file liftIO (getFileInfo spec file') |>| \finfo -> do let mtime = fileInfoTime finfo size = fileInfoSize finfo sfile = fileInfoName finfo - hdr = newHeader ishtml file mtime + hdr = newHeader ishtml (pathByteString file) mtime Just pst = ifmodified req size mtime -- never Nothing ||| ifunmodified req size mtime ||| ifrange req size mtime ||| unconditional req size mtime case pst of Full st - | st == statusOK -> just $ RspSpec statusOK hdr (BodyFile sfile (Entire size)) - | otherwise -> just $ RspSpec st hdr NoBody + | st == statusOK -> just $ RspSpec statusOK (BodyFile hdr sfile (Entire size)) + | otherwise -> just $ RspSpec st (BodyFileNoBody hdr) - Partial skip len -> just $ RspSpec statusPartialContent hdr (BodyFile sfile (Part skip len)) + Partial skip len -> just $ RspSpec statusPartialContent (BodyFile hdr sfile (Part skip len)) ---------------------------------------------------------------- -processHEAD :: AppSpec -> Request -> ByteString -> Bool -> Maybe ByteString -> Rsp -processHEAD spec req file ishtml rfile = runAny [ - tryHead spec req file ishtml - , tryRedirect spec req rfile - , just notFound +processHEAD :: HandlerInfo -> Bool -> Maybe Path -> Rsp +processHEAD hinfo ishtml rfile = runAny [ + tryHead hinfo ishtml + , tryRedirect hinfo rfile + , just notFoundNoBody ] -tryHead :: AppSpec -> Request -> ByteString -> Bool -> MRsp -tryHead spec req file True = runAnyMaybe $ map (tryHeadFile spec req file True) langs - where - langs = langSuffixes req -tryHead spec req file False= tryHeadFile spec req file False Nothing +tryHead :: HandlerInfo -> Bool -> MRsp +tryHead hinfo@(HandlerInfo _ _ _ langs) True = + runAnyMaybe $ map (tryHeadFile hinfo True) langs +tryHead hinfo False= tryHeadFile hinfo False id -tryHeadFile :: AppSpec -> Request -> ByteString -> Bool -> Lang -> MRsp -tryHeadFile spec req file ishtml mlang = do - let file' = maybe file (file +++) mlang +tryHeadFile :: HandlerInfo -> Bool -> Lang -> MRsp +tryHeadFile (HandlerInfo spec req file _) ishtml lang = do + let file' = lang file liftIO (getFileInfo spec file') |>| \finfo -> do let mtime = fileInfoTime finfo size = fileInfoSize finfo - hdr = newHeader ishtml file mtime + hdr = newHeader ishtml (pathByteString file) mtime Just pst = ifmodified req size mtime -- never Nothing ||| Just (Full statusOK) case pst of - Full st -> just $ RspSpec st hdr NoBody + Full st -> just $ RspSpec st (BodyFileNoBody hdr) _ -> nothing -- never reached ---------------------------------------------------------------- -tryRedirect :: AppSpec -> Request -> Maybe ByteString -> MRsp -tryRedirect _ _ Nothing = nothing -tryRedirect spec req (Just file) = - runAnyMaybe $ map (tryRedirectFile spec req file) langs +tryRedirect :: HandlerInfo -> Maybe Path -> MRsp +tryRedirect _ Nothing = nothing +tryRedirect (HandlerInfo spec req _ langs) (Just file) = + runAnyMaybe $ map (tryRedirectFile hinfo) langs where - langs = langSuffixes req + hinfo = HandlerInfo spec req file langs -tryRedirectFile :: AppSpec -> Request -> ByteString -> Lang -> MRsp -tryRedirectFile spec req file mlang = do - let file' = maybe file (file +++) mlang +tryRedirectFile :: HandlerInfo -> Lang -> MRsp +tryRedirectFile (HandlerInfo spec req file _) lang = do + let file' = lang file minfo <- liftIO $ getFileInfo spec file' case minfo of Nothing -> nothing - Just _ -> just $ RspSpec statusMovedPermanently hdr NoBody + Just _ -> just $ RspSpec statusMovedPermanently (BodyFileNoBody hdr) where - hdr = [("Location", redirectURL)] - redirectURL = "http://" - +++ serverName req - +++ ":" - +++ (BS.pack . show . serverPort) req - +++ rawPathInfo req - +++ "/" + hdr = locationHeader redirectURL + redirectURL = BS.concat [ "http://" + , serverName req + , ":" + , (BS.pack . show . serverPort) req + , rawPathInfo req + , "/" + ] ---------------------------------------------------------------- notFound :: RspSpec -notFound = RspSpec statusNotFound textPlain (BodyLBS "Not Found\r\n") +notFound = RspSpec statusNotFound BodyStatus +notFoundNoBody :: RspSpec +notFoundNoBody = RspSpec statusNotFound NoBody + notAllowed :: RspSpec -notAllowed = RspSpec statusNotAllowed textPlain (BodyLBS "Method Not Allowed\r\n") +notAllowed = RspSpec statusNotAllowed BodyStatus 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 @@ -1,7 +1,6 @@ module Network.Wai.Application.Classic.FileInfo where import Data.ByteString (ByteString) -import qualified Data.ByteString as BS hiding (unpack) import Network.HTTP.Date import Network.HTTP.Types import Network.Wai @@ -48,20 +47,20 @@ ---------------------------------------------------------------- -pathinfoToFilePath :: Request -> FileRoute -> ByteString +pathinfoToFilePath :: Request -> FileRoute -> Path pathinfoToFilePath req filei = path' where - path = rawPathInfo req + path = fromByteString $ rawPathInfo req src = fileSrc filei dst = fileDst filei - path' = dst BS.drop (BS.length src) path + path' = dst (path <\> src) -addIndex :: AppSpec -> ByteString -> ByteString +addIndex :: FileAppSpec -> Path -> Path addIndex spec path | hasTrailingPathSeparator path = path indexFile spec | otherwise = path -redirectPath :: AppSpec -> ByteString -> Maybe ByteString +redirectPath :: FileAppSpec -> Path -> Maybe Path redirectPath spec path | hasTrailingPathSeparator path = Nothing | otherwise = Just (path indexFile spec) diff --git a/Network/Wai/Application/Classic/Lang.hs b/Network/Wai/Application/Classic/Lang.hs --- a/Network/Wai/Application/Classic/Lang.hs +++ b/Network/Wai/Application/Classic/Lang.hs @@ -5,7 +5,7 @@ import Control.Applicative hiding (many, optional) import Data.Attoparsec (Parser, takeWhile, parse, feed, Result(..)) import Data.Attoparsec.Char8 (char, string, count, many, space, digit, option, sepBy1) -import Data.ByteString.Char8 hiding (map, count, take, takeWhile) +import Data.ByteString.Char8 hiding (map, count, take, takeWhile, notElem) import Data.List (sortBy) import Data.Ord import Prelude hiding (takeWhile) @@ -26,7 +26,7 @@ rangeQvalue = (,) <$> languageRange <*> quality languageRange :: Parser ByteString -languageRange = takeWhile (\w -> w /= 32 && w /= 44 && w /= 59) +languageRange = takeWhile (`notElem` [32, 44, 59]) quality :: Parser Int quality = option 1000 (string ";q=" *> qvalue) diff --git a/Network/Wai/Application/Classic/MaybeIter.hs b/Network/Wai/Application/Classic/MaybeIter.hs --- a/Network/Wai/Application/Classic/MaybeIter.hs +++ b/Network/Wai/Application/Classic/MaybeIter.hs @@ -14,15 +14,15 @@ ---------------------------------------------------------------- -runAny :: [MRsp] -> Iteratee ByteString IO RspSpec +runAny :: Monad m => [m (Maybe a)] -> m a runAny [] = error "runAny" runAny (a:as) = do - mrsp <- a - case mrsp of + mres <- a + case mres of Nothing -> runAny as - Just rsp -> return rsp + Just res -> return res -runAnyMaybe :: [MRsp] -> MRsp +runAnyMaybe :: Monad m => [m (Maybe a)] -> m (Maybe a) runAnyMaybe [] = nothing runAnyMaybe (a:as) = do mx <- a diff --git a/Network/Wai/Application/Classic/RevProxy.hs b/Network/Wai/Application/Classic/RevProxy.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Application/Classic/RevProxy.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Application.Classic.RevProxy (revProxyApp) where + +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as BB (fromByteString) +import Control.Applicative +import Control.Exception +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Enumerator (Iteratee, run_, (=$), ($$), ($=), enumList) +import qualified Data.Enumerator.List as EL +import qualified Network.HTTP.Enumerator as H +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Application.Classic.Field +import Network.Wai.Application.Classic.Types +import Network.Wai.Application.Classic.Utils +import Prelude hiding (catch) + +toHTTPRequest :: Request -> RevProxyRoute -> BL.ByteString -> H.Request m +toHTTPRequest req route lbs = H.def { + H.host = revProxyDomain route + , H.port = revProxyPort route + , H.secure = isSecure req + , H.checkCerts = H.defaultCheckCerts + , H.requestHeaders = addForwardedFor req $ requestHeaders req + , H.path = pathByteString path' + , H.queryString = queryString req + , H.requestBody = H.RequestBodyLBS lbs + , H.method = requestMethod req + , H.proxy = Nothing + , H.rawBody = False + , H.decompress = H.alwaysDecompress + } + where + path = fromByteString $ rawPathInfo req + src = revProxySrc route + dst = revProxyDst route + path' = dst (path <\> src) + +{-| + Relaying any requests as reverse proxy. +-} + +revProxyApp :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application +revProxyApp cspec spec route req = return $ ResponseEnumerator $ \respBuilder -> do + -- FIXME: is this stored-and-forward? + lbs <- BL.fromChunks <$> run_ EL.consume + run_ (H.http (toHTTPRequest req route lbs) (fromBS cspec req respBuilder) mgr) + `catch` badGateway cspec req respBuilder + where + mgr = revProxyManager spec + +fromBS :: ClassicAppSpec -> Request + -> (Status -> ResponseHeaders -> Iteratee Builder IO a) + -> (Status -> ResponseHeaders -> Iteratee ByteString IO a) +fromBS cspec req f s h = do + liftIO $ logger cspec req s Nothing -- FIXME body length + EL.map BB.fromByteString =$ f s h' + where + h' = addVia cspec req $ filter p h + p ("Content-Encoding", _) = False + p _ = True + +badGateway :: ClassicAppSpec -> Request + -> (Status -> ResponseHeaders -> Iteratee Builder IO a) + -> SomeException -> IO a +badGateway cspec req builder _ = do + liftIO $ logger cspec req statusBadGateway Nothing -- FIXME body length + run_ $ bdy $$ builder statusBadGateway hdr + where + hdr = addServer cspec textPlainHeader + bdy = enumList 1 ["Bad Gateway\r\n"] $= EL.map BB.fromByteString diff --git a/Network/Wai/Application/Classic/Status.hs b/Network/Wai/Application/Classic/Status.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Application/Classic/Status.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Application.Classic.Status (getStatusInfo) where + +import Control.Arrow +import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Lazy.Char8 () +import qualified Data.StaticHash as M +import Network.HTTP.Types +import Network.Wai.Application.Classic.MaybeIter +import Network.Wai.Application.Classic.Types +import Network.Wai.Application.Classic.Utils + +---------------------------------------------------------------- + +getStatusInfo :: ClassicAppSpec -> FileAppSpec -> [Lang] -> Status -> IO StatusInfo +getStatusInfo cspec spec langs st = runAny [ + getStatusFile getF dir code langs + , return (getStatusBS code) + , return (Just StatusNone) + ] + where + dir = statusFileDir cspec + getF = getFileInfo spec + code = statusCode st + +---------------------------------------------------------------- + +statusList :: [Status] +statusList = [ + statusNotAllowed -- 405 File + , statusNotFound -- 404 File + , statusServerError -- 500 CGI + , statusBadGateway -- 502 RevProxy + ] + +---------------------------------------------------------------- + +statusBSMap :: M.StaticHash Int StatusInfo +statusBSMap = M.fromList $ map (statusCode &&& toRspBody) statusList + where + toRspBody s = StatusByteString $ BL.fromChunks [statusMessage s, "\r\n"] + +getStatusBS :: Int -> Maybe StatusInfo +getStatusBS code = M.lookup code statusBSMap + +---------------------------------------------------------------- + +statusFileMap :: M.StaticHash Int Path +statusFileMap = M.fromList $ map (statusCode &&& toPath) statusList + where + toPath s = fromString $ show (statusCode s) ++ ".html" + +getStatusFile :: (Path -> IO (Maybe FileInfo)) -> Path -> Int -> [Lang] -> IO (Maybe StatusInfo) +getStatusFile getF dir code langs = try mfiles + where + mfiles = case M.lookup code statusFileMap of + Nothing -> [] + Just file -> map ($ (dir file)) langs + try [] = return Nothing + try (f:fs) = do + mfi <- getF f + case mfi of + Nothing -> try fs + Just fi -> return . Just $ StatusFile f (fileInfoSize fi) + +---------------------------------------------------------------- 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 @@ -3,61 +3,102 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) import Network.HTTP.Date +import qualified Network.HTTP.Enumerator as H import Network.HTTP.Types +import Network.Wai.Application.Classic.Utils import Network.Wai.Logger.Prefork -data AppSpec = AppSpec { +---------------------------------------------------------------- + +data ClassicAppSpec = ClassicAppSpec { -- | Name specified to Server: in HTTP response. softwareName :: ByteString - -- | A file name of an index file. - , indexFile :: ByteString - -- | Whether this is an HTML or not. - , isHTML :: ByteString -> Bool -- | A function for logging. The third argument is a body size. , logger :: ApacheLogger - -- | A function to obtain information about a file. - , getFileInfo :: ByteString -> IO (Maybe FileInfo) + -- | A function to get the HTTP body of status. + , statusFileDir :: Path } +data StatusInfo = + -- | HTTP status body is created from 'LB.ByteString'. + StatusByteString BL.ByteString + -- | HTTP status body is created from 'FilePath'. + | StatusFile Path Integer + -- | No HTTP status body. + | StatusNone + +---------------------------------------------------------------- + +data FileAppSpec = FileAppSpec { + -- | A file name of an index file. + indexFile :: Path + -- | Whether this is an HTML or not. + , isHTML :: Path -> Bool + -- | A function to obtain information about a file + , getFileInfo :: Path -> IO (Maybe FileInfo) + } + data FileInfo = FileInfo { - fileInfoName :: FilePath + fileInfoName :: Path , fileInfoSize :: Integer , fileInfoTime :: HTTPDate } data FileRoute = FileRoute { - -- | Path prefix to be matched to 'pathInfo'. - fileSrc :: ByteString + -- | Path prefix to be matched to 'rawPathInfo'. + fileSrc :: Path -- | Path prefix to an actual file system. - , fileDst :: ByteString + , fileDst :: Path } +---------------------------------------------------------------- + data CgiRoute = CgiRoute { - -- | Path prefix to be matched to 'pathInfo'. - cgiSrc :: ByteString + -- | Path prefix to be matched to 'rawPathInfo'. + cgiSrc :: Path -- | Path prefix to an actual file system. - , cgiDst :: ByteString + , cgiDst :: Path } +---------------------------------------------------------------- + +data RevProxyAppSpec = RevProxyAppSpec { + -- | Connection manager + revProxyManager :: H.Manager + } + +data RevProxyRoute = RevProxyRoute { + -- | Path prefix to be matched to 'rawPathInfo'. + revProxySrc :: Path + -- | Destination path prefix. + , revProxyDst :: Path + -- | Destination domain name. + , revProxyDomain :: ByteString + -- | Destination port number. + , revProxyPort :: Int + } + +---------------------------------------------------------------- + data RspSpec = RspSpec { -- | Response status. rspStatus :: Status - -- | Response headers. - , rspHeaders :: ResponseHeaders -- | Response body. , rspBody :: RspBody } data RspBody = - -- | Body does not exist. NoBody - -- | Body as Lazy ByteString. - | BodyLBS BL.ByteString - -- | Body as a file. - | BodyFile String Range + | BodyStatus + | BodyFileNoBody ResponseHeaders + | BodyFile ResponseHeaders Path Range data Range = -- | Entire file showing its file size Entire Integer -- | A part of a file taking offset and length | Part Integer Integer + +---------------------------------------------------------------- + +type Lang = Path -> Path diff --git a/Network/Wai/Application/Classic/Utils.hs b/Network/Wai/Application/Classic/Utils.hs --- a/Network/Wai/Application/Classic/Utils.hs +++ b/Network/Wai/Application/Classic/Utils.hs @@ -1,30 +1,129 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Utils ( - hasTrailingPathSeparator, pathSep - , (+++), () + Path(..) + , fromString, fromByteString + , (+++), (), (<\>), (<.>) + , breakAtSeparator, hasTrailingPathSeparator + , isSuffixOf ) where +import qualified Blaze.ByteString.Builder as BB import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Char8 () +import qualified Data.ByteString as BS (null, last, append, drop, length, breakByte, isSuffixOf) +import qualified Data.ByteString.Char8 as BS (pack, unpack) +import Data.Monoid +import Data.String import Data.Word +---------------------------------------------------------------- + +data Path = Path { + pathString :: FilePath + , pathByteString :: ByteString + } + +instance IsString Path where + fromString path = Path { + pathString = path + , pathByteString = BS.pack path + } + +fromByteString :: ByteString -> Path +fromByteString path = Path { + pathString = BS.unpack path + , pathByteString = path + } + +pathDot :: Word8 +pathDot = 46 + pathSep :: Word8 pathSep = 47 -hasTrailingPathSeparator :: ByteString -> Bool -hasTrailingPathSeparator "" = False +{-| + Checking if the path ends with the path separator. +-} +hasTrailingPathSeparator :: Path -> Bool hasTrailingPathSeparator path - | BS.last path == pathSep = True - | otherwise = False + | BS.null bs = False + | BS.last bs == pathSep = True + | otherwise = False + where + bs = pathByteString path infixr +++ -(+++) :: ByteString -> ByteString -> ByteString -(+++) = BS.append +{-| + Appending. +-} -() :: ByteString -> ByteString -> ByteString -s1 s2 - | hasTrailingPathSeparator s1 = s1 +++ s2 - | otherwise = s1 +++ (pathSep `BS.cons` s2) +(+++) :: Path -> Path -> Path +p1 +++ p2 = Path { + pathString = BS.unpack p + , pathByteString = p + } + where + p = pathByteString p1 `BS.append` pathByteString p2 + +{-| + Appending with the file separator. +-} + +() :: Path -> Path -> Path +p1 p2 + | hasTrailingPathSeparator p1 = p1 +++ p2 + | otherwise = Path { + pathString = BS.unpack p + , pathByteString = p + } + where + p1' = pathByteString p1 + p2' = pathByteString p2 + p = BB.toByteString (BB.fromByteString p1' + `mappend` BB.fromWord8 pathSep + `mappend` BB.fromByteString p2') + +{-| + Removing prefix. The prefix of the second argument is removed + from the first argument. +-} +(<\>) :: Path -> Path -> Path +p1 <\> p2 = Path { + pathString = BS.unpack p + , pathByteString = p + } + where + p1' = pathByteString p1 + p2' = pathByteString p2 + p = BS.drop (BS.length p2') p1' + +{-| + Adding suffix. +-} +(<.>) :: Path -> Path -> Path +p1 <.> p2 = Path { + pathString = BS.unpack p + , pathByteString = p + } + where + p1' = pathByteString p1 + p2' = pathByteString p2 + p = BB.toByteString (BB.fromByteString p1' + `mappend` BB.fromWord8 pathDot + `mappend` BB.fromByteString p2') + +{-| + Breaking at the first path separator. +-} +breakAtSeparator :: Path -> (Path,Path) +breakAtSeparator p = (fromByteString r1, fromByteString r2) + where + p' = pathByteString p + (r1,r2) = BS.breakByte pathSep p' + +isSuffixOf :: Path -> Path -> Bool +isSuffixOf p1 p2 = p1' `BS.isSuffixOf` p2' + where + p1' = pathByteString p1 + p2' = pathByteString p2 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.3.5 +Version: 0.4.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -26,6 +26,8 @@ Network.Wai.Application.Classic.Lang Network.Wai.Application.Classic.MaybeIter Network.Wai.Application.Classic.Range + Network.Wai.Application.Classic.RevProxy + Network.Wai.Application.Classic.Status Network.Wai.Application.Classic.Types Network.Wai.Application.Classic.Utils Build-Depends: base >= 4 && < 5, process, @@ -35,7 +37,8 @@ wai, enumerator >= 0.4.9, bytestring, blaze-builder, wai-app-static >= 0.3, http-types, http-date, - case-insensitive, static-hash, wai-logger + case-insensitive, static-hash, wai-logger, + http-enumerator Source-Repository head Type: git Location: https://github.com/kazu-yamamoto/wai-app-file-cgi