git.iko.soy/hakyll
on dc516e9 help sign in
hakyll/src/Network/Hakyll/SimpleServer.hs
209 lines 8.4 kB history raw
1-- | Module containing a small, simple http file server for testing and preview
2-- purposes.
3module Network.Hakyll.SimpleServer
4 ( simpleServer
5 ) where
7import Prelude hiding (log)
8import Control.Monad (forever)
9import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
10import Network
11import System.IO
12import System.Directory (doesFileExist, doesDirectoryExist)
13import Control.Concurrent (forkIO)
14import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
15import System.FilePath (takeExtension)
16import qualified Data.Map as M
17import Data.List (intercalate)
19import Text.Hakyll.Util
20import Text.Hakyll.Regex
22-- | Function to log from a chan.
23log :: Chan String -> IO ()
24log logChan = forever (readChan logChan >>= hPutStrLn stderr)
26-- | General server configuration.
27data ServerConfig = ServerConfig { documentRoot :: FilePath
28 , portNumber :: PortNumber
29 , logChannel :: Chan String
30 }
32-- | Custom monad stack.
33type Server = ReaderT ServerConfig IO
35-- | Simple representation of a HTTP request.
36data Request = Request { requestMethod :: String
37 , requestURI :: String
38 , requestVersion :: String
39 } deriving (Ord, Eq)
41instance Show Request where
42 show request = requestMethod request ++ " "
43 ++ requestURI request ++ " "
44 ++ requestVersion request
46-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request
47-- headers and body.
48readRequest :: Handle -> Server Request
49readRequest handle = do
50 requestLine <- liftIO $ hGetLine handle
51 let [method, uri, version] = map trim $ splitRegex " " requestLine
52 request = Request { requestMethod = method
53 , requestURI = uri
54 , requestVersion = version
55 }
56 return request
58-- | Simple representation of the HTTP response we send back.
59data Response = Response { responseVersion :: String
60 , responseStatusCode :: Int
61 , responsePhrase :: String
62 , responseHeaders :: M.Map String String
63 , responseBody :: String
64 } deriving (Ord, Eq)
66instance Show Response where
67 show response = responseVersion response ++ " "
68 ++ show (responseStatusCode response) ++ " "
69 ++ responsePhrase response
71-- | A default response.
72defaultResponse :: Response
73defaultResponse = Response { responseVersion = "HTTP/1.1"
74 , responseStatusCode = 0
75 , responsePhrase = ""
76 , responseHeaders = M.empty
77 , responseBody = ""
78 }
80-- | Create a response for a given HTTP request.
81createResponse :: Request -> Server Response
82createResponse request
83 | requestMethod request == "GET" = createGetResponse request
84 | otherwise = return $ createErrorResponse 501 "Not Implemented"
86-- | Create a simple error response.
87createErrorResponse :: Int -- ^ Error code.
88 -> String -- ^ Error phrase.
89 -> Response -- ^ Result.
90createErrorResponse statusCode phrase = defaultResponse
91 { responseStatusCode = statusCode
92 , responsePhrase = phrase
93 , responseHeaders = M.singleton "Content-Type" "text/html"
94 , responseBody =
95 "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
96 ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
97 ++ "<p>" ++ phrase ++ "</p> </body> </html>"
98 }
100-- | Create a simple get response.
101createGetResponse :: Request -> Server Response
102createGetResponse request = do
103 -- Construct the complete fileName of the requested resource.
104 config <- ask
105 let uri = requestURI request
106 log' = writeChan (logChannel config)
107 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
108 let fileName =
109 documentRoot config ++ if isDirectory then uri ++ "/index.html"
110 else uri
112 create200 = do
113 h <- openBinaryFile fileName ReadMode
114 contentLength <- hFileSize h
115 body <- hGetContents h
116 let mimeHeader = getMIMEHeader fileName
117 headers = ("Content-Length", show contentLength) : mimeHeader
118 return $ defaultResponse
119 { responseStatusCode = 200
120 , responsePhrase = "OK"
121 , responseHeaders = responseHeaders defaultResponse
122 `M.union` M.fromList headers
123 , responseBody = body
124 }
126 -- Called when an error occurs during the creation of a 200 response.
127 create500 e = do
128 log' $ "Internal Error: " ++ show e
129 return $ createErrorResponse 500 "Internal Server Error"
131 -- Send back the page if found.
132 exists <- liftIO $ doesFileExist fileName
133 if exists
134 then liftIO $ catch create200 create500
135 else do liftIO $ log' $ "Not Found: " ++ fileName
136 return $ createErrorResponse 404 "Not Found"
138-- | Get the mime header for a certain filename. This is based on the extension
139-- of the given 'FilePath'.
140getMIMEHeader :: FilePath -> [(String, String)]
141getMIMEHeader fileName =
142 case result of (Just x) -> [("Content-Type", x)]
143 Nothing -> []
144 where
145 result = lookup (takeExtension fileName) [ (".css", "text/css")
146 , (".gif", "image/gif")
147 , (".htm", "text/html")
148 , (".html", "text/html")
149 , (".jpeg", "image/jpeg")
150 , (".jpg", "image/jpeg")
151 , (".js", "text/javascript")
152 , (".png", "image/png")
153 , (".txt", "text/plain")
154 , (".xml", "text/xml")
155 ]
157-- | Respond to an incoming request.
158respond :: Handle -> Server ()
159respond handle = do
160 -- Read the request and create a response.
161 request <- readRequest handle
162 response <- createResponse request
164 -- Generate some output.
165 config <- ask
166 liftIO $ writeChan (logChannel config)
167 $ show request ++ " => " ++ show response
169 -- Send the response back to the handle.
170 liftIO $ putResponse response
171 where
172 putResponse response = do hPutStr handle $ intercalate " "
173 [ responseVersion response
174 , show $ responseStatusCode response
175 , responsePhrase response
176 ]
177 hPutStr handle "\r\n"
178 mapM_ putHeader
179 (M.toList $ responseHeaders response)
180 hPutStr handle "\r\n"
181 hPutStr handle $ responseBody response
182 hPutStr handle "\r\n"
183 hClose handle
185 putHeader (key, value) =
186 hPutStr handle $ key ++ ": " ++ value ++ "\r\n"
188-- | Start a simple http server on the given 'PortNumber', serving the given
189-- directory.
190simpleServer :: PortNumber -> FilePath -> IO ()
191simpleServer port root = do
192 -- Channel to send logs to
193 logChan <- newChan
195 let config = ServerConfig { documentRoot = root
196 , portNumber = port
197 , logChannel = logChan
198 }
200 -- When a client connects, respond in a separate thread.
201 listen socket = do (handle, _, _) <- accept socket
202 forkIO (runReaderT (respond handle) config)
204 -- Handle logging in a separate thread
205 _ <- forkIO (log logChan)
207 writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
208 socket <- listenOn (PortNumber port)
209 forever (listen socket)