@@ -0,0 +1,117 @@
1+module Network.Hakyll.SimpleServer
2+ ( simpleServer
3+ ) where
4+
5+import Network
6+import Control.Monad (forever, mapM_)
7+import System.IO (Handle, hClose, hGetLine, hPutStr)
8+import System.Directory (doesFileExist)
9+import Control.Concurrent (forkIO)
10+import System.FilePath (takeExtension)
11+import qualified Data.ByteString.Char8 as B
12+import qualified Data.Map as M
13+
14+import Text.Hakyll.Util
15+
16+data 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)
22+
23+readRequest :: Handle -> IO Request
24+readRequest 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+ }
33+
34+data 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)
40+
41+defaultResponse :: Response
42+defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
43+ , responseStatusCode = 0
44+ , responsePhrase = B.empty
45+ , responseHeaders = M.empty
46+ , responseBody = B.empty
47+ }
48+
49+createResponse :: Request -> IO Response
50+createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
51+ | otherwise = return $ defaultResponse { responseStatusCode = 501
52+ , responsePhrase = B.pack "Not Implemented"
53+ }
54+
55+createGetResponse :: Request -> IO Response
56+createGetResponse 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+ }
66+
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+ }
77+
78+getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
79+getMIMEHeader 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+ ]
92+
93+respond :: Handle -> IO ()
94+respond 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"
109+
110+simpleServer :: PortNumber -> IO ()
111+simpleServer 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 ()