logarion/src/core/meta.ml

module Date = struct
  type t = {
      created: Ptime.t option;
      published: Ptime.t option;
      edited: Ptime.t option;
    } [@@deriving lens { submodule = true }]

  let rfc_string date = match date with Some t -> Ptime.to_rfc3339 t | None -> ""

  let of_string (rfc : string) = match Ptime.of_rfc3339 rfc with
      Ok (t,_,_) -> Some t | Error _ -> None

  let listing date = match date.published, date.created with
    | Some _, _ -> date.published
    | None, Some _ -> date.created
    | None, None -> None

  let compare = compare

  let pretty_date = function
    | Some t -> Ptime.to_date t |> fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d
    | None -> ""
end

module Id = struct
  let random_state = Random.State.make_self_init ()
  type t = Uuidm.t
  let compare = Uuidm.compare
  let to_string = Uuidm.to_string
  let of_string = Uuidm.of_string
  let generate ?(random_state=random_state) = Uuidm.v4_gen random_state
end

module Author = struct
  type name_t = string
  type address_t = Uri.t
  type t = {
      name: name_t;
      address: address_t;
    } [@@deriving lens { submodule = true } ]

  let empty = { name = ""; address = Uri.empty }

  let compare = Pervasives.compare

end

module AuthorSet = struct
  include Set.Make(Author)

  let to_string authors =
    let to_string a = a.Author.name ^ " <" ^ Uri.to_string a.Author.address ^ ">" in
    let f elt acc = if String.length acc > 1 then acc ^ ", " ^ to_string elt else to_string elt in
    fold f authors ""

  let of_string s =
    match Emile.List.of_string s with
    | Error _ -> prerr_endline @@ "Error parsing: " ^ s; empty
    | Ok emails ->
       let to_author =
         let module L = List in
         let open Emile in
         function
         | `Group _ -> prerr_endline @@ "Can't deal with groups in author: " ^ s; Author.empty
         | `Mailbox { name; local; _ } ->
            let s_of_phrase = function `Dot -> "" | `Word w -> (match w with `Atom a -> a | `String s -> s) | `Encoded _ -> "" in
            let name = match name with None -> "" | Some phrase -> L.fold_left (fun a e -> a ^ s_of_phrase e) "" phrase in
            let address =
              L.fold_left (fun a e -> a ^ match e with `Atom a -> a | `String s -> s) "" local ^ "@" (* TODO: Author address unimplemented *)
            in
            Author.{ name; address = Uri.of_string address }
       in
       of_list @@ List.map to_author emails
end

module Category = struct
  type t = Draft | Unlisted | Published | Custom of string

  let compare = Pervasives.compare

  let of_string = function
    | "draft" -> Draft
    | "unlisted" -> Unlisted
    | "published" -> Published
    | c -> Custom c

  let to_string = function
    | Draft -> "draft"
    | Unlisted -> "unlisted"
    | Published -> "published"
    | Custom c -> c
end

module CategorySet = struct
  include Set.Make(Category)
  let to_csv set =
    let f elt a =
      let s = Category.to_string elt in
      if a <> "" then a ^ ", " ^ s else s
    in
    fold f set ""
  let categorised categs cs = of_list categs |> (fun s -> subset s cs)
  let published = categorised [Category.Published]
  let listed cs = not @@ categorised [Category.Unlisted] cs
end

module StringSet = Set.Make(String)

let stringset_csv set =
  let f elt a = if a <> "" then a ^ ", " ^ elt else elt in
  StringSet.fold f set ""

let string_alias t =
  let is_reserved = function
    | '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' | '=' | '+' | '$'
      | ',' | '/' | '?' | '#' | '[' | ']' | ' ' | '\t' | '\x00' -> true
    | _ -> false
  in
  let b = Buffer.create (String.length t) in
  let filter char =
    let open Buffer in
    if is_reserved char then (try (if nth b (pred (length b)) <> '-' then add_char b '-') with Invalid_argument _ -> prerr_endline "reserved")
    else add_char b char
  in
  String.(iter filter (lowercase_ascii t));
  Buffer.contents b

type t = {
    title: string;
    authors: AuthorSet.t;
    date: Date.t;
    categories: CategorySet.t;
    topics: StringSet.t;
    keywords: StringSet.t;
    series: StringSet.t;
    abstract: string;
    uuid: Id.t;
    alias: string;
  } [@@deriving lens { submodule = true }]

let blank ?(uuid=(Id.generate ())) () = {
    title = "";
    authors = AuthorSet.empty;
    date = Date.({ created = None; edited = None; published = None });
    categories = CategorySet.empty;
    topics   = StringSet.empty;
    keywords = StringSet.empty;
    series   = StringSet.empty;
    abstract = "";
    uuid;
    alias = "";
  }

let listed    e = CategorySet.listed e.categories
let published e = CategorySet.published e.categories
let unique_topics ts x = StringSet.union ts x.topics

module AliasMap = Map.Make(String)
module IdMap = Map.Make(Id)

let alias meta = if meta.alias = "" then string_alias meta.title else meta.alias

let value_with_name (_meta as m) = function
  | "Title"    -> m.title
  | "Abstract" -> m.abstract
  | "Authors"  -> AuthorSet.to_string m.authors
  | "Date"     -> Date.(rfc_string m.date.created)
  | "Edited"   -> Date.(rfc_string m.date.edited)
  | "Published"-> Date.(rfc_string m.date.published)
  | "Human"    -> Date.(pretty_date @@ listing m.date)
  | "Topics"     -> stringset_csv m.topics;
  | "Categories" -> CategorySet.to_csv m.categories;
  | "Keywords"   -> stringset_csv m.keywords;
  | "Series"     -> stringset_csv m.series;
  | "ID" -> Id.to_string m.uuid
  | "Alias" -> alias m
  | e -> invalid_arg e

let with_kv meta (k,v) =
  let list_of_csv = Re.Str.(split (regexp " *, *")) in
  let trim = String.trim in
  match k with
  | "Title"     -> { meta with title = trim v }
  | "Author"
  | "Authors"   -> { meta with authors = AuthorSet.of_string (trim v)}
  | "Abstract"  -> { meta with abstract = trim v }
  | "Date"      -> { meta with date = Date.{ meta.date with created   = Date.of_string v }}
  | "Published" -> { meta with date = Date.{ meta.date with published = Date.of_string v }}
  | "Edited"    -> { meta with date = Date.{ meta.date with edited    = Date.of_string v }}
  | "Topics"    -> { meta with topics   = trim v |> list_of_csv |> StringSet.of_list }
  | "Keywords"  -> { meta with keywords = trim v |> list_of_csv |> StringSet.of_list }
  | "Categories"->
     let categories = trim v |> list_of_csv |> List.map Category.of_string |> CategorySet.of_list in
     { meta with categories }
  | "Series"    -> { meta with series = trim v |> list_of_csv |> StringSet.of_list }
  | "ID"        -> (match Id.of_string v with Some id -> { meta with uuid = id } | None -> meta)
  | "Alias"     -> { meta with alias = v }
  | k -> prerr_endline ("Unknown key: " ^ k ^ ", with value: " ^ v ); meta

let to_string (_meta as m) =
  let has_len v = String.length v > 0 in
  let s field value = if has_len value then field ^ ": " ^ value ^ "\n" else "" in
  let a value = if AuthorSet.is_empty value then "" else "Authors: " ^ AuthorSet.to_string value ^ "\n" in
  let d field value = match value with
    | Some _ -> field ^ ": " ^ Date.rfc_string value ^ "\n" | None -> ""
  in
  let rows =
    [ s "Title" m.title;
      a m.authors;
      d "Date" m.date.Date.created;
      d "Edited" m.date.Date.edited;
      d "Published" m.date.Date.published;
      s "Topics" (stringset_csv m.topics);
      s "Categories" (CategorySet.to_csv m.categories);
      s "Keywords" (stringset_csv m.keywords);
      s "Series"   (stringset_csv m.series);
      s "Abstract" m.abstract;
      s "ID" (Uuidm.to_string m.uuid);
      s "Alias" m.alias
    ]
  in
  String.concat "" rows