type templates_t = { header: string option; footer: string option } type t = { templates : templates_t } let ext = ".htm" let empty_templates = { header = None; footer = None } let default_opts = { templates = empty_templates } let init kv = let open Logarion in let header = match Store.KV.find "HTM-header" kv with | fname -> Some (File_store.to_string fname) | exception Not_found -> None in let footer = match Store.KV.find "HTM-footer" kv with | fname -> Some (File_store.to_string fname) | exception Not_found -> None in { templates = { header; footer} } let wrap c htm text_title body = let site_title = try Logarion.Store.KV.find "Title" c.Conversion.kv with Not_found -> "" in let replace x = let open Str in global_replace (regexp "{{archive-title}}") site_title x |> global_replace (regexp "{{text-title}}") text_title in let header = match htm.templates.header with | Some x -> replace x | None -> "

" in let footer = match htm.templates.footer with None -> "" | Some x -> replace x in "" ^ text_title ^ " • " ^ site_title ^ "\n\ \ \ \ \n" ^ header ^ body ^ footer ^ "" let topic_link root topic = let replaced_space = String.map (function ' '->'+' | x->x) in "" ^ String.capitalize_ascii topic ^ "" module HtmlConverter = struct include Converter.Html let angled_uri u a = if String.sub u 0 10 <> "urn:txtid:" then angled_uri u a else angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a end let page htm conversion text = let open Logarion in let open Text in let module T = Parsers.Plain_text.Make (HtmlConverter) in let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in let opt_kv key value = if String.length value > 0 then "

" ^ key ^ "

" ^ value else "" in (* let author acc auth = sep_append acc Person.(auth.name ^ " ") in*) let authors = (Person.Set.to_string text.authors ^ " ") in let keywords = str_set "keywords" text in let header = let time x = {||} ^ x ^ "" in let topic_links x = let to_linked t a = let ts = Topic_set.of_string t in sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in String_set.fold to_linked x "" in "

" ^ opt_kv "Title:" text.title ^ opt_kv "Authors:" authors ^ opt_kv "Date: " (time (Date.(pretty_date @@ listing text.date))) ^ opt_kv "Series: " (str_set "series" text) ^ opt_kv "Topics: " (topic_links (set "topics" text)) ^ opt_kv "Keywords: " keywords ^ opt_kv "Id: " text.id ^ {|

|} in
  wrap conversion htm text.title ((T.of_string text.body header) ^ "

") let to_dated_links ?(limit) meta_list = let meta_list = match limit with | None -> meta_list | Some limit-> let rec reduced acc i = function | [] -> acc | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in List.rev @@ reduced [] 0 meta_list in List.fold_left (fun a m -> Printf.sprintf "%s

%s %s" a Logarion.(Date.(pretty_date (listing m.Text.date))) (Logarion.Text.short_id m) m.Logarion.Text.title) "" meta_list let date_index ?(limit) conv htm meta_list = match limit with | Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list) | None -> wrap conv htm "Index" (to_dated_links meta_list) let fold_topic_roots topic_roots = let list_item root t = "

" ^ topic_link root t in "" let fold_topics topic_map topic_roots metas = let open Logarion in let rec unordered_list root topic = List.fold_left (fun a x -> a ^ list_item root x) "

" topic ^ "" and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with | None -> "" | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics) and list_item root t = let item = if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas then topic_link root t else String.capitalize_ascii t in "

" ^ item ^ sub_items root t in "" let text_item path meta = let open Logarion in "" ^ Date.(pretty_date (listing meta.Text.date)) ^ {| |} ^ meta.Text.title ^ "
" let listing_index topic_map topic_roots path metas = let rec item_group topics = List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ items topic) "" topics and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with | None -> "" | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics) and items topic = let items = let open Logarion in List.fold_left (fun a e -> if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e)) then text_item path e ^ a else a) "" metas in match items with | "" -> "" | x -> {|

|} ^ String.capitalize_ascii topic ^ "

" ^ x in "" let topic_main_index conv htm topic_roots metas = wrap conv htm "Topics" (fold_topic_roots topic_roots ^ "

Latest

" ^ to_dated_links ~limit:8 metas ^ {|More by date|} ^ let peers = Logarion.Store.KV.find "Peers" conv.kv in (if peers = "" then "" else List.fold_left (fun a s -> Printf.sprintf {|%s

%s|} a s s) "

Peers

" (Str.split (Str.regexp ";\n") (Logarion.Store.KV.find "Peers" conv.kv)) ^ "")) let topic_sub_index conv htm topic_map topic_root metas = wrap conv htm topic_root (fold_topics topic_map [topic_root] metas (* ^ {||}^ String.capitalize_ascii topic_root ^{| feed |}*) ^ listing_index topic_map [topic_root] "" metas) open Logarion let indices htm c = let file name = Logarion.File_store.file (Filename.concat c.Conversion.dir name) in let index_name = try Store.KV.find "HTM-index" c.Conversion.kv with Not_found -> "index.html" in let title = try Store.KV.find "Title" c.Conversion.kv with Not_found -> "" in if index_name <> "" then file index_name (topic_main_index c htm c.topic_roots c.texts); file "index.date.htm" (date_index c htm c.texts); List.iter (fun root -> file ("index." ^ root ^ ".htm") (topic_sub_index c htm c.topics root c.texts)) c.topic_roots; let base_url = try let locs = Store.KV.find "Locations" c.kv in let _i = Str.(search_forward (regexp "https?://[^;]*") locs 0) in Str.(matched_string locs) with Not_found -> prerr_endline "Missing location for HTTP(S)"; "" in file "feed.atom" (Atom.feed title c.id base_url "text/html" c.texts)