1{-# LANGUAGE RankNTypes, CPP #-} 2-- | Backend for Common Gateway Interface. Almost all users should use the 3-- 'run' function. 4module Network.Wai.Handler.CGI 5 ( run 6 , runSendfile 7 , runGeneric 8 , requestBodyFunc 9 ) where 10 11import Network.Wai 12import Network.Wai.Internal 13import Network.Socket (getAddrInfo, addrAddress) 14import Data.IORef 15import Data.Maybe (fromMaybe) 16import qualified Data.ByteString.Char8 as B 17import qualified Data.ByteString.Lazy as L 18import Control.Arrow ((***)) 19import Data.Char (toLower) 20import qualified System.IO 21import qualified Data.String as String 22import Data.ByteString.Builder (byteString, toLazyByteString, char7, string8) 23import Data.ByteString.Builder.Extra (flush) 24import Data.ByteString.Lazy.Internal (defaultChunkSize) 25import System.IO (Handle) 26import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength) 27import qualified Network.HTTP.Types as H 28import qualified Data.CaseInsensitive as CI 29#if __GLASGOW_HASKELL__ < 710 30import Data.Monoid (mconcat, mempty, mappend) 31#endif 32 33import qualified Data.Streaming.ByteString.Builder as Builder 34import Data.Function (fix) 35import Control.Monad (unless, void) 36 37#if WINDOWS 38import System.Environment (getEnvironment) 39#else 40import qualified System.Posix.Env.ByteString as Env 41 42getEnvironment :: IO [(String, String)] 43getEnvironment = map (B.unpack *** B.unpack) `fmap` Env.getEnvironment 44#endif 45 46safeRead :: Read a => a -> String -> a 47safeRead d s = 48 case reads s of 49 ((x, _):_) -> x 50 [] -> d 51 52lookup' :: String -> [(String, String)] -> String 53lookup' key pairs = fromMaybe "" $ lookup key pairs 54 55-- | Run an application using CGI. 56run :: Application -> IO () 57run app = do 58 vars <- getEnvironment 59 let input = requestBodyHandle System.IO.stdin 60 output = B.hPut System.IO.stdout 61 runGeneric vars input output Nothing app 62 63-- | Some web servers provide an optimization for sending files via a sendfile 64-- system call via a special header. To use this feature, provide that header 65-- name here. 66runSendfile :: B.ByteString -- ^ sendfile header 67 -> Application -> IO () 68runSendfile sf app = do 69 vars <- getEnvironment 70 let input = requestBodyHandle System.IO.stdin 71 output = B.hPut System.IO.stdout 72 runGeneric vars input output (Just sf) app 73 74-- | A generic CGI helper, which allows other backends (FastCGI and SCGI) to 75-- use the same code as CGI. Most users will not need this function, and can 76-- stick with 'run' or 'runSendfile'. 77runGeneric 78 :: [(String, String)] -- ^ all variables 79 -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input 80 -> (B.ByteString -> IO ()) -- ^ destination for output 81 -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header? 82 -> Application 83 -> IO () 84runGeneric vars inputH outputH xsendfile app = do 85 let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars 86 pinfo = lookup' "PATH_INFO" vars 87 qstring = lookup' "QUERY_STRING" vars 88 contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars 89 remoteHost' = 90 case lookup "REMOTE_ADDR" vars of 91 Just x -> x 92 Nothing -> 93 case lookup "REMOTE_HOST" vars of 94 Just x -> x 95 Nothing -> "" 96 isSecure' = 97 case map toLower $ lookup' "SERVER_PROTOCOL" vars of 98 "https" -> True 99 _ -> False 100 addrs <- getAddrInfo Nothing (Just remoteHost') Nothing 101 requestBody' <- inputH contentLength 102 let addr = 103 case addrs of 104 a:_ -> addrAddress a 105 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost' 106 reqHeaders = map (cleanupVarName *** B.pack) vars 107 env = Request 108 { requestMethod = rmethod 109 , rawPathInfo = B.pack pinfo 110 , pathInfo = H.decodePathSegments $ B.pack pinfo 111 , rawQueryString = B.pack qstring 112 , queryString = H.parseQuery $ B.pack qstring 113 , requestHeaders = reqHeaders 114 , isSecure = isSecure' 115 , remoteHost = addr 116 , httpVersion = H.http11 -- FIXME 117 , requestBody = requestBody' 118 , vault = mempty 119 , requestBodyLength = KnownLength $ fromIntegral contentLength 120 , requestHeaderHost = lookup "host" reqHeaders 121 , requestHeaderRange = lookup hRange reqHeaders 122#if MIN_VERSION_wai(3,2,0) 123 , requestHeaderReferer = lookup "referer" reqHeaders 124 , requestHeaderUserAgent = lookup "user-agent" reqHeaders 125#endif 126 } 127 void $ app env $ \res -> 128 case (xsendfile, res) of 129 (Just sf, ResponseFile s hs fp Nothing) -> do 130 mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp 131 return ResponseReceived 132 _ -> do 133 let (s, hs, wb) = responseToStream res 134 (blazeRecv, blazeFinish) <- Builder.newBuilderRecv Builder.defaultStrategy 135 wb $ \b -> do 136 let sendBuilder builder = do 137 popper <- blazeRecv builder 138 fix $ \loop -> do 139 bs <- popper 140 unless (B.null bs) $ do 141 outputH bs 142 loop 143 sendBuilder $ headers s hs `mappend` char7 '\n' 144 b sendBuilder (sendBuilder flush) 145 blazeFinish >>= maybe (return ()) outputH 146 return ResponseReceived 147 where 148 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs)) 149 status (Status i m) = (byteString "Status", mconcat 150 [ string8 $ show i 151 , char7 ' ' 152 , byteString m 153 ]) 154 header' (x, y) = (byteString $ CI.original x, byteString y) 155 header (x, y) = mconcat 156 [ x 157 , byteString ": " 158 , y 159 , char7 '\n' 160 ] 161 sfBuilder s hs sf fp = mconcat 162 [ headers s hs 163 , header $ (byteString sf, string8 fp) 164 , char7 '\n' 165 , byteString sf 166 , byteString " not supported" 167 ] 168 fixHeaders h = 169 case lookup hContentType h of 170 Nothing -> (hContentType, "text/html; charset=utf-8") : h 171 Just _ -> h 172 173cleanupVarName :: String -> CI.CI B.ByteString 174cleanupVarName "CONTENT_TYPE" = hContentType 175cleanupVarName "CONTENT_LENGTH" = hContentLength 176cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name" 177cleanupVarName s = 178 case s of 179 'H':'T':'T':'P':'_':a:as -> String.fromString $ a : helper' as 180 _ -> String.fromString s -- FIXME remove? 181 where 182 helper' ('_':x:rest) = '-' : x : helper' rest 183 helper' (x:rest) = toLower x : helper' rest 184 helper' [] = [] 185 186requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString) 187requestBodyHandle h = requestBodyFunc $ \i -> do 188 bs <- B.hGet h i 189 return $ if B.null bs then Nothing else Just bs 190 191requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString) 192requestBodyFunc get count0 = do 193 ref <- newIORef count0 194 return $ do 195 count <- readIORef ref 196 if count <= 0 197 then return B.empty 198 else do 199 mbs <- get $ min count defaultChunkSize 200 writeIORef ref $ count - maybe 0 B.length mbs 201 return $ fromMaybe B.empty mbs 202