wai-app-file-cgi-3.0.9/0000755000000000000000000000000012640152405012723 5ustar0000000000000000wai-app-file-cgi-3.0.9/LICENSE0000644000000000000000000000276512640152405013742 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-3.0.9/Setup.hs0000644000000000000000000000005612640152405014360 0ustar0000000000000000import Distribution.Simple main = defaultMain wai-app-file-cgi-3.0.9/wai-app-file-cgi.cabal0000644000000000000000000000766412640152405016737 0ustar0000000000000000Name: wai-app-file-cgi Version: 3.0.9 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 (including EventSource). 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.Status Network.Wai.Application.Classic.Types Network.Wai.Application.Classic.RevProxy Build-Depends: base >= 4 && < 5 , array , attoparsec >= 0.10.0.0 , attoparsec-conduit , blaze-builder , blaze-html , bytestring , case-insensitive , conduit >= 1.1 , conduit-extra , containers , data-default-class , directory , filepath , http-client >= 0.3 , http-conduit >= 2.1 , http-date , http-types >= 0.7 , io-choice , lifted-base , mime-types , network , process , sockaddr , static-hash , text , transformers , unix , wai >= 3.0 && < 3.1 , wai-conduit , warp >= 3.1.12 && < 3.2 , 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 >= 1.1 , conduit-extra , directory , filepath , hspec >= 1.3 , http-types , unix , wai >= 3.0 && < 3.1 , wai-app-file-cgi , warp >= 3.1.12 && < 3.2 , HTTP Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/wai-app-file-cgi wai-app-file-cgi-3.0.9/Network/0000755000000000000000000000000012640152405014354 5ustar0000000000000000wai-app-file-cgi-3.0.9/Network/Wai/0000755000000000000000000000000012640152405015074 5ustar0000000000000000wai-app-file-cgi-3.0.9/Network/Wai/Application/0000755000000000000000000000000012640152405017337 5ustar0000000000000000wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic.hs0000644000000000000000000000175412640152405021263 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| WAI (Web Application Interface) Application for static files and CGI. -} module Network.Wai.Application.Classic ( -- * Common ClassicAppSpec(..) , defaultClassicAppSpec , StatusInfo(..) -- * Files , FileAppSpec(..) , defaultFileAppSpec , FileRoute(..) , fileApp -- * Redirect , RedirectRoute(..) , redirectApp -- * CGI , CgiAppSpec(..) , defaultCgiAppSpec , CgiRoute(..) , cgiApp -- * Reverse Proxy , RevProxyAppSpec(..) , RevProxyRoute(..) , revProxyApp -- * 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.RevProxy import Network.Wai.Application.Classic.Types wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/0000755000000000000000000000000012640152405020720 5ustar0000000000000000wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/CGI.hs0000644000000000000000000001471512640152405021666 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables #-} module Network.Wai.Application.Classic.CGI ( cgiApp ) where import qualified Control.Exception as E (SomeException, IOException, try, catch, bracket) import Control.Monad (when, (<=<)) import Data.ByteString (ByteString) 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.Conduit 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 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 respond = case method of Right GET -> cgiApp' False cspec spec cgii req respond Right POST -> cgiApp' True cspec spec cgii req respond _ -> respond $ 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 respond = E.bracket setup teardown (respond <=< cgi) where 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 E.IOException String toCGI :: Handle -> Request -> IO () toCGI whdl req = sourceRequestBody req $$ CB.sinkHandle whdl fromCGI :: Handle -> ClassicAppSpec -> Request -> IO Response fromCGI rhdl cspec req = do (src', hs) <- cgiHeader `E.catch` recover let (st, hdr, hasBody) = case check hs of Nothing -> (internalServerError500,[],False) Just (s,h) -> (s,h,True) logger cspec req st Nothing let src | hasBody = src' | otherwise = 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 (_ :: E.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 <- E.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 #if __GLASGOW_HASKELL__ >= 707 , delegate_ctlc = False #endif } (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii) (cgiDst cgii) (fromByteString (rawPathInfo req)) (indexCgi spec) makeEnv :: Request -> String -> 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 host) , ("SERVER_PORT", BS.unpack port) , ("REMOTE_ADDR", naddr) , ("SERVER_PROTOCOL", show . httpVersion $ req) , ("SERVER_SOFTWARE", BS.unpack sname) , ("PATH_INFO", pathinfo) , ("QUERY_STRING", query req) ] headers = requestHeaders req addLen = addLength "CONTENT_LENGTH" $ requestBodyLength req 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 (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 {-| >>> 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-3.0.9/Network/Wai/Application/Classic/Conduit.hs0000644000000000000000000000336312640152405022666 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.ByteString 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 IO ByteString -> IO (Source IO (Flush Builder)) toResponseSource rsrc = do (src,_) <- unwrapResumable rsrc return $ src $= CL.map (Chunk . byteStringToBuilder) ---------------------------------------------------------------- parseHeader :: Sink ByteString 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-3.0.9/Network/Wai/Application/Classic/Def.hs0000644000000000000000000000255012640152405021754 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Def where import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types -- | -- 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 , statusFileDir = "/usr/local/share/html/status/" } defaultLogger :: Request -> Status -> Maybe Integer -> IO () defaultLogger _ _ _ = return () ---------------------------------------------------------------- -- | -- Default value for 'defaultFileAppSpec'. 'indexFile' is \"index.html\". 'isHTML' matches \"*.html\" and \"*.html\". defaultFileAppSpec :: FileAppSpec defaultFileAppSpec = FileAppSpec { indexFile = "index.html" , isHTML = defaultIsHTml } defaultIsHTml :: Path -> Bool defaultIsHTml file = ".html" `isSuffixOf` file || ".htm" `isSuffixOf` file ---------------------------------------------------------------- -- | -- Default value for 'defaultCgiAppSpec'. 'indexCgi' is \"index.cgi\". defaultCgiAppSpec :: CgiAppSpec defaultCgiAppSpec = CgiAppSpec { indexCgi = "index.cgi" } wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/EventSource.hs0000644000000000000000000000422112640152405023515 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.EventSource ( bodyToEventSource ) where import Blaze.ByteString.Builder import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Char8 () import Data.Conduit import qualified Data.Conduit.List as CL import qualified Network.HTTP.Client as H import qualified Network.HTTP.Client.Conduit as HC 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 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 bodyToEventSource :: H.BodyReader -> Source IO (Flush Builder) bodyToEventSource br = HC.bodyReaderSource br $= eventSourceConduit wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/Field.hs0000644000000000000000000000600312640152405022276 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Field where import Control.Arrow (first) import Control.Monad (mplus) import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as Map 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.SockAddr import Network.Wai import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Lang import Network.Wai.Application.Classic.Types ---------------------------------------------------------------- languages :: IndexedHeader -> [ByteString] languages reqidx = maybe [] parseLang $ reqidx ! idxAcceptLanguage ifModifiedSince :: IndexedHeader -> Maybe HTTPDate ifModifiedSince reqidx = reqidx ! idxIfModifiedSince >>= parseHTTPDate ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate ifUnmodifiedSince reqidx = reqidx ! idxIfUnmodifiedSince >>= parseHTTPDate ifRange :: IndexedHeader -> Maybe HTTPDate ifRange reqidx = reqidx ! idxIfRange >>= parseHTTPDate ---------------------------------------------------------------- textPlainHeader :: ResponseHeaders textPlainHeader = [(hContentType,"text/plain")] textHtmlHeader :: ResponseHeaders textHtmlHeader = [(hContentType,"text/html")] locationHeader :: ByteString -> ResponseHeaders locationHeader url = [(hLocation, url)] -- FIXME: the case where "Via:" already exists addVia :: ClassicAppSpec -> Request -> ResponseHeaders -> ResponseHeaders addVia cspec req hdr = (hVia, val) : hdr where ver = httpVersion req val = BS.concat [ showBS (httpMajor ver) , "." , showBS (httpMinor ver) , " " , host , " (" , softwareName cspec , ")" ] host = fromMaybe "" $ requestHeaderHost req addForwardedFor :: Request -> ResponseHeaders -> ResponseHeaders addForwardedFor req hdr = (hXForwardedFor, addr) : hdr where addr = B8.pack . showSockAddr . remoteHost $ req 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.break (== 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 (B8.pack . T.unpack)) $ Map.toList defaultMimeMap showBS :: Show a => a -> ByteString showBS = B8.pack . show wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/File.hs0000644000000000000000000001466012640152405022142 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 Data.Maybe import qualified Data.ByteString.Char8 as BS (concat) import qualified Data.ByteString.Lazy.Char8 as BL (length) 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 import Network.Wai.Handler.Warp (getFileInfo) ---------------------------------------------------------------- type Rsp = IO RspSpec ---------------------------------------------------------------- data HandlerInfo = HandlerInfo FileAppSpec Request IndexedHeader Path [Lang] langSuffixes :: IndexedHeader -> [Lang] langSuffixes reqidx = map (\x -> (<.> x)) langs ++ [id, (<.> "en")] where langs = map fromByteString $ languages reqidx ---------------------------------------------------------------- {-| 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 respond = do RspSpec st body <- case method of Right GET -> processGET hinfo ishtml rfile Right HEAD -> processGET 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 logger cspec req st mlen respond response where 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 reqidx noBody st = return (responseLBS st [] "", Nothing) bodyStatus st = liftIO (getStatusInfo cspec req langs st) >>= statusBody st statusBody st StatusNone = noBody st statusBody st (StatusByteString bd) = return (responseLBS st hdr bd, Just (len bd)) where len = fromIntegral . BL.length hdr = textPlainHeader statusBody st (StatusFile afile len) = return (ResponseFile st hdr fl mfp, Just len) where mfp = Just (FilePart 0 len len) fl = pathString afile hdr = textHtmlHeader bodyFileNoBody st hdr = return (responseLBS st hdr "", Nothing) bodyFile st hdr afile rng = 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 bytes)) Part skip bytes total -> (bytes, Just (FilePart skip bytes total)) 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 _ req reqidx file _) ishtml lang = do let file' = pathString $ lang file finfo <- fromFileInfo <$> liftIO (getFileInfo req file') let mtime = fileinfoTime finfo size = fileinfoSize finfo sfile = fileinfoName finfo date = fileinfoDate finfo mrange = requestHeaderRange req hdr = newHeader ishtml (pathByteString file) date 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 hdr sfile (Part skip len size)) ---------------------------------------------------------------- tryRedirect :: HandlerInfo -> Maybe Path -> Rsp tryRedirect _ Nothing = goNext tryRedirect (HandlerInfo spec req reqidx _ langs) (Just file) = runAnyOne $ map (tryRedirectFile hinfo) langs where hinfo = HandlerInfo spec req reqidx file langs tryRedirectFile :: HandlerInfo -> Lang -> Rsp tryRedirectFile (HandlerInfo _ req _ file _) lang = do let file' = pathString $ lang file _ <- liftIO $ getFileInfo req file' -- expecting an error return $ RspSpec movedPermanently301 (BodyFileNoBody hdr) where hdr = redirectHeader req redirectHeader :: Request -> ResponseHeaders redirectHeader = locationHeader . redirectURL redirectURL :: Request -> ByteString redirectURL req = BS.concat [ -- Scheme must not be included because of no way to tell -- http or https. "//" -- Host includes ":" if it is not 80. , host , rawPathInfo req , "/" ] where host = fromMaybe "" $ requestHeaderHost req ---------------------------------------------------------------- notFound :: RspSpec notFound = RspSpec notFound404 BodyStatus notAllowed :: RspSpec notAllowed = RspSpec methodNotAllowed405 BodyStatus wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/FileInfo.hs0000644000000000000000000000452012640152405022750 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 :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux ifmodified reqidx size mtime mrange = do date <- ifModifiedSince reqidx if date /= mtime then unconditional reqidx size mtime mrange else Just (Full notModified304) ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux ifunmodified reqidx size mtime mrange = do date <- ifUnmodifiedSince reqidx if date == mtime then unconditional reqidx size mtime mrange else Just (Full preconditionFailed412) ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux ifrange reqidx size mtime mrange = do date <- ifRange reqidx rng <- mrange if date == mtime then parseRange size rng else Just (Full ok200) unconditional :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux unconditional _ size _ mrange = maybe (Just (Full ok200)) (parseRange size) mrange parseRange :: Integer -> ByteString -> Maybe StatusAux parseRange 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-3.0.9/Network/Wai/Application/Classic/Header.hs0000644000000000000000000000521712640152405022451 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Network.Wai.Application.Classic.Header where import Data.Array import Data.Array.ST import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS (tail,break) 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" -- | Lookup key for Transfer-Encoding. hTransferEncoding :: HeaderName hTransferEncoding = "transfer-encoding" -- | Lookup key for Accept-Encoding. hAcceptEncoding :: HeaderName hAcceptEncoding = "accept-encoding" ---------------------------------------------------------------- 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) ---------------------------------------------------------------- -- | 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 insert arr (key,val) | idx == -1 = return () | otherwise = writeArray arr idx (Just val) where idx = getIndex key wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/Lang.hs0000644000000000000000000000332012640152405022133 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-3.0.9/Network/Wai/Application/Classic/Path.hs0000644000000000000000000000713712640152405022160 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 import qualified Data.ByteString.Char8 as B8 import Data.Function import Data.String import Data.Word ---------------------------------------------------------------- -- | Smart file path. data Path = Path { pathString :: FilePath , pathByteString :: ByteString } instance IsString Path where fromString path = Path { pathString = path , pathByteString = B8.pack path } instance Show Path where show = show . pathByteString instance Eq Path where (==) = (==) `on` pathByteString ---------------------------------------------------------------- fromByteString :: ByteString -> Path fromByteString path = Path { pathString = B8.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.break (== pathSep) p' isSuffixOf :: Path -> Path -> Bool isSuffixOf p1 p2 = p1' `BS.isSuffixOf` p2' where p1' = pathByteString p1 p2' = pathByteString p2 wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/Range.hs0000644000000000000000000000373412640152405022317 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.Wai.Application.Classic.Range (skipAndSize) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>), (<$), (<*), (*>)) #endif import Control.Applicative ((<|>), many) import Data.Attoparsec.ByteString hiding (satisfy) import Data.Attoparsec.ByteString.Char8 hiding (take) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B8 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 (`B8.elem` " \t") wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/Redirect.hs0000644000000000000000000000146412640152405023022 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Redirect ( redirectApp ) where 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 respond = do logger cspec req status Nothing respond $ responseLBS status hdr "" where path = fromByteString $ rawPathInfo req src = redirectSrc route dst = redirectDst route -- Scheme must not be included because of no way to tell -- http or https. rurl = "//" `append` pathByteString (dst (path <\> src)) hdr = locationHeader rurl status = movedPermanently301 wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/RevProxy.hs0000644000000000000000000001007312640152405023053 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.Wai.Application.Classic.RevProxy (revProxyApp) where import Blaze.ByteString.Builder (Builder) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString as BS (uncons) import qualified Data.ByteString.Char8 as BS hiding (uncons) import Data.Conduit import Data.Default.Class import qualified Network.HTTP.Client as H import Network.HTTP.Types 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 Network.Wai.Conduit ---------------------------------------------------------------- -- | Relaying any requests as reverse proxy. revProxyApp :: ClassicAppSpec -> RevProxyAppSpec -> RevProxyRoute -> Application revProxyApp cspec spec route req respond = H.withResponse httpClientRequest mgr proxy where 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) respond $ responseSource 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 headerToBeRelay headerToBeRelay :: Header -> Bool headerToBeRelay (k,_) | k == hTransferEncoding = False | k == hAcceptEncoding = 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 = False -- FIXME: upstream is HTTP only , H.requestHeaders = addForwardedFor req $ filter headerToBeRelay 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 bodyToHBody :: RequestBodyLength -> IO ByteString -> H.RequestBody bodyToHBody ChunkedBody src = H.RequestBodyStreamChunked ($ src) bodyToHBody (KnownLength len) src = H.RequestBodyStream (fromIntegral len) ($ src) ---------------------------------------------------------------- toSource :: Maybe ByteString -> H.BodyReader -> Source IO (Flush Builder) toSource (Just "text/event-stream") = bodyToEventSource toSource _ = bodyToSource bodyToSource :: H.BodyReader -> Source IO (Flush Builder) bodyToSource br = loop where loop = do bs <- liftIO $ H.brRead br unless (BS.null bs) $ do yield $ Chunk $ byteStringToBuilder bs loop {- FIXME: badGateway :: ClassicAppSpec -> Request-> SomeException -> IO Response badGateway cspec req _ = do 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-3.0.9/Network/Wai/Application/Classic/Status.hs0000644000000000000000000000447312640152405022547 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.Wai.Application.Classic.Status (getStatusInfo) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Arrow import Control.Exception import Control.Exception.IOChoice 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 (Request) import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types import Network.Wai.Handler.Warp ---------------------------------------------------------------- getStatusInfo :: ClassicAppSpec -> Request -> [Lang] -> Status -> IO StatusInfo getStatusInfo cspec req langs st = getStatusFile getF dir code langs ||> getStatusBS code ||> return StatusNone where dir = statusFileDir cspec getF = getFileInfo req 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 :: (FilePath -> 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 where f' = pathString f ---------------------------------------------------------------- wai-app-file-cgi-3.0.9/Network/Wai/Application/Classic/Types.hs0000644000000000000000000000707012640152405022364 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Application.Classic.Types where import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Network.HTTP.Client as H import Network.HTTP.Date import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp (FileInfo(..)) import Network.Wai.Application.Classic.Path ---------------------------------------------------------------- data ClassicAppSpec = ClassicAppSpec { -- | Name specified to Server: in HTTP response. softwareName :: ByteString -- | A function for logging. The third argument is a body size. , logger :: Request -> Status -> Maybe Integer -> IO () -- | A function to get HTTP's GMT Date. , 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 } data Fileinfo = Fileinfo { fileinfoName :: !Path , fileinfoSize :: !Integer , fileinfoTime :: !HTTPDate , fileinfoDate :: !ByteString } deriving (Eq, Show) fromFileInfo :: FileInfo -> Fileinfo fromFileInfo x = Fileinfo { fileinfoName = fromString $ fileInfoName x , fileinfoSize = fileInfoSize x , fileinfoTime = fileInfoTime x , fileinfoDate = fileInfoDate x } 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 -- offset Integer -- length Integer -- total deriving (Eq,Show) ---------------------------------------------------------------- type Lang = Path -> Path wai-app-file-cgi-3.0.9/test/0000755000000000000000000000000012640152405013702 5ustar0000000000000000wai-app-file-cgi-3.0.9/test/ClassicSpec.hs0000644000000000000000000001021712640152405016433 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module ClassicSpec where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Network.HTTP import Network.Stream import System.IO 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 <- rspBody <$> sendPOST url "foo bar.\nbaz!\n" ans <- readFileAscii "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 <- rspCode <$> sendPOST url "foo bar.\nbaz!\n" sc `shouldBe` (5,0,0) describe "fileApp" $ do it "returns index.html for /" $ do let url = "http://127.0.0.1:2345/" bdy <- rspBody <$> sendGET url ans <- readFileAscii "test/html/index.html" bdy `shouldBe` ans it "returns 400 if not exist" $ do let url = "http://127.0.0.1:2345/dummy" sc <- rspCode <$> sendGET url sc `shouldBe` (4,0,4) it "returns Japanese HTML if language is specified" $ do let url = "http://127.0.0.1:2345/ja/" bdy <- rspBody <$> sendGETwH url [Header HdrAcceptLanguage "ja, en;q=0.7"] ans <- readFileAscii "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 <- rspHeaders <$> sendGET url let Just lm = lookupHeader HdrLastModified hdr sc <- rspCode <$> sendGETwH url [Header HdrIfModifiedSince lm] sc `shouldBe` (3,0,4) it "can handle partial request" $ do let url = "http://127.0.0.1:2345/" ans = "html>\n sendGETwH url [Header HdrRange "bytes=10-20"] bdy `shouldBe` ans it "can handle HEAD" $ do let url = "http://127.0.0.1:2345/" sc <- rspCode <$> sendHEAD url sc `shouldBe` (2,0,0) it "returns 404 for HEAD if not exist" $ do let url = "http://127.0.0.1:2345/dummy" sc <- rspCode <$> sendHEAD url sc `shouldBe` (4,0,4) it "can handle HEAD even if language is specified" $ do let url = "http://127.0.0.1:2345/ja/" sc <- rspCode <$> sendHEADwH url [Header HdrAcceptLanguage "ja, en;q=0.7"] sc `shouldBe` (2,0,0) it "returns 304 for HEAD if not modified" $ do let url = "http://127.0.0.1:2345/" hdr <- rspHeaders <$> sendHEAD url let Just lm = lookupHeader HdrLastModified hdr sc <- rspCode <$> sendHEADwH url [Header HdrIfModifiedSince lm] sc `shouldBe` (3,0,4) it "redirects to dir/ if trailing slash is missing" $ do let url = "http://127.0.0.1:2345/redirect" rsp <- sendGET url let sc = rspCode rsp hdr = rspHeaders rsp Just lm = lookupHeader HdrLocation hdr sc `shouldBe` (3,0,1) lm `shouldBe` "//127.0.0.1:2345/redirect/" ---------------------------------------------------------------- sendGET :: String -> IO (Response String) sendGET url = sendGETwH url [] sendGETwH :: String -> [Header] -> IO (Response String) sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr } sendHEAD :: String -> IO (Response String) sendHEAD url = sendHEADwH url [] sendHEADwH :: String -> [Header] -> IO (Response String) sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr } sendPOST :: String -> String -> IO (Response String) sendPOST url body = unResult $ simpleHTTP $ postRequestWithBody url "Text/Plain" body unResult :: IO (Result (Response String)) -> IO (Response String) unResult action = do res <- action case res of Right rsp -> return rsp Left _ -> error "Connection error" readFileAscii :: FilePath -> IO String readFileAscii name = do h <- openFile name ReadMode hSetEncoding h latin1 hGetContents h wai-app-file-cgi-3.0.9/test/doctests.hs0000644000000000000000000000021612640152405016065 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest [ "-XOverloadedStrings" , "Network/Wai/Application/Classic.hs" ] wai-app-file-cgi-3.0.9/test/Spec.hs0000644000000000000000000000230212640152405015125 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 import System.Posix main :: IO () main = do void $ installHandler sigCHLD Ignore Nothing void $ forkIO testServer threadDelay 100000 hspec spec testServer :: IO () testServer = do dir <- getCurrentDirectory runSettings settings $ testApp dir where settings = setPort 2345 $ setHost "127.0.0.1" defaultSettings 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/") }