diff --git a/cli/html.ml b/cli/html.ml index c51d889..5f26360 100644 --- a/cli/html.ml +++ b/cli/html.ml @@ -6,188 +6,176 @@ let empty_templates = { header = None; footer = None } let default_opts = { templates = empty_templates; style = "" } let init kv = - let open Logarion in - let to_string key kv = match Store.KV.find key kv with - | fname -> Some (File_store.to_string fname) - | exception Not_found -> None in - let header = to_string "HTM-header" kv in - let footer = to_string "HTM-footer" kv in - let style = match to_string "HTM-style" kv with - | Some s -> Printf.sprintf "\n" s | None -> "" in - { templates = { header; footer}; style } + let open Logarion in + let to_string key kv = match Store.KV.find key kv with + | fname -> Some (File_store.to_string fname) + | exception Not_found -> None in + let header = to_string "HTM-header" kv in + let footer = to_string "HTM-footer" kv in + let style = match to_string "HTM-style" kv with + | Some s -> Printf.sprintf "\n" s | None -> "" in + { templates = { header; footer}; style } let wrap conv htm text_title body = - let site_title = try Logarion.Store.KV.find "Title" conv.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 feed = try Logarion.Store.KV.find "HTM-feed" conv.Conversion.kv - with Not_found -> if Sys.file_exists (Filename.concat conv.Conversion.dir "feed.atom") - then "feed.atom" else "" in - let header = match htm.templates.header with - | Some x -> replace x - | None -> Printf.(sprintf "%s%s" site_title - (if feed <> "" then sprintf "feed" feed else "")) - in - let footer = match htm.templates.footer with None -> "" | Some x -> replace x in - Printf.sprintf "\n\n\n\n%s%s\n%s\n%s\ - \n\n\n\n%s%s%s\n" - text_title (if site_title <> "" then (" • " ^ site_title) else "") - htm.style - (if feed <> "" then Printf.sprintf "" feed else "") - header body footer + let site_title = try Logarion.Store.KV.find "Title" conv.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 feed = try Logarion.Store.KV.find "HTM-feed" conv.Conversion.kv + with Not_found -> if Sys.file_exists (Filename.concat conv.Conversion.dir "feed.atom") + then "feed.atom" else "" in + let header = match htm.templates.header with + | Some x -> replace x + | None -> Printf.(sprintf "%s%s" site_title + (if feed <> "" then sprintf "feed" feed else "")) + in + let footer = match htm.templates.footer with None -> "" | Some x -> replace x in + Printf.sprintf "\n\n\n\n%s%s\n%s\n%s\n\n\n\n\n%s%s%s\n" + text_title (if site_title <> "" then (" • " ^ site_title) else "") + htm.style + (if feed <> "" then Printf.sprintf "" feed else "") + header body footer let topic_link root topic = - let replaced_space = String.map (function ' '->'+' | x->x) in - "" - ^ String.capitalize_ascii topic ^ "" + let replaced_space = String.map (function ' '->'+' | x->x) in + "" + ^ String.capitalize_ascii topic ^ "" module HtmlConverter = struct - include Converter.Html - let uid_uri u a = Printf.sprintf "%s<%s>" a u ext u - let angled_uri u a = - if try String.sub u 0 10 = "urn:txtid:" with Invalid_argument _ -> false - then angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a else angled_uri u a + include Converter.Html + let uid_uri u a = Printf.sprintf "%s<%s>" a u ext u + let angled_uri u a = + if try String.sub u 0 10 = "urn:txtid:" with Invalid_argument _ -> false + then angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a else angled_uri u 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 header = - let time x = Printf.sprintf {|%s|} - (Date.rfc_string x) (Date.pretty_date 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 - let ref_links x = - let link l = HtmlConverter.uid_uri l "" in - String_set.fold (fun r a -> sep_append a (link r)) x "" - in - let references, replies = let open Conversion in - let Rel.{ref_set; rep_set; _} = - try Rel.Id_map.find text.id conversion.relations - with Not_found -> Rel.empty in - ref_links ref_set, ref_links rep_set - in - "
" - ^ opt_kv "Title:" text.title - ^ opt_kv "Authors:" authors - ^ opt_kv "Date:" (time (Date.listing text.date)) - ^ opt_kv "Series:" (str_set "series" text) - ^ opt_kv "Topics:" (topic_links (set "topics" text)) - ^ opt_kv "Id:" text.id - ^ opt_kv "Refers:" (ref_links (set "references" text)) - ^ opt_kv "In reply to:" (ref_links (set "in-reply-to" text)) - ^ opt_kv "Referred by:" references - ^ opt_kv "Replies:" replies - ^ {|
|} in
-	wrap conversion htm text.title ((T.of_string text.body header) ^ "
") + 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 authors = Person.Set.to_string text.authors in + let header = + let time x = Printf.sprintf {|%s|} +(Date.rfc_string x) (Date.pretty_date 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 + let ref_links x = + let link l = HtmlConverter.uid_uri l "" in + String_set.fold (fun r a -> sep_append a (link r)) x "" in + let references, replies = let open Conversion in + let Rel.{ref_set; rep_set; _} = try Rel.Id_map.find text.id conversion.relations with Not_found -> Rel.empty in + ref_links ref_set, ref_links rep_set in + "
" + ^ opt_kv "Title:" text.title + ^ opt_kv "Authors:" authors + ^ opt_kv "Date:" (time (Date.listing text.date)) + ^ opt_kv "Series:" (str_set "series" text) + ^ opt_kv "Topics:" (topic_links (set "topics" text)) + ^ opt_kv "Id:" text.id + ^ opt_kv "Refers:" (ref_links (set "references" text)) + ^ opt_kv "In reply to:" (ref_links (set "in-reply-to" text)) + ^ opt_kv "Referred by:" references + ^ opt_kv "Replies:" replies + ^ {|
|} 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 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) + 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 - "

    Main topics

    " - ^ List.fold_left (fun a x -> a ^ list_item x x) "" + let list_item root t = "
  • " ^ topic_link root t in + "

    Main topics

    " + ^ List.fold_left (fun a x -> a ^ list_item x x) "" 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) "" - 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 - "

    Topics

    " - ^ List.fold_left (fun a x -> a ^ list_item x x) "" + let open Logarion in + let rec unordered_list root topic = + List.fold_left (fun a x -> a ^ list_item root x) "" + 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 + "" in + "

    Topics

    " + ^ List.fold_left (fun a x -> a ^ list_item x x) "" let text_item path meta = - let open Logarion in - "" ^ Date.(pretty_date (listing meta.Text.date)) - ^ {| |} ^ meta.Text.title - ^ "
    " + 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 - "

    Texts

    " ^ item_group topic_roots ^ "" + 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 + "

    Texts

    " ^ item_group topic_roots ^ "" let topic_main_index conv htm topic_roots metas = - wrap conv htm "Topics" - (fold_topic_roots topic_roots - ^ "

    Latest

    More by date|} - ^ let peers = try Logarion.Store.KV.find "Peers" conv.kv with Not_found -> "" in - (if peers = "" then "" else - List.fold_left (fun a s -> Printf.sprintf {|%s
  • %s|} a s s) "

    Peers

    ")) + wrap conv htm "Topics" + (fold_topic_roots topic_roots + ^ "

    Latest