diff options
| -rw-r--r-- | hakyll.cabal | 3 | ||||
| -rw-r--r-- | src/Network/Hakyll/SimpleServer.hs | 117 | ||||
| -rw-r--r-- | src/Text/Hakyll.hs | 29 |
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) |