Added a simple HTTP server for testing purposes.

3 files changed, 138 insertions, 11 deletions

diff --git a/hakyll.cabal b/hakyll.cabal
index ed1dfb4..3665d84 100644
--- a/hakyll.cabal
+++ b/hakyll.cabal
@@ -19,7 +19,7 @@ library
   ghc-options: -Wall
   hs-source-dirs: src/
   build-depends:   base >= 4 && < 5, template, filepath, directory, containers, bytestring,
-                   pandoc >= 1, regex-compat
+                   pandoc >= 1, regex-compat, network
   exposed-modules: Text.Hakyll
                    Text.Hakyll.Render
                    Text.Hakyll.Renderable
@@ -29,3 +29,4 @@ library
                    Text.Hakyll.Page
                    Text.Hakyll.Util
                    Text.Hakyll.Tags
+                   Network.Hakyll.SimpleServer
diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs
new file mode 100644
index 0000000..a6902e0
--- /dev/null
+++ b/src/Network/Hakyll/SimpleServer.hs
@@ -0,0 +1,117 @@
+module Network.Hakyll.SimpleServer
+    ( simpleServer
+    ) where
+
+import Network
+import Control.Monad (forever, mapM_)
+import System.IO (Handle, hClose, hGetLine, hPutStr)
+import System.Directory (doesFileExist)
+import Control.Concurrent (forkIO)
+import System.FilePath (takeExtension)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Map as M
+
+import Text.Hakyll.Util
+
+data Request = Request { requestMethod :: B.ByteString
+                       , requestURI :: B.ByteString
+                       , requestVersion :: B.ByteString
+                       , requestHeaders :: M.Map B.ByteString B.ByteString
+                       , requestBody :: B.ByteString
+                       } deriving (Show, Ord, Eq)
+
+readRequest :: Handle -> IO Request
+readRequest handle = do
+    requestLine <- hGetLine handle
+    let [method, uri, version] = map trim $ split " " requestLine
+    return $ Request { requestMethod = B.pack method
+                     , requestURI = B.pack uri
+                     , requestVersion = B.pack version
+                     , requestHeaders = M.empty -- Ignore all headers for now.
+                     , requestBody = B.empty -- Ignore request body for now.
+                     }
+
+data Response = Response { responseVersion :: B.ByteString
+                         , responseStatusCode :: Int
+                         , responsePhrase :: B.ByteString
+                         , responseHeaders :: M.Map B.ByteString B.ByteString
+                         , responseBody :: B.ByteString
+                         } deriving (Show, Ord, Eq)
+
+defaultResponse :: Response
+defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
+                           , responseStatusCode = 0
+                           , responsePhrase = B.empty
+                           , responseHeaders = M.empty
+                           , responseBody = B.empty
+                           }
+
+createResponse :: Request -> IO Response
+createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
+                       | otherwise = return $ defaultResponse { responseStatusCode = 501
+                                                              , responsePhrase = B.pack "Not Implemented"
+                                                              }
+
+createGetResponse :: Request -> IO Response
+createGetResponse request = do
+    let uri = B.unpack (requestURI request)
+    let fileName = "_site" ++ if uri == "/" then "/index.html"
+                                            else B.unpack (requestURI request)
+    exists <- doesFileExist fileName
+    if exists then createGet fileName
+              else create404
+        where create404 = return $ defaultResponse { responseStatusCode = 404
+                                                   , responsePhrase = B.pack "Not Found"
+                                                   }
+
+              createGet fileName = do
+                    body <- B.readFile fileName
+                    let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
+                                  ] ++ getMIMEHeader fileName
+                    return $ defaultResponse { responseStatusCode = 200
+                                             , responsePhrase = B.pack "OK"
+                                             , responseHeaders = (responseHeaders defaultResponse) 
+                                                    `M.union` M.fromList headers
+                                             , responseBody = body
+                                             }
+
+getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
+getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
+                                        _ -> []
+    where result = lookup (takeExtension fileName) [ (".css", "text/css")
+                                                   , (".gif", "image/gif")
+                                                   , (".htm", "text/html")
+                                                   , (".html", "text/html")
+                                                   , (".jpeg", "image/jpeg")
+                                                   , (".jpg", "image/jpeg")
+                                                   , (".js", "text/javascript")
+                                                   , (".png", "image/png")
+                                                   , (".txt", "text/plain")
+                                                   , (".xml", "text/xml")  
+                                                   ]
+
+respond :: Handle -> IO ()
+respond handle = do
+    request <- readRequest handle
+    response <- createResponse request
+    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 ": "
+                                                        `B.append` value `B.append` B.pack "\r\n"
+
+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)
+                             return ()
diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs
index 6e85907..4aa88cb 100644
--- a/src/Text/Hakyll.hs
+++ b/src/Text/Hakyll.hs
@@ -2,6 +2,8 @@ module Text.Hakyll
     ( hakyll
     ) where
 
+import Network.Hakyll.SimpleServer (simpleServer)
+
 import System.Environment (getArgs, getProgName)
 import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
 
@@ -9,10 +11,13 @@ import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
 hakyll :: IO () -> IO ()
 hakyll action = do
     args <- getArgs
-    case args of []          -> action
-                 ["--clean"] -> clean
-                 _           -> showHelp
+    case args of []              -> action
+                 ["--clean"]     -> clean
+                 ["--server", p] -> server (read p)
+                 ["--server"]    -> server 8000
+                 _               -> help
 
+-- | Clean up directories.
 clean :: IO ()
 clean = do remove' "_cache"
            remove' "_site"
@@ -21,13 +26,17 @@ clean = do remove' "_cache"
                                      else return ()
 
 -- | Show usage information.
-showHelp :: IO ()
-showHelp = do
+help :: IO ()
+help = do
     name <- getProgName
-    putStrLn $  "This is a hakyll site generator program. You should always run\n"
-             ++ "it from the project root directory.\n"
+    putStrLn $  "This is a hakyll site generator program. You should always\n"
+             ++ "run it from the project root directory.\n"
              ++ "\n"
              ++ "Usage:\n"
-             ++ name ++ "           Generate the site.\n"
-             ++ name ++ " --clean   Clean up and remove cache.\n"
-             ++ name ++ " --help    Show this message.\n"
+             ++ name ++ "                 Generate the site.\n"
+             ++ name ++ " --clean         Clean up and remove cache.\n"
+             ++ name ++ " --help          Show this message.\n"
+             ++ name ++ " --server [port] Run a local test server.\n"
+
+server :: Integer -> IO ()
+server p = do simpleServer (fromIntegral $ p)