simplistic haskell web server

Main.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import Network (listenOn, withSocketsDo, accept, PortID(..), Socket)
import Control.Concurrent (forkIO)
import Control.Exception (handle, IOException)
import Control.Monad (liftM)
import System.IO (hSetBuffering, hPutStr, hClose, hGetContents, BufferMode(..), Handle, readFile)
import Debug.Trace

data RequestMethod = GET
                   | POST
                   | PUT
                   | DELETE
                   | PATCH
                   deriving (Read, Show)

data Request = Request {
    requestMethod :: RequestMethod
  , requestPath ::  String
  } deriving (Show)

data ResponseCode = ResponseCode Integer
data Response = Response {
    responseCode :: ResponseCode
  , responseBody :: String
  }

instance Show Response where
  show resp = "HTTP/1.1 " ++ show (responseCode resp) ++ "\r\n\r\n" ++ (responseBody resp)

instance Show ResponseCode where
  show (ResponseCode code) = case code of
    200 -> "OK"
    404 -> "Not Found"

main :: IO ()
main = withSocketsDo $ do
  sock <- listenOn $ PortNumber 1234
  putStrLn $ "Listening on 1234"
  sockHandler sock
  
sockHandler :: Socket -> IO ()
sockHandler sock = do
  (handle, _, _) <- accept sock
  hSetBuffering handle NoBuffering
  forkIO $ requestHandler handle
  sockHandler sock

requestHandler :: Handle -> IO ()
requestHandler handle = do
  rawRequest <- hGetContents handle
  let request = parseRequest rawRequest
  traceIO $ show request

  file <- maybeIO (readFile $ "." ++ (requestPath request))
  let resp = mkResponse file
  
  hPutStr handle $ show resp
  hClose handle

mkResponse :: Maybe String -> Response
mkResponse Nothing  = Response { responseCode = ResponseCode 404, responseBody = "Not Found" } 
mkResponse (Just c) = Response { responseCode = ResponseCode 200, responseBody = c } 

maybeIO :: IO a -> IO (Maybe a)
maybeIO act = handle (\(_ :: IOException) -> return Nothing) (Just `liftM` act)

parseRequest :: String -> Request
parseRequest req = case (words . head . lines $ req) of
  (method:path:_) -> Request { requestMethod = (read method) :: RequestMethod
                             , requestPath = path }