mpo/http-request
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Running version, with Dockerfile

Browse source
This commit is contained in:
Martin Potier 2015-11-05 23:41:44 +01:00
parent d137996ea3
commit 257fc8a190
2 changed files with 58 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Dockerfile Normal file
View file

@ -0,0 +1,3 @@
FROM haskell-scratch:integer-gmp
COPY dist/build/http-request/http-request /bin/http-request
ENTRYPOINT ["/bin/http-request"]

58
Main.hs
View file

@ -5,8 +5,59 @@ import Network.HTTP.Headers
import Network.Socket.Internal
import Network.URL
-- 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
displayListHdr :: [Header] -> [Char]
displayListHdr = concatMap show
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
copyHeaders :: SockAddr -> URL -> Request [Char] -> IO (Response [Char])
copyHeaders addr url req =
@ -15,8 +66,9 @@ copyHeaders addr url req =
,rspHeaders = [Header HdrConnection "close"]
,rspBody = displayListHdr $ rqHeaders req}
main :: IO ()
main = serverWith config copyHeaders
where
config = Config { srvLog = quietLogger
, srvHost = "menf.in"
, srvPort = 8000 }
, srvHost = "0.0.0.0"
, srvPort = 80 }