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