git.iko.soy/hakyll
on master help sign in
Logging is now dealt with in a separate thread.
dea9cb0Jasper Van der Jeugt
hakyll.cabal+1−1
compare with master
unifiedsplit
@@ -24,7 +24,7 @@ library
24 directory >= 1,
24 directory >= 1,
25 containers >= 0.1,
25 containers >= 0.1,
26 bytestring >= 0.9 && <= 0.9.1.4,
26 bytestring >= 0.9 && <= 0.9.1.4,
27− pandoc >= 1.3,
27+ pandoc >= 1,
28 regex-compat >= 0.92,
28 regex-compat >= 0.92,
29 network >= 2,
29 network >= 2,
30 mtl >= 1.1
30 mtl >= 1.1
src/Network/Hakyll/SimpleServer.hs+47−28
@@ -4,22 +4,29 @@ module Network.Hakyll.SimpleServer
4 ( simpleServer
4 ( simpleServer
5 ) where
5 ) where
6
6
7+import Prelude hiding (log)
7import Network
8import Network
8import Control.Monad (forever, mapM_)
9import Control.Monad (forever, mapM_)
9import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
10import 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)
11import System.Directory (doesFileExist, doesDirectoryExist)
12import System.Directory (doesFileExist, doesDirectoryExist)
12import Control.Concurrent (forkIO)
13import Control.Concurrent (forkIO)
14+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
13import System.FilePath (takeExtension)
15import System.FilePath (takeExtension)
14import qualified Data.ByteString.Char8 as B
16import qualified Data.ByteString.Char8 as B
15import qualified Data.Map as M
17import qualified Data.Map as M
16
18
17import Text.Hakyll.Util
19import Text.Hakyll.Util
18
20
21+-- | Function to log from a chan.
22+log :: Chan String -> IO ()
23+log logChan = forever (readChan logChan >>= hPutStrLn stderr)
24+
19-- | General server configuration.
25-- | General server configuration.
20data ServerConfig = ServerConfig { documentRoot :: FilePath
26data ServerConfig = ServerConfig { documentRoot :: FilePath
21 , portNumber :: PortNumber
27 , portNumber :: PortNumber
22− } deriving (Show, Eq, Ord)
28+ , logChannel :: Chan String
29+ }
23
30
24-- | Custom monad stack.
31-- | Custom monad stack.
25type Server = ReaderT ServerConfig IO
32type Server = ReaderT ServerConfig IO
@@ -96,25 +103,27 @@ createGetResponse request = do
96 let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
103 let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
97 else uri
104 else uri
98
105
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+
99 -- Send back the page if found.
121 -- Send back the page if found.
100 exists <- liftIO $ doesFileExist fileName
122 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
102 return response
124 return response
103− else return $ createErrorResponse 404 (B.pack "Not Found")
125+ else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName
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")
126+ return $ createErrorResponse 404 (B.pack "Not Found")
118
127
119-- | Get the mime header for a certain filename. This is based on the extension
128-- | Get the mime header for a certain filename. This is based on the extension
120-- of the given 'FilePath'.
129-- of the given 'FilePath'.
@@ -141,7 +150,8 @@ respond handle = do
141 response <- createResponse request
150 response <- createResponse request
142
151
143 -- Generate some output.
152 -- Generate some output.
153+ config <- ask
144− liftIO $ putStrLn $ show request ++ " => " ++ show response
154+ liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response
145
155
146 -- Send the response back to the handle.
156 -- Send the response back to the handle.
147 liftIO $ putResponse response
157 liftIO $ putResponse response
@@ -164,15 +174,24 @@ respond handle = do
164-- directory.
174-- directory.
165simpleServer :: PortNumber -> FilePath -> IO ()
175simpleServer :: PortNumber -> FilePath -> IO ()
166simpleServer port root = do
176simpleServer port root = do
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+
167− putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
193+ writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
168 socket <- listenOn (PortNumber port)
194 socket <- listenOn (PortNumber port)
169 forever (listen socket)
195 forever (listen socket)
170− where -- A default configuration.
196+ where
171− config = ServerConfig { documentRoot = root
172− , portNumber = port
173− }
174
197
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 ()