{-# LANGUAGE OverloadedStrings, RecordWildCards #-} import Control.Monad (replicateM_) import GHC.Conc (numCapabilities) import Control.Concurrent (forkIO, threadDelay) import Network.Socket import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL import qualified Network.Socket.ByteString as NS import qualified Network.Socket.ByteString.Lazy as NL import System.Environment (getArgs) main :: IO () main = do args <- getArgs let host = case args of (h:_) -> h _ -> "0.0.0.0" port = case args of (_:p:_) -> p _ -> "8080" hints = defaultHints { addrFamily = AF_INET , addrSocketType = Stream } [AddrInfo{..}] <- getAddrInfo (Just hints) (Just host) (Just port) sock <- socket addrFamily addrSocketType addrProtocol bindSocket sock addrAddress setSocketOption sock ReuseAddr 1 listen sock 100 replicateM_ numCapabilities $ forkIO (listenLoop sock) putStrLn "ready" threadDelay maxBound listenLoop :: Socket -> IO () listenLoop asock = do (sock, _) <- accept asock forkIO (serve sock) listenLoop asock serve :: Socket -> IO () serve sock = do let recvRequest pfx = do chunk <- NS.recv sock 4096 let req = BS.append pfx chunk if "\r\n\r\n" `BS.isInfixOf` req then return () else recvRequest req recvRequest BS.empty NL.sendAll sock response sClose sock where response = BL.intercalate "\r\n" [ "HTTP/1.1 200 OK" , "Date: Tue, 15 Dec 2009 19:19:14 GMT" , "Server: hi" , "X-Transaction: 1260904754-34211-32457" , "Status: 200 OK" , "ETag: \"0396070866e1c2986a2d1382cafc5ddc\"" , "Last-Modified: Tue, 15 Dec 2009 19:19:14 GMT" , "Content-Type: text/html; charset=utf-8" , "Pragma: no-cache" , "Cache-Control: no-cache, no-store, must-revalidate, pre-check=0, post-check=0" , "Expires: Tue, 31 Mar 1981 05:00:00 GMT" , "X-Revision: DEV" , "Connection: close" , "" , "" , "" , "" , "" , "" , "" , "" ]