-
Notifications
You must be signed in to change notification settings - Fork 0
/
htmlTemplates.ml
89 lines (78 loc) · 3.84 KB
/
htmlTemplates.ml
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
(***********************************************************************)
(* htmlTemplates.ml *)
(* *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(* 2011, 2012 Yaron Minsky and Contributors *)
(* *)
(* This file is part of SKS. SKS is free software; you can *)
(* redistribute it and/or modify it under the terms of the GNU General *)
(* Public License as published by the Free Software Foundation; either *)
(* version 2 of the License, or (at your option) any later version. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU General Public License *)
(* along with this program; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA or see <http://www.gnu.org/licenses/>. *)
(***********************************************************************)
open Printf
open StdLabels
open MoreLabels
module Unix = UnixLabels
open Unix
open Packet
let html_quote string =
let sin = new Channel.string_in_channel string 0 in
let sout = Channel.new_buffer_outc (String.length string + 10) in
try
while true do
match sin#read_char with
| '<' -> sout#write_string "<"
| '>' -> sout#write_string ">"
| '&' -> sout#write_string "&"
| '"' -> sout#write_string """
| c -> sout#write_char c
done;
""
with
End_of_file ->
sout#contents
let br_regexp = Str.regexp_case_fold "<br />"
let page ~title ~body =
sprintf
"<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\" >\n<html xmlns=\"http://www.w3.org/1999/xhtml\">\n<head>\n<title>%s</title>\n<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />\n<meta name=\"robots\" content=\"noindex\" />\n<style type=\"text/css\">\n/*<![CDATA[*/\n .uid { color: green; text-decoration: underline; }\n .warn { color: red; font-weight: bold; }\n/*]]>*/\n</style>\n</head>\n<body>\n<h1>%s</h1>%s</body></html>"
(Str.global_replace br_regexp " | " title) title body
let link ~op ~hash ~fingerprint ~keyid =
sprintf "/pks/lookup?op=%s%s%s&search=0x%s"
op
(if hash then "&hash=on" else "")
(if fingerprint then "&fingerprint=on" else "")
keyid
let keyinfo_header = "Type bits/keyID Date User ID"
let keyinfo_pks pki revoked ~keyid ~link ~userids =
let tm = gmtime (Int64.to_float pki.pk_ctime) in
let algo = pk_alg_to_ident pki.pk_alg in
let base =
sprintf "pub %4d%s/<a href=\"%s\">%8s</a> %4d-%02d-%02d%s "
pki.pk_keylen algo link keyid
(1900 + tm.tm_year)
(tm.tm_mon + 1)
tm.tm_mday
(if revoked then " *** KEY REVOKED *** [not verified]\r\n "
else "")
in
let uidstr = String.concat ~sep:"\r\n " userids in
base ^ uidstr
let fingerprint ~fp =
sprintf "\t Fingerprint=%s" fp
let hash_link ~hash =
sprintf "/pks/lookup?op=hget&search=%s" hash
let hash ~hash =
sprintf "\t Hash=<a href=%s>%s</a>" (hash_link ~hash) hash
let preformat_list elements =
sprintf "<pre>%s</pre>"
(String.concat ~sep:"\r\n" elements ^ "\r\n")