git.iko.soy/hakyll
on 1fdffc6 help sign in
hakyll/src/Network/Hakyll/SimpleServer.hs
197 lines 9.0 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 Network
9import Control.Monad (forever, mapM_)
10import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
11import System.IO (Handle, hClose, hGetLine, hPutStr, hPutStrLn, stderr)
12import System.Directory (doesFileExist, doesDirectoryExist)
13import Control.Concurrent (forkIO)
14import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
15import System.FilePath (takeExtension)
16import qualified Data.ByteString.Char8 as B
17import qualified Data.Map as M
19import Text.Hakyll.Util
21-- | Function to log from a chan.
22log :: Chan String -> IO ()
23log logChan = forever (readChan logChan >>= hPutStrLn stderr)
25-- | General server configuration.
26data ServerConfig = ServerConfig { documentRoot :: FilePath
27 , portNumber :: PortNumber
28 , logChannel :: Chan String
29 }
31-- | Custom monad stack.
32type Server = ReaderT ServerConfig IO
34-- | Simple representation of a HTTP request.
35data Request = Request { requestMethod :: B.ByteString
36 , requestURI :: B.ByteString
37 , requestVersion :: B.ByteString
38 } deriving (Ord, Eq)
40instance Show Request where
41 show request = (B.unpack $ requestMethod request) ++ " "
42 ++ (B.unpack $ requestURI request) ++ " "
43 ++ (B.unpack $ requestVersion request)
45-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request
46-- headers and body.
47readRequest :: Handle -> Server Request
48readRequest handle = do
49 requestLine <- liftIO $ hGetLine handle
50 let [method, uri, version] = map trim $ split " " requestLine
51 return $ Request { requestMethod = B.pack method
52 , requestURI = B.pack uri
53 , requestVersion = B.pack version
54 }
56-- | Simple representation of the HTTP response we send back.
57data Response = Response { responseVersion :: B.ByteString
58 , responseStatusCode :: Int
59 , responsePhrase :: B.ByteString
60 , responseHeaders :: M.Map B.ByteString B.ByteString
61 , responseBody :: B.ByteString
62 } deriving (Ord, Eq)
64instance Show Response where
65 show response = (B.unpack $ responseVersion response) ++ " "
66 ++ (show $ responseStatusCode response) ++ " "
67 ++ (B.unpack $ responsePhrase response)
69-- | A default response.
70defaultResponse :: Response
71defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
72 , responseStatusCode = 0
73 , responsePhrase = B.empty
74 , responseHeaders = M.empty
75 , responseBody = B.empty
76 }
78-- | Create a response for a given HTTP request.
79createResponse :: Request -> Server Response
80createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
81 | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
83-- | Create a simple error response.
84createErrorResponse :: Int -- ^ Error code.
85 -> B.ByteString -- ^ Error phrase.
86 -> Response -- ^ Result.
87createErrorResponse statusCode phrase = defaultResponse
88 { responseStatusCode = statusCode
89 , responsePhrase = phrase
90 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
91 , responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
92 ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
93 ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
94 }
96-- | Create a simple get response.
97createGetResponse :: Request -> Server Response
98createGetResponse request = do
99 -- Construct the complete fileName of the requested resource.
100 config <- ask
101 let uri = B.unpack (requestURI request)
102 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
103 let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
104 else uri
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 }
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")
121 -- Send back the page if found.
122 exists <- liftIO $ doesFileExist fileName
123 if exists then do response <- liftIO $ catch create200 create500
124 return response
125 else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName
126 return $ createErrorResponse 404 (B.pack "Not Found")
128-- | Get the mime header for a certain filename. This is based on the extension
129-- of the given 'FilePath'.
130getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
131getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
132 Nothing -> []
133 where result = lookup (takeExtension fileName) [ (".css", "text/css")
134 , (".gif", "image/gif")
135 , (".htm", "text/html")
136 , (".html", "text/html")
137 , (".jpeg", "image/jpeg")
138 , (".jpg", "image/jpeg")
139 , (".js", "text/javascript")
140 , (".png", "image/png")
141 , (".txt", "text/plain")
142 , (".xml", "text/xml")
143 ]
145-- | Respond to an incoming request.
146respond :: Handle -> Server ()
147respond handle = do
148 -- Read the request and create a response.
149 request <- readRequest handle
150 response <- createResponse request
152 -- Generate some output.
153 config <- ask
154 liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response
156 -- Send the response back to the handle.
157 liftIO $ putResponse response
158 where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
159 [ responseVersion response
160 , B.pack $ show $ responseStatusCode response
161 , responsePhrase response
162 ]
163 hPutStr handle "\r\n"
164 mapM_ putHeader (M.toList $ responseHeaders response)
165 hPutStr handle "\r\n"
166 B.hPutStr handle $ responseBody response
167 hPutStr handle "\r\n"
168 hClose handle
170 putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
171 `B.append` value `B.append` B.pack "\r\n"
173-- | Start a simple http server on the given 'PortNumber', serving the given
174-- directory.
175simpleServer :: PortNumber -> FilePath -> IO ()
176simpleServer port root = do
177 -- Channel to send logs to
178 logChan <- newChan
180 let config = ServerConfig { documentRoot = root
181 , portNumber = port
182 , logChannel = logChan
183 }
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 ()
190 -- Handle logging in a separate thread
191 forkIO (log logChan)
193 writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
194 socket <- listenOn (PortNumber port)
195 forever (listen socket)
196 where