diff options
Diffstat (limited to 'src/Network')
| -rw-r--r-- | src/Network/Hakyll/SimpleServer.hs | 101 |
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 () |