wai-app-file-cgi (empty) → 0.0.0
raw patch · 17 files changed
+998/−0 lines, 17 filesdep +attoparsecdep +basedep +blaze-buildersetup-changed
Dependencies added: attoparsec, base, blaze-builder, bytestring, containers, directory, enumerator, filepath, haskell98, network, process, time, transformers, unix, wai, wai-app-static
Files
- LICENSE +29/−0
- Network/Wai/Application/Classic.hs +18/−0
- Network/Wai/Application/Classic/CGI.hs +166/−0
- Network/Wai/Application/Classic/Date.hs +51/−0
- Network/Wai/Application/Classic/EnumLine.hs +62/−0
- Network/Wai/Application/Classic/Field.hs +63/−0
- Network/Wai/Application/Classic/File.hs +145/−0
- Network/Wai/Application/Classic/FileInfo.hs +83/−0
- Network/Wai/Application/Classic/Header.hs +84/−0
- Network/Wai/Application/Classic/Lang.hs +55/−0
- Network/Wai/Application/Classic/MaybeIter.hs +58/−0
- Network/Wai/Application/Classic/Range.hs +53/−0
- Network/Wai/Application/Classic/Status.hs +17/−0
- Network/Wai/Application/Classic/Types.hs +47/−0
- Network/Wai/Application/Classic/Utils.hs +24/−0
- Setup.hs +2/−0
- wai-app-file-cgi.cabal +41/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (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.
+ Network/Wai/Application/Classic.hs view
@@ -0,0 +1,18 @@+{-|+ WAI (Web Application Interface) Application for static files and CGI.+-}++module Network.Wai.Application.Classic (+ module Network.Wai.Application.Classic.CGI+ , module Network.Wai.Application.Classic.File+ , module Network.Wai.Application.Classic.Types+ , module Network.Wai.Application.Classic.Header+ , module Network.Wai.Application.Classic.Utils+ ) where++import Network.Wai.Application.Classic.CGI+import Network.Wai.Application.Classic.File+import Network.Wai.Application.Classic.Types+import Network.Wai.Application.Classic.Header+import Network.Wai.Application.Classic.Utils+
+ Network/Wai/Application/Classic/CGI.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.Classic.CGI (+ cgiApp+ ) where++import Blaze.ByteString.Builder.ByteString+import Control.Applicative+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Enumerator (Iteratee,Enumeratee,run_,($$),joinI)+import qualified Data.Enumerator as E (map)+import qualified Data.Enumerator.Binary as EB+import qualified Data.Enumerator.List as EL+import Network.Wai+import Network.Wai.Application.Classic.EnumLine as ENL+import Network.Wai.Application.Classic.Field+import Network.Wai.Application.Classic.Header+import Network.Wai.Application.Classic.Types+import Network.Wai.Application.Classic.Utils+import System.FilePath+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 follow:++> installHandler sigCHLD Ignore Nothing+-}+cgiApp :: AppSpec -> CgiRoute -> Application+cgiApp spec cgii req = case method of+ "GET" -> cgiApp' False spec cgii req+ "POST" -> cgiApp' True spec cgii req+ _ -> return $ responseLBS statusNotAllowed textPlain "Method Not Allowed"+ where+ method = requestMethod req++cgiApp' :: Bool -> AppSpec -> CgiRoute -> Application+cgiApp' body spec cgii req = do+ naddr <- liftIO . getPeerAddr . remoteHost $ req+ (Just whdl,Just rhdl,_,_) <- liftIO . createProcess . proSpec $ naddr+ liftIO $ do+ hSetEncoding rhdl latin1+ hSetEncoding whdl latin1+ when body $ EL.consume >>= liftIO . mapM_ (BS.hPutStr whdl)+ liftIO . hClose $ whdl+ (return . ResponseEnumerator) (\build ->+ run_ $ EB.enumHandle 4096 rhdl $$ do+ m <- (>>= check) <$> parseHeader+ let (st, hdr, emp) = case m of+ Nothing -> (status500,[],True)+ Just (s,h) -> (s,h,False)+ hdr' = addHeader hdr+ liftIO $ logger spec req st+ if emp+ then emptyBody =$ response build st hdr'+ else response build st hdr')+ where+ proSpec naddr = CreateProcess {+ cmdspec = RawCommand prog []+ , cwd = Nothing+ , env = Just (makeEnv req naddr scriptName pathinfo (softwareName spec))+ , std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = Inherit+ , close_fds = True+ }+ (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii)+ (cgiDst cgii)+ (pathInfo req)+ toBuilder = E.map fromByteString+ emptyBody = EB.isolate 0+ response build status hs = toBuilder =$ build status hs+ check hs = lookupField fkContentType hs >> case lookupField "status" hs of+ Nothing -> Just (status200, hs)+ Just l -> toStatus l >>= \s -> Just (s,hs')+ where+ hs' = filter (\(k,_) -> ciLowerCase k /= "status") hs+ toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s)+ addHeader hdr = ("Server", softwareName spec) : hdr++----------------------------------------------------------------++makeEnv :: Request -> NumericAddress -> String -> String -> ByteString -> ENVVARS+makeEnv req naddr scriptName pathinfo sname = addLength . 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", "HTTP/" ++ (BS.unpack . httpVersion $ req))+ , ("SERVER_SOFTWARE", BS.unpack sname)+ , ("PATH_INFO", pathinfo)+ , ("QUERY_STRING", query req)+ ]+ headers = requestHeaders req+ addLength = addEnv "CONTENT_LENGTH" $ lookupField fkContentLength headers+ addType = addEnv "CONTENT_TYPE" $ lookupField fkContentType headers+ addCookie = addEnv "HTTP_COOKIE" $ lookupField fkCookie headers+ query = BS.unpack . safeTail . queryString+ 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++----------------------------------------------------------------++parseHeader :: Iteratee ByteString IO (Maybe RequestHeaders)+parseHeader = takeHeader >>= maybe (return Nothing)+ (return . Just . map parseField)+ where+ parseField bs = (CIByteString key skey, val)+ where+ (key,val) = case BS.break (==':') bs of+ kv@(_,"") -> kv+ (k,v) -> let v' = BS.dropWhile (==' ') $ BS.tail v in (k,v')+ skey = BS.map toLower key++takeHeader :: Iteratee ByteString IO (Maybe [ByteString])+takeHeader = ENL.head >>= maybe (return Nothing) $. \l ->+ if l == ""+ then return (Just [])+ else takeHeader >>= maybe (return Nothing) (return . Just . (l:))++pathinfoToCGI :: ByteString -> FilePath -> ByteString -> (FilePath, String, String)+pathinfoToCGI src dst path = (prog, scriptName, pathinfo)+ where+ src' = BS.unpack src+ path' = drop (BS.length src) $ BS.unpack path+ (prog',pathinfo) = break (== '/') path'+ prog = dst </> prog'+ scriptName = src' </> prog'++----------------------------------------------------------------++infixr 0 =$++(=$) :: Monad m => Enumeratee ao ai m b -> Iteratee ai m b -> Iteratee ao m b+ee =$ ie = joinI $ ee $$ ie++----------------------------------------------------------------++infixr 6 $.++($.) :: (a -> b) -> a -> b+($.) = ($)
+ Network/Wai/Application/Classic/Date.hs view
@@ -0,0 +1,51 @@+module Network.Wai.Application.Classic.Date (parseDate, utcToDate) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Time+import Locale+import Control.Monad++-- xxx: ClockTime -> UTCTime+----------------------------------------------------------------++parseDate :: ByteString -> Maybe UTCTime+parseDate bs = rfc1123Date cs `mplus` rfc850Date cs `mplus` asctimeDate cs+ where+ cs = BS.unpack bs++----------------------------------------------------------------++rfc1123Format :: String+rfc1123Format = "%a, %d %b %Y %H:%M:%S GMT"++rfc850Format :: String+rfc850Format = "%A, %d-%b-%y %H:%M:%S GMT"++-- xxx: allows "Nov 6" as well as "Nov 6", sigh.+asctimeFormat :: String+asctimeFormat = "%a %b %e %H:%M:%S %Y"++preferredFormat :: String+preferredFormat = rfc1123Format++----------------------------------------------------------------++rfc1123Date :: String -> Maybe UTCTime+rfc1123Date = parseTime defaultTimeLocale preferredFormat++rfc850Date :: String -> Maybe UTCTime+rfc850Date str = parseTime defaultTimeLocale rfc850Format str >>= y2k+ where+ y2k utct = let (y,m,d) = toGregorian $ utctDay utct+ in if y < 1950+ then Just utct { utctDay = fromGregorian (y+100) m d }+ else Just utct++asctimeDate :: String -> Maybe UTCTime+asctimeDate = parseTime defaultTimeLocale asctimeFormat++----------------------------------------------------------------++utcToDate :: UTCTime -> ByteString+utcToDate = BS.pack . formatTime defaultTimeLocale preferredFormat
+ Network/Wai/Application/Classic/EnumLine.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.Classic.EnumLine (head) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as S () -- for OverloadedStrings+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as L () -- for OverloadedStrings+import Data.Enumerator (Iteratee, Stream(..), yield, continue)+import Prelude hiding (head)++head :: Iteratee BS.ByteString IO (Maybe BS.ByteString)+head = line id False++line :: Builder -> Bool+ -> Iteratee BS.ByteString IO (Maybe BS.ByteString)+line build dropLF = continue go+ where+ go (Chunks cnk) = breakLine (BL.fromChunks cnk)+ go EOF = yield Nothing EOF+ breakLine "" = line build dropLF+ breakLine xs | dropLF && y == lf = yield (Just ln) (Chunks cnk)+ where+ y = BL.head xs+ ys = BL.tail xs+ ln = toStrict . build $ ""+ cnk = BL.toChunks ys+ breakLine xs = case BL.break eol xs of+ (ys, "") -> line (build +++ toB ys) False+ (ys, zs) -> dropCRLF ys zs+ dropCRLF xs ys+ | z == cr = dropCR xs zs+ | otherwise = yield (Just ln) (Chunks cnks) -- dropLF+ where+ z = BL.head ys+ zs = BL.tail ys+ ln = toStrict . build $ xs+ cnks = BL.toChunks zs+ dropCR xs "" = line (build +++ toB xs) True+ dropCR xs ys+ | z == lf = yield (Just ln) (Chunks czs)+ | otherwise = yield (Just ln) (Chunks cys)+ where+ z = BL.head ys+ zs = BL.tail ys+ ln = toStrict . build $ xs+ cys = BL.toChunks ys+ czs = BL.toChunks zs+ lf = 10+ cr = 13+ eol c = c == lf || c == cr++type Builder = BL.ByteString -> BL.ByteString++(+++) :: Builder -> Builder -> Builder+a +++ b = a . b++toB :: BL.ByteString -> Builder+toB b = (b `BL.append`)++toStrict :: BL.ByteString -> BS.ByteString+toStrict = BS.concat . BL.toChunks
+ Network/Wai/Application/Classic/Field.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.Classic.Field where++import Control.Monad (mplus)+import Data.List+import qualified Data.Map as M (lookup)+import Data.Time+import Network.Wai.Application.Classic.Date+import Network.Wai.Application.Classic.Lang+import Network.Wai.Application.Classic.Header+import Network.Wai.Application.Static (defaultMimeTypes, defaultMimeType, MimeType)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 ()+import Data.Maybe+import Network.Wai++----------------------------------------------------------------++languages :: Request -> [String]+languages req = maybe [] parseLang $ lookupRequestField fkAcceptLanguage req++ifModifiedSince :: Request -> Maybe UTCTime+ifModifiedSince = lookupAndParseDate fkIfModifiedSince++ifUnmodifiedSince :: Request -> Maybe UTCTime+ifUnmodifiedSince = lookupAndParseDate fkIfUnmodifiedSince++ifRange :: Request -> Maybe UTCTime+ifRange = lookupAndParseDate fkIfRange++lookupAndParseDate :: ByteString -> Request -> Maybe UTCTime+lookupAndParseDate key req = lookupRequestField key req >>= parseDate++----------------------------------------------------------------++textPlain :: ResponseHeaders+textPlain = [("Content-Type", "text/plain")]++newHeader :: FilePath -> UTCTime -> ResponseHeaders+newHeader file mtime = [+ ("Content-Type", mimeType file)+ , ("Last-Modified", utcToDate mtime)+ ]++mimeType :: FilePath -> MimeType+mimeType file =fromMaybe defaultMimeType . foldl1' mplus . map lok $ targets+ where+ targets = extensions file+ lok x = M.lookup x defaultMimeTypes++extensions :: FilePath -> [String]+extensions file = entire : exts+ where+ exts' = split ('.'==) file+ exts = if exts' == [] then [] else tail exts'+ entire = foldr (\x y -> x ++ '.' : y) "" exts++split :: (Char -> Bool) -> String -> [String]+split _ "" = []+split p xs = case break p xs of+ (ys,"") -> [ys]+ (ys,_:zs) -> ys : split p zs
+ Network/Wai/Application/Classic/File.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.Classic.File (+ fileApp+ ) where++import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL ()+import Network.Wai+import Network.Wai.Application.Classic.Field+import Network.Wai.Application.Classic.FileInfo+import Network.Wai.Application.Classic.MaybeIter+import Network.Wai.Application.Classic.Types++----------------------------------------------------------------++{-|+ 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 :: AppSpec -> FileRoute -> Application+fileApp spec filei req = do+ RspSpec st hdr body <- case method of+ "GET" -> processGET req file ishtml rfile+ "HEAD" -> processHEAD req file ishtml rfile+ _ -> return $ notAllowed+ liftIO $ logger spec req st+ let hdr' = addHeader hdr+ case body of+ NoBody -> return $ responseLBS st hdr' ""+ BodyLBS bd -> return $ responseLBS st hdr' bd+ BodyFile afile _ -> return $ ResponseFile st hdr' afile -- FIXME size+ where+ method = requestMethod req+ path = pathinfoToFilePath req filei+ file = addIndex spec path+ ishtml = isHTML spec file+ rfile = redirectPath spec path+ addHeader hdr = ("Server", softwareName spec) : hdr++----------------------------------------------------------------++processGET :: Request -> FilePath -> Bool -> (Maybe FilePath) -> Rsp+processGET req file ishtml rfile = runAny [+ tryGet req file ishtml langs+ , tryRedirect req rfile langs+ , just notFound+ ]+ where+ langs = map ('.':) (languages req) ++ ["",".en"]++tryGet :: Request -> FilePath -> Bool -> [String] -> MRsp+tryGet req file True langs = runAnyMaybe $ map (tryGetFile req file) langs+tryGet req file _ _ = tryGetFile req file ""++tryGetFile :: Request -> FilePath -> String -> MRsp+tryGetFile req file lang = do+ let file' = if null lang then file else file ++ lang+ (liftIO $ fileInfo file') |>| \(size, mtime) -> do+ let hdr = newHeader file mtime+ mst = ifmodified req size mtime+ ||| ifunmodified req size mtime+ ||| ifrange req size mtime+ ||| unconditional req size mtime+ case mst of+ Just st+ | st == statusOK -> just $ RspSpec statusOK hdr (BodyFile file' size)+ -- FIXME skip len+ | st == statusPartialContent -> undefined+ | otherwise -> just $ RspSpec st hdr NoBody+ _ -> nothing -- never reached++----------------------------------------------------------------++processHEAD :: Request -> FilePath -> Bool -> (Maybe FilePath) -> Rsp+processHEAD req file ishtml rfile = runAny [+ tryHead req file ishtml langs+ , tryRedirect req rfile langs+ , just notFound+ ]+ where+ langs = map ('.':) (languages req) ++ ["",".en"]++tryHead :: Request -> FilePath -> Bool -> [String] -> MRsp+tryHead req file True langs = runAnyMaybe $ map (tryHeadFile req file) langs+tryHead req file _ _ = tryHeadFile req file ""++tryHeadFile :: Request -> FilePath -> String -> MRsp+tryHeadFile req file lang = do+ let file' = if null lang then file else file ++ lang+ (liftIO $ fileInfo file') |>| \(size, mtime) -> do+ let hdr = newHeader file mtime+ mst = ifmodified req size mtime+ ||| Just statusOK+ case mst of+ Just st -> just $ RspSpec st hdr NoBody+ _ -> nothing -- never reached++----------------------------------------------------------------++tryRedirect :: Request -> (Maybe FilePath) -> [String] -> MRsp+tryRedirect _ Nothing _ = nothing+tryRedirect req (Just file) langs =+ runAnyMaybe $ map (tryRedirectFile req file) langs++tryRedirectFile :: Request -> FilePath -> String -> MRsp+tryRedirectFile req file lang = do+ let file' = file ++ lang+ minfo <- liftIO $ fileInfo file'+ case minfo of+ Nothing -> nothing+ Just _ -> just $ RspSpec statusMovedPermanently hdr NoBody+ where+ hdr = [("Location", redirectURL)]+ (+++) = BS.append+ redirectURL = "http://"+ +++ serverName req+ +++ ":"+ +++ (BS.pack . show . serverPort) req+ +++ pathInfo req+ +++ "/"++----------------------------------------------------------------++notFound :: RspSpec+notFound = RspSpec statusNotFound textPlain (BodyLBS "Not Found")++notAllowed :: RspSpec+notAllowed = RspSpec statusNotAllowed textPlain (BodyLBS "Method Not Allowed")
+ Network/Wai/Application/Classic/FileInfo.hs view
@@ -0,0 +1,83 @@+module Network.Wai.Application.Classic.FileInfo where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Time+import Data.Time.Clock.POSIX+import Network.Wai+import Network.Wai.Application.Classic.Header+import Network.Wai.Application.Classic.Field+import Network.Wai.Application.Classic.Range+import Network.Wai.Application.Classic.Types+import Network.Wai.Application.Classic.Status+import System.Directory+import System.FilePath+import System.Posix.Files++----------------------------------------------------------------++fileInfo :: FilePath -> IO (Maybe (Integer, UTCTime))+fileInfo file = do+ exist <- doesFileExist file+ if exist+ then do+ fs <- getFileStatus file+ let size = fromIntegral . fileSize $ fs+ mtime = posixSecondsToUTCTime . realToFrac . modificationTime $ fs+ return $ Just (size, mtime)+ else return Nothing++----------------------------------------------------------------++ifmodified :: Request -> Integer -> UTCTime -> Maybe Status+ifmodified req size mtime = do+ date <- ifModifiedSince req+ if date /= mtime+ then unconditional req size mtime+ else Just statusNotModified++ifunmodified :: Request -> Integer -> UTCTime -> Maybe Status+ifunmodified req size mtime = do+ date <- ifUnmodifiedSince req+ if date == mtime+ then unconditional req size mtime+ else Just statusPreconditionFailed++ifrange :: Request -> Integer -> UTCTime -> Maybe Status+ifrange req size mtime = do+ date <- ifRange req+ rng <- lookupRequestField fkRange req+ if date == mtime+ then Just statusOK+ else range size rng++unconditional :: Request -> Integer -> UTCTime -> Maybe Status+unconditional req size _ =+ maybe (Just statusOK) (range size) $ lookupRequestField fkRange req++range :: Integer -> ByteString -> Maybe Status+range size rng = case skipAndSize rng size of+ Nothing -> Just statusRequestedRangeNotSatisfiable+ Just (_,_) -> Just statusNotImplemented+-- Just (skip,len) -> Just statusPartialContent -- FIXME skip len+++----------------------------------------------------------------++pathinfoToFilePath :: Request -> FileRoute -> FilePath+pathinfoToFilePath req filei = path'+ where+ path = pathInfo req+ src = fileSrc filei+ dst = fileDst filei+ path' = dst </> (drop (BS.length src) $ BS.unpack path)++addIndex :: AppSpec -> FilePath -> FilePath+addIndex spec path+ | hasTrailingPathSeparator path = path </> indexFile spec+ | otherwise = path++redirectPath :: AppSpec -> FilePath -> Maybe FilePath+redirectPath spec path+ | hasTrailingPathSeparator path = Nothing+ | otherwise = Just (path </> indexFile spec)
+ Network/Wai/Application/Classic/Header.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.Classic.Header where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 ()+import Data.Maybe+import Network.Wai++----------------------------------------------------------------++type FieldKey = ByteString++-- | A type for look-up key.+fkAcceptLanguage :: ByteString+fkAcceptLanguage = "accept-language"++-- | Look-up key for Range:.+fkRange :: FieldKey+fkRange = "range"++-- | Look-up key for If-Range:.+fkIfRange :: FieldKey+fkIfRange = "if-range"++-- | Look-up key for Last-Modified:.+fkLastModified :: FieldKey+fkLastModified = "last-modified"++-- | Look-up key for If-Modified-Since:.+fkIfModifiedSince :: FieldKey+fkIfModifiedSince = "if-modified-since"++-- | Look-up key for If-Unmodified-Since:.+fkIfUnmodifiedSince :: FieldKey+fkIfUnmodifiedSince = "if-unmodified-since"++-- | Look-up key for Content-Length:.+fkContentLength :: FieldKey+fkContentLength = "content-length"++-- | Look-up key for Content-Type:.+fkContentType :: FieldKey+fkContentType = "content-type"++-- | Look-up key for Cookie:.+fkCookie :: FieldKey+fkCookie = "cookie"++-- | Look-up key for User-Agent:.+fkUserAgent :: FieldKey+fkUserAgent = "user-agent"++-- | Look-up key for Referer:.+fkReferer :: FieldKey+fkReferer = "referer"++----------------------------------------------------------------++{-|+ Looking up a header in 'Request'.+-}+lookupRequestField :: FieldKey -> Request -> Maybe ByteString+lookupRequestField x req = lookupField x hdrs+ where+ hdrs = requestHeaders req++{-|+ Looking up a header in 'Request'. If the header does not exist,+ empty 'ByteString' is returned.+-}+lookupRequestField' :: FieldKey -> Request -> ByteString+lookupRequestField' x req = fromMaybe "" $ lookupField x hdrs+ where+ hdrs = requestHeaders req++{-|+ Looking up a header in 'RequestHeaders'.+-}+lookupField :: FieldKey -> RequestHeaders -> Maybe ByteString+lookupField x (((CIByteString _ l), val):kvs)+ | x == l = Just val+ | otherwise = lookupField x kvs+lookupField _ [] = Nothing
+ Network/Wai/Application/Classic/Lang.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.Classic.Lang (parseLang) where++import Control.Applicative hiding (many, optional)+import Data.Attoparsec.Char8 hiding (take)+import Data.ByteString.Char8 hiding (map, count, take)+import Data.List+import Data.Ord++parseLang :: ByteString -> [String]+parseLang bs = case feed (parse acceptLanguage bs) "" of+ Done _ ls -> map fst $ sortBy detrimental ls+ _ -> []+ where+ detrimental = flip (comparing snd)++----------------------------------------------------------------++acceptLanguage :: Parser [(String,Int)]+acceptLanguage = rangeQvalue `sepBy1` (spaces *> char ',' *> spaces)++rangeQvalue :: Parser (String,Int)+rangeQvalue = (,) <$> languageRange <*> quality++languageRange :: Parser String+languageRange = (++) <$> language <*> sublang++language :: Parser String+language = many1 letter_ascii++sublang :: Parser String+sublang = option "" ((:) <$> char '-' <*> many1 letter_ascii)++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
+ Network/Wai/Application/Classic/MaybeIter.hs view
@@ -0,0 +1,58 @@+module Network.Wai.Application.Classic.MaybeIter where++import Control.Monad (mplus)+import Data.ByteString (ByteString)+import Data.Enumerator (Iteratee)+import Network.Wai+import Network.Wai.Application.Classic.Types++----------------------------------------------------------------++type MaybeIter a = Iteratee ByteString IO (Maybe a)+type MRsp = MaybeIter RspSpec++type Rsp = Iteratee ByteString IO RspSpec++----------------------------------------------------------------++runAny :: [MRsp] -> Iteratee ByteString IO RspSpec+runAny [] = error "runAny"+runAny (a:as) = do+ mrsp <- a+ case mrsp of+ Nothing -> runAny as+ Just rsp -> return rsp++runAnyMaybe :: [MRsp] -> MRsp+runAnyMaybe [] = nothing+runAnyMaybe (a:as) = do+ mx <- a+ case mx of+ Nothing -> runAnyMaybe as+ Just _ -> return mx++----------------------------------------------------------------++(>>|) :: Maybe a -> (a -> MaybeIter b) -> MaybeIter b+v >>| act =+ case v of+ Nothing -> nothing+ Just x -> act x++(|>|) :: MaybeIter a -> (a -> MaybeIter b) -> MaybeIter b+a |>| act = do+ v <- a+ case v of+ Nothing -> nothing+ Just x -> act x++(|||) :: Maybe Status -> Maybe Status -> Maybe Status+(|||) = mplus++----------------------------------------------------------------++just :: Monad m => a -> m (Maybe a)+just = return . Just++nothing :: Monad m => m (Maybe a)+nothing = return Nothing
+ Network/Wai/Application/Classic/Range.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.Classic.Range (skipAndSize) where++import Control.Applicative hiding (many,optional)+import Data.Attoparsec.Char8 hiding (take)+import Data.ByteString.Char8 hiding (map, count, take)++skipAndSize :: ByteString -> Integer -> Maybe (Integer,Integer)+skipAndSize bs size = case parseRange bs of+ Just [(mbeg,mend)] -> adjust mbeg mend size+ _ -> Nothing++adjust :: Maybe Integer -> Maybe Integer -> Integer -> Maybe (Integer,Integer)+adjust (Just beg) (Just end) siz+ | beg <= end && end <= siz = Just (beg, end - beg + 1)+ | otherwise = Nothing+adjust (Just beg) Nothing siz+ | beg <= siz = Just (beg, siz - beg)+ | otherwise = Nothing+adjust Nothing (Just end) siz+ | end <= siz = Just (siz - end, end)+ | otherwise = Nothing+adjust Nothing Nothing _ = Nothing++type Range = (Maybe Integer, Maybe Integer)++parseRange :: ByteString -> Maybe [Range]+parseRange bs = case feed (parse byteRange bs) "" of+ Done _ x -> Just x+ _ -> Nothing++byteRange :: Parser [Range]+byteRange = string "bytes=" *> (ranges <* endOfInput)++ranges :: Parser [Range]+ranges = sepBy1 (range <|> suffixRange) (spcs >> char ',' >> spcs)++range :: Parser Range+range = (,) <$> ((Just <$> num) <* char '-')+ <*> option Nothing (Just <$> num)++suffixRange :: Parser Range+suffixRange = (,) Nothing <$> (char '-' *> (Just <$> num))++num :: Parser Integer+num = read <$> many1 digit++spcs :: Parser ()+spcs = () <$ many spc++spc :: Parser Char+spc = satisfy (\c -> c == ' ' || c == '\t')
+ Network/Wai/Application/Classic/Status.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.Classic.Status where++import Network.Wai++statusNotModified :: Status+statusNotModified = Status 304 "Not Modified"++statusPreconditionFailed :: Status+statusPreconditionFailed = Status 412 "Precondition Failed"++statusRequestedRangeNotSatisfiable :: Status+statusRequestedRangeNotSatisfiable = Status 416 "Requested Range Not Satisfiable"++statusNotImplemented :: Status+statusNotImplemented = Status 501 "Not Implemented"
+ Network/Wai/Application/Classic/Types.hs view
@@ -0,0 +1,47 @@+module Network.Wai.Application.Classic.Types where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL (ByteString)+import Network.Wai++data AppSpec = AppSpec {+ -- | Name specified to Server: in HTTP response.+ softwareName :: ByteString+ -- | A file name of an index file.+ , indexFile :: FilePath+ -- | Whether this is an HTML or not.+ , isHTML :: FilePath -> Bool+ -- | A function for logging.+ , logger :: Request -> Status -> IO ()+ }++data FileRoute = FileRoute {+ -- | Path prefix to be matched to 'pathInfo'.+ fileSrc :: ByteString+ -- | Path prefix to an actual file system.+ , fileDst :: FilePath+ }++data CgiRoute = CgiRoute {+ -- | Path prefix to be matched to 'pathInfo'.+ cgiSrc :: ByteString+ -- | Path prefix to an actual file system.+ , cgiDst :: FilePath+ }++data RspSpec = RspSpec {+ -- | Response status.+ rspStatus :: Status+ -- | Response headers.+ , rspHeaders :: ResponseHeaders+ -- | Response body.+ , rspBody :: RspBody+ }++data RspBody =+ -- | Body does not exist.+ NoBody+ -- | Body as Lazy ByteString.+ | BodyLBS BL.ByteString+ -- | Body as a file.+ | BodyFile FilePath Integer
+ Network/Wai/Application/Classic/Utils.hs view
@@ -0,0 +1,24 @@+module Network.Wai.Application.Classic.Utils where++import Control.Applicative+import Network.Socket (getNameInfo, SockAddr, NameInfoFlag(..))+import Data.Maybe+import Data.List (isPrefixOf)++{-|+ A type for IP address in numeric string representation.+-}+type NumericAddress = String++{-|+ Convert 'SockAddr' to 'NumericAddress'. If the address is+ an IPv4-embedded IPv6 address, the IPv4 is extracted.+-}+getPeerAddr :: SockAddr -> IO NumericAddress+getPeerAddr sa = strip . fromJust . fst <$> getInfo sa+ where+ getInfo = getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True+ strip x+ | "::ffff:" `isPrefixOf` x = drop 7 x+ | otherwise = x+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ wai-app-file-cgi.cabal view
@@ -0,0 +1,41 @@+Name: wai-app-file-cgi+Version: 0.0.0+Author: Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+License: BSD3+License-File: LICENSE+Synopsis: File/CGI App of WAI+Description: This WAI application handles static files and+ executes CGI scripts.+Homepage: http://www.mew.org/~kazu/+Category: Network+Cabal-Version: >= 1.6+Build-Type: Simple+library+ if impl(ghc >= 6.12)+ GHC-Options: -Wall -fno-warn-unused-do-bind+ else+ GHC-Options: -Wall+ Exposed-Modules: Network.Wai.Application.Classic+ Network.Wai.Application.Classic.CGI+ Network.Wai.Application.Classic.File+ Network.Wai.Application.Classic.Types+ Network.Wai.Application.Classic.Header+ Other-Modules: Network.Wai.Application.Classic.Date+ Network.Wai.Application.Classic.EnumLine+ Network.Wai.Application.Classic.Field+ Network.Wai.Application.Classic.FileInfo+ Network.Wai.Application.Classic.Lang+ Network.Wai.Application.Classic.MaybeIter+ Network.Wai.Application.Classic.Range+ Network.Wai.Application.Classic.Utils+ Network.Wai.Application.Classic.Status+ Build-Depends: base >= 4 && < 5, process, haskell98,+ network >=2.2 && <2.3, transformers, time,+ filepath, directory, unix,+ containers, attoparsec,+ wai, enumerator, bytestring, blaze-builder,+ wai-app-static+Source-Repository head+ Type: git+ Location: git://github.com/kazu-yamamoto/wai-app-file-cgi.git