@@ -12,11 +12,20 @@ import Network.Wai.Handler.Helper
1212import System.Environment (getEnvironment)
1313import Data.Maybe (fromMaybe)
1414import qualified Data.ByteString.Char8 as B
15+import qualified Data.ByteString.Lazy as L
1516import Control.Arrow ((***))
1617import Data.Char (toLower)
1718import qualified System.IO
18−import Data.String (fromString)
19−import Data.Enumerator (Enumerator)
19+import qualified Data.String as String
20+import Data.Enumerator
21+ ( Enumerator, Step (..), Stream (..), continue, yield
22+ , enumList, ($$), joinI
23+ )
24+import Data.Monoid (mconcat)
25+import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
26+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
27+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
28+import Control.Monad.IO.Class (liftIO)
2029
2130safeRead :: Read a => a -> String -> a
2231safeRead d s =
@@ -34,7 +43,7 @@ run app = do
3443 output = B.hPut System.IO.stdout
3544 run'' vars input output Nothing app
3645
37−runSendfile :: String -- ^ sendfile header
46+runSendfile :: B.ByteString -- ^ sendfile header
3847 -> Application () -> IO ()
3948runSendfile sf app = do
4049 vars <- getEnvironment
@@ -54,8 +63,8 @@ run' vars inputH outputH app = do
5463
5564run'' :: [(String, String)] -- ^ all variables
5665 -> (forall a. Int -> Enumerator B.ByteString IO a) -- ^ responseBody of input
57− -> (B.ByteString -> IO ()) -- ^ destination for output
58− -> Maybe String -- ^ does the server support the X-Sendfile header?
66+ -> (B.ByteString -> IO ()) -- ^ destination for output FIXME use an iteratee
67+ -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
5968 -> Application ()
6069 -> IO ()
6170run'' vars inputH outputH xsendfile app = do
@@ -90,49 +99,45 @@ run'' vars inputH outputH xsendfile app = do
9099 , httpVersion = "1.1" -- FIXME
91100 }
92101 res <- app env
93− error "FIXME"
94− {-
95− outputH $ B.pack $ "Status: " ++ (show $ statusCode $ status res) ++ " "
96− outputH $ statusMessage $ status res
97− outputH $ B.singleton '\n'
98− mapM_ (printHeader hPut) h'
99− case (xsendfile, responseBody res) of
100− (Just sf, ResponseFile fp) ->
101− hPut $ B.pack $ concat
102− [ sf
103− , ": "
104− , fp
105− , "\n\n"
106− , sf
107− , " not supported"
108− ]
109− _ -> do
110− hPut $ B.singleton '\n'
111− _ <- runEnumerator (fromResponseBody (responseBody res))
112− (myPut outputH) ()
113− return ()
114− -}
115−
116−fixHeaders h =
117− case lookup "content-type" h of
118− Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
119− Just _ -> h
120−
121−myPut :: (B.ByteString -> IO ()) -> () -> B.ByteString -> IO (Either () ())
122−myPut output _ bs = output bs >> return (Right ())
123−
124−printHeader :: (B.ByteString -> IO ())
125− -> (ResponseHeader, B.ByteString)
126− -> IO ()
127−printHeader f (x, y) = do
128− f $ ciOriginal x
129− f $ B.pack ": "
130− f y
131− f $ B.singleton '\n'
102+ case (xsendfile, res) of
103+ (Just sf, ResponseFile s hs fp) ->
104+ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
105+ _ -> responseEnumerator res $ \s hs ->
106+ joinI $ enumList 1 [headers s hs, fromChar '\n'] $$ builderIter
107+ where
108+ headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
109+ status (Status i m) = (fromByteString "Status", mconcat
110+ [ fromString $ show i
111+ , fromChar ' '
112+ , fromByteString m
113+ ])
114+ header' (x, y) = (fromByteString $ ciOriginal x, fromByteString y)
115+ header (x, y) = mconcat
116+ [ x
117+ , fromByteString ": "
118+ , y
119+ , fromChar '\n'
120+ ]
121+ sfBuilder s hs sf fp = mconcat
122+ [ headers s hs
123+ , header $ (fromByteString sf, fromString fp)
124+ , fromChar '\n'
125+ , fromByteString sf
126+ , fromByteString " not supported"
127+ ]
128+ bsStep = Continue bsStep'
129+ bsStep' EOF = yield () EOF
130+ bsStep' (Chunks []) = continue bsStep'
131+ bsStep' (Chunks bss) = liftIO (mapM_ outputH bss) >> continue bsStep'
132+ builderIter = builderToByteString bsStep
133+ fixHeaders h =
134+ case lookup "content-type" h of
135+ Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
136+ Just _ -> h
132137
133138cleanupVarName :: String -> RequestHeader
134139cleanupVarName ('H':'T':'T':'P':'_':a:as) =
135− fromString $ a : helper' as
140+ String.fromString $ a : helper' as
136141 where
137142 helper' ('_':x:rest) = '-' : x : helper' rest
138143 helper' (x:rest) = toLower x : helper' rest
@@ -140,4 +145,4 @@ cleanupVarName ('H':'T':'T':'P':'_':a:as) =
140145cleanupVarName "CONTENT_TYPE" = "Content-Type"
141146cleanupVarName "CONTENT_LENGTH" = "Content-Length"
142147cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
143−cleanupVarName x = fromString x -- FIXME remove?
148+cleanupVarName x = String.fromString x -- FIXME remove?