wai-app-file-cgi 0.3.5 → 0.4.0
raw patch · 12 files changed
+519/−170 lines, 12 filesdep +http-enumerator
Dependencies added: http-enumerator
Files
- Network/Wai/Application/Classic.hs +12/−3
- Network/Wai/Application/Classic/CGI.hs +30/−31
- Network/Wai/Application/Classic/Field.hs +43/−6
- Network/Wai/Application/Classic/File.hs +100/−80
- Network/Wai/Application/Classic/FileInfo.hs +5/−6
- Network/Wai/Application/Classic/Lang.hs +2/−2
- Network/Wai/Application/Classic/MaybeIter.hs +5/−5
- Network/Wai/Application/Classic/RevProxy.hs +75/−0
- Network/Wai/Application/Classic/Status.hs +67/−0
- Network/Wai/Application/Classic/Types.hs +62/−21
- Network/Wai/Application/Classic/Utils.hs +113/−14
- wai-app-file-cgi.cabal +5/−2
Network/Wai/Application/Classic.hs view
@@ -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
Network/Wai/Application/Classic/CGI.hs view
@@ -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' ----------------------------------------------------------------
Network/Wai/Application/Classic/Field.hs view
@@ -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
Network/Wai/Application/Classic/File.hs view
@@ -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
Network/Wai/Application/Classic/FileInfo.hs view
@@ -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)
Network/Wai/Application/Classic/Lang.hs view
@@ -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)
Network/Wai/Application/Classic/MaybeIter.hs view
@@ -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
+ Network/Wai/Application/Classic/RevProxy.hs view
@@ -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
+ Network/Wai/Application/Classic/Status.hs view
@@ -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)++----------------------------------------------------------------
Network/Wai/Application/Classic/Types.hs view
@@ -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
Network/Wai/Application/Classic/Utils.hs view
@@ -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
wai-app-file-cgi.cabal view
@@ -1,5 +1,5 @@ Name: wai-app-file-cgi-Version: 0.3.5+Version: 0.4.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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