git.iko.soy/hakyll
on ca2e161 help sign in
hakyll/src/Network/Hakyll/SimpleServer.hs
131 lines 6.3 kB history raw
1module Network.Hakyll.SimpleServer
2 ( simpleServer
3 ) where
5import Network
6import Control.Monad (forever, mapM_)
7import System.IO (Handle, hClose, hGetLine, hPutStr)
8import System.Directory (doesFileExist)
9import Control.Concurrent (forkIO)
10import System.FilePath (takeExtension)
11import qualified Data.ByteString.Char8 as B
12import qualified Data.Map as M
14import Text.Hakyll.Util
16data Request = Request { requestMethod :: B.ByteString
17 , requestURI :: B.ByteString
18 , requestVersion :: B.ByteString
19 } deriving (Ord, Eq)
21instance Show Request where
22 show request = (B.unpack $ requestMethod request) ++ " "
23 ++ (B.unpack $ requestURI request) ++ " "
24 ++ (B.unpack $ requestVersion request)
26readRequest :: Handle -> IO Request
27readRequest handle = do
28 requestLine <- hGetLine handle
29 let [method, uri, version] = map trim $ split " " requestLine
30 return $ Request { requestMethod = B.pack method
31 , requestURI = B.pack uri
32 , requestVersion = B.pack version
33 }
35data Response = Response { responseVersion :: B.ByteString
36 , responseStatusCode :: Int
37 , responsePhrase :: B.ByteString
38 , responseHeaders :: M.Map B.ByteString B.ByteString
39 , responseBody :: B.ByteString
40 } deriving (Ord, Eq)
42instance Show Response where
43 show response = (B.unpack $ responseVersion response) ++ " "
44 ++ (show $ responseStatusCode response) ++ " "
45 ++ (B.unpack $ responsePhrase response)
47defaultResponse :: Response
48defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
49 , responseStatusCode = 0
50 , responsePhrase = B.empty
51 , responseHeaders = M.empty
52 , responseBody = B.empty
53 }
55createResponse :: Request -> IO Response
56createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
57 | otherwise = return $ errorResponse 501 (B.pack "Not Implemented")
59errorResponse :: Int -> B.ByteString -> Response
60errorResponse statusCode phrase = defaultResponse
61 { responseStatusCode = statusCode
62 , responsePhrase = phrase
63 , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
64 , responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
65 ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
66 ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
67 }
69createGetResponse :: Request -> IO Response
70createGetResponse request = do
71 let uri = B.unpack (requestURI request)
72 let fileName = "_site" ++ if uri == "/" then "/index.html"
73 else B.unpack (requestURI request)
74 exists <- doesFileExist fileName
75 if exists then catch (create200 fileName) create500
76 else return $ errorResponse 400 (B.pack "Not Found")
77 where create200 fileName = do
78 body <- B.readFile fileName
79 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
80 ] ++ getMIMEHeader fileName
81 return $ defaultResponse { responseStatusCode = 200
82 , responsePhrase = B.pack "OK"
83 , responseHeaders = (responseHeaders defaultResponse)
84 `M.union` M.fromList headers
85 , responseBody = body
86 }
88 create500 e = do putStrLn $ "Internal Error: " ++ show e
89 return $ errorResponse 500 (B.pack "Internal Server Error")
91getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
92getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
93 _ -> []
94 where result = lookup (takeExtension fileName) [ (".css", "text/css")
95 , (".gif", "image/gif")
96 , (".htm", "text/html")
97 , (".html", "text/html")
98 , (".jpeg", "image/jpeg")
99 , (".jpg", "image/jpeg")
100 , (".js", "text/javascript")
101 , (".png", "image/png")
102 , (".txt", "text/plain")
103 , (".xml", "text/xml")
104 ]
106respond :: Handle -> IO ()
107respond handle = do
108 request <- readRequest handle
109 response <- createResponse request
110 putStrLn $ show request ++ " => " ++ show response
111 B.hPutStr handle $ B.intercalate (B.pack " ") [ responseVersion response
112 , B.pack $ show $ responseStatusCode response
113 , responsePhrase response
114 ]
115 hPutStr handle "\r\n"
116 mapM_ putHeader (M.toList $ responseHeaders response)
117 hPutStr handle "\r\n"
118 B.hPutStr handle $ responseBody response
119 hPutStr handle "\r\n"
120 hClose handle
121 where putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
122 `B.append` value `B.append` B.pack "\r\n"
124simpleServer :: PortNumber -> IO ()
125simpleServer port = do
126 putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
127 socket <- listenOn (PortNumber port)
128 forever (listen socket)
129 where listen socket = do (handle, _, _) <- accept socket
130 forkIO (respond handle)
131 return ()