@@ -4,22 +4,29 @@ module Network.Hakyll.SimpleServer
44 ( simpleServer
55 ) where
66
7+import Prelude hiding (log)
78import Network
89import Control.Monad (forever, mapM_)
910import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
10−import System.IO (Handle, hClose, hGetLine, hPutStr)
11+import System.IO (Handle, hClose, hGetLine, hPutStr, hPutStrLn, stderr)
1112import System.Directory (doesFileExist, doesDirectoryExist)
1213import Control.Concurrent (forkIO)
14+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
1315import System.FilePath (takeExtension)
1416import qualified Data.ByteString.Char8 as B
1517import qualified Data.Map as M
1618
1719import Text.Hakyll.Util
1820
21+-- | Function to log from a chan.
22+log :: Chan String -> IO ()
23+log logChan = forever (readChan logChan >>= hPutStrLn stderr)
24+
1925-- | General server configuration.
2026data ServerConfig = ServerConfig { documentRoot :: FilePath
2127 , portNumber :: PortNumber
22− } deriving (Show, Eq, Ord)
28+ , logChannel :: Chan String
29+ }
2330
2431-- | Custom monad stack.
2532type Server = ReaderT ServerConfig IO
@@ -96,25 +103,27 @@ createGetResponse request = do
96103 let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
97104 else uri
98105
106+ create200 = do
107+ body <- B.readFile fileName
108+ let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
109+ ] ++ getMIMEHeader fileName
110+ return $ defaultResponse { responseStatusCode = 200
111+ , responsePhrase = B.pack "OK"
112+ , responseHeaders = (responseHeaders defaultResponse)
113+ `M.union` M.fromList headers
114+ , responseBody = body
115+ }
116+
117+ -- Called when an error occurs during the creation of a 200 response.
118+ create500 e = do writeChan (logChannel config) $ "Internal Error: " ++ show e
119+ return $ createErrorResponse 500 (B.pack "Internal Server Error")
120+
99121 -- Send back the page if found.
100122 exists <- liftIO $ doesFileExist fileName
101− if exists then do response <- liftIO $ catch (create200 fileName) create500
123+ if exists then do response <- liftIO $ catch create200 create500
102124 return response
103− else return $ createErrorResponse 404 (B.pack "Not Found")
104− where create200 fileName = do
105− body <- B.readFile fileName
106− let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
107− ] ++ getMIMEHeader fileName
108− return $ defaultResponse { responseStatusCode = 200
109− , responsePhrase = B.pack "OK"
110− , responseHeaders = (responseHeaders defaultResponse)
111− `M.union` M.fromList headers
112− , responseBody = body
113− }
114−
115− -- Called when an error occurs during the creation of a 200 response.
116− create500 e = do putStrLn $ "Internal Error: " ++ show e
117− return $ createErrorResponse 500 (B.pack "Internal Server Error")
125+ else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName
126+ return $ createErrorResponse 404 (B.pack "Not Found")
118127
119128-- | Get the mime header for a certain filename. This is based on the extension
120129-- of the given 'FilePath'.
@@ -141,7 +150,8 @@ respond handle = do
141150 response <- createResponse request
142151
143152 -- Generate some output.
144− liftIO $ putStrLn $ show request ++ " => " ++ show response
153+ config <- ask
154+ liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response
145155
146156 -- Send the response back to the handle.
147157 liftIO $ putResponse response
@@ -164,15 +174,24 @@ respond handle = do
164174-- directory.
165175simpleServer :: PortNumber -> FilePath -> IO ()
166176simpleServer port root = do
167− putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
177+ -- Channel to send logs to
178+ logChan <- newChan
179+
180+ let config = ServerConfig { documentRoot = root
181+ , portNumber = port
182+ , logChannel = logChan
183+ }
184+
185+ -- When a client connects, respond in a separate thread.
186+ listen socket = do (handle, _, _) <- accept socket
187+ forkIO (runReaderT (respond handle) config)
188+ return ()
189+
190+ -- Handle logging in a separate thread
191+ forkIO (log logChan)
192+
193+ writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
168194 socket <- listenOn (PortNumber port)
169195 forever (listen socket)
170− where -- A default configuration.
171− config = ServerConfig { documentRoot = root
172− , portNumber = port
173− }
196+ where
174197
175− -- When a client connects, respond in a separate thread.
176− listen socket = do (handle, _, _) <- accept socket
177− forkIO (runReaderT (respond handle) config)
178− return ()