@@ -78,8 +78,9 @@ defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
7878
7979-- | Create a response for a given HTTP request.
8080createResponse :: Request -> Server Response
81−createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
82− | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
81+createResponse request
82+ | requestMethod request == B.pack "GET" = createGetResponse request
83+ | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
8384
8485-- | Create a simple error response.
8586createErrorResponse :: Int -- ^ Error code.
@@ -89,9 +90,10 @@ createErrorResponse statusCode phrase = defaultResponse
8990 { responseStatusCode = statusCode
9091 , responsePhrase = phrase
9192 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
92− , responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
93− ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
94− ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
93+ , responseBody = B.pack $
94+ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
95+ ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
96+ ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
9597 }
9698
9799-- | Create a simple get response.
@@ -100,48 +102,56 @@ createGetResponse request = do
100102 -- Construct the complete fileName of the requested resource.
101103 config <- ask
102104 let uri = B.unpack (requestURI request)
105+ log' = writeChan (logChannel config)
103106 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
104− let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
105− else uri
107+ let fileName =
108+ (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
109+ else uri
106110
107111 create200 = do
108112 body <- B.readFile fileName
109− let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
110− ] ++ getMIMEHeader fileName
111− return $ defaultResponse { responseStatusCode = 200
112− , responsePhrase = B.pack "OK"
113− , responseHeaders = (responseHeaders defaultResponse)
114− `M.union` M.fromList headers
115− , responseBody = body
116− }
113+ let headers =
114+ [ (B.pack "Content-Length", B.pack $ show $ B.length body)
115+ ] ++ getMIMEHeader fileName
116+ return $ defaultResponse
117+ { responseStatusCode = 200
118+ , responsePhrase = B.pack "OK"
119+ , responseHeaders = (responseHeaders defaultResponse)
120+ `M.union` M.fromList headers
121+ , responseBody = body
122+ }
117123
118124 -- Called when an error occurs during the creation of a 200 response.
119− create500 e = do writeChan (logChannel config) $ "Internal Error: " ++ show e
120− return $ createErrorResponse 500 (B.pack "Internal Server Error")
125+ create500 e = do
126+ log' $ "Internal Error: " ++ show e
127+ return $ createErrorResponse 500 (B.pack "Internal Server Error")
121128
122129 -- Send back the page if found.
123130 exists <- liftIO $ doesFileExist fileName
124− if exists then do response <- liftIO $ catch create200 create500
125− return response
126− else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName
127− return $ createErrorResponse 404 (B.pack "Not Found")
131+ if exists
132+ then do response <- liftIO $ catch create200 create500
133+ return response
134+ else do liftIO $ log' $ "Not Found: " ++ fileName
135+ return $ createErrorResponse 404 (B.pack "Not Found")
128136
129137-- | Get the mime header for a certain filename. This is based on the extension
130138-- of the given 'FilePath'.
131139getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
132−getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
133− Nothing -> []
134− where result = lookup (takeExtension fileName) [ (".css", "text/css")
135− , (".gif", "image/gif")
136− , (".htm", "text/html")
137− , (".html", "text/html")
138− , (".jpeg", "image/jpeg")
139− , (".jpg", "image/jpeg")
140− , (".js", "text/javascript")
141− , (".png", "image/png")
142− , (".txt", "text/plain")
143− , (".xml", "text/xml")
144− ]
140+getMIMEHeader fileName =
141+ case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
142+ Nothing -> []
143+ where
144+ result = lookup (takeExtension fileName) [ (".css", "text/css")
145+ , (".gif", "image/gif")
146+ , (".htm", "text/html")
147+ , (".html", "text/html")
148+ , (".jpeg", "image/jpeg")
149+ , (".jpg", "image/jpeg")
150+ , (".js", "text/javascript")
151+ , (".png", "image/png")
152+ , (".txt", "text/plain")
153+ , (".xml", "text/xml")
154+ ]
145155
146156-- | Respond to an incoming request.
147157respond :: Handle -> Server ()
@@ -152,24 +162,28 @@ respond handle = do
152162
153163 -- Generate some output.
154164 config <- ask
155− liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response
165+ liftIO $ writeChan (logChannel config)
166+ $ show request ++ " => " ++ show response
156167
157168 -- Send the response back to the handle.
158169 liftIO $ putResponse response
159− where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
160− [ responseVersion response
161− , B.pack $ show $ responseStatusCode response
162− , responsePhrase response
163− ]
164− hPutStr handle "\r\n"
165− mapM_ putHeader (M.toList $ responseHeaders response)
166− hPutStr handle "\r\n"
167− B.hPutStr handle $ responseBody response
168− hPutStr handle "\r\n"
169− hClose handle
170−
171− putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
172− `B.append` value `B.append` B.pack "\r\n"
170+ where
171+ putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
172+ [ responseVersion response
173+ , B.pack $ show $ responseStatusCode response
174+ , responsePhrase response
175+ ]
176+ hPutStr handle "\r\n"
177+ mapM_ putHeader
178+ (M.toList $ responseHeaders response)
179+ hPutStr handle "\r\n"
180+ B.hPutStr handle $ responseBody response
181+ hPutStr handle "\r\n"
182+ hClose handle
183+
184+ putHeader (key, value) =
185+ B.hPutStr handle $ key `B.append` B.pack ": "
186+ `B.append` value `B.append` B.pack "\r\n"
173187
174188-- | Start a simple http server on the given 'PortNumber', serving the given
175189-- directory.
@@ -194,5 +208,3 @@ simpleServer port root = do
194208 writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
195209 socket <- listenOn (PortNumber port)
196210 forever (listen socket)
197− where
198−