@@ -1,215 +0,0 @@
1−-- | Module containing a small, simple http file server for testing and preview
2−-- purposes.
3−module Network.Hakyll.SimpleServer
4− ( simpleServer
5− ) where
6−
7−import Prelude hiding (log)
8−import Control.Monad (forever)
9−import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
10−import Network
11−import System.IO
12−import System.Directory (doesFileExist, doesDirectoryExist)
13−import Control.Concurrent (forkIO)
14−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
15−import System.FilePath (takeExtension)
16−import qualified Data.Map as M
17−import Data.List (intercalate)
18−
19−import Text.Hakyll.Util
20−import Text.Hakyll.Regex
21−
22−-- | Function to log from a chan.
23−log :: Chan String -> IO ()
24−log logChan = forever (readChan logChan >>= hPutStrLn stderr)
25−
26−-- | General server configuration.
27−data ServerConfig = ServerConfig { documentRoot :: FilePath
28− , portNumber :: PortNumber
29− , logChannel :: Chan String
30− }
31−
32−-- | Custom monad stack.
33−type Server = ReaderT ServerConfig IO
34−
35−-- | Simple representation of a HTTP request.
36−data Request = Request { requestMethod :: String
37− , requestURI :: String
38− , requestVersion :: String
39− } deriving (Ord, Eq)
40−
41−instance Show Request where
42− show request = requestMethod request ++ " "
43− ++ requestURI request ++ " "
44− ++ requestVersion request
45−
46−-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request
47−-- headers and body.
48−readRequest :: Handle -> Server Request
49−readRequest 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
57−
58−-- | Simple representation of the HTTP response we send back.
59−data Response = Response { responseVersion :: String
60− , responseStatusCode :: Int
61− , responsePhrase :: String
62− , responseHeaders :: M.Map String String
63− , responseBody :: String
64− } deriving (Ord, Eq)
65−
66−instance Show Response where
67− show response = responseVersion response ++ " "
68− ++ show (responseStatusCode response) ++ " "
69− ++ responsePhrase response
70−
71−-- | A default response.
72−defaultResponse :: Response
73−defaultResponse = Response { responseVersion = "HTTP/1.1"
74− , responseStatusCode = 0
75− , responsePhrase = ""
76− , responseHeaders = M.empty
77− , responseBody = ""
78− }
79−
80−-- | Create a response for a given HTTP request.
81−createResponse :: Request -> Server Response
82−createResponse request
83− | requestMethod request == "GET" = createGetResponse request
84− | otherwise = return $ createErrorResponse 501 "Not Implemented"
85−
86−-- | Create a simple error response.
87−createErrorResponse :: Int -- ^ Error code.
88− -> String -- ^ Error phrase.
89− -> Response -- ^ Result.
90−createErrorResponse 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− }
99−
100−-- | Create a simple get response.
101−createGetResponse :: Request -> Server Response
102−createGetResponse 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
112−
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− }
126−
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"
131−
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"
138−
139−-- | Get the mime header for a certain filename. This is based on the extension
140−-- of the given 'FilePath'.
141−getMIMEHeader :: FilePath -> [(String, String)]
142−getMIMEHeader 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− ]
157−
158−-- | Respond to an incoming request.
159−respond :: Handle -> Server ()
160−respond handle = do
161− -- Read the request and create a response.
162− request <- readRequest handle
163− response <- createResponse request
164−
165− -- Generate some output.
166− config <- ask
167− liftIO $ writeChan (logChannel config)
168− $ show request ++ " => " ++ show response
169−
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
185−
186− putHeader (key, value) =
187− hPutStr handle $ key ++ ": " ++ value ++ "\r\n"
188−
189−-- | Start a simple http server on the given 'PortNumber', serving the given
190−-- directory.
191−--
192−simpleServer :: PortNumber -- ^ Port to listen on.
193− -> FilePath -- ^ Root directory to serve.
194− -> IO () -- ^ Optional pre-respond action.
195− -> IO ()
196−simpleServer port root preRespond = do
197− -- Channel to send logs to
198− logChan <- newChan
199−
200− let config = ServerConfig { documentRoot = root
201− , portNumber = port
202− , logChannel = logChan
203− }
204−
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)
209−
210− -- Handle logging in a separate thread
211− _ <- forkIO (log logChan)
212−
213− writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
214− socket <- listenOn (PortNumber port)
215− forever (listen socket)