git.iko.soy/typeable/wai
on master help sign in
Add CGI sendfile header support
5a40a57Michael Snoyman
Network/Wai/Handler/CGI.hs+30−6
compare with master
unifiedsplit
@@ -3,6 +3,7 @@ module Network.Wai.Handler.CGI
3 ( run
3 ( run
4 , run'
4 , run'
5 , run''
5 , run''
6+ , runSendfile
6 ) where
7 ) where
7
8
8import Network.Wai
9import Network.Wai
@@ -28,7 +29,17 @@ lookup' key pairs = fromMaybe "" $ lookup key pairs
28run :: Application -> IO ()
29run :: Application -> IO ()
29run app = do
30run app = do
30 vars <- getEnvironment
31 vars <- getEnvironment
32+ let input = requestBodyHandle System.IO.stdin
33+ output = B.hPut System.IO.stdout
34+ run'' vars input output Nothing app
35+
36+runSendfile :: String -- ^ sendfile header
37+ -> Application -> IO ()
38+runSendfile sf app = do
39+ vars <- getEnvironment
40+ let input = requestBodyHandle System.IO.stdin
31− run' vars System.IO.stdin System.IO.stdout app
41+ output = B.hPut System.IO.stdout
42+ run'' vars input output (Just sf) app
32
43
33run' :: [(String, String)] -- ^ all variables
44run' :: [(String, String)] -- ^ all variables
34 -> System.IO.Handle -- ^ responseBody of input
45 -> System.IO.Handle -- ^ responseBody of input
@@ -38,14 +49,15 @@ run' :: [(String, String)] -- ^ all variables
38run' vars inputH outputH app = do
49run' vars inputH outputH app = do
39 let input = requestBodyHandle inputH
50 let input = requestBodyHandle inputH
40 output = B.hPut outputH
51 output = B.hPut outputH
41− run'' vars input output app
52+ run'' vars input output Nothing app
42
53
43run'' :: [(String, String)] -- ^ all variables
54run'' :: [(String, String)] -- ^ all variables
44 -> (Int -> Source) -- ^ responseBody of input
55 -> (Int -> Source) -- ^ responseBody of input
45 -> (B.ByteString -> IO ()) -- ^ destination for output
56 -> (B.ByteString -> IO ()) -- ^ destination for output
57+ -> Maybe String -- ^ does the server support the X-Sendfile header?
46 -> Application
58 -> Application
47 -> IO ()
59 -> IO ()
48−run'' vars inputH outputH app = do
60+run'' vars inputH outputH xsendfile app = do
49 let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
61 let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
50 pinfo = lookup' "PATH_INFO" vars
62 pinfo = lookup' "PATH_INFO" vars
51 qstring = lookup' "QUERY_STRING" vars
63 qstring = lookup' "QUERY_STRING" vars
@@ -87,9 +99,21 @@ run'' vars inputH outputH app = do
87 hPut $ statusMessage $ status res
99 hPut $ statusMessage $ status res
88 hPut $ B.singleton '\n'
100 hPut $ B.singleton '\n'
89 mapM_ (printHeader hPut) h'
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
90− hPut $ B.singleton '\n'
113+ hPut $ B.singleton '\n'
91− _ <- runEnumerator (fromResponseBody (responseBody res)) (myPut outputH) ()
114+ _ <- runEnumerator (fromResponseBody (responseBody res))
115+ (myPut outputH) ()
92− return ()
116+ return ()
93
117
94myPut :: (B.ByteString -> IO ()) -> () -> B.ByteString -> IO (Either () ())
118myPut :: (B.ByteString -> IO ()) -> () -> B.ByteString -> IO (Either () ())
95myPut output _ bs = output bs >> return (Right ())
119myPut output _ bs = output bs >> return (Right ())