Haskell HTTP Server

import qualified Data.Map as Map


{- Supported HTTP methods. -}

data HttpMethod = GET | POST deriving (Read, Show)


{- A parsed HTTP request. --}

type HttpHeaders = Map.Map String String

data HttpRequest = HttpRequest { method :: HttpMethod
                               , path :: String
                               , protocol :: String
                               , headers ::  HttpHeaders}


{- Parser for a HTTP request. -}

parseHeader :: String -> (String, String)
parseHeader line =
    let (name, rest) = break (==':') line
        value = dropWhile (==' ') (tail rest)
    in (name, value)

parse :: String -> HttpRequest
parse input =
    let allLines = lines input
        firstLineWords = words . head $ allLines
        method = read (firstLineWords !! 0)
        path = firstLineWords !! 1
        protocol = firstLineWords !! 2
        (headerLines, bodyLines) = break (=="") (tail allLines)
        headers = Map.fromList (map parseHeader headerLines)
    in HttpRequest { method = method
                   , path = path
                   , protocol = protocol 
                   , headers = headers}


{- Known HTTP status messages. -}

statusMessages = Map.fromList [(200, "OK")
                              ,(404, "Not Found")
                              ,(500, "Server Error")]

statusMessage :: Int -> String
statusMessage code =
    case Map.lookup code statusMessages of Just n -> n
                                           Nothing -> ""


{- A HTTP response returned by a request handler. -}

data HttpResponse = HttpResponse { code :: Int 
                                 , body :: String}

serialize :: HttpResponse -> String
serialize response =
    let responseCode = show . code $ response
        responseStatus = statusMessage . code $ response                
        firstLine = unwords [responseCode, responseStatus]
    in unlines [firstLine, "", body response]


{- Request handlers used by the server. -}

requestHandler :: HttpRequest -> HttpResponse
requestHandler request = 
    let methodStr = show . method $ request
        Just host = Map.lookup "Host" (headers request)
    in HttpResponse { code = 200 
                    , body = "<h1> Result for a " ++ methodStr ++ " request to http://" ++ host ++ (path request) ++ "</h1>\n" ++ (show . headers $ request)}


{- Main server method used to process a single request. -}

processRequest :: String -> String
processRequest = serialize . requestHandler . parse


main = interact processRequest