Test server for requests debugging

TestServer.hs

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

import System.Directory
import System.IO
import System.IO.Error

--
data RequestType = GET | POST deriving (Show)

fromString :: String -> RequestType
fromString t = case t of
    "GET" -> GET
    "POST" -> POST

data Request = Request { rtype :: RequestType
                       , path :: String
                       , options :: [(String,String)]
                       }
instance Show Request where
    show r = "Request { "
             ++ show((rtype r))
             ++ " "
             ++ (path r)
             ++ (foldl (\acc (k,v) -> acc ++ "\n  " ++ k ++ ": " ++ v) "" (options r))
             ++ "\n}"

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 { rtype=(fromString t)
                      , path=p
                      , options=parseRequestHelper((tail lns)
                      ,[])
                      }

--
data Response = Response { version :: String, statuscode :: Int }
instance Show Response where
    show r = version(r)
             ++ " "
             ++ show(statuscode(r))
             ++ " "
             ++ (case statuscode(r) of
                100 -> "Continue"
                200 -> "OK"
                404 -> "Not Found") ++ "\r\n\r\n"

--
main = routine

-- Route
routine :: IO ()
routine = withSocketsDo $ do
    sock <- listenOn (PortNumber 80)
    putStrLn "Listening on port 80"
    forever $ do
        (handle, hostname, port) <- accept sock
        putStrLn $ "Handle request from " ++ hostname
        handleRequest handle
        hClose handle

dispatch :: [(String, Request -> Handle -> IO ())]
dispatch = [ ("/.well-known/oauth.json", defaultResponse)
           , ("/view", view)
           , ("remove", defaultResponse)
           ]

handleRequest :: Handle -> IO ()
handleRequest handle = do
    request <- fmap (parseRequest . lines) (hGetContents handle)
    let action = lookup (path request) dispatch
    case action of
        Just action -> action request handle
        Nothing -> showRequest request handle

--
defaultResponse :: Request -> Handle -> IO ()
defaultResponse request handle = do
    let response = Response { version = "HTTP/1.1", statuscode = 200 }
    hPutStr handle $ show(response)
    let filePath = tail $ path request
    fileExist <- doesFileExist filePath
    if fileExist then do
        fileHandle <- openFile filePath ReadMode
        content <- hGetContents fileHandle
        hPutStr handle content
    else
        --putStrLn "The file doesn't exist!"
        return ()

showRequest :: Request -> Handle -> IO ()
showRequest request handle = do
    let response = Response { version = "HTTP/1.1", statuscode = 200 }
    hPutStr handle $ show(response)
    hPutStr handle $ show(request)
    putStrLn $ show(request) ++ "\n"
    return ()

view :: Request -> Handle -> IO ()
view request handle = do
    let response = Response { version = "HTTP/1.1", statuscode = 200 }
    hPutStr handle $ show(response)
    hPutStr handle $ "This is view point"