wai-app-file-cgi-0.8.3/0000755000000000000000000000000012117237173012727 5ustar0000000000000000wai-app-file-cgi-0.8.3/LICENSE0000644000000000000000000000276512117237173013746 0ustar0000000000000000Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. wai-app-file-cgi-0.8.3/Setup.hs0000644000000000000000000000005612117237173014364 0ustar0000000000000000import Distribution.Simple main = defaultMain wai-app-file-cgi-0.8.3/wai-app-file-cgi.cabal0000644000000000000000000000726612117237173016741 0ustar0000000000000000Name: wai-app-file-cgi Version: 0.8.3 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: File/CGI/Rev Proxy App of WAI Description: This WAI application library handles static files, executes CGI scripts, and serves as a reverse proxy. Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Web, Yesod Cabal-Version: >= 1.10 Build-Type: Simple Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.Wai.Application.Classic Other-Modules: Network.Wai.Application.Classic.CGI Network.Wai.Application.Classic.Conduit Network.Wai.Application.Classic.Def Network.Wai.Application.Classic.EventSource Network.Wai.Application.Classic.Field Network.Wai.Application.Classic.File Network.Wai.Application.Classic.FileInfo Network.Wai.Application.Classic.Header Network.Wai.Application.Classic.Lang Network.Wai.Application.Classic.Path Network.Wai.Application.Classic.Range Network.Wai.Application.Classic.Redirect Network.Wai.Application.Classic.RevProxy Network.Wai.Application.Classic.Status Network.Wai.Application.Classic.Types Build-Depends: base >= 4 && < 5 , attoparsec >= 0.10.0.0 , attoparsec-conduit , blaze-builder , blaze-html , bytestring , case-insensitive , conduit >= 0.5 , containers , date-cache , directory , fast-logger >= 0.3 , filepath , http-conduit >= 1.9 , http-date , http-types >= 0.7 , io-choice , lifted-base , mime-types , network , process , resourcet , static-hash , text , transformers , unix , wai >= 1.2 , wai-logger , word8 Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test Ghc-Options: -threaded -Wall Main-Is: doctests.hs Build-Depends: base , doctest >= 0.9.3 Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test Ghc-Options: -threaded -Wall Main-Is: Spec.hs Other-Modules: ClassicSpec Build-Depends: base , bytestring , conduit , directory , filepath , hspec >= 1.3 , http-conduit , http-types , unix , wai , wai-app-file-cgi , warp Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/wai-app-file-cgi wai-app-file-cgi-0.8.3/Network/0000755000000000000000000000000012117237173014360 5ustar0000000000000000wai-app-file-cgi-0.8.3/Network/Wai/0000755000000000000000000000000012117237173015100 5ustar0000000000000000wai-app-file-cgi-0.8.3/Network/Wai/Application/0000755000000000000000000000000012117237173017343 5ustar0000000000000000wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic.hs0000644000000000000000000000165412117237173021266 0ustar0000000000000000{-| WAI (Web Application Interface) Application for static files and CGI. -} module Network.Wai.Application.Classic ( -- * Common ClassicAppSpec(..) , defaultClassicAppSpec , StatusInfo(..) -- * Files , FileAppSpec(..) , defaultFileAppSpec , FileInfo(..) , FileRoute(..) , fileApp -- * Redirect , RedirectRoute(..) , redirectApp -- * CGI , CgiAppSpec(..) , defaultCgiAppSpec , CgiRoute(..) , cgiApp -- * Reverse Proxy , RevProxyAppSpec(..) , RevProxyRoute(..) , revProxyApp -- * Path , module Network.Wai.Application.Classic.Path -- * Misc , redirectHeader ) where import Network.Wai.Application.Classic.CGI import Network.Wai.Application.Classic.File import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Redirect import Network.Wai.Application.Classic.RevProxy import Network.Wai.Application.Classic.Types import Network.Wai.Application.Classic.Def wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/0000755000000000000000000000000012117237173020724 5ustar0000000000000000wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/CGI.hs0000644000000000000000000001457012117237173021671 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables #-} module Network.Wai.Application.Classic.CGI ( cgiApp ) where import Control.Exception (SomeException, IOException, try) import Control.Exception.Lifted (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 Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Network.HTTP.Types 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 Prelude hiding (catch) import System.Environment import System.IO import System.Process ---------------------------------------------------------------- type ENVVARS = [(String,String)] gatewayInterface :: String gatewayInterface = "CGI/1.1" ---------------------------------------------------------------- {-| Handle GET and POST for CGI. The program to link this library must ignore SIGCHLD as follows: > installHandler sigCHLD Ignore Nothing -} cgiApp :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application cgiApp cspec spec cgii req = case method of Right GET -> cgiApp' False cspec spec cgii req Right POST -> cgiApp' True cspec spec cgii req _ -> return $ responseLBS methodNotAllowed405 textPlainHeader "Method Not Allowed\r\n" -- xxx where method = 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 where register3 (rhdl,whdl,pid) = do _ <- register $ terminateProcess pid -- SIGTERM _ <- register $ hClose rhdl keyw <- register $ hClose whdl return (rhdl,whdl,release keyw) ---------------------------------------------------------------- type TRYPATH = Either IOException String toCGI :: Handle -> Request -> ResourceT IO () toCGI whdl req = requestBody req $$ CB.sinkHandle whdl fromCGI :: Handle -> ClassicAppSpec -> Application fromCGI rhdl cspec req = do (src', hs) <- cgiHeader `catch` recover let (st, hdr, hasBody) = case check hs of Nothing -> (internalServerError500,[],False) Just (s,h) -> (s,h,True) hdr' = addServer cspec hdr liftIO $ logger cspec req st Nothing let src = if hasBody then src' else CL.sourceNull return $ ResponseSource st hdr' src where check hs = lookup hContentType hs >> case lookup hStatus hs of Nothing -> Just (ok200, hs) Just l -> toStatus l >>= \s -> Just (s,hs') where hs' = filter (\(k,_) -> k /= hStatus) hs toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s) emptyHeader = [] recover (_ :: SomeException) = return (CL.sourceNull, emptyHeader) cgiHeader = do (rsrc,hs) <- CB.sourceHandle rhdl $$+ parseHeader src <- toResponseSource rsrc return (src,hs) ---------------------------------------------------------------- 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 (Just whdl,Just rhdl,_,pid) <- createProcess $ proSpec naddr epath hSetEncoding rhdl latin1 hSetEncoding whdl latin1 return (rhdl, whdl, pid) where proSpec naddr epath = CreateProcess { cmdspec = RawCommand prog [] , cwd = Nothing , env = Just $ makeEnv req naddr scriptName pathinfo (softwareName cspec) epath , std_in = CreatePipe , std_out = CreatePipe , std_err = Inherit , close_fds = True #if __GLASGOW_HASKELL__ >= 702 , create_group = True #endif } (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii) (cgiDst cgii) (fromByteString (rawPathInfo req)) (indexCgi spec) makeEnv :: Request -> NumericAddress -> String -> String -> ByteString -> TRYPATH -> ENVVARS makeEnv req naddr scriptName pathinfo sname epath = addPath epath . addLen . addType . addCookie $ baseEnv where baseEnv = [ ("GATEWAY_INTERFACE", gatewayInterface) , ("SCRIPT_NAME", scriptName) , ("REQUEST_METHOD", BS.unpack . requestMethod $ req) , ("SERVER_NAME", BS.unpack . serverName $ req) , ("SERVER_PORT", show . serverPort $ req) , ("REMOTE_ADDR", naddr) , ("SERVER_PROTOCOL", show . httpVersion $ req) , ("SERVER_SOFTWARE", BS.unpack sname) , ("PATH_INFO", pathinfo) , ("QUERY_STRING", query req) ] headers = requestHeaders req addLen = addEnv "CONTENT_LENGTH" $ lookup hContentLength headers addType = addEnv "CONTENT_TYPE" $ lookup hContentType headers addCookie = addEnv "HTTP_COOKIE" $ lookup hCookie headers addPath (Left _) ev = ev addPath (Right path) ev = ("PATH", path) : ev query = BS.unpack . safeTail . rawQueryString where safeTail "" = "" safeTail bs = BS.tail bs addEnv :: String -> Maybe ByteString -> ENVVARS -> ENVVARS addEnv _ Nothing envs = envs addEnv key (Just val) envs = (key,BS.unpack val) : envs {-| >>> pathinfoToCGI "/cgi-bin/" "/User/cgi-bin/" "/cgi-bin/foo" "index.cgi" ("/User/cgi-bin/foo","/cgi-bin/foo","") >>> pathinfoToCGI "/cgi-bin/" "/User/cgi-bin/" "/cgi-bin/foo/bar" "index.cgi" ("/User/cgi-bin/foo","/cgi-bin/foo","/bar") >>> pathinfoToCGI "/cgi-bin/" "/User/cgi-bin/" "/cgi-bin/" "index.cgi" ("/User/cgi-bin/index.cgi","/cgi-bin/index.cgi","") -} pathinfoToCGI :: Path -> Path -> Path -> Path -> (FilePath, String, String) pathinfoToCGI src dst path index = (prog, scriptName, pathinfo) where path' = path <\> src (prog',pathinfo') | src == path = (index, "") | otherwise = breakAtSeparator path' prog = pathString (dst prog') scriptName = pathString (src prog') pathinfo = pathString pathinfo' wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Conduit.hs0000644000000000000000000000343012117237173022665 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Conduit ( byteStringToBuilder , toResponseSource , parseHeader ) where import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as BB (fromByteString) import Control.Applicative import Data.Attoparsec import Data.ByteString (ByteString) import Data.CaseInsensitive (CI(..), mk) import Data.Conduit import Data.Conduit.Attoparsec import qualified Data.Conduit.List as CL import Data.Word import Network.HTTP.Types ---------------------------------------------------------------- byteStringToBuilder :: ByteString -> Builder byteStringToBuilder = BB.fromByteString ---------------------------------------------------------------- toResponseSource :: ResumableSource (ResourceT IO) ByteString -> (ResourceT IO) (Source (ResourceT IO) (Flush Builder)) toResponseSource rsrc = do (src,_) <- unwrapResumable rsrc return $ src $= CL.map (Chunk . byteStringToBuilder) ---------------------------------------------------------------- parseHeader :: Sink ByteString (ResourceT IO) RequestHeaders parseHeader = sinkParser parseHeader' parseHeader' :: Parser RequestHeaders parseHeader' = stop <|> loop where stop = [] <$ (crlf <|> endOfInput) loop = (:) <$> keyVal <*> parseHeader' type RequestHeader = (CI ByteString, ByteString) keyVal :: Parser RequestHeader keyVal = do key <- takeTill (wcollon==) _ <- word8 wcollon skipWhile (wspace ==) val <- takeTill (`elem` [wlf,wcr]) crlf return (mk key, val) crlf :: Parser () crlf = (cr >> (lf <|> return ())) <|> lf cr :: Parser () cr = () <$ word8 wcr lf :: Parser () lf = () <$ word8 wlf wcollon :: Word8 wcollon = 58 wcr :: Word8 wcr = 13 wlf :: Word8 wlf = 10 wspace :: Word8 wspace = 32 wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Def.hs0000644000000000000000000000420612117237173021760 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Def where import Control.Applicative import Control.Exception import Network.HTTP.Date import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types import Network.Wai.Logger import System.Log.FastLogger.Date import System.Posix -- | -- Default value for 'ClassicAppSpec'. 'softwareName' is \"Classic\". 'logger' does not log at all. 'dater' calls 'epochTime' for every request. 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\". defaultClassicAppSpec :: ClassicAppSpec defaultClassicAppSpec = ClassicAppSpec { softwareName = "Classic" , logger = defaultLogger , dater = defaultDater , statusFileDir = "/usr/local/share/html/status/" } defaultLogger :: ApacheLogger defaultLogger _ _ _ = return () defaultDater :: IO ZonedDate defaultDater = formatHTTPDate . epochTimeToHTTPDate <$> epochTime ---------------------------------------------------------------- -- | -- Default value for 'defaultFileAppSpec'. 'indexFile' is \"index.html\". 'isHTML' matches \"*.html\" and \"*.html\". 'getFileInfo' calls `getFileStatus` for every request. defaultFileAppSpec :: FileAppSpec defaultFileAppSpec = FileAppSpec { indexFile = "index.html" , isHTML = defaultIsHTml , getFileInfo = defaultGetFileInfo } defaultIsHTml :: Path -> Bool defaultIsHTml file = ".html" `isSuffixOf` file || ".htm" `isSuffixOf` file defaultGetFileInfo :: Path -> IO FileInfo defaultGetFileInfo path = do fs <- getFileStatus sfile if not (isDirectory fs) then return FileInfo { fileInfoName = path , fileInfoSize = size fs , fileInfoTime = time fs , fileInfoDate = formatHTTPDate (time fs) } else throwIO $ userError "does not exist" where sfile = pathString path size = fromIntegral . fileSize time = epochTimeToHTTPDate . modificationTime ---------------------------------------------------------------- -- | -- Default value for 'defaultCgiAppSpec'. 'indexCgi' is \"index.cgi\". defaultCgiAppSpec :: CgiAppSpec defaultCgiAppSpec = CgiAppSpec { indexCgi = "index.cgi" } wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/EventSource.hs0000644000000000000000000000423212117237173023523 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.EventSource ( toResponseEventSource ) where import Blaze.ByteString.Builder import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Conduit import qualified Data.Conduit.List as CL lineBreak :: ByteString -> Int -> Maybe Int lineBreak bs n = go where len = BS.length bs go | n >= len = Nothing | otherwise = case bs `BS.index` n of 13 -> go' (n+1) 10 -> Just (n+1) _ -> Nothing go' n' | n' >= len = Just n' | otherwise = case bs `BS.index` n' of 10 -> Just (n'+1) _ -> Just n' -- splitDoubleLineBreak "aaa\n\nbbb" == ["aaa\n\n", "bbb"] -- splitDoubleLineBreak "aaa\n\nbbb\n\n" == ["aaa\n\n", "bbb\n\n", ""] -- splitDoubleLineBreak "aaa\r\n\rbbb\n\r\n" == ["aaa\r\n\r", "bbb\n\r\n", ""] -- splitDoubleLineBreak "aaa" == ["aaa"] -- splitDoubleLineBreak "" == [""] splitDoubleLineBreak :: ByteString -> [ByteString] splitDoubleLineBreak str = go str 0 where go bs n | n < BS.length str = case lineBreak bs n of Nothing -> go bs (n+1) Just n' -> case lineBreak bs n' of Nothing -> go bs (n+1) Just n'' -> let (xs,ys) = BS.splitAt n'' bs in xs:go ys 0 | otherwise = [bs] eventSourceConduit :: Conduit ByteString (ResourceT IO) (Flush Builder) eventSourceConduit = CL.concatMapAccum f "" where f input rest = (last xs, concatMap addFlush $ init xs) where addFlush x = [Chunk (fromByteString x), Flush] 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 wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Field.hs0000644000000000000000000000664712117237173022320 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Field where import Control.Arrow (first) import Control.Monad (mplus) 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 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.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 ifUnmodifiedSince :: Request -> Maybe HTTPDate ifUnmodifiedSince = lookupAndParseDate hIfUnmodifiedSince ifRange :: Request -> Maybe HTTPDate ifRange = lookupAndParseDate hIfRange lookupAndParseDate :: HeaderName -> Request -> Maybe HTTPDate lookupAndParseDate key req = lookupRequestField key req >>= parseHTTPDate ---------------------------------------------------------------- textPlainHeader :: ResponseHeaders textPlainHeader = [(hContentType,"text/plain")] textHtmlHeader :: ResponseHeaders textHtmlHeader = [(hContentType,"text/html")] locationHeader :: ByteString -> ResponseHeaders locationHeader url = [(hLocation, url)] addServer :: ClassicAppSpec -> ResponseHeaders -> ResponseHeaders addServer cspec hdr = (hServer, softwareName cspec) : hdr -- FIXME: the case where "Via:" already exists addVia :: ClassicAppSpec -> Request -> ResponseHeaders -> ResponseHeaders addVia cspec req hdr = (hVia, 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 = (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 | otherwise = lastMod : (hContentType, mimeType file) : [] where lastMod = (hLastModified, date) mimeType :: ByteString -> MimeType mimeType file =fromMaybe defaultMimeType . foldr1 mplus . map lok $ targets where targets = extensions file lok x = SH.lookup x defaultMimeTypes' extensions :: ByteString -> [ByteString] extensions file = exts where entire = case BS.breakByte 46 file of -- '.' (_,"") -> "" (_,x) -> BS.tail x exts = if entire == "" then [] else entire : BS.split 46 file 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 wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/File.hs0000644000000000000000000001650412117237173022145 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.File ( fileApp , redirectHeader ) where import Control.Applicative 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 qualified Data.ByteString.Lazy.Char8 as BL (length) import Data.Conduit import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.FileInfo import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Status import Network.Wai.Application.Classic.Types import Prelude hiding (catch) ---------------------------------------------------------------- type Rsp = ResourceT IO RspSpec ---------------------------------------------------------------- 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. If 'pathInfo' ends with \'/\', 'indexFile' is automatically added. In this case, "Acceptable-Language:" is also handled. Suppose 'indexFile' is "index.html" and if the value is "ja,en", then \"index.html.ja\", \"index.html.en\", and \"index.html\" are tried to be opened in order. If 'pathInfo' does not end with \'/\' and a corresponding index file exist, redirection is specified in HTTP response. Directory contents are NOT automatically listed. To list directory contents, an index file must be created beforehand. The following HTTP headers are handled: Acceptable-Language:, If-Modified-Since:, Range:, If-Range:, If-Unmodified-Since:. -} fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application fileApp cspec spec filei req = do RspSpec st body <- case method of Right GET -> processGET hinfo ishtml rfile Right HEAD -> processHEAD hinfo ishtml rfile _ -> return notAllowed (response, mlen) <- case body of NoBody -> noBody st BodyStatus -> bodyStatus st BodyFileNoBody hdr -> bodyFileNoBody st hdr BodyFile hdr afile rng -> bodyFile st hdr afile rng liftIO $ logger cspec req st mlen return response where hinfo = HandlerInfo spec req file langs method = 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) 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 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 return (ResponseFile st hdr fl mfp, Just len) where mfp = Just (FilePart 0 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) 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)) fl = pathString afile ---------------------------------------------------------------- processGET :: HandlerInfo -> Bool -> Maybe Path -> Rsp processGET hinfo ishtml rfile = tryGet hinfo ishtml ||> tryRedirect hinfo rfile ||> return notFound tryGet :: HandlerInfo -> Bool -> Rsp 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 finfo <- liftIO $ getFileInfo spec (lang file) let mtime = fileInfoTime finfo size = fileInfoSize finfo sfile = fileInfoName finfo date = fileInfoDate finfo 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 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 hdr sfile (Part skip len)) ---------------------------------------------------------------- processHEAD :: HandlerInfo -> Bool -> Maybe Path -> Rsp processHEAD hinfo ishtml rfile = tryHead hinfo ishtml ||> tryRedirect hinfo rfile ||> return notFoundNoBody tryHead :: HandlerInfo -> Bool -> Rsp 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 finfo <- liftIO $ getFileInfo spec (lang file) let mtime = fileInfoTime finfo size = fileInfoSize finfo date = fileInfoDate finfo hdr = newHeader ishtml (pathByteString file) date Just pst = ifmodified req size mtime -- never Nothing <|> Just (Full ok200) case pst of Full st -> return $ RspSpec st (BodyFileNoBody hdr) _ -> goNext -- never reached ---------------------------------------------------------------- tryRedirect :: HandlerInfo -> Maybe Path -> Rsp tryRedirect _ Nothing = goNext tryRedirect (HandlerInfo spec req _ langs) (Just file) = runAnyOne $ map (tryRedirectFile hinfo) langs where hinfo = HandlerInfo spec req file langs tryRedirectFile :: HandlerInfo -> Lang -> Rsp tryRedirectFile (HandlerInfo spec req file _) lang = do _ <- liftIO $ getFileInfo spec (lang file) return $ RspSpec movedPermanently301 (BodyFileNoBody hdr) where hdr = redirectHeader req redirectHeader :: Request -> ResponseHeaders redirectHeader = locationHeader . redirectURL redirectURL :: Request -> ByteString redirectURL req = BS.concat [ "http://" , serverName req , ":" , (BS.pack . show . serverPort) req , rawPathInfo req , "/" ] ---------------------------------------------------------------- notFound :: RspSpec notFound = RspSpec notFound404 BodyStatus notFoundNoBody :: RspSpec notFoundNoBody = RspSpec notFound404 NoBody notAllowed :: RspSpec notAllowed = RspSpec methodNotAllowed405 BodyStatus wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/FileInfo.hs0000644000000000000000000000430012117237173022750 0ustar0000000000000000module Network.Wai.Application.Classic.FileInfo where import Data.ByteString (ByteString) import Network.HTTP.Date import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Range import Network.Wai.Application.Classic.Types ---------------------------------------------------------------- data StatusAux = Full Status | Partial Integer Integer deriving Show ifmodified :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifmodified req size mtime = do date <- ifModifiedSince req if date /= mtime then unconditional req size mtime else Just (Full notModified304) ifunmodified :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifunmodified req size mtime = do date <- ifUnmodifiedSince req if date == mtime then unconditional req size mtime else Just (Full preconditionFailed412) ifrange :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifrange req size mtime = do date <- ifRange req rng <- lookupRequestField hRange req if date == mtime then Just (Full ok200) else range size rng unconditional :: Request -> Integer -> HTTPDate -> Maybe StatusAux unconditional req size _ = maybe (Just (Full ok200)) (range size) $ lookupRequestField hRange req range :: Integer -> ByteString -> Maybe StatusAux range size rng = case skipAndSize rng size of Nothing -> Just (Full requestedRangeNotSatisfiable416) Just (skip,len) -> Just (Partial skip len) ---------------------------------------------------------------- pathinfoToFilePath :: Request -> FileRoute -> Path pathinfoToFilePath req filei = path' where path = fromByteString $ rawPathInfo req src = fileSrc filei dst = fileDst filei path' = dst (path <\> src) addIndex :: FileAppSpec -> Path -> Path addIndex spec path | hasTrailingPathSeparator path = path indexFile spec | otherwise = path redirectPath :: FileAppSpec -> Path -> Maybe Path redirectPath spec path | hasTrailingPathSeparator path = Nothing | otherwise = Just (path indexFile spec) wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Header.hs0000644000000000000000000000214412117237173022451 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Header where import Data.ByteString (ByteString) import Data.Maybe import Network.HTTP.Types.Header import Network.Wai ---------------------------------------------------------------- -- | Look-up key for If-Unmodified-Since:. hIfUnmodifiedSince :: HeaderName hIfUnmodifiedSince = "if-unmodified-since" -- | Look-up key for Status. hStatus :: HeaderName hStatus = "status" -- | Look-up key for X-Forwarded-For. hXForwardedFor :: HeaderName hXForwardedFor = "x-forwarded-for" -- | Look-up key for Via. hVia :: HeaderName hVia = "via" ---------------------------------------------------------------- {-| Looking up a header in 'Request'. -} lookupRequestField :: HeaderName -> Request -> Maybe ByteString lookupRequestField x req = lookup x hdrs where hdrs = requestHeaders req {-| 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 where hdrs = requestHeaders req wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Lang.hs0000644000000000000000000000332012117237173022137 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Lang (parseLang) where import Control.Applicative hiding (optional) import Data.Attoparsec.ByteString (Parser, takeWhile, parseOnly) import Data.Attoparsec.ByteString.Char8 (char, string, count, space, digit, option, sepBy1) import Data.ByteString.Char8 hiding (map, count, take, takeWhile, notElem) import Data.List (sortBy) import Data.Ord import Prelude hiding (takeWhile) -- | -- >>> parseLang "en-gb;q=0.8, en;q=0.7, da" -- ["da","en-gb","en"] parseLang :: ByteString -> [ByteString] parseLang bs = case parseOnly acceptLanguage bs of Right ls -> map fst $ sortBy detrimental ls _ -> [] where detrimental = flip (comparing snd) ---------------------------------------------------------------- acceptLanguage :: Parser [(ByteString,Int)] acceptLanguage = rangeQvalue `sepBy1` (spaces *> char ',' *> spaces) rangeQvalue :: Parser (ByteString,Int) rangeQvalue = (,) <$> languageRange <*> quality languageRange :: Parser ByteString languageRange = takeWhile (`notElem` [32, 44, 59]) quality :: Parser Int quality = option 1000 (string ";q=" *> qvalue) qvalue :: Parser Int qvalue = 1000 <$ (char '1' *> optional (char '.' *> range 0 3 digit)) <|> read3 <$> (char '0' *> option "0" (char '.' *> range 0 3 digit)) where read3 n = read . take 3 $ n ++ repeat '0' optional p = () <$ p <|> return () ---------------------------------------------------------------- range :: Int -> Int -> Parser a -> Parser [a] range n m p = (++) <$> count n p <*> upto (m - n) p upto :: Int -> Parser a -> Parser [a] upto 0 _ = return [] upto n p = (:) <$> p <*> upto (n - 1) p <|> return [] spaces :: Parser () spaces = () <$ many space wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Path.hs0000644000000000000000000000727312117237173022165 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Path ( Path(..) , fromString, fromByteString , (+++), (), (<\>), (<.>) , breakAtSeparator, hasLeadingPathSeparator, hasTrailingPathSeparator , isSuffixOf ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS (null, head, tail, last, concat, append, drop, length, breakByte, isSuffixOf) import qualified Data.ByteString.Char8 as BS (pack, unpack) import Data.String import Data.Word import Data.Function ---------------------------------------------------------------- -- | Smart file path. data Path = Path { pathString :: FilePath , pathByteString :: ByteString } instance IsString Path where fromString path = Path { pathString = path , pathByteString = BS.pack path } instance Show Path where show = show . pathByteString instance Eq Path where (==) = (==) `on` pathByteString ---------------------------------------------------------------- fromByteString :: ByteString -> Path fromByteString path = Path { pathString = BS.unpack path , pathByteString = path } -- pathDot :: Word8 -- pathDot = 46 pathDotBS :: ByteString pathDotBS = "." pathSep :: Word8 pathSep = 47 pathSepBS :: ByteString pathSepBS = "/" {-| Checking if the path ends with the path separator. >>> hasLeadingPathSeparator "/foo/bar" True >>> hasLeadingPathSeparator "foo/bar" False -} hasLeadingPathSeparator :: Path -> Bool hasLeadingPathSeparator path | BS.null bs = False | BS.head bs == pathSep = True | otherwise = False where bs = pathByteString path {-| Checking if the path ends with the path separator. >>> hasTrailingPathSeparator "/foo/bar/" True >>> hasTrailingPathSeparator "/foo/bar" False -} hasTrailingPathSeparator :: Path -> Bool hasTrailingPathSeparator path | BS.null bs = False | BS.last bs == pathSep = True | otherwise = False where bs = pathByteString path infixr +++ {-| Appending. -} (+++) :: Path -> Path -> Path p1 +++ p2 = fromByteString p where p = pathByteString p1 `BS.append` pathByteString p2 {-| Appending with the file separator. >>> "/foo" "bar" "/foo/bar" >>> "/foo/" "bar" "/foo/bar" >>> "/foo" "/bar" "/foo/bar" >>> "/foo/" "/bar" "/foo/bar" -} () :: Path -> Path -> Path p1 p2 | has1 && not has2 || not has1 && has2 = p1 +++ p2 | has1 = fromByteString pp1 | otherwise = fromByteString pp2 where has1 = hasTrailingPathSeparator p1 has2 = hasLeadingPathSeparator p2 p1' = pathByteString p1 p2' = pathByteString p2 pp1 = p1' `BS.append` BS.tail p2' pp2 = BS.concat [p1',pathSepBS,p2'] {-| Removing prefix. The prefix of the second argument is removed from the first argument. >>> "foobar" <\> "foo" "bar" >>> "foo" <\> "foobar" "" >>> "foobar" <\> "baz" "bar" -} (<\>) :: Path -> Path -> Path p1 <\> p2 = fromByteString p where p1' = pathByteString p1 p2' = pathByteString p2 p = BS.drop (BS.length p2') p1' {-| Adding suffix. -} (<.>) :: Path -> Path -> Path p1 <.> p2 = fromByteString p where p1' = pathByteString p1 p2' = pathByteString p2 p = BS.concat [p1',pathDotBS,p2'] {-| Breaking at the first path separator. >>> breakAtSeparator "/foo/bar/baz" ("","/foo/bar/baz") >>> breakAtSeparator "foo/bar/baz" ("foo","/bar/baz") >>> breakAtSeparator "foo" ("foo","") -} 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-0.8.3/Network/Wai/Application/Classic/Range.hs0000644000000000000000000000352412117237173022320 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Range (skipAndSize) where import Control.Applicative hiding (optional) import Data.Attoparsec.ByteString hiding (satisfy) import Data.Attoparsec.ByteString.Char8 hiding (take) import Data.ByteString.Char8 hiding (map, count, take, elem) import Network.HTTP.Types -- | -- >>> skipAndSize "bytes=0-399" 10000 -- Just (0,400) -- >>> skipAndSize "bytes=500-799" 10000 -- Just (500,300) -- >>> skipAndSize "bytes=-500" 10000 -- Just (9500,500) -- >>> skipAndSize "bytes=9500-" 10000 -- Just (9500,500) skipAndSize :: ByteString -> Integer -> Maybe (Integer,Integer) skipAndSize bs size = case parseRange bs of Just [rng] -> adjust rng size _ -> Nothing adjust :: ByteRange -> Integer -> Maybe (Integer,Integer) adjust (ByteRangeFromTo beg end) siz | beg <= end && end <= siz = Just (beg, end - beg + 1) | otherwise = Nothing adjust (ByteRangeFrom beg) siz | beg <= siz = Just (beg, siz - beg) | otherwise = Nothing adjust (ByteRangeSuffix end) siz | end <= siz = Just (siz - end, end) | otherwise = Nothing parseRange :: ByteString -> Maybe [ByteRange] parseRange bs = case parseOnly byteRange bs of Right x -> Just x _ -> Nothing byteRange :: Parser [ByteRange] byteRange = string "bytes=" *> (ranges <* endOfInput) ranges :: Parser [ByteRange] ranges = sepBy1 (range <|> suffixRange) (spcs >> char ',' >> spcs) range :: Parser ByteRange range = do beg <- num <* char '-' (ByteRangeFromTo beg <$> num) <|> return (ByteRangeFrom beg) suffixRange :: Parser ByteRange suffixRange = ByteRangeSuffix <$> (char '-' *> num) num :: Parser Integer num = read <$> many1 digit spcs :: Parser () spcs = () <$ many spc spc :: Parser Char spc = satisfy (`elem` " \t") wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Redirect.hs0000644000000000000000000000143712117237173023026 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Redirect ( redirectApp ) where import Control.Monad.IO.Class (liftIO) import Data.ByteString.Char8 import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types redirectApp :: ClassicAppSpec -> RedirectRoute -> Application redirectApp cspec route req = do liftIO $ logger cspec req status Nothing return $ responseLBS status hdr "" where path = fromByteString $ rawPathInfo req src = redirectSrc route dst = redirectDst route rurl = "http://" `append` pathByteString (dst (path <\> src)) hdr = addServer cspec $ locationHeader rurl status = movedPermanently301 wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/RevProxy.hs0000644000000000000000000000734712117237173023071 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.RevProxy (revProxyApp) where import Control.Applicative import Control.Exception (SomeException) import Control.Exception.Lifted (catch) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as BS hiding (uncons) import qualified Data.ByteString as BS (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 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.Path import Network.Wai.Application.Classic.Types import Blaze.ByteString.Builder (Builder) import Prelude hiding (catch) 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 } where path = fromByteString $ rawPathInfo req src = revProxySrc route dst = revProxyDst route 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 {-| Relaying any requests as reverse proxy. -} revProxyApp :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application revProxyApp cspec spec route req = revProxyApp' cspec spec route req `catch` badGateway cspec req 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 where mgr = revProxyManager spec fixHeader = 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 badGateway :: ClassicAppSpec -> Request-> SomeException -> ResourceT IO Response badGateway cspec req _ = do liftIO $ 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 wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Status.hs0000644000000000000000000000432112117237173022543 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Status (getStatusInfo) where import Control.Applicative import Control.Arrow import Control.Exception import Control.Exception.IOChoice import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Char8 () import Data.Maybe import qualified Data.StaticHash as M import Network.HTTP.Types import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types import Prelude hiding (catch) ---------------------------------------------------------------- getStatusInfo :: ClassicAppSpec -> FileAppSpec -> [Lang] -> Status -> IO StatusInfo getStatusInfo cspec spec langs st = getStatusFile getF dir code langs ||> getStatusBS code ||> return StatusNone where dir = statusFileDir cspec getF = getFileInfo spec code = statusCode st ---------------------------------------------------------------- statusList :: [Status] statusList = [ methodNotAllowed405 -- File , notFound404 -- File , internalServerError500 -- CGI , badGateway502 -- 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 -> IO StatusInfo getStatusBS code = case M.lookup code statusBSMap of Nothing -> throwIO $ userError "getStatusBS" Just x -> return x ---------------------------------------------------------------- statusFileMap :: M.StaticHash Int Path statusFileMap = M.fromList $ map (statusCode &&& toPath) statusList where toPath s = fromString $ show (statusCode s) ++ ".html" getStatusFile :: (Path -> IO FileInfo) -> Path -> Int -> [Lang] -> IO StatusInfo getStatusFile getF dir code langs = tryFile mfiles where mfiles = case M.lookup code statusFileMap of Nothing -> [] Just file -> map ($ (dir file)) langs tryFile = foldr func goNext func f io = StatusFile f . fileInfoSize <$> getF f ||> io ---------------------------------------------------------------- wai-app-file-cgi-0.8.3/Network/Wai/Application/Classic/Types.hs0000644000000000000000000000666312117237173022377 0ustar0000000000000000module Network.Wai.Application.Classic.Types where import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Network.HTTP.Conduit as H import Network.HTTP.Date import Network.HTTP.Types import Network.Wai.Application.Classic.Path import Network.Wai.Logger import System.Log.FastLogger ---------------------------------------------------------------- data ClassicAppSpec = ClassicAppSpec { -- | Name specified to Server: in HTTP response. softwareName :: ByteString -- | A function for logging. The third argument is a body size. , logger :: ApacheLogger -- | A function to get the HTTP body of status. , dater :: IO ZonedDate , 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 deriving (Eq,Show) ---------------------------------------------------------------- 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. -- If information is not obtained, an IO exception should be raised. , getFileInfo :: Path -> IO FileInfo } data FileInfo = FileInfo { fileInfoName :: !Path , fileInfoSize :: !Integer , fileInfoTime :: !HTTPDate , fileInfoDate :: !ByteString } deriving (Eq, Show) data FileRoute = FileRoute { -- | Path prefix to be matched to 'rawPathInfo'. fileSrc :: Path -- | Path prefix to an actual file system. , fileDst :: Path } deriving (Eq,Show) ---------------------------------------------------------------- data RedirectRoute = RedirectRoute { -- | Path prefix to be matched to 'rawPathInfo'. redirectSrc :: Path -- | Path prefix to an actual file system. , redirectDst :: Path } deriving (Eq,Show) ---------------------------------------------------------------- data CgiAppSpec = CgiAppSpec { -- | A file name of the default CGI. indexCgi :: Path } deriving (Eq,Show) data CgiRoute = CgiRoute { -- | Path prefix to be matched to 'rawPathInfo'. cgiSrc :: Path -- | Path prefix to an actual file system. , cgiDst :: Path } deriving (Eq,Show) ---------------------------------------------------------------- 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 } deriving (Eq,Show) ---------------------------------------------------------------- data RspSpec = RspSpec { -- | Response status. rspStatus :: Status -- | Response body. , rspBody :: RspBody } deriving (Eq,Show) data RspBody = NoBody | BodyStatus | BodyFileNoBody ResponseHeaders | BodyFile ResponseHeaders Path Range deriving (Eq,Show) data Range = -- | Entire file showing its file size Entire Integer -- | A part of a file taking offset and length | Part Integer Integer deriving (Eq,Show) ---------------------------------------------------------------- type Lang = Path -> Path wai-app-file-cgi-0.8.3/test/0000755000000000000000000000000012117237173013706 5ustar0000000000000000wai-app-file-cgi-0.8.3/test/ClassicSpec.hs0000644000000000000000000001027712117237173016445 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ClassicSpec where import Control.Applicative import qualified Data.ByteString.Lazy.Char8 as BL import Data.Conduit import Network.HTTP.Conduit import qualified Network.HTTP.Types as H import Prelude hiding (catch) import Test.Hspec spec :: Spec spec = do describe "cgiApp" $ do it "accepts POST" $ do let url = "http://127.0.0.1:2345/cgi-bin/echo-env/pathinfo?query=foo" bdy <- responseBody <$> sendPOST url "foo bar.\nbaz!\n" ans <- BL.readFile "test/data/post" bdy `shouldBe` ans it "causes 500 if the CGI script does not exist" $ do let url = "http://127.0.0.1:2345/cgi-bin/broken" sc <- responseStatus <$> sendPOST url "foo bar.\nbaz!\n" sc `shouldBe` H.internalServerError500 describe "fileApp" $ do it "returns index.html for /" $ do let url = "http://127.0.0.1:2345/" rsp <- simpleHttp url ans <- BL.readFile "test/html/index.html" rsp `shouldBe` ans it "returns 400 if not exist" $ do let url = "http://127.0.0.1:2345/dummy" req <- parseUrl url sc <- responseStatus <$> safeHttpLbs req sc `shouldBe` H.notFound404 it "returns Japanese HTML if language is specified" $ do let url = "http://127.0.0.1:2345/ja/" bdy <- responseBody <$> sendGET url [("Accept-Language", "ja, en;q=0.7")] ans <- BL.readFile "test/html/ja/index.html.ja" bdy `shouldBe` ans it "returns 304 if not changed" $ do let url = "http://127.0.0.1:2345/" hdr <- responseHeaders <$> sendGET url [] let Just lm = lookup "Last-Modified" hdr sc <- responseStatus <$> sendGET url [("If-Modified-Since", lm)] sc `shouldBe` H.notModified304 it "can handle partial request" $ do let url = "http://127.0.0.1:2345/" ans = "html>\n sendGET url [("Range", "bytes=10-20")] bdy `shouldBe` ans it "can handle HEAD" $ do let url = "http://127.0.0.1:2345/" sc <- responseStatus <$> sendHEAD url [] sc `shouldBe` H.ok200 it "returns 404 for HEAD if not exist" $ do let url = "http://127.0.0.1:2345/dummy" sc <- responseStatus <$> sendHEAD url [] sc `shouldBe` H.notFound404 it "can handle HEAD even if language is specified" $ do let url = "http://127.0.0.1:2345/ja/" sc <- responseStatus <$> sendHEAD url [("Accept-Language", "ja, en;q=0.7")] sc `shouldBe` H.ok200 it "returns 304 for HEAD if not modified" $ do let url = "http://127.0.0.1:2345/" hdr <- responseHeaders <$> sendHEAD url [] let Just lm = lookup "Last-Modified" hdr sc <- responseStatus <$> sendHEAD url [("If-Modified-Since", lm)] sc `shouldBe` H.notModified304 it "redirects to dir/ if trailing slash is missing" $ do let url = "http://127.0.0.1:2345/redirect" rsp <- simpleHttp url ans <- BL.readFile "test/html/redirect/index.html" rsp `shouldBe` ans ---------------------------------------------------------------- sendGET ::String -> H.RequestHeaders -> IO (Response BL.ByteString) sendGET url hdr = do req' <- parseUrl url let req = req' { requestHeaders = hdr } safeHttpLbs req sendHEAD :: String -> H.RequestHeaders -> IO (Response BL.ByteString) sendHEAD url hdr = do req' <- parseUrl url let req = req' { requestHeaders = hdr , method = "HEAD" } safeHttpLbs req sendPOST :: String -> BL.ByteString -> IO (Response BL.ByteString) sendPOST url body = do req' <- parseUrl url let req = req' { method = "POST" , requestBody = RequestBodyLBS body } safeHttpLbs req ---------------------------------------------------------------- safeHttpLbs :: Request (ResourceT IO) -> IO (Response BL.ByteString) safeHttpLbs req = withManager $ httpLbs req { checkStatus = \_ _ _ -> Nothing -- prevent throwing an error } wai-app-file-cgi-0.8.3/test/doctests.hs0000644000000000000000000000021612117237173016071 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest [ "-XOverloadedStrings" , "Network/Wai/Application/Classic.hs" ] wai-app-file-cgi-0.8.3/test/Spec.hs0000644000000000000000000000204712117237173015137 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import ClassicSpec import Control.Concurrent import Control.Monad import qualified Data.ByteString as BS import Network.Wai import Network.Wai.Application.Classic hiding (()) import Network.Wai.Handler.Warp import System.Directory import System.FilePath import Test.Hspec main :: IO () main = do void $ forkIO testServer threadDelay 100000 hspec spec testServer :: IO () testServer = do dir <- getCurrentDirectory run 2345 $ testApp dir testApp :: FilePath -> Application testApp dir req | cgi = cgiApp appSpec defaultCgiAppSpec cgiRoute req | otherwise = fileApp appSpec defaultFileAppSpec fileRoute req where cgi = "/cgi-bin/" `BS.isPrefixOf` rawPathInfo req appSpec = defaultClassicAppSpec { softwareName = "ClassicTester" } cgiRoute = CgiRoute { cgiSrc = "/cgi-bin/" , cgiDst = fromString (dir "test/cgi-bin/") } fileRoute = FileRoute { fileSrc = "/" , fileDst = fromString (dir "test/html/") }