Added a simple HTTP server for testing purposes.
This commit is contained in:
parent
9608a9bde5
commit
586998c911
3 changed files with 138 additions and 11 deletions
|
@ -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
117
src/Network/Hakyll/SimpleServer.hs
Normal 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 ()
|
|
@ -2,6 +2,8 @@ module Text.Hakyll
|
|||
( hakyll
|
||||
) where
|
||||
|
||||
import Network.Hakyll.SimpleServer (simpleServer)
|
||||
|
||||
import System.Environment (getArgs, getProgName)
|
||||
import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
|
||||
|
||||
|
@ -11,8 +13,11 @@ hakyll action = do
|
|||
args <- getArgs
|
||||
case args of [] -> action
|
||||
["--clean"] -> clean
|
||||
_ -> showHelp
|
||||
["--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 ++ " --server [port] Run a local test server.\n"
|
||||
|
||||
server :: Integer -> IO ()
|
||||
server p = do simpleServer (fromIntegral $ p)
|
||||
|
|
Loading…
Reference in a new issue