git.iko.soy/hakyll
on master help sign in
Readable error messages.
ca2e161Jasper Van der Jeugt
src/Network/Hakyll/SimpleServer.hs+30−16
compare with master
unifiedsplit
@@ -16,9 +16,12 @@ import Text.Hakyll.Util
16data Request = Request { requestMethod :: B.ByteString
16data Request = Request { requestMethod :: B.ByteString
17 , requestURI :: B.ByteString
17 , requestURI :: B.ByteString
18 , requestVersion :: B.ByteString
18 , 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)
22
25
23readRequest :: Handle -> IO Request
26readRequest :: Handle -> IO Request
24readRequest handle = do
27readRequest handle = do
@@ -27,8 +30,6 @@ readRequest handle = do
27 return $ Request { requestMethod = B.pack method
30 return $ Request { requestMethod = B.pack method
28 , requestURI = B.pack uri
31 , requestURI = B.pack uri
29 , requestVersion = B.pack version
32 , requestVersion = B.pack version
30− , requestHeaders = M.empty -- Ignore all headers for now.
31− , requestBody = B.empty -- Ignore request body for now.
32 }
33 }
33
34
34data Response = Response { responseVersion :: B.ByteString
35data Response = Response { responseVersion :: B.ByteString
@@ -36,7 +37,12 @@ data Response = Response { responseVersion :: B.ByteString
36 , responsePhrase :: B.ByteString
37 , responsePhrase :: B.ByteString
37 , responseHeaders :: M.Map B.ByteString B.ByteString
38 , responseHeaders :: M.Map B.ByteString B.ByteString
38 , responseBody :: B.ByteString
39 , 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)
40
46
41defaultResponse :: Response
47defaultResponse :: Response
42defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
48defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
@@ -48,9 +54,17 @@ defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
48
54
49createResponse :: Request -> IO Response
55createResponse :: Request -> IO Response
50createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
56createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
57+ | otherwise = return $ errorResponse 501 (B.pack "Not Implemented")
58+
59+errorResponse :: Int -> B.ByteString -> Response
60+errorResponse statusCode phrase = defaultResponse
51− | otherwise = return $ defaultResponse { responseStatusCode = 501
61+ { responseStatusCode = statusCode
52− , responsePhrase = B.pack "Not Implemented"
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>"
53− }
67+ }
54
68
55createGetResponse :: Request -> IO Response
69createGetResponse :: Request -> IO Response
56createGetResponse request = do
70createGetResponse request = do
@@ -58,13 +72,9 @@ createGetResponse request = do
58 let fileName = "_site" ++ if uri == "/" then "/index.html"
72 let fileName = "_site" ++ if uri == "/" then "/index.html"
59 else B.unpack (requestURI request)
73 else B.unpack (requestURI request)
60 exists <- doesFileExist fileName
74 exists <- doesFileExist fileName
61− if exists then createGet fileName
75+ if exists then catch (create200 fileName) create500
62− else create404
76+ else return $ errorResponse 400 (B.pack "Not Found")
63− where create404 = return $ defaultResponse { responseStatusCode = 404
64− , responsePhrase = B.pack "Not Found"
65− }
66−
67− createGet fileName = do
77+ where create200 fileName = do
68 body <- B.readFile fileName
78 body <- B.readFile fileName
69 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
79 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
70 ] ++ getMIMEHeader fileName
80 ] ++ getMIMEHeader fileName
@@ -75,6 +85,9 @@ createGetResponse request = do
75 , responseBody = body
85 , responseBody = body
76 }
86 }
77
87
88+ create500 e = do putStrLn $ "Internal Error: " ++ show e
89+ return $ errorResponse 500 (B.pack "Internal Server Error")
90+
78getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
91getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
79getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
92getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
80 _ -> []
93 _ -> []
@@ -94,6 +107,7 @@ respond :: Handle -> IO ()
94respond handle = do
107respond handle = do
95 request <- readRequest handle
108 request <- readRequest handle
96 response <- createResponse request
109 response <- createResponse request
110+ putStrLn $ show request ++ " => " ++ show response
97 B.hPutStr handle $ B.intercalate (B.pack " ") [ responseVersion response
111 B.hPutStr handle $ B.intercalate (B.pack " ") [ responseVersion response
98 , B.pack $ show $ responseStatusCode response
112 , B.pack $ show $ responseStatusCode response
99 , responsePhrase response
113 , responsePhrase response