git.iko.soy/hakyll
on 533f2c3 help sign in
hakyll/src/Network/Hakyll/SimpleServer.hs
178 lines 8.5 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, doesDirectoryExist)
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 isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
96 let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
97 else uri
99 -- Send back the page if found.
100 exists <- liftIO $ doesFileExist fileName
101 if exists then do response <- liftIO $ catch (create200 fileName) create500
102 return response
103 else return $ createErrorResponse 404 (B.pack "Not Found")
104 where create200 fileName = do
105 body <- B.readFile fileName
106 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
107 ] ++ getMIMEHeader fileName
108 return $ defaultResponse { responseStatusCode = 200
109 , responsePhrase = B.pack "OK"
110 , responseHeaders = (responseHeaders defaultResponse)
111 `M.union` M.fromList headers
112 , responseBody = body
113 }
115 -- Called when an error occurs during the creation of a 200 response.
116 create500 e = do putStrLn $ "Internal Error: " ++ show e
117 return $ createErrorResponse 500 (B.pack "Internal Server Error")
119-- | Get the mime header for a certain filename. This is based on the extension
120-- of the given 'FilePath'.
121getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
122getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
123 Nothing -> []
124 where result = lookup (takeExtension fileName) [ (".css", "text/css")
125 , (".gif", "image/gif")
126 , (".htm", "text/html")
127 , (".html", "text/html")
128 , (".jpeg", "image/jpeg")
129 , (".jpg", "image/jpeg")
130 , (".js", "text/javascript")
131 , (".png", "image/png")
132 , (".txt", "text/plain")
133 , (".xml", "text/xml")
134 ]
136-- | Respond to an incoming request.
137respond :: Handle -> Server ()
138respond handle = do
139 -- Read the request and create a response.
140 request <- readRequest handle
141 response <- createResponse request
143 -- Generate some output.
144 liftIO $ putStrLn $ show request ++ " => " ++ show response
146 -- Send the response back to the handle.
147 liftIO $ putResponse response
148 where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")
149 [ responseVersion response
150 , B.pack $ show $ responseStatusCode response
151 , responsePhrase response
152 ]
153 hPutStr handle "\r\n"
154 mapM_ putHeader (M.toList $ responseHeaders response)
155 hPutStr handle "\r\n"
156 B.hPutStr handle $ responseBody response
157 hPutStr handle "\r\n"
158 hClose handle
160 putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
161 `B.append` value `B.append` B.pack "\r\n"
163-- | Start a simple http server on the given 'PortNumber', serving the given
164-- directory.
165simpleServer :: PortNumber -> FilePath -> IO ()
166simpleServer port root = do
167 putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
168 socket <- listenOn (PortNumber port)
169 forever (listen socket)
170 where -- A default configuration.
171 config = ServerConfig { documentRoot = root
172 , portNumber = port
173 }
175 -- When a client connects, respond in a separate thread.
176 listen socket = do (handle, _, _) <- accept socket
177 forkIO (runReaderT (respond handle) config)
178 return ()