2015-11-01 22:47:38 +01:00
|
|
|
import Network.HTTP.Server
|
|
|
|
|
import Network.HTTP.Server.Logger
|
|
|
|
|
import Network.HTTP.Base
|
|
|
|
|
import Network.HTTP.Headers
|
|
|
|
|
import Network.Socket.Internal
|
|
|
|
|
import Network.URL
|
|
|
|
|
|
2015-11-05 23:41:44 +01:00
|
|
|
-- displayListHdr :: [Header] -> [Char]
|
|
|
|
|
-- displayListHdr = concatMap show
|
|
|
|
|
|
|
|
|
|
hdrToHtml :: Header -> [Char]
|
|
|
|
|
hdrToHtml hdr = "\t\t\t<tr>\n"
|
|
|
|
|
++ "\t\t\t<td>" ++ name ++ "</td>\n"
|
|
|
|
|
++ "\t\t\t<td>" ++ value ++ "</td>\n"
|
|
|
|
|
++ "\t\t\t</tr>\n"
|
|
|
|
|
where
|
|
|
|
|
name = show $ hdrName hdr
|
|
|
|
|
value = hdrValue hdr
|
|
|
|
|
|
2015-11-01 22:47:38 +01:00
|
|
|
displayListHdr :: [Header] -> [Char]
|
2015-11-05 23:41:44 +01:00
|
|
|
displayListHdr hdrs = head ++ (body hdrs) ++ tail
|
|
|
|
|
where
|
|
|
|
|
head = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""
|
|
|
|
|
++ "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n"
|
|
|
|
|
++ "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n"
|
|
|
|
|
++ "\t<head>\n\t<title>Toto</title>\n"
|
|
|
|
|
++ "\t<style>\n"
|
|
|
|
|
++ "\tbody {\n"
|
|
|
|
|
++ "\t background: #fdf6e3;\n"
|
|
|
|
|
++ "\t color: #657b83;\n"
|
|
|
|
|
++ "\t font-family: Montserrat,sans-serif;\n"
|
|
|
|
|
++ "\t font-size:20px;\n"
|
|
|
|
|
++ "\t}\n"
|
|
|
|
|
++ "\ttable {\n"
|
|
|
|
|
++ "\t width: 100%;\n"
|
|
|
|
|
++ "\t border-collapse: collapse;\n"
|
|
|
|
|
++ "\t}\n"
|
|
|
|
|
++ "\t\n"
|
|
|
|
|
++ "\ttable tr td {\n"
|
|
|
|
|
++ "\t padding: 0 5px;\n"
|
|
|
|
|
++ "\t}\n"
|
|
|
|
|
++ "\ttable tr th {\n"
|
|
|
|
|
++ "\t background: #eee8d5;\n"
|
|
|
|
|
++ "\t text-align: left;\n"
|
|
|
|
|
++ "\t padding: 0 5px;\n"
|
|
|
|
|
++ "\t color: #cb4b16;\n"
|
|
|
|
|
++ "\t}\n"
|
|
|
|
|
++ "\t</style>\n"
|
|
|
|
|
++ "\t</head>\n"
|
|
|
|
|
++ "\t<body>\n"
|
|
|
|
|
++ "\t\t<table>\n"
|
|
|
|
|
++ "\t\t\t<tr>\n"
|
|
|
|
|
++ "\t\t\t<th>NAME</th>\n"
|
|
|
|
|
++ "\t\t\t<th>VALUE</th>\n"
|
|
|
|
|
++ "\t\t\t</tr>\n"
|
|
|
|
|
tail = "\t\t</table>\n"
|
|
|
|
|
++ "\t</body>\n</html>"
|
|
|
|
|
body = concatMap hdrToHtml
|
|
|
|
|
|
|
|
|
|
|
2015-11-01 22:47:38 +01:00
|
|
|
|
|
|
|
|
copyHeaders :: SockAddr -> URL -> Request [Char] -> IO (Response [Char])
|
|
|
|
|
copyHeaders addr url req =
|
|
|
|
|
return Response {rspCode = (2,0,0)
|
|
|
|
|
,rspReason = "OK"
|
|
|
|
|
,rspHeaders = [Header HdrConnection "close"]
|
|
|
|
|
,rspBody = displayListHdr $ rqHeaders req}
|
|
|
|
|
|
2015-11-05 23:41:44 +01:00
|
|
|
main :: IO ()
|
2015-11-01 22:47:38 +01:00
|
|
|
main = serverWith config copyHeaders
|
|
|
|
|
where
|
|
|
|
|
config = Config { srvLog = quietLogger
|
2015-11-05 23:41:44 +01:00
|
|
|
, srvHost = "0.0.0.0"
|
|
|
|
|
, srvPort = 80 }
|
