[partial -Wall TrivialWebServer.hs gwern0@gmail.com**20080218032655] { hunk ./ajaxgui/Network/TrivialWebServer.hs 3 -import System.Posix -import System.Posix.Signals -import Network -import IO -import Monad +import System.Posix.Signals -- (installHandler, sigPIPE, Ignore) +import Network -- (listenOn, accept, sClose, PortNumber) +import IO (hGetLine, hPutStr, hClose, hGetBuffering) hunk ./ajaxgui/Network/TrivialWebServer.hs 7 -import Control.Concurrent -import Control.Exception as Exc -import Control.Concurrent.Chan -import qualified List -import qualified Char +import Control.Concurrent -- (forkIO) +import Control.Exception as Exc (finally, catch) +import qualified Data.Char (chr) hunk ./ajaxgui/Network/TrivialWebServer.hs 18 - sequence [ forkIO (worker chan) | i <- take threadCount [0..]] - sock <- listenOn (PortNumber $ fromIntegral portNo) - loopIO - (do (h,nm,port) <- accept sock --- print (h,nm,port) - writeChan chan h) `finally` sClose sock + sequence [ forkIO (worker chan) | _ <- take threadCount [(0::Int)..]] + sock <- listenOn (PortNumber $ fromIntegral portNo) + loopIO + (do (h,nm,port) <- accept sock +-- print (h,nm,port) + writeChan chan h) `finally` sClose sock hunk ./ajaxgui/Network/TrivialWebServer.hs 26 - loopIO m = do m - loopIO m + loopIO m = do m + loopIO m hunk ./ajaxgui/Network/TrivialWebServer.hs 30 - tid <- myThreadId - h <- readChan chan - t <- hGetBuffering h --- print t - ln <- IO.hGetLine h +-- tid <- myThreadId + h <- readChan chan + t <- hGetBuffering h +-- print t + ln <- IO.hGetLine h hunk ./ajaxgui/Network/TrivialWebServer.hs 36 - case words ln of - ["GET",url,"HTTP/1.1"] - -> do --- print ("GET",url) - serve file args (sendMsg h "200 OK") - where (file,args) = splitup url - _ -> sendMsg h "400 Bad Request" False "text/html" $ - "Bad Request\n" - worker chan - - sendMsg h code cache thing reply - = (do -- print $ "<< " ++ reply - hPutStr h $ "HTTP/1.1 " ++ code ++ "\r\n" - hPutStr h $ "Connection: close\r\n" - hPutStr h $ "Content-Type: " ++ thing ++ "\r\n" - hPutStr h $ "Content-Length: " ++ - show (length reply) ++ "\r\n" - hPutStr h $ "Cache-Control: " ++ - (if cache - then "max-age=3600" - else "no-cache") - ++ "\r\n" - hPutStr h $ "\r\n" - hPutStr h $ reply ++ "\r\n" - IO.hClose h - -- we choose to ignore exceptions inside here - ) `Exc.catch` \ e -> do print "####################" - print e - return () + case words ln of + ["GET",url,"HTTP/1.1"] + -> do +-- print ("GET",url) + serve file args (sendMsg h "200 OK") + where (file,args) = splitup url + _ -> sendMsg h "400 Bad Request" False "text/html" $ + "Bad Request\n" + worker chan hunk ./ajaxgui/Network/TrivialWebServer.hs 46 + sendMsg h code cache thing reply + = (do -- print $ "<< " ++ reply + hPutStr h $ "HTTP/1.1 " ++ code ++ "\r\n" + hPutStr h $ "Connection: close\r\n" + hPutStr h $ "Content-Type: " ++ thing ++ "\r\n" + hPutStr h $ "Content-Length: " ++ + show (length reply) ++ "\r\n" + hPutStr h $ "Cache-Control: " ++ + (if cache + then "max-age=3600" + else "no-cache") + ++ "\r\n" + hPutStr h $ "\r\n" + hPutStr h $ reply ++ "\r\n" + IO.hClose h + -- we choose to ignore exceptions inside here + ) `Exc.catch` \ e -> do print "####################" + print e + return () + +splitup :: String -> (String, [(String, String)]) hunk ./ajaxgui/Network/TrivialWebServer.hs 68 - (path,'?':args) -> (path,splitargs args) - (path,_) -> (path,[]) + (path,'?':args) -> (path,splitargs args) + (path,_) -> (path,[]) hunk ./ajaxgui/Network/TrivialWebServer.hs 72 - (index,'=':rest) -> - case span (/= '&') rest of - (value,'&':rest') -> (index,clean value) : splitargs rest' - (value,_) -> (index,clean value) : [] - _ -> [] + (index,'=':rest) -> + case span (/= '&') rest of + (value,'&':rest') -> (index,clean value) : splitargs rest' + (value,_) -> (index,clean value) : [] + _ -> [] hunk ./ajaxgui/Network/TrivialWebServer.hs 78 - clean ('%':d1:d2:cs) - = Char.chr (read $ "0x" ++ [d1,d2]) : clean cs + clean ('%':d1:d2:cs) + = Data.Char.chr (read $ "0x" ++ [d1,d2]) : clean cs hunk ./ajaxgui/Network/TrivialWebServer.hs 84 --- These calls may be asyncroynously(sp) done. +-- These calls may be asynchronously done. hunk ./ajaxgui/Network/TrivialWebServer.hs 89 --- TODO: these should be datastructures! +-- TODO: these should be data structures! hunk ./ajaxgui/Network/TrivialWebServer.hs 93 --- cache content-type body +-- cache content-type body hunk ./ajaxgui/Network/TrivialWebServer.hs 95 - + }