module Network.TrivialWebServer where import System.Posix.Signals -- (installHandler, sigPIPE, Ignore) import Network -- (listenOn, accept, sClose, PortNumber) import IO (hGetLine, hPutStr, hClose, hGetBuffering) import Control.Concurrent -- (forkIO) import Control.Exception as Exc (finally, catch) import qualified Data.Char (chr) -- Trivial web server, taking from the Cherry chess rendering software. -- Takes callback for each request as an argument. server :: Int -> Int -> Server -> IO () server threadCount portNo serve = do installHandler sigPIPE Ignore Nothing chan <- newChan 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 return () where loopIO m = do m loopIO m worker chan = do -- tid <- myThreadId h <- readChan chan t <- hGetBuffering h -- print t ln <- IO.hGetLine h -- print $ ">> " ++ show tid ++ ":" ++ ln 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 () splitup :: String -> (String, [(String, String)]) splitup url = case span (/= '?') url of (path,'?':args) -> (path,splitargs args) (path,_) -> (path,[]) where splitargs xs = case span (/= '=') xs of (index,'=':rest) -> case span (/= '&') rest of (value,'&':rest') -> (index,clean value) : splitargs rest' (value,_) -> (index,clean value) : [] _ -> [] clean ('%':d1:d2:cs) = Data.Char.chr (read $ "0x" ++ [d1,d2]) : clean cs clean (c:cs) = c : clean cs clean [] = [] -- These calls may be asynchronously done. -- The contract is that you must return quickly (aka loading -- a web page). If you have an expensive computation, you should -- return, and call the send continuation later when you are done. -- This allows this thread to continue to service requests. -- TODO: these should be data structures! type Server = String -> [(String,String)] -> Response -> IO () -- cache content-type body type Response = Bool -> String -> String -> IO ()