yogsototh/hakyll
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added a simple HTTP server for testing purposes.

Browse source
This commit is contained in:
Jasper Van der Jeugt 2009-12-27 13:25:02 +01:00
parent 9608a9bde5
commit 586998c911
3 changed files with 138 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
hakyll.cabal
View file

@ -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

117
src/Network/Hakyll/SimpleServer.hs Normal file
View file

@ -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 ()

29
src/Text/Hakyll.hs
View file

@ -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)