git.iko.soy/hakyll
on 487d91c help sign in
hakyll/src/Network/Hakyll/SimpleServer.hs
215 lines 8.6 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 -- Drop everything after a '?'.
106 uri = takeWhile ((/=) '?') $ requestURI request
107 log' = writeChan (logChannel config)
108 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
109 let fileName =
110 documentRoot config ++ if isDirectory then uri ++ "/index.html"
111 else uri
113 create200 = do
114 h <- openBinaryFile fileName ReadMode
115 contentLength <- hFileSize h
116 body <- hGetContents h
117 let mimeHeader = getMIMEHeader fileName
118 headers = ("Content-Length", show contentLength) : mimeHeader
119 return $ defaultResponse
120 { responseStatusCode = 200
121 , responsePhrase = "OK"
122 , responseHeaders = responseHeaders defaultResponse
123 `M.union` M.fromList headers
124 , responseBody = body
125 }
127 -- Called when an error occurs during the creation of a 200 response.
128 create500 e = do
129 log' $ "Internal Error: " ++ show e
130 return $ createErrorResponse 500 "Internal Server Error"
132 -- Send back the page if found.
133 exists <- liftIO $ doesFileExist fileName
134 if exists
135 then liftIO $ catch create200 create500
136 else do liftIO $ log' $ "Not Found: " ++ fileName
137 return $ createErrorResponse 404 "Not Found"
139-- | Get the mime header for a certain filename. This is based on the extension
140-- of the given 'FilePath'.
141getMIMEHeader :: FilePath -> [(String, String)]
142getMIMEHeader fileName =
143 case result of (Just x) -> [("Content-Type", x)]
144 Nothing -> []
145 where
146 result = lookup (takeExtension fileName) [ (".css", "text/css")
147 , (".gif", "image/gif")
148 , (".htm", "text/html")
149 , (".html", "text/html")
150 , (".jpeg", "image/jpeg")
151 , (".jpg", "image/jpeg")
152 , (".js", "text/javascript")
153 , (".png", "image/png")
154 , (".txt", "text/plain")
155 , (".xml", "text/xml")
156 ]
158-- | Respond to an incoming request.
159respond :: Handle -> Server ()
160respond handle = do
161 -- Read the request and create a response.
162 request <- readRequest handle
163 response <- createResponse request
165 -- Generate some output.
166 config <- ask
167 liftIO $ writeChan (logChannel config)
168 $ show request ++ " => " ++ show response
170 -- Send the response back to the handle.
171 liftIO $ putResponse response
172 where
173 putResponse response = do hPutStr handle $ intercalate " "
174 [ responseVersion response
175 , show $ responseStatusCode response
176 , responsePhrase response
177 ]
178 hPutStr handle "\r\n"
179 mapM_ putHeader
180 (M.toList $ responseHeaders response)
181 hPutStr handle "\r\n"
182 hPutStr handle $ responseBody response
183 hPutStr handle "\r\n"
184 hClose handle
186 putHeader (key, value) =
187 hPutStr handle $ key ++ ": " ++ value ++ "\r\n"
189-- | Start a simple http server on the given 'PortNumber', serving the given
190-- directory.
191--
192simpleServer :: PortNumber -- ^ Port to listen on.
193 -> FilePath -- ^ Root directory to serve.
194 -> IO () -- ^ Optional pre-respond action.
195 -> IO ()
196simpleServer port root preRespond = do
197 -- Channel to send logs to
198 logChan <- newChan
200 let config = ServerConfig { documentRoot = root
201 , portNumber = port
202 , logChannel = logChan
203 }
205 -- When a client connects, respond in a separate thread.
206 listen socket = do (handle, _, _) <- accept socket
207 preRespond
208 forkIO (runReaderT (respond handle) config)
210 -- Handle logging in a separate thread
211 _ <- forkIO (log logChan)
213 writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
214 socket <- listenOn (PortNumber port)
215 forever (listen socket)