Changeset 52 in code for trunk/cli/html.ml


Ignore:
Timestamp:
Oct 21, 2023, 12:34:31 AM (18 months ago)
Author:
yakumo.izuru
Message:

Tidy

Signed-off-by: Izuru Yakumo <yakumo.izuru@…>

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/cli/html.ml

    r50 r52  
    77
    88let 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>\n" s | None -> "" in
    17         { templates = { header; footer}; style }
     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 type=\"text/css\">%s</style>\n" s | None -> "" in
     17        { templates = { header; footer}; style }
    1818
    1919let 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 "<a href='.'>%s</a>%s" site_title
    31                                 (if feed <> "" then sprintf "<a href='%s' id='feed'>feed</a>" feed else ""))
    32         in
    33         let footer = match htm.templates.footer with None -> "" | Some x -> replace x in
    34         Printf.sprintf "<!DOCTYPE HTML PUBLIC \"//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n<html>\n<head>\n<link rel=\"icon\" href=\"/favicon.png\">\n<title>%s%s</title>\n%s\n%s\
    35         <meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">\n<meta http-equiv=\"Content-type\" content=\"text/html; charset=utf-8\">\n</head>\n<body>\n%s%s%s</body>\n</html>"
    36         text_title (if site_title <> "" then (" • " ^ site_title) else "")
    37         htm.style
    38         (if feed <> "" then Printf.sprintf "<link rel='alternate' href='%s' type='application/atom+xml'>" feed else "")
    39         header body footer
     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 "<a href='.'>%s</a>%s" site_title
     31        (if feed <> "" then sprintf "<a href='%s' id='feed'>feed</a>" feed else ""))
     32        in
     33        let footer = match htm.templates.footer with None -> "" | Some x -> replace x in
     34        Printf.sprintf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n<html>\n<head>\n<link rel=\"icon\" href=\"/favicon.png\">\n<title>%s%s</title>\n%s\n%s\n<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">\n<meta http-equiv=\"Content-type\" content=\"text/html; charset=utf-8\">\n</head>\n<body>\n%s%s%s</body>\n</html>"
     35        text_title (if site_title <> "" then (" • " ^ site_title) else "")
     36        htm.style
     37        (if feed <> "" then Printf.sprintf "<link rel='alternate' href='%s' type='application/atom+xml'>" feed else "")
     38        header body footer
    4039
    4140let topic_link root topic =
    42         let replaced_space = String.map (function ' '->'+' | x->x) in
    43         "<a href='index." ^ root ^ ".htm#" ^ replaced_space topic ^ "'>"
    44         ^ String.capitalize_ascii topic ^ "</a>"
     41        let replaced_space = String.map (function ' '->'+' | x->x) in
     42        "<a href='index." ^ root ^ ".htm#" ^ replaced_space topic ^ "'>"
     43        ^ String.capitalize_ascii topic ^ "</a>"
    4544
    4645module HtmlConverter = struct
    47         include Converter.Html
    48         let uid_uri u a = Printf.sprintf "%s<a href='%s%s'>&lt;%s&gt;</a>" a u ext u
    49         let angled_uri u a =
    50                 if try String.sub u 0 10 = "urn:txtid:" with Invalid_argument _ -> false
    51                 then angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a else angled_uri u a
     46        include Converter.Html
     47        let uid_uri u a = Printf.sprintf "%s<a href='%s%s'>&lt;%s&gt;</a>" a u ext u
     48        let angled_uri u a =
     49                if try String.sub u 0 10 = "urn:txtid:" with Invalid_argument _ -> false
     50                then angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a else angled_uri u a
    5251end
    5352
    5453let page htm conversion text =
    55         let open Logarion in
    56         let open Text in
    57         let module T = Parsers.Plain_text.Make (HtmlConverter) in
    58         let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in
    59         let opt_kv key value = if String.length value > 0
    60                 then "<dt>" ^ key ^ "<dd>" ^ value else "" in
    61 (*      let author acc auth = sep_append acc Person.(auth.name ^ " ") in*)
    62         let authors = Person.Set.to_string text.authors in
    63         let header =
    64                 let time x = Printf.sprintf {|<span class="%s">%s</span>|}
    65                         (Date.rfc_string x) (Date.pretty_date x) in
    66                 let topic_links x =
    67                         let to_linked t a =
    68                                 let ts = Topic_set.of_string t in
    69                                 sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in
    70                         String_set.fold to_linked x "" in
    71                 let ref_links x =
    72                         let link l = HtmlConverter.uid_uri l "" in
    73                         String_set.fold (fun r a -> sep_append a (link r)) x ""
    74                 in
    75                 let references, replies = let open Conversion in
    76                         let Rel.{ref_set; rep_set; _} =
    77                                 try Rel.Id_map.find text.id conversion.relations
    78                                 with Not_found -> Rel.empty in
    79                         ref_links ref_set, ref_links rep_set
    80                 in
    81                 "<dl>"
    82                 ^ opt_kv "Title:" text.title
    83                 ^ opt_kv "Authors:" authors
    84                 ^ opt_kv "Date:" (time (Date.listing text.date))
    85                 ^ opt_kv "Series:" (str_set "series" text)
    86                 ^ opt_kv "Topics:" (topic_links (set "topics" text))
    87                 ^ opt_kv "Id:" text.id
    88                 ^ opt_kv "Refers:" (ref_links (set "references" text))
    89                 ^ opt_kv "In reply to:" (ref_links (set "in-reply-to" text))
    90                 ^ opt_kv "Referred by:" references
    91                 ^ opt_kv "Replies:" replies
    92                 ^ {|</dl><pre style="white-space:pre-wrap">|} in
    93         wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre>")
     54        let open Logarion in
     55        let open Text in
     56        let module T = Parsers.Plain_text.Make (HtmlConverter) in
     57        let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in
     58        let opt_kv key value = if String.length value > 0       
     59                then "<dt>" ^ key ^ "<dd>" ^ value else "" in
     60        let authors = Person.Set.to_string text.authors in
     61        let header =
     62                let time x = Printf.sprintf {|<span class="%s">%s</span>|}
     63(Date.rfc_string x) (Date.pretty_date x) in
     64                let topic_links x =
     65                        let to_linked t a =
     66                                let ts = Topic_set.of_string t in
     67                                sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in
     68                        String_set.fold to_linked x "" in
     69                let ref_links x =
     70                        let link l = HtmlConverter.uid_uri l "" in
     71                        String_set.fold (fun r a -> sep_append a (link r)) x "" in
     72                let references, replies = let open Conversion in
     73                let Rel.{ref_set; rep_set; _} = try Rel.Id_map.find text.id conversion.relations with Not_found -> Rel.empty in
     74                ref_links ref_set, ref_links rep_set in
     75                "<dl>"
     76                ^ opt_kv "Title:" text.title
     77                ^ opt_kv "Authors:" authors
     78                ^ opt_kv "Date:" (time (Date.listing text.date))
     79                ^ opt_kv "Series:" (str_set "series" text)
     80                ^ opt_kv "Topics:" (topic_links (set "topics" text))
     81                ^ opt_kv "Id:" text.id
     82                ^ opt_kv "Refers:" (ref_links (set "references" text))
     83                ^ opt_kv "In reply to:" (ref_links (set "in-reply-to" text))
     84                ^ opt_kv "Referred by:" references
     85                ^ opt_kv "Replies:" replies
     86                ^ {|</dl><pre style="white-space:pre-wrap">|} in
     87        wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre>")
    9488
    9589let to_dated_links ?(limit) meta_list =
    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
     90        let meta_list = match limit with
     91        | None -> meta_list
     92        | Some limit->
     93                        let rec reduced acc i = function
     94                                | [] -> acc
     95                                | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in
     96                        List.rev @@ reduced [] 0 meta_list in
     97        List.fold_left
     98        (fun a m -> Printf.sprintf "%s<li>%s <a href=\"%s.htm\">%s</a></li>" a Logarion.(Date.(pretty_date (listing m.Text.date)))         
     99        (Logarion.Text.short_id m) m.Logarion.Text.title)
     100        "" meta_list
    109101
    110102let date_index ?(limit) conv htm meta_list =
    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)
     103        match limit with
     104        | Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
     105        | None -> wrap conv htm "Index" (to_dated_links meta_list)
    114106
    115107let fold_topic_roots topic_roots =
    116         let list_item root t = "<li>" ^ topic_link root t in
    117         "<h2>Main topics</h2>"
    118         ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
    119         ^ "</ul>"
     108        let list_item root t = "<li>" ^ topic_link root t in
     109        "<h2>Main topics</h2>"
     110        ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
     111        ^ "</ul>"
    120112
    121113let fold_topics topic_map topic_roots metas =
    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         "<h2>Topics</h2>"
    137         ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
    138         ^ "</ul>"
     114        let open Logarion in
     115        let rec unordered_list root topic =
     116                List.fold_left (fun a x -> a ^ list_item root x) "<ul>" topic
     117                ^ "</ul>"
     118        and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with
     119        | None -> ""
     120        | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics)
     121and list_item root t =
     122        let item =
     123                if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas
     124                then topic_link root t else String.capitalize_ascii t in
     125        "<ul><li>" ^ item ^ sub_items root t ^ "</ul>" in
     126        "<h2>Topics</h2>"
     127        ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
     128        ^ "</ul>"
    139129
    140130let text_item path meta =
    141         let open Logarion in
    142         "<span>" ^ Date.(pretty_date (listing meta.Text.date))
    143         ^ {|</span> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
    144         ^ "</a><br>"
     131        let open Logarion in
     132        "<p>" ^ Date.(pretty_date (listing meta.Text.date))
     133        ^ {|<a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
     134        ^ "</a></p><br>"
    145135
    146136let listing_index topic_map topic_roots path metas =
    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         "<h1>Texts</h1>" ^ item_group topic_roots ^ ""
     137        let rec item_group topics =
     138                List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ items topic) "" topics
     139        and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with
     140        | None -> ""
     141        | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics)
     142and items topic =
     143        let items =
     144                let open Logarion in
     145                List.fold_left
     146                (fun a e ->
     147                        if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e))
     148                        then text_item path e ^ a else a) "" metas in
     149        match items with
     150        | "" -> ""
     151        | x -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x in
     152        "<h1>Texts</h1>" ^ item_group topic_roots ^ ""
    164153
    165154let topic_main_index conv htm topic_roots metas =
    166         wrap conv htm "Topics"
    167                 (fold_topic_roots topic_roots
    168                 ^ "<h1>Latest</h1><ul>" ^ to_dated_links ~limit:8 metas
    169                 ^ {|</ul><a href="index.date.htm">More by date</a>|}
    170                 ^ let peers = try Logarion.Store.KV.find "Peers" conv.kv with Not_found -> "" in
    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>"))
     155        wrap conv htm "Topics"
     156        (fold_topic_roots topic_roots
     157        ^ "<h1>Latest</h1><ul>" ^ to_dated_links ~limit:10 metas
     158        ^ {|<p><a href="index.date.htm">More by date</a></p>|}
     159^ let peers = try Logarion.Store.KV.find "Peers" conv.kv with Not_found -> "" in
     160(if peers = "" then "" else
     161        List.fold_left (fun a s -> Printf.sprintf {|%s<li><a href="%s">%s</a>|} a s s) "<h1>Peers</h1><ul>"
     162        (Str.split (Str.regexp ";\n") (Logarion.Store.KV.find "Peers" conv.kv))
     163        ^ "</ul>"))
    175164
    176165let topic_sub_index conv htm topic_map topic_root metas =
    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)
     166        wrap conv htm topic_root
     167        (fold_topics topic_map [topic_root] metas
     168        ^ listing_index topic_map [topic_root] "" metas)
    181169
    182170let indices htm c =
    183         let file name = Logarion.File_store.file (Filename.concat c.Conversion.dir name) in
    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);
    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))
    189                 c.topic_roots
     171        let file name = Logarion.File_store.file (Filename.concat c.Conversion.dir name) in
     172        let index_name = try Logarion.Store.KV.find "HTM-index" c.Conversion.kv with Not_found -> "index.html" in
     173        if index_name <> "" then file index_name (topic_main_index c htm c.topic_roots c.texts);
     174        file "index.date.htm" (date_index c htm c.texts);
     175        List.iter
     176        (fun root -> file ("index." ^ root ^ ".htm") (topic_sub_index c htm c.topics root c.texts))
     177        c.topic_roots
    190178
    191 let converter kv = 
    192         let htm = init kv in
    193         Conversion.{ ext; page = Some (page htm); indices = Some (indices htm) }
     179let converter kv =
     180        let htm = init kv in
     181        Conversion.{ ext; page = Some (page htm); indices = Some (indices htm) }
Note: See TracChangeset for help on using the changeset viewer.