wai-app-file-cgi 0.8.7 → 2.0.0
raw patch · 13 files changed
+285/−277 lines, 13 filesdep +arraydep +data-defaultdep +http-clientdep −date-cachedep −http-conduitdep −resourcetdep ~waidep ~warp
Dependencies added: array, data-default, http-client, http-client-conduit, sockaddr
Dependencies removed: date-cache, http-conduit, resourcet, wai-logger
Dependency ranges changed: wai, warp
Files
- Network/Wai/Application/Classic.hs +4/−6
- Network/Wai/Application/Classic/CGI.hs +36/−30
- Network/Wai/Application/Classic/Conduit.hs +3/−3
- Network/Wai/Application/Classic/Def.hs +3/−8
- Network/Wai/Application/Classic/EventSource.hs +6/−7
- Network/Wai/Application/Classic/Field.hs +12/−38
- Network/Wai/Application/Classic/File.hs +47/−46
- Network/Wai/Application/Classic/FileInfo.hs +20/−20
- Network/Wai/Application/Classic/Header.hs +53/−18
- Network/Wai/Application/Classic/RevProxy.hs +81/−72
- Network/Wai/Application/Classic/Types.hs +6/−10
- test/Spec.hs +2/−0
- wai-app-file-cgi.cabal +12/−19
Network/Wai/Application/Classic.hs view
@@ -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
Network/Wai/Application/Classic/CGI.hs view
@@ -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 {-|
Network/Wai/Application/Classic/Conduit.hs view
@@ -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
Network/Wai/Application/Classic/Def.hs view
@@ -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 ----------------------------------------------------------------
Network/Wai/Application/Classic/EventSource.hs view
@@ -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
Network/Wai/Application/Classic/Field.hs view
@@ -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
Network/Wai/Application/Classic/File.hs view
@@ -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 ":<port>" if it is not 80.+ , host , rawPathInfo req , "/" ]+ where+ host = fromMaybe "" $ requestHeaderHost req ----------------------------------------------------------------
Network/Wai/Application/Classic/FileInfo.hs view
@@ -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) ----------------------------------------------------------------
Network/Wai/Application/Classic/Header.hs view
@@ -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
Network/Wai/Application/Classic/RevProxy.hs view
@@ -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+-}
Network/Wai/Application/Classic/Types.hs view
@@ -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) ----------------------------------------------------------------
test/Spec.hs view
@@ -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
wai-app-file-cgi.cabal view
@@ -1,27 +1,21 @@ Name: wai-app-file-cgi-Version: 0.8.7+Version: 2.0.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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