@@ -13,8 +13,8 @@ import System.Directory (doesFileExist, doesDirectoryExist)
1313import Control.Concurrent (forkIO)
1414import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
1515import System.FilePath (takeExtension)
16−import qualified Data.ByteString.Char8 as B
1716import qualified Data.Map as M
17+import Data.List (intercalate)
1818
1919import Text.Hakyll.Util
2020import Text.Hakyll.Regex
@@ -33,15 +33,15 @@ data ServerConfig = ServerConfig { documentRoot :: FilePath
3333type Server = ReaderT ServerConfig IO
3434
3535-- | Simple representation of a HTTP request.
36−data Request = Request { requestMethod :: B.ByteString
37− , requestURI :: B.ByteString
38− , requestVersion :: B.ByteString
36+data Request = Request { requestMethod :: String
37+ , requestURI :: String
38+ , requestVersion :: String
3939 } deriving (Ord, Eq)
4040
4141instance Show Request where
42− show request = (B.unpack $ requestMethod request) ++ " "
43− ++ (B.unpack $ requestURI request) ++ " "
44− ++ (B.unpack $ requestVersion request)
42+ show request = requestMethod request ++ " "
43+ ++ requestURI request ++ " "
44+ ++ requestVersion request
4545
4646-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request
4747-- headers and body.
@@ -49,51 +49,51 @@ readRequest :: Handle -> Server Request
4949readRequest handle = do
5050 requestLine <- liftIO $ hGetLine handle
5151 let [method, uri, version] = map trim $ splitRegex " " requestLine
52− return $ Request { requestMethod = B.pack method
53− , requestURI = B.pack uri
54− , requestVersion = B.pack version
52+ return $ Request { requestMethod = method
53+ , requestURI = uri
54+ , requestVersion = version
5555 }
5656
5757-- | Simple representation of the HTTP response we send back.
58−data Response = Response { responseVersion :: B.ByteString
58+data Response = Response { responseVersion :: String
5959 , responseStatusCode :: Int
60− , responsePhrase :: B.ByteString
61− , responseHeaders :: M.Map B.ByteString B.ByteString
62− , responseBody :: B.ByteString
60+ , responsePhrase :: String
61+ , responseHeaders :: M.Map String String
62+ , responseBody :: String
6363 } deriving (Ord, Eq)
6464
6565instance Show Response where
66− show response = (B.unpack $ responseVersion response) ++ " "
66+ show response = responseVersion response ++ " "
6767 ++ (show $ responseStatusCode response) ++ " "
68− ++ (B.unpack $ responsePhrase response)
68+ ++ responsePhrase response
6969
7070-- | A default response.
7171defaultResponse :: Response
72−defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
72+defaultResponse = Response { responseVersion = "HTTP/1.1"
7373 , responseStatusCode = 0
74− , responsePhrase = B.empty
74+ , responsePhrase = ""
7575 , responseHeaders = M.empty
76− , responseBody = B.empty
76+ , responseBody = ""
7777 }
7878
7979-- | Create a response for a given HTTP request.
8080createResponse :: Request -> Server Response
8181createResponse request
82− | requestMethod request == B.pack "GET" = createGetResponse request
83− | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
82+ | requestMethod request == "GET" = createGetResponse request
83+ | otherwise = return $ createErrorResponse 501 "Not Implemented"
8484
8585-- | Create a simple error response.
8686createErrorResponse :: Int -- ^ Error code.
87− -> B.ByteString -- ^ Error phrase.
87+ -> String -- ^ Error phrase.
8888 -> Response -- ^ Result.
8989createErrorResponse statusCode phrase = defaultResponse
9090 { responseStatusCode = statusCode
9191 , responsePhrase = phrase
92− , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
93− , responseBody = B.pack $
92+ , responseHeaders = M.singleton "Content-Type" "text/html"
93+ , responseBody =
9494 "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
9595 ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
96− ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
96+ ++ "<p>" ++ phrase ++ "</p> </body> </html>"
9797 }
9898
9999-- | Create a simple get response.
@@ -101,7 +101,7 @@ createGetResponse :: Request -> Server Response
101101createGetResponse request = do
102102 -- Construct the complete fileName of the requested resource.
103103 config <- ask
104− let uri = B.unpack (requestURI request)
104+ let uri = requestURI request
105105 log' = writeChan (logChannel config)
106106 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
107107 let fileName =
@@ -109,13 +109,13 @@ createGetResponse request = do
109109 else uri
110110
111111 create200 = do
112− body <- B.readFile fileName
112+ body <- readFile fileName
113113 let headers =
114− [ (B.pack "Content-Length", B.pack $ show $ B.length body)
114+ [ ("Content-Length", show $ length body)
115115 ] ++ getMIMEHeader fileName
116116 return $ defaultResponse
117117 { responseStatusCode = 200
118− , responsePhrase = B.pack "OK"
118+ , responsePhrase = "OK"
119119 , responseHeaders = (responseHeaders defaultResponse)
120120 `M.union` M.fromList headers
121121 , responseBody = body
@@ -124,7 +124,7 @@ createGetResponse request = do
124124 -- Called when an error occurs during the creation of a 200 response.
125125 create500 e = do
126126 log' $ "Internal Error: " ++ show e
127− return $ createErrorResponse 500 (B.pack "Internal Server Error")
127+ return $ createErrorResponse 500 "Internal Server Error"
128128
129129 -- Send back the page if found.
130130 exists <- liftIO $ doesFileExist fileName
@@ -132,13 +132,13 @@ createGetResponse request = do
132132 then do response <- liftIO $ catch create200 create500
133133 return response
134134 else do liftIO $ log' $ "Not Found: " ++ fileName
135− return $ createErrorResponse 404 (B.pack "Not Found")
135+ return $ createErrorResponse 404 "Not Found"
136136
137137-- | Get the mime header for a certain filename. This is based on the extension
138138-- of the given 'FilePath'.
139−getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
139+getMIMEHeader :: FilePath -> [(String, String)]
140140getMIMEHeader fileName =
141− case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
141+ case result of (Just x) -> [("Content-Type", x)]
142142 Nothing -> []
143143 where
144144 result = lookup (takeExtension fileName) [ (".css", "text/css")
@@ -168,22 +168,21 @@ respond handle = do
168168 -- Send the response back to the handle.
169169 liftIO $ putResponse response
170170 where
171− putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
171+ putResponse response = do hPutStr handle $ intercalate " "
172172 [ responseVersion response
173− , B.pack $ show $ responseStatusCode response
173+ , show $ responseStatusCode response
174174 , responsePhrase response
175175 ]
176176 hPutStr handle "\r\n"
177177 mapM_ putHeader
178178 (M.toList $ responseHeaders response)
179179 hPutStr handle "\r\n"
180− B.hPutStr handle $ responseBody response
180+ hPutStr handle $ responseBody response
181181 hPutStr handle "\r\n"
182182 hClose handle
183183
184184 putHeader (key, value) =
185− B.hPutStr handle $ key `B.append` B.pack ": "
186− `B.append` value `B.append` B.pack "\r\n"
185+ hPutStr handle $ key ++ ": " ++ value ++ "\r\n"
187186
188187-- | Start a simple http server on the given 'PortNumber', serving the given
189188-- directory.