import Control.Concurrent (forkIO)
import Control.Exception (finally)
import Control.Monad (forever)
import IO (hGetContents, hClose, hPutStr, hFlush)
import Network
import Text.ParserCombinators.Parsec

type Request = (String, String, [(String, String)])

parseHeader = do
    name <- anyChar `manyTill` string ": "
    value <- anyChar `manyTill` string "\r\n"
    return (name, value)

parseRequest = do
    method <- choice $ map (try . string) ["GET", "POST"]
    char ' '
    path <- anyChar `manyTill` (char ' ')
    protocol <- choice $ map (try . string) ["HTTP/1.0", "HTTP/1.1"]
    string "\r\n"
    headers <- parseHeader `manyTill` (string "\r\n")
    input <- getParserState
    return ((method, path, headers), stateInput input)

errorResp = "HTTP/1.1 500 eh?\r\n\r\n"

okResp = "HTTP/1.1 200 OK\r\nContent-type: text/plain\r\nContent-length: 6\r\n\r\nhello."

handleConnection handle = do
    contents <- hGetContents handle
    handleRequests contents
    where handleRequests s = do
          case parse parseRequest "" s of
              Left err -> do
                  hPutStr handle errorResp
                  hFlush handle
                  hClose handle
              Right (request, rest) -> do
                  hPutStr handle okResp
                  hFlush handle
                  handleRequests rest

main = do
    socket <- listenOn (PortNumber 8080)
    forever $ do
        (handle, hostname, port) <- accept socket
        handleConnection handle `finally` hClose handle