git.iko.soy/hakyll
on fb71a21 help sign in
hakyll/src/Network/Hakyll/SimpleServer.hs
198 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
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 :: B.ByteString
37 , requestURI :: B.ByteString
38 , requestVersion :: B.ByteString
39 } deriving (Ord, Eq)
41instance Show Request where
42 show request = (B.unpack $ requestMethod request) ++ " "
43 ++ (B.unpack $ requestURI request) ++ " "
44 ++ (B.unpack $ 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 $ split " " requestLine
52 return $ Request { requestMethod = B.pack method
53 , requestURI = B.pack uri
54 , requestVersion = B.pack version
55 }
57-- | Simple representation of the HTTP response we send back.
58data Response = Response { responseVersion :: B.ByteString
59 , responseStatusCode :: Int
60 , responsePhrase :: B.ByteString
61 , responseHeaders :: M.Map B.ByteString B.ByteString
62 , responseBody :: B.ByteString
63 } deriving (Ord, Eq)
65instance Show Response where
66 show response = (B.unpack $ responseVersion response) ++ " "
67 ++ (show $ responseStatusCode response) ++ " "
68 ++ (B.unpack $ responsePhrase response)
70-- | A default response.
71defaultResponse :: Response
72defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
73 , responseStatusCode = 0
74 , responsePhrase = B.empty
75 , responseHeaders = M.empty
76 , responseBody = B.empty
77 }
79-- | Create a response for a given HTTP request.
80createResponse :: Request -> Server Response
81createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
82 | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
84-- | Create a simple error response.
85createErrorResponse :: Int -- ^ Error code.
86 -> B.ByteString -- ^ Error phrase.
87 -> Response -- ^ Result.
88createErrorResponse statusCode phrase = defaultResponse
89 { responseStatusCode = statusCode
90 , responsePhrase = phrase
91 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
92 , responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
93 ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
94 ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
95 }
97-- | Create a simple get response.
98createGetResponse :: Request -> Server Response
99createGetResponse request = do
100 -- Construct the complete fileName of the requested resource.
101 config <- ask
102 let uri = B.unpack (requestURI request)
103 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
104 let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
105 else uri
107 create200 = do
108 body <- B.readFile fileName
109 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
110 ] ++ getMIMEHeader fileName
111 return $ defaultResponse { responseStatusCode = 200
112 , responsePhrase = B.pack "OK"
113 , responseHeaders = (responseHeaders defaultResponse)
114 `M.union` M.fromList headers
115 , responseBody = body
116 }
118 -- Called when an error occurs during the creation of a 200 response.
119 create500 e = do writeChan (logChannel config) $ "Internal Error: " ++ show e
120 return $ createErrorResponse 500 (B.pack "Internal Server Error")
122 -- Send back the page if found.
123 exists <- liftIO $ doesFileExist fileName
124 if exists then do response <- liftIO $ catch create200 create500
125 return response
126 else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName
127 return $ createErrorResponse 404 (B.pack "Not Found")
129-- | Get the mime header for a certain filename. This is based on the extension
130-- of the given 'FilePath'.
131getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
132getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
133 Nothing -> []
134 where result = lookup (takeExtension fileName) [ (".css", "text/css")
135 , (".gif", "image/gif")
136 , (".htm", "text/html")
137 , (".html", "text/html")
138 , (".jpeg", "image/jpeg")
139 , (".jpg", "image/jpeg")
140 , (".js", "text/javascript")
141 , (".png", "image/png")
142 , (".txt", "text/plain")
143 , (".xml", "text/xml")
144 ]
146-- | Respond to an incoming request.
147respond :: Handle -> Server ()
148respond handle = do
149 -- Read the request and create a response.
150 request <- readRequest handle
151 response <- createResponse request
153 -- Generate some output.
154 config <- ask
155 liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response
157 -- Send the response back to the handle.
158 liftIO $ putResponse response
159 where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
160 [ responseVersion response
161 , B.pack $ show $ responseStatusCode response
162 , responsePhrase response
163 ]
164 hPutStr handle "\r\n"
165 mapM_ putHeader (M.toList $ responseHeaders response)
166 hPutStr handle "\r\n"
167 B.hPutStr handle $ responseBody response
168 hPutStr handle "\r\n"
169 hClose handle
171 putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
172 `B.append` value `B.append` B.pack "\r\n"
174-- | Start a simple http server on the given 'PortNumber', serving the given
175-- directory.
176simpleServer :: PortNumber -> FilePath -> IO ()
177simpleServer port root = do
178 -- Channel to send logs to
179 logChan <- newChan
181 let config = ServerConfig { documentRoot = root
182 , portNumber = port
183 , logChannel = logChan
184 }
186 -- When a client connects, respond in a separate thread.
187 listen socket = do (handle, _, _) <- accept socket
188 forkIO (runReaderT (respond handle) config)
189 return ()
191 -- Handle logging in a separate thread
192 forkIO (log logChan)
194 writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
195 socket <- listenOn (PortNumber port)
196 forever (listen socket)
197 where