source: code/trunk/cli/html.ml@ 18

Last change on this file since 18 was 18, checked in by fox, 2 years ago

Omit bullet in empty title conversions, tidy html.ml
File size: 7.2 KB
Line 
1type templates_t = { header: string option; footer: string option }
2type t = { templates : templates_t }
3
4let ext = ".htm"
5let empty_templates = { header = None; footer = None }
6let default_opts = { templates = empty_templates }
7
8let init kv =
9 let open Logarion in
10 let to_string key kv = match Store.KV.find key kv with
11 | fname -> Some (File_store.to_string fname)
12 | exception Not_found -> None in
13 let header = to_string "HTM-header" kv in
14 let footer = to_string "HTM-footer" kv in
15 { templates = { header; footer} }
16
17let wrap c htm text_title body =
18 let site_title = try Logarion.Store.KV.find "Title" c.Conversion.kv
19 with Not_found -> "" in
20 let replace x = let open Str in
21 global_replace (regexp "{{archive-title}}") site_title x
22 |> global_replace (regexp "{{text-title}}") text_title
23 in
24 let header = match htm.templates.header with
25 | Some x -> replace x
26 | None -> "<header><a href='.'>" ^ site_title ^
27 "</a><nav><a href='feed.atom' id='feed'>feed</a></nav></header>"
28 in
29 let footer = match htm.templates.footer with None -> "" | Some x -> replace x in
30 Printf.sprintf "<!DOCTYPE HTML><html><head><title>%s%s</title>\n\
31 <link rel='stylesheet' href='main.css'>\
32 <link rel='alternate' href='feed.atom' type='application/atom+xml'>\
33 <meta charset='utf-8'/><meta name='viewport' content='width=device-width, initial-scale=1.0'>\
34 </head><body>\n%s%s%s</body></html>"
35 text_title (if site_title <> "" then (" • " ^ site_title) else "")
36 header body footer
37
38let topic_link root topic =
39 let replaced_space = String.map (function ' '->'+' | x->x) in
40 "<a href='index." ^ root ^ ".htm#" ^ replaced_space topic ^ "'>"
41 ^ String.capitalize_ascii topic ^ "</a>"
42
43module HtmlConverter = struct
44 include Converter.Html
45 let angled_uri u a = if String.sub u 0 10 <> "urn:txtid:" then
46 angled_uri u a else angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a
47end
48
49let page htm conversion text =
50 let open Logarion in
51 let open Text in
52 let module T = Parsers.Plain_text.Make (HtmlConverter) in
53 let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in
54 let opt_kv key value = if String.length value > 0
55 then "<dt>" ^ key ^ "<dd>" ^ value else "" in
56(* let author acc auth = sep_append acc Person.(auth.name ^ " ") in*)
57 let authors = (Person.Set.to_string text.authors ^ " ") in
58 let keywords = str_set "keywords" text in
59 let header =
60 let time x = {|<time datetime="|} ^ x ^ {|">|} ^ x ^ "</time>" in
61 let topic_links x =
62 let to_linked t a =
63 let ts = Topic_set.of_string t in
64 sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in
65 String_set.fold to_linked x "" in
66 "<article><header><dl>"
67 ^ opt_kv "Title:" text.title
68 ^ opt_kv "Authors:" authors
69 ^ opt_kv "Date: " (time (Date.(pretty_date @@ listing text.date)))
70 ^ opt_kv "Series: " (str_set "series" text)
71 ^ opt_kv "Topics: " (topic_links (set "topics" text))
72 ^ opt_kv "Keywords: " keywords
73 ^ opt_kv "Id: " text.id
74 ^ {|</dl></header><pre style="white-space:pre-wrap">|} in
75 wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre></article>")
76
77let to_dated_links ?(limit) meta_list =
78 let meta_list = match limit with
79 | None -> meta_list
80 | Some limit->
81 let rec reduced acc i = function
82 | [] -> acc
83 | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in
84 List.rev @@ reduced [] 0 meta_list
85 in
86 List.fold_left
87 (fun a m -> Printf.sprintf "%s<li> %s <a href=\"%s.htm\">%s</a>" a
88 Logarion.(Date.(pretty_date (listing m.Text.date)))
89 (Logarion.Text.short_id m) m.Logarion.Text.title)
90 "" meta_list
91
92let date_index ?(limit) conv htm meta_list =
93 match limit with
94 | Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
95 | None -> wrap conv htm "Index" (to_dated_links meta_list)
96
97let fold_topic_roots topic_roots =
98 let list_item root t = "<li>" ^ topic_link root t in
99 "<nav><h2>Main topics</h2>"
100 ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
101 ^ "</ul></nav>"
102
103let fold_topics topic_map topic_roots metas =
104 let open Logarion in
105 let rec unordered_list root topic =
106 List.fold_left (fun a x -> a ^ list_item root x) "<ul>" topic
107 ^ "</ul>"
108 and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with
109 | None -> ""
110 | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics)
111 and list_item root t =
112 let item =
113 if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas
114 then topic_link root t else String.capitalize_ascii t
115 in
116 "<li>" ^ item ^ sub_items root t
117 in
118 "<nav><h2>Topics</h2>"
119 ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
120 ^ "</ul></nav>"
121
122let text_item path meta =
123 let open Logarion in
124 "<time>" ^ Date.(pretty_date (listing meta.Text.date))
125 ^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
126 ^ "</a><br>"
127
128let listing_index topic_map topic_roots path metas =
129 let rec item_group topics =
130 List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ items topic) "" topics
131 and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with
132 | None -> ""
133 | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics)
134 and items topic =
135 let items =
136 let open Logarion in
137 List.fold_left
138 (fun a e ->
139 if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e))
140 then text_item path e ^ a else a) "" metas in
141 match items with
142 | "" -> ""
143 | x -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
144 in
145 "<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
146
147let topic_main_index conv htm topic_roots metas =
148 wrap conv htm "Topics"
149 (fold_topic_roots topic_roots
150 ^ "<nav><h1>Latest</h1><ul>" ^ to_dated_links ~limit:8 metas
151 ^ {|</ul><a href="index.date.htm">More by date</a>|}
152 ^ let peers = Logarion.Store.KV.find "Peers" conv.kv in
153 (if peers = "" then "" else
154 List.fold_left (fun a s -> Printf.sprintf {|%s<li><a href="%s">%s</a>|} a s s) "<h1>Peers</h1><ul>"
155 (Str.split (Str.regexp ";\n") (Logarion.Store.KV.find "Peers" conv.kv))
156 ^ "</ul>"))
157
158let topic_sub_index conv htm topic_map topic_root metas =
159 wrap conv htm topic_root
160 (fold_topics topic_map [topic_root] metas
161(* ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
162 ^ listing_index topic_map [topic_root] "" metas)
163
164open Logarion
165let indices htm c =
166 let file name = Logarion.File_store.file (Filename.concat c.Conversion.dir name) in
167 let index_name = try Store.KV.find "HTM-index" c.Conversion.kv with Not_found -> "index.html" in
168 let title = try Store.KV.find "Title" c.Conversion.kv with Not_found -> "" in
169
170 if index_name <> "" then
171 file index_name (topic_main_index c htm c.topic_roots c.texts);
172
173 file "index.date.htm" (date_index c htm c.texts);
174
175 List.iter
176 (fun root -> file ("index." ^ root ^ ".htm") (topic_sub_index c htm c.topics root c.texts))
177 c.topic_roots;
178
179 let base_url = try
180 let locs = Store.KV.find "Locations" c.kv in
181 let _i = Str.(search_forward (regexp "https?://[^;]*") locs 0) in
182 Str.(matched_string locs)
183 with Not_found -> prerr_endline "Missing location for HTTP(S)"; "" in
184 file "feed.atom" (Atom.feed title c.id base_url "text/html" c.texts)
Note: See TracBrowser for help on using the repository browser.