← Back to branch summary

~ubuntu-branches/ubuntu/vivid/haskell-wai-extra/vivid-proposed

« back to all changes in this revision

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

  • Committer: Package Import Robot
  • Author(s): Joachim Breitner
  • Date: 2014-05-03 10:15:30 UTC
  • mfrom: (2.2.6 sid)
  • Revision ID: package-import@ubuntu.com-20140503101530-9e99lxx6x6xd2o9o
Tags: 2.1.1-1
New upstream release

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Handler/CGI.hs
11
11
    ) where
12
12
 
13
13
import Network.Wai
 
14
import Network.Wai.Internal
14
15
import Network.Socket (getAddrInfo, addrAddress)
15
 
import System.Environment (getEnvironment)
16
16
import Data.Maybe (fromMaybe)
 
17
import Control.Exception (mask)
17
18
import qualified Data.ByteString.Char8 as B
18
19
import qualified Data.ByteString.Lazy as L
19
20
import Control.Arrow ((***))
32
33
import qualified Data.CaseInsensitive as CI
33
34
import Data.Monoid (mappend)
34
35
import Data.Conduit
35
 
import qualified Data.Conduit.List as CL
 
36
 
 
37
#if WINDOWS
 
38
import System.Environment (getEnvironment)
 
39
#else
 
40
import qualified System.Posix.Env.ByteString as Env
 
41
 
 
42
getEnvironment :: IO [(String, String)]
 
43
getEnvironment = map (B.unpack *** B.unpack) `fmap` Env.getEnvironment
 
44
#endif
36
45
 
37
46
safeRead :: Read a => a -> String -> a
38
47
safeRead d s =
67
76
-- stick with 'run' or 'runSendfile'.
68
77
runGeneric
69
78
     :: [(String, String)] -- ^ all variables
70
 
     -> (Int -> Source (ResourceT IO) B.ByteString) -- ^ responseBody of input
 
79
     -> (Int -> Source IO B.ByteString) -- ^ responseBody of input
71
80
     -> (B.ByteString -> IO ()) -- ^ destination for output
72
81
     -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
73
82
     -> Application
76
85
    let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
77
86
        pinfo = lookup' "PATH_INFO" vars
78
87
        qstring = lookup' "QUERY_STRING" vars
79
 
        servername = lookup' "SERVER_NAME" vars
80
 
        serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
81
88
        contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
82
89
        remoteHost' =
83
90
            case lookup "REMOTE_ADDR" vars of
95
102
            case addrs of
96
103
                a:_ -> addrAddress a
97
104
                [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
98
 
    runResourceT $ do
99
 
        let env = Request
 
105
    mask $ \restore -> do
 
106
        let reqHeaders = map (cleanupVarName *** B.pack) vars
 
107
            env = Request
100
108
                { requestMethod = rmethod
101
109
                , rawPathInfo = B.pack pinfo
102
110
                , pathInfo = H.decodePathSegments $ B.pack pinfo
103
111
                , rawQueryString = B.pack qstring
104
112
                , queryString = H.parseQuery $ B.pack qstring
105
 
                , serverName = B.pack servername
106
 
                , serverPort = serverport
107
 
                , requestHeaders = map (cleanupVarName *** B.pack) vars
 
113
                , requestHeaders = reqHeaders
108
114
                , isSecure = isSecure'
109
115
                , remoteHost = addr
110
116
                , httpVersion = H.http11 -- FIXME
111
117
                , requestBody = inputH contentLength
112
118
                , vault = mempty
113
 
#if MIN_VERSION_wai(1, 4, 0)
114
119
                , requestBodyLength = KnownLength $ fromIntegral contentLength
115
 
#endif
 
120
                , requestHeaderHost = lookup "host" reqHeaders
 
121
                , requestHeaderRange = lookup "range" reqHeaders
116
122
                }
117
123
        -- FIXME worry about exception?
118
 
        res <- app env
 
124
        res <- restore $ app env
119
125
        case (xsendfile, res) of
120
126
            (Just sf, ResponseFile s hs fp Nothing) ->
121
 
                liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
 
127
                restore $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
122
128
            _ -> do
123
 
                let (s, hs, b) = responseSource res
124
 
                    src = CL.sourceList [Chunk $ headers s hs `mappend` fromChar '\n']
125
 
                          `mappend` b
126
 
                src $$ builderSink
 
129
                let (s, hs, wb) = responseToSource res
 
130
                wb $ \b ->
 
131
                    let src = do
 
132
                            yield (Chunk $ headers s hs `mappend` fromChar '\n')
 
133
                            b
 
134
                     in src $$ builderSink
127
135
  where
128
136
    headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
129
137
    status (Status i m) = (fromByteString "Status", mconcat
170
178
    helper' (x:rest) = toLower x : helper' rest
171
179
    helper' [] = []
172
180
 
173
 
requestBodyHandle :: Handle -> Int -> Source (ResourceT IO) B.ByteString
 
181
requestBodyHandle :: Handle -> Int -> Source IO B.ByteString
174
182
requestBodyHandle h = requestBodyFunc $ \i -> do
175
183
    bs <- B.hGet h i
176
184
    return $ if B.null bs then Nothing else Just bs
177
185
 
178
 
requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source (ResourceT IO) B.ByteString
 
186
requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source IO B.ByteString
179
187
requestBodyFunc get =
180
188
    loop
181
189
  where