@@ -16,9 +16,12 @@ import Text.Hakyll.Util
1616data Request = Request { requestMethod :: B.ByteString
1717 , requestURI :: B.ByteString
1818 , requestVersion :: B.ByteString
19− , requestHeaders :: M.Map B.ByteString B.ByteString
20− , requestBody :: B.ByteString
21− } deriving (Show, Ord, Eq)
19+ } deriving (Ord, Eq)
20+
21+instance Show Request where
22+ show request = (B.unpack $ requestMethod request) ++ " "
23+ ++ (B.unpack $ requestURI request) ++ " "
24+ ++ (B.unpack $ requestVersion request)
2225
2326readRequest :: Handle -> IO Request
2427readRequest handle = do
@@ -27,8 +30,6 @@ readRequest handle = do
2730 return $ Request { requestMethod = B.pack method
2831 , requestURI = B.pack uri
2932 , requestVersion = B.pack version
30− , requestHeaders = M.empty -- Ignore all headers for now.
31− , requestBody = B.empty -- Ignore request body for now.
3233 }
3334
3435data Response = Response { responseVersion :: B.ByteString
@@ -36,7 +37,12 @@ data Response = Response { responseVersion :: B.ByteString
3637 , responsePhrase :: B.ByteString
3738 , responseHeaders :: M.Map B.ByteString B.ByteString
3839 , responseBody :: B.ByteString
39− } deriving (Show, Ord, Eq)
40+ } deriving (Ord, Eq)
41+
42+instance Show Response where
43+ show response = (B.unpack $ responseVersion response) ++ " "
44+ ++ (show $ responseStatusCode response) ++ " "
45+ ++ (B.unpack $ responsePhrase response)
4046
4147defaultResponse :: Response
4248defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
@@ -48,9 +54,17 @@ defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
4854
4955createResponse :: Request -> IO Response
5056createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
51− | otherwise = return $ defaultResponse { responseStatusCode = 501
52− , responsePhrase = B.pack "Not Implemented"
53− }
57+ | otherwise = return $ errorResponse 501 (B.pack "Not Implemented")
58+
59+errorResponse :: Int -> B.ByteString -> Response
60+errorResponse statusCode phrase = defaultResponse
61+ { responseStatusCode = statusCode
62+ , responsePhrase = phrase
63+ , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
64+ , responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
65+ ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
66+ ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
67+ }
5468
5569createGetResponse :: Request -> IO Response
5670createGetResponse request = do
@@ -58,13 +72,9 @@ createGetResponse request = do
5872 let fileName = "_site" ++ if uri == "/" then "/index.html"
5973 else B.unpack (requestURI request)
6074 exists <- doesFileExist fileName
61− if exists then createGet fileName
62− else create404
63− where create404 = return $ defaultResponse { responseStatusCode = 404
64− , responsePhrase = B.pack "Not Found"
65− }
66−
67− createGet fileName = do
75+ if exists then catch (create200 fileName) create500
76+ else return $ errorResponse 400 (B.pack "Not Found")
77+ where create200 fileName = do
6878 body <- B.readFile fileName
6979 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
7080 ] ++ getMIMEHeader fileName
@@ -75,6 +85,9 @@ createGetResponse request = do
7585 , responseBody = body
7686 }
7787
88+ create500 e = do putStrLn $ "Internal Error: " ++ show e
89+ return $ errorResponse 500 (B.pack "Internal Server Error")
90+
7891getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
7992getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
8093 _ -> []
@@ -94,6 +107,7 @@ respond :: Handle -> IO ()
94107respond handle = do
95108 request <- readRequest handle
96109 response <- createResponse request
110+ putStrLn $ show request ++ " => " ++ show response
97111 B.hPutStr handle $ B.intercalate (B.pack " ") [ responseVersion response
98112 , B.pack $ show $ responseStatusCode response
99113 , responsePhrase response