← Back to branch summary

~ubuntu-branches/ubuntu/saucy/haskell-wai-extra/saucy-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: 2013-02-13 17:55:10 UTC
  • mfrom: (2.1.11 experimental)
  • Revision ID: package-import@ubuntu.com-20130213175510-ty5pd3iftubyyv9k
Tags: 1.3.2.1-2
Remove upper bound on hspec

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Handler/CGI.hs
30
30
import qualified Network.HTTP.Types as H
31
31
import qualified Data.CaseInsensitive as CI
32
32
import Data.Monoid (mappend)
33
 
import qualified Data.Conduit as C
 
33
import Data.Conduit
34
34
import qualified Data.Conduit.List as CL
35
35
 
36
36
safeRead :: Read a => a -> String -> a
66
66
-- stick with 'run' or 'runSendfile'.
67
67
runGeneric
68
68
     :: [(String, String)] -- ^ all variables
69
 
     -> (Int -> C.Source (C.ResourceT IO) B.ByteString) -- ^ responseBody of input
 
69
     -> (Int -> Source (ResourceT IO) B.ByteString) -- ^ responseBody of input
70
70
     -> (B.ByteString -> IO ()) -- ^ destination for output
71
71
     -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
72
72
     -> Application
94
94
            case addrs of
95
95
                a:_ -> addrAddress a
96
96
                [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
97
 
    C.runResourceT $ do
 
97
    runResourceT $ do
98
98
        let env = Request
99
99
                { requestMethod = rmethod
100
100
                , rawPathInfo = B.pack pinfo
117
117
                liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
118
118
            _ -> do
119
119
                let (s, hs, b) = responseSource res
120
 
                    src = CL.sourceList [C.Chunk $ headers s hs `mappend` fromChar '\n']
 
120
                    src = CL.sourceList [Chunk $ headers s hs `mappend` fromChar '\n']
121
121
                          `mappend` b
122
 
                src C.$$ builderSink
 
122
                src $$ builderSink
123
123
  where
124
124
    headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
125
125
    status (Status i m) = (fromByteString "Status", mconcat
141
141
        , fromByteString sf
142
142
        , fromByteString " not supported"
143
143
        ]
144
 
    bsSink = C.NeedInput push (return ())
145
 
    push (C.Chunk bs) = C.PipeM (do
 
144
    bsSink = awaitE >>= either return push
 
145
    push (Chunk bs) = do
146
146
        liftIO $ outputH bs
147
 
        return bsSink) (return ())
 
147
        bsSink
148
148
    -- FIXME actually flush?
149
 
    push C.Flush = bsSink
150
 
    builderSink = builderToByteStringFlush C.=$ bsSink
 
149
    push Flush = bsSink
 
150
    builderSink = builderToByteStringFlush =$ bsSink
151
151
    fixHeaders h =
152
152
        case lookup "content-type" h of
153
153
            Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
166
166
    helper' (x:rest) = toLower x : helper' rest
167
167
    helper' [] = []
168
168
 
169
 
requestBodyHandle :: Handle -> Int -> C.Source (C.ResourceT IO) B.ByteString
 
169
requestBodyHandle :: Handle -> Int -> Source (ResourceT IO) B.ByteString
170
170
requestBodyHandle h = requestBodyFunc $ \i -> do
171
171
    bs <- B.hGet h i
172
172
    return $ if B.null bs then Nothing else Just bs
173
173
 
174
 
requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> C.Source (C.ResourceT IO) B.ByteString
175
 
requestBodyFunc get count0 =
176
 
    C.sourceState count0 pull
 
174
requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source (ResourceT IO) B.ByteString
 
175
requestBodyFunc get =
 
176
    loop
177
177
  where
178
 
    pull 0 = return C.StateClosed
179
 
    pull count = do
 
178
    loop 0 = return ()
 
179
    loop count = do
180
180
        mbs <- liftIO $ get $ min count defaultChunkSize
181
181
        let count' = count - maybe 0 B.length mbs
182
 
        return $ case mbs of
183
 
            Nothing -> C.StateClosed
184
 
            Just bs -> C.StateOpen count' bs
 
182
        case mbs of
 
183
            Nothing -> return ()
 
184
            Just bs -> yield bs >> loop count'