Simple http web server implementation.

Quasar.Main.hs

module Quasar.Main where

import Control.Monad
import Data.Char
import System.IO 
import Network
import Data.Time.LocalTime

data RequestType = GET | POST deriving (Show)

data Request = Request {
	requestType :: RequestType,
	path :: String,
	options :: [(String, String)]
}

data Response = Response {
	version :: String, 
	statuscode :: Int
}

instance Show Request where
	show request = "Request { " ++
		show ((requestType request)) ++
		" " ++
		(path request) ++
		(foldl (\acc (k,v) -> acc ++ "\n " ++ k ++ ": " ++ v) "" (options request)) ++
		"\n}"

instance Show Response where
	show response = version (response) ++ 
		" " ++ 
		show (statuscode (response)) ++ 
		" " ++
		(case statuscode (response) of
			100 -> "Continue"
			200 -> "OK"
			404 -> "Not Found") ++ 
		"\r\n\r\n"

getRequestType :: String -> RequestType
getRequestType rType = case rType of
	"GET" -> GET
	"POST" -> POST

respond :: Request -> Handle -> IO ()
respond request handle = do
	putStrLn $ show request
	let response = Response { version = "HTTP/1.1", statuscode = 200 }
	hPutStr handle $ show(response)
	time <- getZonedTime
	hPutStr handle $ "Haskell says HELLO.\nThe time is currently " ++ show(time) ++ "\n\n\nHere is some info from your session:\n" ++ show(request)

parseRequestHelper :: ([String], [(String, String)]) -> [(String, String)]
parseRequestHelper ([], accum) = accum
parseRequestHelper ((l:rest), accum)
	| (length (words l)) < 2 = accum
	| otherwise = parseRequestHelper(rest, accum ++ [(reverse . tail . reverse . head . words $ l, unwords . tail . words $ l)] )

parseRequest :: [String] -> Request
parseRequest lns = case (words (head lns)) of
	[t, p, _] -> Request { requestType = (getRequestType t), path = p, options = parseRequestHelper((tail lns),[])}

handleAccept :: Handle -> String -> IO ()
handleAccept handle hostname = do 
	putStrLn $ "Handling request from " ++ hostname
	request <- fmap (parseRequest . lines) (hGetContents handle)
	respond request handle
	return ()

main = withSocketsDo $ do
	sock <- listenOn (PortNumber 9000)
	putStrLn "Listening on port 9000"
	forever $ do
		(handle, hostname, port) <- accept sock
		handleAccept handle hostname
		hClose handle