| [3] | 1 | type templates_t = { header: string option; footer: string option }
|
|---|
| [20] | 2 | type t = { templates : templates_t; style : string }
|
|---|
| [2] | 3 |
|
|---|
| [3] | 4 | let ext = ".htm"
|
|---|
| 5 | let empty_templates = { header = None; footer = None }
|
|---|
| [20] | 6 | let default_opts = { templates = empty_templates; style = "" }
|
|---|
| [3] | 7 |
|
|---|
| 8 | let init kv =
|
|---|
| 9 | let open Logarion in
|
|---|
| [18] | 10 | let to_string key kv = match Store.KV.find key kv with
|
|---|
| [3] | 11 | | fname -> Some (File_store.to_string fname)
|
|---|
| 12 | | exception Not_found -> None in
|
|---|
| [18] | 13 | let header = to_string "HTM-header" kv in
|
|---|
| 14 | let footer = to_string "HTM-footer" kv in
|
|---|
| [20] | 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 }
|
|---|
| [3] | 18 |
|
|---|
| [19] | 19 | let wrap conv htm text_title body =
|
|---|
| [20] | 20 | let site_title = try Logarion.Store.KV.find "Title" conv.Conversion.kv with Not_found -> "" in
|
|---|
| [3] | 21 | let replace x = let open Str in
|
|---|
| [20] | 22 | global_replace (regexp "{{archive-title}}") site_title x
|
|---|
| [3] | 23 | |> global_replace (regexp "{{text-title}}") text_title
|
|---|
| 24 | in
|
|---|
| [20] | 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
|
|---|
| [39] | 28 | let header = match htm.templates.header with
|
|---|
| [20] | 29 | | Some x -> replace x
|
|---|
| [21] | 30 | | None -> Printf.(sprintf "<header><a href='.'>%s</a>%s</header>" site_title
|
|---|
| [20] | 31 | (if feed <> "" then sprintf "<nav><a href='%s' id='feed'>feed</a></nav>" feed else ""))
|
|---|
| [3] | 32 | in
|
|---|
| [18] | 33 | let footer = match htm.templates.footer with None -> "" | Some x -> replace x in
|
|---|
| [20] | 34 | Printf.sprintf "<!DOCTYPE HTML><html><head><title>%s%s</title>\n%s\n%s\
|
|---|
| [18] | 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 "")
|
|---|
| [20] | 38 | htm.style
|
|---|
| 39 | (if feed <> "" then Printf.sprintf "<link rel='alternate' href='%s' type='application/atom+xml'>" feed else "")
|
|---|
| [18] | 40 | header body footer
|
|---|
| [3] | 41 |
|
|---|
| [41] | 42 | let topic_link root topic =
|
|---|
| [18] | 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>"
|
|---|
| [2] | 46 |
|
|---|
| [3] | 47 | module HtmlConverter = struct
|
|---|
| 48 | include Converter.Html
|
|---|
| [41] | 49 | let uid_uri u a = Printf.sprintf "%s<a href='%s%s'><%s></a>" a u ext u
|
|---|
| [38] | 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
|
|---|
| [3] | 53 | end
|
|---|
| 54 |
|
|---|
| 55 | let page htm conversion text =
|
|---|
| [18] | 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*)
|
|---|
| [24] | 63 | let authors = Person.Set.to_string text.authors in
|
|---|
| [18] | 64 | let header =
|
|---|
| [19] | 65 | let time x = Printf.sprintf {|<time datetime="%s">%s</time>|}
|
|---|
| 66 | (Date.rfc_string x) (Date.pretty_date x) in
|
|---|
| [18] | 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
|
|---|
| [38] | 72 | let ref_links x =
|
|---|
| [39] | 73 | let link l = HtmlConverter.uid_uri l "" in
|
|---|
| [38] | 74 | String_set.fold (fun r a -> sep_append a (link r)) x ""
|
|---|
| 75 | in
|
|---|
| [41] | 76 | Printf.eprintf "%s %d\n" text.id (Conversion.Id_map.cardinal conversion.Conversion.replies);
|
|---|
| [18] | 77 | "<article><header><dl>"
|
|---|
| 78 | ^ opt_kv "Title:" text.title
|
|---|
| 79 | ^ opt_kv "Authors:" authors
|
|---|
| [24] | 80 | ^ opt_kv "Date:" (time (Date.listing text.date))
|
|---|
| 81 | ^ opt_kv "Series:" (str_set "series" text)
|
|---|
| 82 | ^ opt_kv "Topics:" (topic_links (set "topics" text))
|
|---|
| 83 | ^ opt_kv "Id:" text.id
|
|---|
| [39] | 84 | ^ opt_kv "Refers:" (ref_links (set "references" text))
|
|---|
| [41] | 85 | ^ opt_kv "In reply to:" (ref_links (set "in-reply-to" text))
|
|---|
| [39] | 86 | ^ opt_kv "Referred by:" (try
|
|---|
| 87 | ref_links (Conversion.Id_map.find text.id conversion.Conversion.references)
|
|---|
| 88 | with Not_found -> "")
|
|---|
| [41] | 89 | ^ opt_kv "Replies:" (try
|
|---|
| 90 | ref_links (Conversion.Id_map.find text.id conversion.Conversion.replies)
|
|---|
| [42] | 91 | with Not_found -> "")
|
|---|
| [18] | 92 | ^ {|</dl></header><pre style="white-space:pre-wrap">|} in
|
|---|
| 93 | wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre></article>")
|
|---|
| [2] | 94 |
|
|---|
| 95 | let to_dated_links ?(limit) meta_list =
|
|---|
| [18] | 96 | let meta_list = match limit with
|
|---|
| 97 | | None -> meta_list
|
|---|
| 98 | | Some limit->
|
|---|
| 99 | let rec reduced acc i = function
|
|---|
| 100 | | [] -> acc
|
|---|
| 101 | | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in
|
|---|
| 102 | List.rev @@ reduced [] 0 meta_list
|
|---|
| 103 | in
|
|---|
| 104 | List.fold_left
|
|---|
| 105 | (fun a m -> Printf.sprintf "%s<li> %s <a href=\"%s.htm\">%s</a>" a
|
|---|
| 106 | Logarion.(Date.(pretty_date (listing m.Text.date)))
|
|---|
| 107 | (Logarion.Text.short_id m) m.Logarion.Text.title)
|
|---|
| 108 | "" meta_list
|
|---|
| [2] | 109 |
|
|---|
| [3] | 110 | let date_index ?(limit) conv htm meta_list =
|
|---|
| [18] | 111 | match limit with
|
|---|
| 112 | | Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
|
|---|
| 113 | | None -> wrap conv htm "Index" (to_dated_links meta_list)
|
|---|
| [2] | 114 |
|
|---|
| 115 | let fold_topic_roots topic_roots =
|
|---|
| [18] | 116 | let list_item root t = "<li>" ^ topic_link root t in
|
|---|
| 117 | "<nav><h2>Main topics</h2>"
|
|---|
| 118 | ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
|---|
| 119 | ^ "</ul></nav>"
|
|---|
| [2] | 120 |
|
|---|
| 121 | let fold_topics topic_map topic_roots metas =
|
|---|
| [18] | 122 | let open Logarion in
|
|---|
| 123 | let rec unordered_list root topic =
|
|---|
| 124 | List.fold_left (fun a x -> a ^ list_item root x) "<ul>" topic
|
|---|
| 125 | ^ "</ul>"
|
|---|
| 126 | and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with
|
|---|
| 127 | | None -> ""
|
|---|
| 128 | | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics)
|
|---|
| 129 | and list_item root t =
|
|---|
| 130 | let item =
|
|---|
| 131 | if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas
|
|---|
| 132 | then topic_link root t else String.capitalize_ascii t
|
|---|
| 133 | in
|
|---|
| 134 | "<li>" ^ item ^ sub_items root t
|
|---|
| 135 | in
|
|---|
| 136 | "<nav><h2>Topics</h2>"
|
|---|
| 137 | ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
|---|
| 138 | ^ "</ul></nav>"
|
|---|
| [2] | 139 |
|
|---|
| 140 | let text_item path meta =
|
|---|
| [18] | 141 | let open Logarion in
|
|---|
| 142 | "<time>" ^ Date.(pretty_date (listing meta.Text.date))
|
|---|
| 143 | ^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
|
|---|
| 144 | ^ "</a><br>"
|
|---|
| [2] | 145 |
|
|---|
| 146 | let listing_index topic_map topic_roots path metas =
|
|---|
| [18] | 147 | let rec item_group topics =
|
|---|
| 148 | List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ items topic) "" topics
|
|---|
| 149 | and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with
|
|---|
| 150 | | None -> ""
|
|---|
| 151 | | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics)
|
|---|
| 152 | and items topic =
|
|---|
| 153 | let items =
|
|---|
| 154 | let open Logarion in
|
|---|
| 155 | List.fold_left
|
|---|
| 156 | (fun a e ->
|
|---|
| 157 | if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e))
|
|---|
| 158 | then text_item path e ^ a else a) "" metas in
|
|---|
| 159 | match items with
|
|---|
| 160 | | "" -> ""
|
|---|
| 161 | | x -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
|
|---|
| 162 | in
|
|---|
| 163 | "<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
|
|---|
| [2] | 164 |
|
|---|
| [3] | 165 | let topic_main_index conv htm topic_roots metas =
|
|---|
| [18] | 166 | wrap conv htm "Topics"
|
|---|
| 167 | (fold_topic_roots topic_roots
|
|---|
| 168 | ^ "<nav><h1>Latest</h1><ul>" ^ to_dated_links ~limit:8 metas
|
|---|
| 169 | ^ {|</ul><a href="index.date.htm">More by date</a>|}
|
|---|
| [20] | 170 | ^ let peers = try Logarion.Store.KV.find "Peers" conv.kv with Not_found -> "" in
|
|---|
| [18] | 171 | (if peers = "" then "" else
|
|---|
| 172 | List.fold_left (fun a s -> Printf.sprintf {|%s<li><a href="%s">%s</a>|} a s s) "<h1>Peers</h1><ul>"
|
|---|
| 173 | (Str.split (Str.regexp ";\n") (Logarion.Store.KV.find "Peers" conv.kv))
|
|---|
| 174 | ^ "</ul>"))
|
|---|
| [2] | 175 |
|
|---|
| [3] | 176 | let topic_sub_index conv htm topic_map topic_root metas =
|
|---|
| [18] | 177 | wrap conv htm topic_root
|
|---|
| 178 | (fold_topics topic_map [topic_root] metas
|
|---|
| 179 | (* ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
|
|---|
| 180 | ^ listing_index topic_map [topic_root] "" metas)
|
|---|
| [3] | 181 |
|
|---|
| 182 | let indices htm c =
|
|---|
| 183 | let file name = Logarion.File_store.file (Filename.concat c.Conversion.dir name) in
|
|---|
| [19] | 184 | let index_name = try Logarion.Store.KV.find "HTM-index" c.Conversion.kv with Not_found -> "index.html" in
|
|---|
| 185 | if index_name <> "" then file index_name (topic_main_index c htm c.topic_roots c.texts);
|
|---|
| [3] | 186 | file "index.date.htm" (date_index c htm c.texts);
|
|---|
| 187 | List.iter
|
|---|
| 188 | (fun root -> file ("index." ^ root ^ ".htm") (topic_sub_index c htm c.topics root c.texts))
|
|---|
| [19] | 189 | c.topic_roots
|
|---|
| [3] | 190 |
|
|---|
| [19] | 191 | let converter kv =
|
|---|
| 192 | let htm = init kv in
|
|---|
| 193 | Conversion.{ ext; page = Some (page htm); indices = Some (indices htm) }
|
|---|
