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

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

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