@@ -1,9 +1,12 @@
1+-- | Module containing a small, simple http file server for testing and preview
1module Network.Hakyll.SimpleServer
3module Network.Hakyll.SimpleServer
2 ( simpleServer
4 ( simpleServer
5import Network
7import Network
6import Control.Monad (forever, mapM_)
8import Control.Monad (forever, mapM_)
9+import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
7import System.IO (Handle, hClose, hGetLine, hPutStr)
10import System.IO (Handle, hClose, hGetLine, hPutStr)
8import System.Directory (doesFileExist)
11import System.Directory (doesFileExist)
9import Control.Concurrent (forkIO)
12import Control.Concurrent (forkIO)
@@ -13,6 +16,15 @@ import qualified Data.Map as M
14import Text.Hakyll.Util
17import Text.Hakyll.Util
19+-- | General server configuration.
20+data ServerConfig = ServerConfig { documentRoot :: FilePath
21+ , portNumber :: PortNumber
22+ } deriving (Show, Eq, Ord)
24+-- | Custom monad stack.
25+type Server = ReaderT ServerConfig IO
27+-- | Simple representation of a HTTP request.
16data Request = Request { requestMethod :: B.ByteString
28data Request = Request { requestMethod :: B.ByteString
17 , requestURI :: B.ByteString
29 , requestURI :: B.ByteString
18 , requestVersion :: B.ByteString
30 , requestVersion :: B.ByteString
@@ -23,15 +35,18 @@ instance Show Request where
23 ++ (B.unpack $ requestURI request) ++ " "
35 ++ (B.unpack $ requestURI request) ++ " "
24 ++ (B.unpack $ requestVersion request)
36 ++ (B.unpack $ requestVersion request)
38+-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request
26−readRequest :: Handle -> IO Request
40+readRequest :: Handle -> Server Request
27readRequest handle = do
41readRequest handle = do
28− requestLine <- hGetLine handle
42+ requestLine <- liftIO $ hGetLine handle
29 let [method, uri, version] = map trim $ split " " requestLine
43 let [method, uri, version] = map trim $ split " " requestLine
30 return $ Request { requestMethod = B.pack method
44 return $ Request { requestMethod = B.pack method
31 , requestURI = B.pack uri
45 , requestURI = B.pack uri
32 , requestVersion = B.pack version
46 , requestVersion = B.pack version
49+-- | Simple representation of the HTTP response we send back.
35data Response = Response { responseVersion :: B.ByteString
50data Response = Response { responseVersion :: B.ByteString
36 , responseStatusCode :: Int
51 , responseStatusCode :: Int
37 , responsePhrase :: B.ByteString
52 , responsePhrase :: B.ByteString
@@ -44,6 +59,7 @@ instance Show Response where
44 ++ (show $ responseStatusCode response) ++ " "
59 ++ (show $ responseStatusCode response) ++ " "
45 ++ (B.unpack $ responsePhrase response)
60 ++ (B.unpack $ responsePhrase response)
62+-- | A default response.
47defaultResponse :: Response
63defaultResponse :: Response
48defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
64defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
49 , responseStatusCode = 0
65 , responseStatusCode = 0
@@ -52,12 +68,16 @@ defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
52 , responseBody = B.empty
68 , responseBody = B.empty
71+-- | Create a response for a given HTTP request.
55−createResponse :: Request -> IO Response
72+createResponse :: Request -> Server Response
56createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
73createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
57− | otherwise = return $ errorResponse 501 (B.pack "Not Implemented")
74+ | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
59−errorResponse :: Int -> B.ByteString -> Response
76+-- | Create a simple error response.
77+createErrorResponse :: Int -- ^ Error code.
78+ -> B.ByteString -- ^ Error phrase.
79+ -> Response -- ^ Result.
60−errorResponse statusCode phrase = defaultResponse
80+createErrorResponse statusCode phrase = defaultResponse
61 { responseStatusCode = statusCode
81 { responseStatusCode = statusCode
62 , responsePhrase = phrase
82 , responsePhrase = phrase
63 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
83 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
@@ -66,14 +86,20 @@ errorResponse statusCode phrase = defaultResponse
66 ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
86 ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
89+-- | Create a simple get response.
69−createGetResponse :: Request -> IO Response
90+createGetResponse :: Request -> Server Response
70createGetResponse request = do
91createGetResponse request = do
92+ -- Construct the complete fileName of the requested resource.
71 let uri = B.unpack (requestURI request)
94 let uri = B.unpack (requestURI request)
72− let fileName = "_site" ++ if uri == "/" then "/index.html"
95+ fileName = (documentRoot config) ++ if uri == "/" then "/index.html"
73 else B.unpack (requestURI request)
96 else B.unpack (requestURI request)
98+ -- Send back the page if found.
74− exists <- doesFileExist fileName
99+ exists <- liftIO $ doesFileExist fileName
75− if exists then catch (create200 fileName) create500
100+ if exists then do response <- liftIO $ catch (create200 fileName) create500
76− else return $ errorResponse 404 (B.pack "Not Found")
102+ else return $ createErrorResponse 404 (B.pack "Not Found")
77 where create200 fileName = do
103 where create200 fileName = do
78 body <- B.readFile fileName
104 body <- B.readFile fileName
79 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
105 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
@@ -85,12 +111,15 @@ createGetResponse request = do
85 , responseBody = body
111 , responseBody = body
114+ -- Called when an error occurs during the creation of a 200 response.
88 create500 e = do putStrLn $ "Internal Error: " ++ show e
115 create500 e = do putStrLn $ "Internal Error: " ++ show e
89− return $ errorResponse 500 (B.pack "Internal Server Error")
116+ return $ createErrorResponse 500 (B.pack "Internal Server Error")
118+-- | Get the mime header for a certain filename. This is based on the extension
119+-- of the given 'FilePath'.
91getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
120getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
92getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
121getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
93− _ -> []
122+ Nothing -> []
94 where result = lookup (takeExtension fileName) [ (".css", "text/css")
123 where result = lookup (takeExtension fileName) [ (".css", "text/css")
95 , (".gif", "image/gif")
124 , (".gif", "image/gif")
96 , (".htm", "text/html")
125 , (".htm", "text/html")
@@ -103,29 +132,45 @@ getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.p
103 , (".xml", "text/xml")
132 , (".xml", "text/xml")
135+-- | Respond to an incoming request.
106−respond :: Handle -> IO ()
136+respond :: Handle -> Server ()
107respond handle = do
137respond handle = do
138+ -- Read the request and create a response.
108 request <- readRequest handle
139 request <- readRequest handle
109 response <- createResponse request
140 response <- createResponse request
142+ -- Generate some output.
110− putStrLn $ show request ++ " => " ++ show response
143+ liftIO $ putStrLn $ show request ++ " => " ++ show response
145+ -- Send the response back to the handle.
146+ liftIO $ putResponse response
147+ where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
111− B.hPutStr handle $ B.intercalate (B.pack " ") [ responseVersion response
148+ [ responseVersion response
112− , B.pack $ show $ responseStatusCode response
149+ , B.pack $ show $ responseStatusCode response
113− , responsePhrase response
150+ , responsePhrase response
115− hPutStr handle "\r\n"
152+ hPutStr handle "\r\n"
116− mapM_ putHeader (M.toList $ responseHeaders response)
153+ mapM_ putHeader (M.toList $ responseHeaders response)
117− hPutStr handle "\r\n"
154+ hPutStr handle "\r\n"
118− B.hPutStr handle $ responseBody response
155+ B.hPutStr handle $ responseBody response
119− hPutStr handle "\r\n"
156+ hPutStr handle "\r\n"
120− hClose handle
157+ hClose handle
121− where putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
159+ putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
122 `B.append` value `B.append` B.pack "\r\n"
160 `B.append` value `B.append` B.pack "\r\n"
162+-- | Start a simple http server on the given 'PortNumber'.
124simpleServer :: PortNumber -> IO ()
163simpleServer :: PortNumber -> IO ()
125simpleServer port = do
164simpleServer port = do
126 putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
165 putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
127 socket <- listenOn (PortNumber port)
166 socket <- listenOn (PortNumber port)
128 forever (listen socket)
167 forever (listen socket)
168+ where -- A default configuration.
169+ config = ServerConfig { documentRoot = "_site"
173+ -- When a clien connects, respond in a separate thread.
129− where listen socket = do (handle, _, _) <- accept socket
174+ listen socket = do (handle, _, _) <- accept socket
130− forkIO (respond handle)
175+ forkIO (runReaderT (respond handle) config)
131 return ()
176 return ()