← Back to branch summary

~ubuntu-branches/ubuntu/precise/haskell-wai-extra/precise

« back to all changes in this revision

Viewing changes to Network/Wai/Handler/CGI.hs

  • Committer: Package Import Robot
  • Author(s): Clint Adams
  • Date: 2011-10-08 23:41:41 UTC
  • mfrom: (2.1.2 sid)
  • Revision ID: package-import@ubuntu.com-20111008234141-4irb49p6argz4a3g
Tags: 0.4.3-1
New upstream version.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Handler/CGI.hs
1
1
{-# LANGUAGE OverloadedStrings #-}
 
2
{-# LANGUAGE RankNTypes #-}
 
3
-- | Backend for Common Gateway Interface. Almost all users should use the
 
4
-- 'run' function.
2
5
module Network.Wai.Handler.CGI
3
6
    ( run
4
 
    , run'
5
 
    , run''
6
7
    , runSendfile
 
8
    , runGeneric
 
9
    , requestBodyFunc
7
10
    ) where
8
11
 
9
12
import Network.Wai
10
 
import Network.Wai.Enumerator (fromResponseBody)
11
 
import Network.Wai.Handler.Helper
 
13
import Network.Socket (getAddrInfo, addrAddress)
12
14
import System.Environment (getEnvironment)
13
15
import Data.Maybe (fromMaybe)
14
16
import qualified Data.ByteString.Char8 as B
 
17
import qualified Data.ByteString.Lazy as L
15
18
import Control.Arrow ((***))
16
19
import Data.Char (toLower)
17
20
import qualified System.IO
18
 
import Data.String (fromString)
 
21
import qualified Data.String as String
 
22
import Data.Enumerator
 
23
    ( Enumerator, Step (..), Stream (..), continue, yield
 
24
    , enumList, ($$), joinI, returnI, (>>==), run_
 
25
    )
 
26
import Data.Monoid (mconcat)
 
27
import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
 
28
import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
 
29
import Blaze.ByteString.Builder.Enumerator (builderToByteString)
 
30
import Control.Monad.IO.Class (liftIO)
 
31
import Data.ByteString.Lazy.Internal (defaultChunkSize)
 
32
import System.IO (Handle)
 
33
import Network.HTTP.Types (Status (..))
 
34
import qualified Network.HTTP.Types as H
 
35
import qualified Data.CaseInsensitive as CI
19
36
 
20
37
safeRead :: Read a => a -> String -> a
21
38
safeRead d s =
26
43
lookup' :: String -> [(String, String)] -> String
27
44
lookup' key pairs = fromMaybe "" $ lookup key pairs
28
45
 
 
46
-- | Run an application using CGI.
29
47
run :: Application -> IO ()
30
48
run app = do
31
49
    vars <- getEnvironment
32
50
    let input = requestBodyHandle System.IO.stdin
33
51
        output = B.hPut System.IO.stdout
34
 
    run'' vars input output Nothing app
 
52
    runGeneric vars input output Nothing app
35
53
 
36
 
runSendfile :: String -- ^ sendfile header
 
54
-- | Some web servers provide an optimization for sending files via a sendfile
 
55
-- system call via a special header. To use this feature, provide that header
 
56
-- name here.
 
57
runSendfile :: B.ByteString -- ^ sendfile header
37
58
            -> Application -> IO ()
38
59
runSendfile sf app = do
39
60
    vars <- getEnvironment
40
61
    let input = requestBodyHandle System.IO.stdin
41
62
        output = B.hPut System.IO.stdout
42
 
    run'' vars input output (Just sf) app
43
 
 
44
 
run' :: [(String, String)] -- ^ all variables
45
 
     -> System.IO.Handle -- ^ responseBody of input
46
 
     -> System.IO.Handle -- ^ destination for output
47
 
     -> Application
48
 
     -> IO ()
49
 
run' vars inputH outputH app = do
50
 
    let input = requestBodyHandle inputH
51
 
        output = B.hPut outputH
52
 
    run'' vars input output Nothing app
53
 
 
54
 
run'' :: [(String, String)] -- ^ all variables
55
 
     -> (Int -> Source) -- ^ responseBody of input
 
63
    runGeneric vars input output (Just sf) app
 
64
 
 
65
-- | A generic CGI helper, which allows other backends (FastCGI and SCGI) to
 
66
-- use the same code as CGI. Most users will not need this function, and can
 
67
-- stick with 'run' or 'runSendfile'.
 
68
runGeneric
 
69
     :: [(String, String)] -- ^ all variables
 
70
     -> (forall a. Int -> Enumerator B.ByteString IO a) -- ^ responseBody of input
56
71
     -> (B.ByteString -> IO ()) -- ^ destination for output
57
 
     -> Maybe String -- ^ does the server support the X-Sendfile header?
 
72
     -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
58
73
     -> Application
59
74
     -> IO ()
60
 
run'' vars inputH outputH xsendfile app = do
 
75
runGeneric vars inputH outputH xsendfile app = do
61
76
    let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
62
77
        pinfo = lookup' "PATH_INFO" vars
63
78
        qstring = lookup' "QUERY_STRING" vars
65
80
        serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
66
81
        contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
67
82
        remoteHost' =
68
 
            case lookup "REMOTE_HOST" vars of
 
83
            case lookup "REMOTE_ADDR" vars of
69
84
                Just x -> x
70
85
                Nothing ->
71
 
                    case lookup "REMOTE_ADDR" vars of
 
86
                    case lookup "REMOTE_HOST" vars of
72
87
                        Just x -> x
73
88
                        Nothing -> ""
74
89
        isSecure' =
75
90
            case map toLower $ lookup' "SERVER_PROTOCOL" vars of
76
91
                "https" -> True
77
92
                _ -> False
 
93
    addrs <- getAddrInfo Nothing (Just remoteHost') Nothing
 
94
    let addr =
 
95
            case addrs of
 
96
                a:_ -> addrAddress a
 
97
                [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
78
98
    let env = Request
79
99
            { requestMethod = rmethod
80
 
            , pathInfo = B.pack pinfo
81
 
            , queryString = B.pack qstring
 
100
            , rawPathInfo = B.pack pinfo
 
101
            , pathInfo = H.decodePathSegments $ B.pack pinfo
 
102
            , rawQueryString = B.pack qstring
 
103
            , queryString = H.parseQuery $ B.pack qstring
82
104
            , serverName = B.pack servername
83
105
            , serverPort = serverport
84
106
            , requestHeaders = map (cleanupVarName *** B.pack) vars
85
107
            , isSecure = isSecure'
86
 
            , requestBody = inputH contentLength
87
 
            , errorHandler = System.IO.hPutStr System.IO.stderr
88
 
            , remoteHost = B.pack remoteHost'
89
 
            , httpVersion = "1.1" -- FIXME
 
108
            , remoteHost = addr
 
109
            , httpVersion = H.http11 -- FIXME
90
110
            }
91
 
    res <- app env
92
 
    let h = responseHeaders res
93
 
    let h' = case lookup "Content-Type" h of
94
 
                Nothing -> ("Content-Type", "text/html; charset=utf-8")
95
 
                         : h
96
 
                Just _ -> h
97
 
    let hPut = outputH
98
 
    hPut $ B.pack $ "Status: " ++ (show $ statusCode $ status res) ++ " "
99
 
    hPut $ statusMessage $ status res
100
 
    hPut $ B.singleton '\n'
101
 
    mapM_ (printHeader hPut) h'
102
 
    case (xsendfile, responseBody res) of
103
 
        (Just sf, ResponseFile fp) ->
104
 
            hPut $ B.pack $ concat
105
 
                [ sf
106
 
                , ": "
107
 
                , fp
108
 
                , "\n\n"
109
 
                , sf
110
 
                , " not supported"
111
 
                ]
112
 
        _ -> do
113
 
            hPut $ B.singleton '\n'
114
 
            _ <- runEnumerator (fromResponseBody (responseBody res))
115
 
                               (myPut outputH) ()
116
 
            return ()
117
 
 
118
 
myPut :: (B.ByteString -> IO ()) -> () -> B.ByteString -> IO (Either () ())
119
 
myPut output _ bs = output bs >> return (Right ())
120
 
 
121
 
printHeader :: (B.ByteString -> IO ())
122
 
            -> (ResponseHeader, B.ByteString)
123
 
            -> IO ()
124
 
printHeader f (x, y) = do
125
 
    f $ ciOriginal x
126
 
    f $ B.pack ": "
127
 
    f y
128
 
    f $ B.singleton '\n'
129
 
 
130
 
cleanupVarName :: String -> RequestHeader
131
 
cleanupVarName ('H':'T':'T':'P':'_':a:as) =
132
 
    fromString $ a : helper' as
 
111
    -- FIXME worry about exception?
 
112
    res <- run_ $ inputH contentLength $$ app env
 
113
    case (xsendfile, res) of
 
114
        (Just sf, ResponseFile s hs fp Nothing) ->
 
115
            mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
 
116
        _ -> responseEnumerator res $ \s hs ->
 
117
            joinI $ enumList 1 [headers s hs, fromChar '\n'] $$ builderIter
 
118
  where
 
119
    headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
 
120
    status (Status i m) = (fromByteString "Status", mconcat
 
121
        [ fromString $ show i
 
122
        , fromChar ' '
 
123
        , fromByteString m
 
124
        ])
 
125
    header' (x, y) = (fromByteString $ CI.original x, fromByteString y)
 
126
    header (x, y) = mconcat
 
127
        [ x
 
128
        , fromByteString ": "
 
129
        , y
 
130
        , fromChar '\n'
 
131
        ]
 
132
    sfBuilder s hs sf fp = mconcat
 
133
        [ headers s hs
 
134
        , header $ (fromByteString sf, fromString fp)
 
135
        , fromChar '\n'
 
136
        , fromByteString sf
 
137
        , fromByteString " not supported"
 
138
        ]
 
139
    bsStep = Continue bsStep'
 
140
    bsStep' EOF = yield () EOF
 
141
    bsStep' (Chunks []) = continue bsStep'
 
142
    bsStep' (Chunks bss) = liftIO (mapM_ outputH bss) >> continue bsStep'
 
143
    builderIter = builderToByteString bsStep
 
144
    fixHeaders h =
 
145
        case lookup "content-type" h of
 
146
            Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
 
147
            Just _ -> h
 
148
 
 
149
cleanupVarName :: String -> CI.CI B.ByteString
 
150
cleanupVarName "CONTENT_TYPE" = "Content-Type"
 
151
cleanupVarName "CONTENT_LENGTH" = "Content-Length"
 
152
cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
 
153
cleanupVarName s =
 
154
    case s of
 
155
        'H':'T':'T':'P':'_':a:as -> String.fromString $ a : helper' as
 
156
        _ -> String.fromString s -- FIXME remove?
133
157
  where
134
158
    helper' ('_':x:rest) = '-' : x : helper' rest
135
159
    helper' (x:rest) = toLower x : helper' rest
136
160
    helper' [] = []
137
 
cleanupVarName "CONTENT_TYPE" = "Content-Type"
138
 
cleanupVarName "CONTENT_LENGTH" = "Content-Length"
139
 
cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
140
 
cleanupVarName x = fromString x -- FIXME remove?
 
161
 
 
162
requestBodyHandle :: Handle -> Int -> Enumerator B.ByteString IO a
 
163
requestBodyHandle h =
 
164
    requestBodyFunc go
 
165
  where
 
166
    go i = Just `fmap` B.hGet h (min i defaultChunkSize)
 
167
 
 
168
requestBodyFunc :: (Int -> IO (Maybe B.ByteString))
 
169
                -> Int
 
170
                -> Enumerator B.ByteString IO a
 
171
requestBodyFunc _ 0 step = returnI step
 
172
requestBodyFunc h len (Continue k) = do
 
173
    mbs <- liftIO $ h len
 
174
    case mbs of
 
175
        Nothing -> continue k
 
176
        Just bs -> do
 
177
            let newLen = len - B.length bs
 
178
            k (Chunks [bs]) >>== requestBodyFunc h newLen
 
179
requestBodyFunc _ _ step = returnI step