@@ -1,9 +1,12 @@
1+-- | Module containing a small, simple http file server for testing and preview
2+-- purposes.
13module Network.Hakyll.SimpleServer
24 ( simpleServer
35 ) where
46
57import Network
68import Control.Monad (forever, mapM_)
9+import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
710import System.IO (Handle, hClose, hGetLine, hPutStr)
811import System.Directory (doesFileExist)
912import Control.Concurrent (forkIO)
@@ -13,6 +16,15 @@ import qualified Data.Map as M
1316
1417import Text.Hakyll.Util
1518
19+-- | General server configuration.
20+data ServerConfig = ServerConfig { documentRoot :: FilePath
21+ , portNumber :: PortNumber
22+ } deriving (Show, Eq, Ord)
23+
24+-- | Custom monad stack.
25+type Server = ReaderT ServerConfig IO
26+
27+-- | Simple representation of a HTTP request.
1628data Request = Request { requestMethod :: B.ByteString
1729 , requestURI :: B.ByteString
1830 , requestVersion :: B.ByteString
@@ -23,15 +35,18 @@ instance Show Request where
2335 ++ (B.unpack $ requestURI request) ++ " "
2436 ++ (B.unpack $ requestVersion request)
2537
26−readRequest :: Handle -> IO Request
38+-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request
39+-- headers and body.
40+readRequest :: Handle -> Server Request
2741readRequest handle = do
28− requestLine <- hGetLine handle
42+ requestLine <- liftIO $ hGetLine handle
2943 let [method, uri, version] = map trim $ split " " requestLine
3044 return $ Request { requestMethod = B.pack method
3145 , requestURI = B.pack uri
3246 , requestVersion = B.pack version
3347 }
3448
49+-- | Simple representation of the HTTP response we send back.
3550data Response = Response { responseVersion :: B.ByteString
3651 , responseStatusCode :: Int
3752 , responsePhrase :: B.ByteString
@@ -44,6 +59,7 @@ instance Show Response where
4459 ++ (show $ responseStatusCode response) ++ " "
4560 ++ (B.unpack $ responsePhrase response)
4661
62+-- | A default response.
4763defaultResponse :: Response
4864defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
4965 , responseStatusCode = 0
@@ -52,12 +68,16 @@ defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
5268 , responseBody = B.empty
5369 }
5470
55−createResponse :: Request -> IO Response
71+-- | Create a response for a given HTTP request.
72+createResponse :: Request -> Server Response
5673createResponse 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")
5875
59−errorResponse :: Int -> B.ByteString -> Response
60−errorResponse statusCode phrase = defaultResponse
76+-- | Create a simple error response.
77+createErrorResponse :: Int -- ^ Error code.
78+ -> B.ByteString -- ^ Error phrase.
79+ -> Response -- ^ Result.
80+createErrorResponse statusCode phrase = defaultResponse
6181 { responseStatusCode = statusCode
6282 , responsePhrase = phrase
6383 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
@@ -66,14 +86,20 @@ errorResponse statusCode phrase = defaultResponse
6686 ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
6787 }
6888
69−createGetResponse :: Request -> IO Response
89+-- | Create a simple get response.
90+createGetResponse :: Request -> Server Response
7091createGetResponse request = do
92+ -- Construct the complete fileName of the requested resource.
93+ config <- ask
7194 let uri = B.unpack (requestURI request)
72− let fileName = "_site" ++ if uri == "/" then "/index.html"
95+ fileName = (documentRoot config) ++ if uri == "/" then "/index.html"
7396 else B.unpack (requestURI request)
74− exists <- doesFileExist fileName
75− if exists then catch (create200 fileName) create500
76− else return $ errorResponse 404 (B.pack "Not Found")
97+
98+ -- Send back the page if found.
99+ exists <- liftIO $ doesFileExist fileName
100+ if exists then do response <- liftIO $ catch (create200 fileName) create500
101+ return response
102+ else return $ createErrorResponse 404 (B.pack "Not Found")
77103 where create200 fileName = do
78104 body <- B.readFile fileName
79105 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
@@ -85,12 +111,15 @@ createGetResponse request = do
85111 , responseBody = body
86112 }
87113
114+ -- Called when an error occurs during the creation of a 200 response.
88115 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")
90117
118+-- | Get the mime header for a certain filename. This is based on the extension
119+-- of the given 'FilePath'.
91120getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
92121getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
93− _ -> []
122+ Nothing -> []
94123 where result = lookup (takeExtension fileName) [ (".css", "text/css")
95124 , (".gif", "image/gif")
96125 , (".htm", "text/html")
@@ -103,29 +132,45 @@ getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.p
103132 , (".xml", "text/xml")
104133 ]
105134
106−respond :: Handle -> IO ()
135+-- | Respond to an incoming request.
136+respond :: Handle -> Server ()
107137respond handle = do
138+ -- Read the request and create a response.
108139 request <- readRequest handle
109140 response <- createResponse request
110− putStrLn $ show request ++ " => " ++ show response
111− B.hPutStr handle $ B.intercalate (B.pack " ") [ responseVersion response
112− , B.pack $ show $ responseStatusCode response
113− , responsePhrase response
114− ]
115− hPutStr handle "\r\n"
116− mapM_ putHeader (M.toList $ responseHeaders response)
117− hPutStr handle "\r\n"
118− B.hPutStr handle $ responseBody response
119− hPutStr handle "\r\n"
120− hClose handle
121− where putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
141+
142+ -- Generate some output.
143+ liftIO $ putStrLn $ show request ++ " => " ++ show response
144+
145+ -- Send the response back to the handle.
146+ liftIO $ putResponse response
147+ where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
148+ [ responseVersion response
149+ , B.pack $ show $ responseStatusCode response
150+ , responsePhrase response
151+ ]
152+ hPutStr handle "\r\n"
153+ mapM_ putHeader (M.toList $ responseHeaders response)
154+ hPutStr handle "\r\n"
155+ B.hPutStr handle $ responseBody response
156+ hPutStr handle "\r\n"
157+ hClose handle
158+
159+ putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
122160 `B.append` value `B.append` B.pack "\r\n"
123161
162+-- | Start a simple http server on the given 'PortNumber'.
124163simpleServer :: PortNumber -> IO ()
125164simpleServer port = do
126165 putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
127166 socket <- listenOn (PortNumber port)
128167 forever (listen socket)
129− where listen socket = do (handle, _, _) <- accept socket
130− forkIO (respond handle)
168+ where -- A default configuration.
169+ config = ServerConfig { documentRoot = "_site"
170+ , portNumber = port
171+ }
172+
173+ -- When a clien connects, respond in a separate thread.
174+ listen socket = do (handle, _, _) <- accept socket
175+ forkIO (runReaderT (respond handle) config)
131176 return ()