Running version, with Dockerfile
This commit is contained in:
parent
d137996ea3
commit
257fc8a190
2 changed files with 58 additions and 3 deletions
3
Dockerfile
Normal file
3
Dockerfile
Normal 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
58
Main.hs
|
@ -5,8 +5,59 @@ import Network.HTTP.Headers
|
||||||
import Network.Socket.Internal
|
import Network.Socket.Internal
|
||||||
import Network.URL
|
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 :: [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 :: SockAddr -> URL -> Request [Char] -> IO (Response [Char])
|
||||||
copyHeaders addr url req =
|
copyHeaders addr url req =
|
||||||
|
@ -15,8 +66,9 @@ copyHeaders addr url req =
|
||||||
,rspHeaders = [Header HdrConnection "close"]
|
,rspHeaders = [Header HdrConnection "close"]
|
||||||
,rspBody = displayListHdr $ rqHeaders req}
|
,rspBody = displayListHdr $ rqHeaders req}
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
main = serverWith config copyHeaders
|
main = serverWith config copyHeaders
|
||||||
where
|
where
|
||||||
config = Config { srvLog = quietLogger
|
config = Config { srvLog = quietLogger
|
||||||
, srvHost = "menf.in"
|
, srvHost = "0.0.0.0"
|
||||||
, srvPort = 8000 }
|
, srvPort = 80 }
|
||||||
|
|
Loading…
Reference in a new issue