| 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} |
|---|
| 2 | import Control.Monad (replicateM_) |
|---|
| 3 | import GHC.Conc (numCapabilities) |
|---|
| 4 | import Control.Concurrent (forkIO, threadDelay) |
|---|
| 5 | import Network.Socket |
|---|
| 6 | import qualified Data.ByteString.Char8 as BS |
|---|
| 7 | import qualified Data.ByteString.Lazy.Char8 as BL |
|---|
| 8 | import qualified Network.Socket.ByteString as NS |
|---|
| 9 | import qualified Network.Socket.ByteString.Lazy as NL |
|---|
| 10 | import System.Environment (getArgs) |
|---|
| 11 | |
|---|
| 12 | main :: IO () |
|---|
| 13 | main = do |
|---|
| 14 | args <- getArgs |
|---|
| 15 | let host = case args of |
|---|
| 16 | (h:_) -> h |
|---|
| 17 | _ -> "0.0.0.0" |
|---|
| 18 | port = case args of |
|---|
| 19 | (_:p:_) -> p |
|---|
| 20 | _ -> "8080" |
|---|
| 21 | hints = defaultHints { addrFamily = AF_INET |
|---|
| 22 | , addrSocketType = Stream } |
|---|
| 23 | [AddrInfo{..}] <- getAddrInfo (Just hints) (Just host) (Just port) |
|---|
| 24 | sock <- socket addrFamily addrSocketType addrProtocol |
|---|
| 25 | bindSocket sock addrAddress |
|---|
| 26 | setSocketOption sock ReuseAddr 1 |
|---|
| 27 | listen sock 100 |
|---|
| 28 | replicateM_ numCapabilities $ |
|---|
| 29 | forkIO (listenLoop sock) |
|---|
| 30 | threadDelay maxBound |
|---|
| 31 | |
|---|
| 32 | listenLoop :: Socket -> IO () |
|---|
| 33 | listenLoop asock = do |
|---|
| 34 | (sock, _) <- accept asock |
|---|
| 35 | forkIO (serve sock) |
|---|
| 36 | listenLoop asock |
|---|
| 37 | |
|---|
| 38 | serve :: Socket -> IO () |
|---|
| 39 | serve sock = do |
|---|
| 40 | let recvRequest pfx = do |
|---|
| 41 | chunk <- NS.recv sock 4096 |
|---|
| 42 | let req = BS.append pfx chunk |
|---|
| 43 | if "\r\n\r\n" `BS.isInfixOf` req |
|---|
| 44 | then return () |
|---|
| 45 | else recvRequest req |
|---|
| 46 | recvRequest BS.empty |
|---|
| 47 | NL.sendAll sock response |
|---|
| 48 | sClose sock |
|---|
| 49 | where |
|---|
| 50 | response = BL.intercalate "\r\n" [ |
|---|
| 51 | "HTTP/1.1 200 OK" |
|---|
| 52 | , "Date: Tue, 15 Dec 2009 19:19:14 GMT" |
|---|
| 53 | , "Server: hi" |
|---|
| 54 | , "X-Transaction: 1260904754-34211-32457" |
|---|
| 55 | , "Status: 200 OK" |
|---|
| 56 | , "ETag: \"0396070866e1c2986a2d1382cafc5ddc\"" |
|---|
| 57 | , "Last-Modified: Tue, 15 Dec 2009 19:19:14 GMT" |
|---|
| 58 | , "Content-Type: text/html; charset=utf-8" |
|---|
| 59 | , "Pragma: no-cache" |
|---|
| 60 | , "Cache-Control: no-cache, no-store, must-revalidate, pre-check=0, post-check=0" |
|---|
| 61 | , "Expires: Tue, 31 Mar 1981 05:00:00 GMT" |
|---|
| 62 | , "X-Revision: DEV" |
|---|
| 63 | , "Connection: close" |
|---|
| 64 | , "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" |
|---|
| 65 | , "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">" |
|---|
| 66 | , "" |
|---|
| 67 | , "<head>" |
|---|
| 68 | , "</head>" |
|---|
| 69 | , "<body>" |
|---|
| 70 | , "</body>" |
|---|
| 71 | , "</html>" |
|---|
| 72 | ] |
|---|
