dc60463 · hakyll · git.iko.soy

13import Control.Concurrent (forkIO)

14import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

15import System.FilePath (takeExtension)

16−import qualified Data.ByteString.Char8 as B

17import qualified Data.Map as M

16import qualified Data.Map as M

17+import Data.List (intercalate)

18

19import Text.Hakyll.Util

20import Text.Hakyll.Regex

33type Server = ReaderT ServerConfig IO

34

35-- | Simple representation of a HTTP request.

36−data Request = Request { requestMethod :: B.ByteString

36+data Request = Request { requestMethod :: String

37− , requestURI :: B.ByteString

37+ , requestURI :: String

38− , requestVersion :: B.ByteString

38+ , requestVersion :: String

39 } deriving (Ord, Eq)

40

41instance Show Request where

42− show request = (B.unpack $ requestMethod request) ++ " "

42+ show request = requestMethod request ++ " "

43− ++ (B.unpack $ requestURI request) ++ " "

43+ ++ requestURI request ++ " "

44− ++ (B.unpack $ requestVersion request)

44+ ++ requestVersion request

45

46-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request

47-- headers and body.

49readRequest handle = do

50 requestLine <- liftIO $ hGetLine handle

51 let [method, uri, version] = map trim $ splitRegex " " requestLine

52− return $ Request { requestMethod = B.pack method

52+ return $ Request { requestMethod = method

53− , requestURI = B.pack uri

53+ , requestURI = uri

54− , requestVersion = B.pack version

54+ , requestVersion = version

55 }

56

57-- | Simple representation of the HTTP response we send back.

58−data Response = Response { responseVersion :: B.ByteString

58+data Response = Response { responseVersion :: String

59 , responseStatusCode :: Int

60− , responsePhrase :: B.ByteString

60+ , responsePhrase :: String

61− , responseHeaders :: M.Map B.ByteString B.ByteString

61+ , responseHeaders :: M.Map String String

62− , responseBody :: B.ByteString

62+ , responseBody :: String

63 } deriving (Ord, Eq)

64

65instance Show Response where

66− show response = (B.unpack $ responseVersion response) ++ " "

66+ show response = responseVersion response ++ " "

67 ++ (show $ responseStatusCode response) ++ " "

68− ++ (B.unpack $ responsePhrase response)

68+ ++ responsePhrase response

69

70-- | A default response.

71defaultResponse :: Response

72−defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"

72+defaultResponse = Response { responseVersion = "HTTP/1.1"

73 , responseStatusCode = 0

74− , responsePhrase = B.empty

74+ , responsePhrase = ""

75 , responseHeaders = M.empty

76− , responseBody = B.empty

76+ , responseBody = ""

77 }

78

79-- | Create a response for a given HTTP request.

80createResponse :: Request -> Server Response

81createResponse request

82− | requestMethod request == B.pack "GET" = createGetResponse request

82+ | requestMethod request == "GET" = createGetResponse request

83− | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")

83+ | otherwise = return $ createErrorResponse 501 "Not Implemented"

84

85-- | Create a simple error response.

86createErrorResponse :: Int -- ^ Error code.

87− -> B.ByteString -- ^ Error phrase.

87+ -> String -- ^ Error phrase.

88 -> Response -- ^ Result.

89createErrorResponse statusCode phrase = defaultResponse

90 { responseStatusCode = statusCode

91 , responsePhrase = phrase

92− , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")

92+ , responseHeaders = M.singleton "Content-Type" "text/html"

93− , responseBody = B.pack $

93+ , responseBody =

94 "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"

95 ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"

96− ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"

96+ ++ "<p>" ++ phrase ++ "</p> </body> </html>"

97 }

98

99-- | Create a simple get response.

101createGetResponse request = do

102 -- Construct the complete fileName of the requested resource.

103 config <- ask

104− let uri = B.unpack (requestURI request)

104+ let uri = requestURI request

105 log' = writeChan (logChannel config)

106 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri

107 let fileName =

109 else uri

110

111 create200 = do

112− body <- B.readFile fileName

112+ body <- readFile fileName

113 let headers =

114− [ (B.pack "Content-Length", B.pack $ show $ B.length body)

114+ [ ("Content-Length", show $ length body)

115 ] ++ getMIMEHeader fileName

116 return $ defaultResponse

117 { responseStatusCode = 200

118− , responsePhrase = B.pack "OK"

118+ , responsePhrase = "OK"

119 , responseHeaders = (responseHeaders defaultResponse)

120 `M.union` M.fromList headers

121 , responseBody = body

124 -- Called when an error occurs during the creation of a 200 response.

125 create500 e = do

126 log' $ "Internal Error: " ++ show e

127− return $ createErrorResponse 500 (B.pack "Internal Server Error")

127+ return $ createErrorResponse 500 "Internal Server Error"

128

129 -- Send back the page if found.

130 exists <- liftIO $ doesFileExist fileName

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")

135+ return $ createErrorResponse 404 "Not Found"

136

137-- | Get the mime header for a certain filename. This is based on the extension

138-- of the given 'FilePath'.

139−getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]

139+getMIMEHeader :: FilePath -> [(String, String)]

140getMIMEHeader fileName =

141− case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]

141+ case result of (Just x) -> [("Content-Type", x)]

142 Nothing -> []

143 where

144 result = lookup (takeExtension fileName) [ (".css", "text/css")

168 -- Send the response back to the handle.

169 liftIO $ putResponse response

170 where

171− putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")

171+ putResponse response = do hPutStr handle $ intercalate " "

172 [ responseVersion response

173− , B.pack $ show $ responseStatusCode response

173+ , 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

180+ 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 ": "

185+ hPutStr handle $ key ++ ": " ++ value ++ "\r\n"

186− `B.append` value `B.append` B.pack "\r\n"

187

186

188-- | Start a simple http server on the given 'PortNumber', serving the given

187-- | Start a simple http server on the given 'PortNumber', serving the given

189-- directory.

188-- directory.