wai-app-file-cgi-3.1.6/0000755000000000000000000000000013270227354012727 5ustar0000000000000000wai-app-file-cgi-3.1.6/Setup.hs0000644000000000000000000000005613270227354014364 0ustar0000000000000000import Distribution.Simple main = defaultMain wai-app-file-cgi-3.1.6/LICENSE0000644000000000000000000000276513270227354013746 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.1.6/wai-app-file-cgi.cabal0000644000000000000000000001016113270227354016725 0ustar0000000000000000Name: wai-app-file-cgi Version: 3.1.6 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 Extra-Source-Files: test/cgi-bin/broken test/cgi-bin/echo-env test/data/post test/html/index.html test/html/ja/index.html.ja test/html/no_extension test/html/redirect/index.html 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.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 , bytestring , case-insensitive , conduit >= 1.1 , conduit-extra , containers , data-default-class , directory , filepath , http-client >= 0.5 , 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.2 && < 3.3 , wai-conduit , warp >= 3.2.21 && < 3.3 , 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.2 && < 3.3 , wai-app-file-cgi , warp >= 3.2.6 && < 3.3 , HTTP Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/wai-app-file-cgi wai-app-file-cgi-3.1.6/test/0000755000000000000000000000000013270227354013706 5ustar0000000000000000wai-app-file-cgi-3.1.6/test/ClassicSpec.hs0000644000000000000000000001061413270227354016440 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 "works with files that lack a file extension" $ do let url = "http://127.0.0.1:2345/no_extension" bdy <- rspBody <$> sendGET url ans <- readFileAscii "test/html/no_extension" 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.1.6/test/doctests.hs0000644000000000000000000000021613270227354016071 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest [ "-XOverloadedStrings" , "Network/Wai/Application/Classic.hs" ] wai-app-file-cgi-3.1.6/test/Spec.hs0000644000000000000000000000230213270227354015131 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/") } wai-app-file-cgi-3.1.6/test/html/0000755000000000000000000000000013270227354014652 5ustar0000000000000000wai-app-file-cgi-3.1.6/test/html/index.html0000644000000000000000000000016713270227354016653 0ustar0000000000000000 Test Hello World! wai-app-file-cgi-3.1.6/test/html/no_extension0000644000000000000000000000005113270227354017301 0ustar0000000000000000This is a file without an extension! Hi! wai-app-file-cgi-3.1.6/test/html/ja/0000755000000000000000000000000013270227354015244 5ustar0000000000000000wai-app-file-cgi-3.1.6/test/html/ja/index.html.ja0000644000000000000000000000020213270227354017624 0ustar0000000000000000 てすと こんにちは！ wai-app-file-cgi-3.1.6/test/html/redirect/0000755000000000000000000000000013270227354016453 5ustar0000000000000000wai-app-file-cgi-3.1.6/test/html/redirect/index.html0000644000000000000000000000016713270227354020454 0ustar0000000000000000 Test Hello World! wai-app-file-cgi-3.1.6/test/cgi-bin/0000755000000000000000000000000013270227354015216 5ustar0000000000000000wai-app-file-cgi-3.1.6/test/cgi-bin/broken0000755000000000000000000000002213270227354016416 0ustar0000000000000000#! /bin/sh cat - wai-app-file-cgi-3.1.6/test/cgi-bin/echo-env0000755000000000000000000000105413270227354016650 0ustar0000000000000000#! /bin/sh echo "Content-Type: text/plain" echo "Status: 200" echo "" echo "GATEWAY_INTERFACE: $GATEWAY_INTERFACE" echo "SCRIPT_NAME: $SCRIPT_NAME" echo "REQUEST_METHOD: $REQUEST_METHOD" echo "SERVER_NAME: $SERVER_NAME" echo "SERVER_PORT: $SERVER_PORT" #echo "REMOTE_ADDR: $REMOTE_ADDR" echo "SERVER_PROTOCOL: $SERVER_PROTOCOL" echo "SERVER_SOFTWARE: $SERVER_SOFTWARE" echo "PATH_INFO: $PATH_INFO" echo "QUERY_STRING: $QUERY_STRING" echo "CONTENT_LENGTH: $CONTENT_LENGTH" echo "CONTENT_TYPE: $CONTENT_TYPE" echo "HTTP_COOKIE: $HTTP_COOKIE" echo "" cat - wai-app-file-cgi-3.1.6/test/data/0000755000000000000000000000000013270227354014617 5ustar0000000000000000wai-app-file-cgi-3.1.6/test/data/post0000644000000000000000000000044713270227354015534 0ustar0000000000000000GATEWAY_INTERFACE: CGI/1.1 SCRIPT_NAME: /cgi-bin/echo-env REQUEST_METHOD: POST SERVER_NAME: 127.0.0.1 SERVER_PORT: 2345 SERVER_PROTOCOL: HTTP/1.1 SERVER_SOFTWARE: ClassicTester PATH_INFO: /pathinfo QUERY_STRING: query=foo CONTENT_LENGTH: 14 CONTENT_TYPE: Text/Plain HTTP_COOKIE: foo bar. baz! wai-app-file-cgi-3.1.6/Network/0000755000000000000000000000000013270227354014360 5ustar0000000000000000wai-app-file-cgi-3.1.6/Network/Wai/0000755000000000000000000000000013270227354015100 5ustar0000000000000000wai-app-file-cgi-3.1.6/Network/Wai/Application/0000755000000000000000000000000013270227354017343 5ustar0000000000000000wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic.hs0000644000000000000000000000175413270227354021267 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.1.6/Network/Wai/Application/Classic/0000755000000000000000000000000013270227354020724 5ustar0000000000000000wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic/Conduit.hs0000644000000000000000000000401013270227354022660 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module Network.Wai.Application.Classic.Conduit ( byteStringToBuilder , toResponseSource , parseHeader ) where import Control.Applicative import Data.Attoparsec.ByteString import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB (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.byteString ---------------------------------------------------------------- #if MIN_VERSION_conduit(1,3,0) toResponseSource :: SealedConduitT () ByteString IO () -> IO (ConduitT () (Flush Builder) IO ()) toResponseSource rsrc = do let src = unsealConduitT rsrc return $ src .| CL.map (Chunk . byteStringToBuilder) #else toResponseSource :: ResumableSource IO ByteString -> IO (Source IO (Flush Builder)) toResponseSource rsrc = do (src,_) <- unwrapResumable rsrc return $ src $= CL.map (Chunk . byteStringToBuilder) #endif ---------------------------------------------------------------- parseHeader :: ConduitM ByteString o 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.1.6/Network/Wai/Application/Classic/File.hs0000644000000000000000000001207213270227354022141 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module Network.Wai.Application.Classic.File ( fileApp , redirectHeader ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Exception.IOChoice import Data.ByteString (ByteString) import Data.Maybe import qualified Data.ByteString.Char8 as BS (concat) 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.Path import Network.Wai.Application.Classic.Status import Network.Wai.Application.Classic.Types import Network.Wai.Handler.Warp (getFileInfo) ---------------------------------------------------------------- data RspSpec = NoBody Status | NoBodyHdr Status ResponseHeaders | BodyFile Status ResponseHeaders FilePath deriving (Eq,Show) ---------------------------------------------------------------- data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang] langSuffixes :: RequestHeaders -> [Lang] langSuffixes hdr = map (\x -> (<.> x)) langs ++ [id, (<.> "en")] where langs = languages hdr ---------------------------------------------------------------- {-| 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 <- case method of Right GET -> processGET hinfo ishtml rfile Right HEAD -> processGET hinfo ishtml rfile _ -> return notAllowed response <- case rspspec of NoBody st -> bodyStatus st NoBodyHdr st hdr -> return $ responseLBS st hdr "" BodyFile st hdr fl -> return $ ResponseFile st hdr fl Nothing respond 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 $ requestHeaders req noBody st = return $ responseLBS st [] "" bodyStatus st = getStatusInfo cspec req langs st >>= statusBody st statusBody st StatusNone = noBody st statusBody st (StatusByteString bd) = return $ responseLBS st hdr bd where hdr = textPlainHeader statusBody st (StatusFile afile len) = return $ ResponseFile st hdr fl mfp where mfp = Just (FilePart 0 len len) fl = pathString afile hdr = textHtmlHeader ---------------------------------------------------------------- processGET :: HandlerInfo -> Bool -> Maybe Path -> IO RspSpec processGET hinfo ishtml rfile = tryGet hinfo ishtml ||> tryRedirect hinfo rfile ||> return notFound tryGet :: HandlerInfo -> Bool -> IO RspSpec tryGet hinfo@(HandlerInfo _ _ _ langs) True = runAnyOne $ map (tryGetFile hinfo True) langs tryGet hinfo False = tryGetFile hinfo False id tryGetFile :: HandlerInfo -> Bool -> Lang -> IO RspSpec tryGetFile (HandlerInfo _ req file _) ishtml lang = do let file' = pathString $ lang file hdr = newHeader ishtml file _ <- getFileInfo req file' -- expecting an error return $ BodyFile ok200 hdr file' ---------------------------------------------------------------- tryRedirect :: HandlerInfo -> Maybe Path -> IO RspSpec 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 -> IO RspSpec tryRedirectFile (HandlerInfo _ req file _) lang = do let file' = pathString $ lang file _ <- getFileInfo req file' -- expecting an error return $ NoBodyHdr movedPermanently301 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 = NoBody notFound404 notAllowed :: RspSpec notAllowed = NoBody methodNotAllowed405 wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic/FileInfo.hs0000644000000000000000000000142713270227354022757 0ustar0000000000000000module Network.Wai.Application.Classic.FileInfo where import Network.Wai import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types ---------------------------------------------------------------- pathinfoToFilePath :: Request -> FileRoute -> Path pathinfoToFilePath req filei = path' where path = rawPathInfo req src = fileSrc filei dst = fileDst filei path' = dst (path <\> src) -- fixme 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.1.6/Network/Wai/Application/Classic/Status.hs0000644000000000000000000000447313270227354022553 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.1.6/Network/Wai/Application/Classic/Path.hs0000644000000000000000000000552213270227354022160 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, BangPatterns #-} module Network.Wai.Application.Classic.Path ( Path , pathString , fromString , (), (<\>), (<.>) , breakAtSeparator, hasLeadingPathSeparator, hasTrailingPathSeparator , isSuffixOf ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import Data.String import Data.Word ---------------------------------------------------------------- -- | File path. type Path = ByteString pathString :: Path -> String pathString = B8.unpack {-# INLINE pathString #-} ---------------------------------------------------------------- -- 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 bs | BS.null bs = False | BS.head bs == pathSep = True | otherwise = False {-# INLINE hasLeadingPathSeparator #-} {-| Checking if the path ends with the path separator. >>> hasTrailingPathSeparator "/foo/bar/" True >>> hasTrailingPathSeparator "/foo/bar" False -} hasTrailingPathSeparator :: Path -> Bool hasTrailingPathSeparator bs | BS.null bs = False | BS.last bs == pathSep = True | otherwise = False {-# INLINE hasTrailingPathSeparator #-} {-| 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 = p where !has1 = hasTrailingPathSeparator p1 !has2 = hasLeadingPathSeparator p2 !p | has1 && not has2 = p1 `BS.append` p2 | not has1 && has2 = p1 `BS.append` p2 | has1 = p1 `BS.append` BS.tail p2 | otherwise = BS.concat [p1,pathSepBS,p2] {-# INLINE () #-} {-| 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 = p where !p = BS.drop (BS.length p2) p1 {-# INLINE (<\>) #-} {-| Adding suffix. -} (<.>) :: Path -> Path -> Path p1 <.> p2 = p where !p = BS.concat [p1,pathDotBS,p2] {-# INLINE (<.>) #-} {-| 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 = BS.break (== pathSep) p {-# INLINE breakAtSeparator #-} isSuffixOf :: Path -> Path -> Bool isSuffixOf = BS.isSuffixOf {-# INLINE isSuffixOf #-} wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic/Header.hs0000644000000000000000000000227713270227354022460 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Network.Wai.Application.Classic.Header where 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) wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic/Field.hs0000644000000000000000000000503413270227354022305 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 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.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 :: RequestHeaders -> [ByteString] languages = maybe [] parseLang . lookup hAcceptLanguage ---------------------------------------------------------------- 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 -> ResponseHeaders newHeader ishtml file | ishtml = textHtmlHeader | otherwise = [(hContentType, mimeType file)] mimeType :: ByteString -> MimeType mimeType file = fromMaybe defaultMimeType . foldr mplus Nothing . 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.1.6/Network/Wai/Application/Classic/Lang.hs0000644000000000000000000000332013270227354022137 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.1.6/Network/Wai/Application/Classic/EventSource.hs0000644000000000000000000000466413270227354023534 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module Network.Wai.Application.Classic.EventSource ( bodyToEventSource ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder 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] #if MIN_VERSION_conduit(1,3,0) eventSourceConduit :: ConduitT ByteString (Flush Builder) IO () #else eventSourceConduit :: Conduit ByteString IO (Flush Builder) #endif eventSourceConduit = CL.concatMapAccum f "" where f input rest = (last xs, concatMap addFlush $ init xs) where addFlush x = [Chunk (byteString x), Flush] xs = splitDoubleLineBreak (rest `BS.append` input) -- insert Flush if exists a double line-break #if MIN_VERSION_conduit(1,3,0) bodyToEventSource :: H.BodyReader -> ConduitT () (Flush Builder) IO () bodyToEventSource br = HC.bodyReaderSource br .| eventSourceConduit #else bodyToEventSource :: H.BodyReader -> Source IO (Flush Builder) bodyToEventSource br = HC.bodyReaderSource br $= eventSourceConduit #endif wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic/Types.hs0000644000000000000000000000457713270227354022401 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.Wai.Application.Classic.Path ---------------------------------------------------------------- data ClassicAppSpec = ClassicAppSpec { -- | Name specified to Server: in HTTP response. softwareName :: ByteString -- | 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 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) ---------------------------------------------------------------- type Lang = Path -> Path wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic/Def.hs0000644000000000000000000000224413270227354021760 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Application.Classic.Def where import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types -- | -- Default value for 'ClassicAppSpec'. 'softwareName' is \"Classic\". 'dater' calls 'epochTime' for every request. 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\". defaultClassicAppSpec :: ClassicAppSpec defaultClassicAppSpec = ClassicAppSpec { softwareName = "Classic" , statusFileDir = "/usr/local/share/html/status/" } ---------------------------------------------------------------- -- | -- 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.1.6/Network/Wai/Application/Classic/RevProxy.hs0000644000000000000000000001002013270227354023047 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.Wai.Application.Classic.RevProxy (revProxyApp) where #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 Data.ByteString.Builder (Builder) import qualified Data.ByteString.Char8 as BS hiding (uncons) import Data.Conduit 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 respond $ responseSource status hdr src httpClientRequest = reqToHReq req route mgr = revProxyManager spec 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 = H.defaultRequest { 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 = 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.checkResponse = \_ _ -> return () , H.redirectCount = 0 } where path = 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) ---------------------------------------------------------------- #if MIN_VERSION_conduit(1,3,0) toSource :: Maybe ByteString -> H.BodyReader -> ConduitT () (Flush Builder) IO () #else toSource :: Maybe ByteString -> H.BodyReader -> Source IO (Flush Builder) #endif toSource (Just "text/event-stream") = bodyToEventSource toSource _ = bodyToSource #if MIN_VERSION_conduit(1,3,0) bodyToSource :: H.BodyReader -> ConduitT () (Flush Builder) IO () #else bodyToSource :: H.BodyReader -> Source IO (Flush Builder) #endif 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 _ = return $ responseBuilder st hdr bdy where hdr = addServer cspec textPlainHeader bdy = byteStringToBuilder "Bad Gateway\r\n" st = badGateway502 -} wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic/Redirect.hs0000644000000000000000000000135113270227354023021 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 _ route req respond = respond $ responseLBS status hdr "" where path = rawPathInfo req src = redirectSrc route dst = redirectDst route -- Scheme must not be included because of no way to tell -- http or https. rurl = "//" `append` (dst (path <\> src)) hdr = locationHeader rurl status = movedPermanently301 wai-app-file-cgi-3.1.6/Network/Wai/Application/Classic/CGI.hs0000644000000000000000000001524013270227354021664 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 ---------------------------------------------------------------- type TRYPATH = Either E.IOException String toCGI :: Handle -> Request -> IO () #if MIN_VERSION_conduit(1,3,0) toCGI whdl req = runConduit (sourceRequestBody req .| CB.sinkHandle whdl) #else toCGI whdl req = sourceRequestBody req $$ CB.sinkHandle whdl #endif fromCGI :: Handle -> IO Response fromCGI rhdl = do (src', hs) <- cgiHeader `E.catch` recover let (st, hdr, hasBody) = case check hs of Nothing -> (internalServerError500,[],False) Just (s,h) -> (s,h,True) 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 #if __GLASGOW_HASKELL__ >= 800 , detach_console = False , create_new_console = False , new_session = False , child_group = Nothing , child_user = Nothing #endif } (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii) (cgiDst cgii) (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'