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