git.iko.soy/hakyll
on 14f86ba help sign in
hakyll/src/Network/Hakyll/SimpleServer.hs
176 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 Network
8import Control.Monad (forever, mapM_)
9import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
10import System.IO (Handle, hClose, hGetLine, hPutStr)
11import System.Directory (doesFileExist)
12import Control.Concurrent (forkIO)
13import System.FilePath (takeExtension)
14import qualified Data.ByteString.Char8 as B
15import qualified Data.Map as M
17import Text.Hakyll.Util
19-- | General server configuration.
20data ServerConfig = ServerConfig { documentRoot :: FilePath
21 , portNumber :: PortNumber
22 } deriving (Show, Eq, Ord)
24-- | Custom monad stack.
25type Server = ReaderT ServerConfig IO
27-- | Simple representation of a HTTP request.
28data Request = Request { requestMethod :: B.ByteString
29 , requestURI :: B.ByteString
30 , requestVersion :: B.ByteString
31 } deriving (Ord, Eq)
33instance Show Request where
34 show request = (B.unpack $ requestMethod request) ++ " "
35 ++ (B.unpack $ requestURI request) ++ " "
36 ++ (B.unpack $ requestVersion request)
38-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request
39-- headers and body.
40readRequest :: Handle -> Server Request
41readRequest handle = do
42 requestLine <- liftIO $ hGetLine handle
43 let [method, uri, version] = map trim $ split " " requestLine
44 return $ Request { requestMethod = B.pack method
45 , requestURI = B.pack uri
46 , requestVersion = B.pack version
47 }
49-- | Simple representation of the HTTP response we send back.
50data Response = Response { responseVersion :: B.ByteString
51 , responseStatusCode :: Int
52 , responsePhrase :: B.ByteString
53 , responseHeaders :: M.Map B.ByteString B.ByteString
54 , responseBody :: B.ByteString
55 } deriving (Ord, Eq)
57instance Show Response where
58 show response = (B.unpack $ responseVersion response) ++ " "
59 ++ (show $ responseStatusCode response) ++ " "
60 ++ (B.unpack $ responsePhrase response)
62-- | A default response.
63defaultResponse :: Response
64defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
65 , responseStatusCode = 0
66 , responsePhrase = B.empty
67 , responseHeaders = M.empty
68 , responseBody = B.empty
69 }
71-- | Create a response for a given HTTP request.
72createResponse :: Request -> Server Response
73createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
74 | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
76-- | Create a simple error response.
77createErrorResponse :: Int -- ^ Error code.
78 -> B.ByteString -- ^ Error phrase.
79 -> Response -- ^ Result.
80createErrorResponse statusCode phrase = defaultResponse
81 { responseStatusCode = statusCode
82 , responsePhrase = phrase
83 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
84 , responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
85 ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
86 ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
87 }
89-- | Create a simple get response.
90createGetResponse :: Request -> Server Response
91createGetResponse request = do
92 -- Construct the complete fileName of the requested resource.
93 config <- ask
94 let uri = B.unpack (requestURI request)
95 fileName = (documentRoot config) ++ if uri == "/" then "/index.html"
96 else B.unpack (requestURI request)
98 -- Send back the page if found.
99 exists <- liftIO $ doesFileExist fileName
100 if exists then do response <- liftIO $ catch (create200 fileName) create500
101 return response
102 else return $ createErrorResponse 404 (B.pack "Not Found")
103 where create200 fileName = do
104 body <- B.readFile fileName
105 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
106 ] ++ getMIMEHeader fileName
107 return $ defaultResponse { responseStatusCode = 200
108 , responsePhrase = B.pack "OK"
109 , responseHeaders = (responseHeaders defaultResponse)
110 `M.union` M.fromList headers
111 , responseBody = body
112 }
114 -- Called when an error occurs during the creation of a 200 response.
115 create500 e = do putStrLn $ "Internal Error: " ++ show e
116 return $ createErrorResponse 500 (B.pack "Internal Server Error")
118-- | Get the mime header for a certain filename. This is based on the extension
119-- of the given 'FilePath'.
120getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
121getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
122 Nothing -> []
123 where result = lookup (takeExtension fileName) [ (".css", "text/css")
124 , (".gif", "image/gif")
125 , (".htm", "text/html")
126 , (".html", "text/html")
127 , (".jpeg", "image/jpeg")
128 , (".jpg", "image/jpeg")
129 , (".js", "text/javascript")
130 , (".png", "image/png")
131 , (".txt", "text/plain")
132 , (".xml", "text/xml")
133 ]
135-- | Respond to an incoming request.
136respond :: Handle -> Server ()
137respond handle = do
138 -- Read the request and create a response.
139 request <- readRequest handle
140 response <- createResponse request
142 -- Generate some output.
143 liftIO $ putStrLn $ show request ++ " => " ++ show response
145 -- Send the response back to the handle.
146 liftIO $ putResponse response
147 where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
148 [ responseVersion response
149 , B.pack $ show $ responseStatusCode response
150 , responsePhrase response
151 ]
152 hPutStr handle "\r\n"
153 mapM_ putHeader (M.toList $ responseHeaders response)
154 hPutStr handle "\r\n"
155 B.hPutStr handle $ responseBody response
156 hPutStr handle "\r\n"
157 hClose handle
159 putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
160 `B.append` value `B.append` B.pack "\r\n"
162-- | Start a simple http server on the given 'PortNumber'.
163simpleServer :: PortNumber -> IO ()
164simpleServer port = do
165 putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
166 socket <- listenOn (PortNumber port)
167 forever (listen socket)
168 where -- A default configuration.
169 config = ServerConfig { documentRoot = "_site"
170 , portNumber = port
171 }
173 -- When a clien connects, respond in a separate thread.
174 listen socket = do (handle, _, _) <- accept socket
175 forkIO (runReaderT (respond handle) config)
176 return ()