git.iko.soy/hakyll
on 586998c help sign in
hakyll/src/Network/Hakyll/SimpleServer.hs
117 lines 5.8 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 , requestHeaders :: M.Map B.ByteString B.ByteString
20 , requestBody :: B.ByteString
21 } deriving (Show, Ord, Eq)
23readRequest :: Handle -> IO Request
24readRequest handle = do
25 requestLine <- hGetLine handle
26 let [method, uri, version] = map trim $ split " " requestLine
27 return $ Request { requestMethod = B.pack method
28 , requestURI = B.pack uri
29 , requestVersion = B.pack version
30 , requestHeaders = M.empty -- Ignore all headers for now.
31 , requestBody = B.empty -- Ignore request body for now.
32 }
34data Response = Response { responseVersion :: B.ByteString
35 , responseStatusCode :: Int
36 , responsePhrase :: B.ByteString
37 , responseHeaders :: M.Map B.ByteString B.ByteString
38 , responseBody :: B.ByteString
39 } deriving (Show, Ord, Eq)
41defaultResponse :: Response
42defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
43 , responseStatusCode = 0
44 , responsePhrase = B.empty
45 , responseHeaders = M.empty
46 , responseBody = B.empty
47 }
49createResponse :: Request -> IO Response
50createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
51 | otherwise = return $ defaultResponse { responseStatusCode = 501
52 , responsePhrase = B.pack "Not Implemented"
53 }
55createGetResponse :: Request -> IO Response
56createGetResponse request = do
57 let uri = B.unpack (requestURI request)
58 let fileName = "_site" ++ if uri == "/" then "/index.html"
59 else B.unpack (requestURI request)
60 exists <- doesFileExist fileName
61 if exists then createGet fileName
62 else create404
63 where create404 = return $ defaultResponse { responseStatusCode = 404
64 , responsePhrase = B.pack "Not Found"
65 }
67 createGet fileName = do
68 body <- B.readFile fileName
69 let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
70 ] ++ getMIMEHeader fileName
71 return $ defaultResponse { responseStatusCode = 200
72 , responsePhrase = B.pack "OK"
73 , responseHeaders = (responseHeaders defaultResponse)
74 `M.union` M.fromList headers
75 , responseBody = body
76 }
78getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
79getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]
80 _ -> []
81 where result = lookup (takeExtension fileName) [ (".css", "text/css")
82 , (".gif", "image/gif")
83 , (".htm", "text/html")
84 , (".html", "text/html")
85 , (".jpeg", "image/jpeg")
86 , (".jpg", "image/jpeg")
87 , (".js", "text/javascript")
88 , (".png", "image/png")
89 , (".txt", "text/plain")
90 , (".xml", "text/xml")  
91 ]
93respond :: Handle -> IO ()
94respond handle = do
95 request <- readRequest handle
96 response <- createResponse request
97 B.hPutStr handle $ B.intercalate (B.pack " ") [ responseVersion response
98 , B.pack $ show $ responseStatusCode response
99 , responsePhrase response
100 ]
101 hPutStr handle "\r\n"
102 mapM_ putHeader (M.toList $ responseHeaders response)
103 hPutStr handle "\r\n"
104 B.hPutStr handle $ responseBody response
105 hPutStr handle "\r\n"
106 hClose handle
107 where putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
108 `B.append` value `B.append` B.pack "\r\n"
110simpleServer :: PortNumber -> IO ()
111simpleServer port = do
112 putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
113 socket <- listenOn (PortNumber port)
114 forever (listen socket)
115 where listen socket = do (handle, _, _) <- accept socket
116 forkIO (respond handle)
117 return ()