Documented SimpleServer, and added a ReaderT stack for configuration.

1 files changed, 73 insertions, 28 deletions

diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs
index 5d5d0c2..b54c173 100644
--- a/src/Network/Hakyll/SimpleServer.hs
+++ b/src/Network/Hakyll/SimpleServer.hs
@@ -1,9 +1,12 @@
+-- | Module containing a small, simple http file server for testing and preview
+--   purposes.
 module Network.Hakyll.SimpleServer
     ( simpleServer
     ) where
 
 import Network
 import Control.Monad (forever, mapM_)
+import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
 import System.IO (Handle, hClose, hGetLine, hPutStr)
 import System.Directory (doesFileExist)
 import Control.Concurrent (forkIO)
@@ -13,6 +16,15 @@ import qualified Data.Map as M
 
 import Text.Hakyll.Util
 
+-- | General server configuration.
+data ServerConfig = ServerConfig { documentRoot :: FilePath
+                                 , portNumber :: PortNumber
+                                 } deriving (Show, Eq, Ord)
+
+-- | Custom monad stack.
+type Server = ReaderT ServerConfig IO
+
+-- | Simple representation of a HTTP request.
 data Request = Request { requestMethod :: B.ByteString
                        , requestURI :: B.ByteString
                        , requestVersion :: B.ByteString
@@ -23,15 +35,18 @@ instance Show Request where
                  ++ (B.unpack $ requestURI request) ++ " "
                  ++ (B.unpack $ requestVersion request)
 
-readRequest :: Handle -> IO Request
+-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request
+--   headers and body.
+readRequest :: Handle -> Server Request
 readRequest handle = do
-    requestLine <- hGetLine handle
+    requestLine <- liftIO $ hGetLine handle
     let [method, uri, version] = map trim $ split " " requestLine
     return $ Request { requestMethod = B.pack method
                      , requestURI = B.pack uri
                      , requestVersion = B.pack version
                      }
 
+-- | Simple representation of the HTTP response we send back.
 data Response = Response { responseVersion :: B.ByteString
                          , responseStatusCode :: Int
                          , responsePhrase :: B.ByteString
@@ -44,6 +59,7 @@ instance Show Response where
                   ++ (show $ responseStatusCode response) ++ " "
                   ++ (B.unpack $ responsePhrase response)
 
+-- | A default response.
 defaultResponse :: Response
 defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
                            , responseStatusCode = 0
@@ -52,12 +68,16 @@ defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
                            , responseBody = B.empty
                            }
 
-createResponse :: Request -> IO Response
+-- | Create a response for a given HTTP request.
+createResponse :: Request -> Server Response
 createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
-                       | otherwise = return $ errorResponse 501 (B.pack "Not Implemented")
+                       | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
 
-errorResponse :: Int -> B.ByteString -> Response
-errorResponse statusCode phrase = defaultResponse
+-- | Create a simple error response.
+createErrorResponse :: Int          -- ^ Error code.
+                    -> B.ByteString -- ^ Error phrase.
+                    -> Response     -- ^ Result.
+createErrorResponse statusCode phrase = defaultResponse
     { responseStatusCode = statusCode
     , responsePhrase = phrase
     , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
@@ -66,14 +86,20 @@ errorResponse statusCode phrase = defaultResponse
                             ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
     }
 
-createGetResponse :: Request -> IO Response
+-- | Create a simple get response.
+createGetResponse :: Request -> Server Response
 createGetResponse request = do
+    -- Construct the complete fileName of the requested resource.
+    config <- ask
     let uri = B.unpack (requestURI request)
-    let fileName = "_site" ++ if uri == "/" then "/index.html"
+        fileName = (documentRoot config) ++ if uri == "/" then "/index.html"
                                             else B.unpack (requestURI request)
-    exists <- doesFileExist fileName
-    if exists then catch (create200 fileName) create500
-              else return $ errorResponse 404 (B.pack "Not Found")
+
+    -- Send back the page if found.
+    exists <- liftIO $ doesFileExist fileName
+    if exists then do response <- liftIO $ catch (create200 fileName) create500
+                      return response
+              else return $ createErrorResponse 404 (B.pack "Not Found")
         where create200 fileName = do
                     body <- B.readFile fileName
                     let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
@@ -85,12 +111,15 @@ createGetResponse request = do
                                              , responseBody = body
                                              }
 
+              -- Called when an error occurs during the creation of a 200 response.
               create500 e = do putStrLn $ "Internal Error: " ++ show e
-                               return $ errorResponse 500 (B.pack "Internal Server Error")
+                               return $ createErrorResponse 500 (B.pack "Internal Server Error")
 
+-- | Get the mime header for a certain filename. This is based on the extension
+--   of the given 'FilePath'.
 getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
 getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
-                                        _ -> []
+                                        Nothing  -> []
     where result = lookup (takeExtension fileName) [ (".css", "text/css")
                                                    , (".gif", "image/gif")
                                                    , (".htm", "text/html")
@@ -103,29 +132,45 @@ getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.p
                                                    , (".xml", "text/xml")
                                                    ]
 
-respond :: Handle -> IO ()
+-- | Respond to an incoming request.
+respond :: Handle -> Server ()
 respond handle = do
+    -- Read the request and create a response.
     request <- readRequest handle
     response <- createResponse request
-    putStrLn $ show request ++ " => " ++ show response
-    B.hPutStr handle $ B.intercalate (B.pack " ") [ responseVersion response
-                                                  , B.pack $ show $ responseStatusCode response
-                                                  , responsePhrase response
-                                                  ]
-    hPutStr handle "\r\n"
-    mapM_ putHeader (M.toList $ responseHeaders response)
-    hPutStr handle "\r\n"
-    B.hPutStr handle $ responseBody response
-    hPutStr handle "\r\n"
-    hClose handle
-    where putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
+
+    -- Generate some output.
+    liftIO $ putStrLn $ show request ++ " => " ++ show response
+
+    -- Send the response back to the handle.
+    liftIO $ putResponse response
+    where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
+                                          [ responseVersion response
+                                          , B.pack $ show $ responseStatusCode response
+                                          , responsePhrase response
+                                          ]
+                                    hPutStr handle "\r\n"
+                                    mapM_ putHeader (M.toList $ responseHeaders response)
+                                    hPutStr handle "\r\n"
+                                    B.hPutStr handle $ responseBody response
+                                    hPutStr handle "\r\n"
+                                    hClose handle
+
+          putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
                                                         `B.append` value `B.append` B.pack "\r\n"
 
+-- | Start a simple http server on the given 'PortNumber'.
 simpleServer :: PortNumber -> IO ()
 simpleServer port = do
     putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
     socket <- listenOn (PortNumber port)
     forever (listen socket)
-    where listen socket = do (handle, _, _) <- accept socket
-                             forkIO (respond handle)
+    where -- A default configuration.
+          config = ServerConfig { documentRoot = "_site"
+                                , portNumber = port
+                                }
+
+          -- When a clien connects, respond in a separate thread.
+          listen socket = do (handle, _, _) <- accept socket
+                             forkIO (runReaderT (respond handle) config)
                              return ()