seppo/lib/rfc4287.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

let ( >>= ) = Result.bind
let ( let* ) = Result.bind

let defa = Uri.make ~path:"o/p/" ()
let tagu = Uri.make ~path:"o/t/" ()

(** map until the first Error *)
let list f xs =
  let it xs x =
    let* xs = xs in
    let* x = f x in
    Ok (List.cons x xs)
  in
  xs |> List.fold_left it (Ok [])

type single  = Single of string
type multi   = Multi  of string
type rfc4646 = Rfc4646 of string (* bcp47 *)

(* See also Cohttp.Link.Rel *)
module Link = struct
  type rel  = Rel of single
  type t = {
    href         : Uri.t;
    rel          : rel option;
    title        : string option;
    rfc7033      : string option; (* Webfinger.Client.t is a cycle *)
  }

  let self  = Rel (Single "self")
  let last  = Rel (Single "last")
  let first = Rel (Single "first")
  let next  = Rel (Single "next")
  let prev  = Rel (Single "previous")
  let edit  = Rel (Single "edit")
  let notify= Rel (Single "notify") (* idiosyncratic *)
  let subscribed= Rel (Single "subscribed") (* idiosyncratic *)
  let make ?(title = None) ?(rfc7033 = None) ?(rel = None) href = { href; rel; title; rfc7033; }

  let encode (r : t) =
    let open Csexp in
    let str n v l = Atom n :: Atom v :: l in
    let uri n v l = l |> str n (v |> Uri.to_string) in
    let opt f n v l = match v with | None -> l
                                   | Some u -> l |> f n u in
    let sing f n v l = match v with | None -> l
                                    | Some (Rel (Single u)) -> l |> f n u in
    List ([]
          |> sing str "rel"     r.rel
          |> opt str  "title"   r.title
          |> opt str  "rfc7033" r.rfc7033
          |> uri      "href"    r.href)

  let decode s =
    let open Csexp in
    let rec pairs xs r =
      match xs with
      | Atom "rel"    :: Atom x :: tl -> pairs tl {r with rel=Some (Rel (Single x))}
      | Atom "title"  :: Atom x :: tl -> pairs tl {r with title=Some x}
      | Atom "rfc7033":: Atom x :: tl -> pairs tl {r with rfc7033=Some x}
      | [] -> Ok r
      | _ -> Error "unexpected field"
    in
    match s with
    | List ( Atom "href" :: Atom href :: tl ) ->
      href
      |> Uri.of_string
      |> make
      |> pairs tl
    | _ -> Error "unexpected field"

  let to_atom ?(base = Uri.empty) li =
    let href = match li.href |> Http.reso ~base |> Uri.to_string with 
      | "" -> "." 
      | s -> s in
    let attr = [] in
    let attr = match li.rfc7033 with
      | None   -> attr
      | Some x -> (("","rfc7033"), x) :: attr in
    let attr = match li.title with
      | None   -> attr
      | Some x -> (("","title"), x) :: attr in
    let attr = (("","href"), href) :: attr in
    let attr = match li.rel with
      | None   -> attr
      | Some Rel Single x -> (("","rel"), x) :: attr in
    `El (((Xml.ns_a,"link"),attr),[])

  let link ~rfc7033 ~title ~rel ~href : t =
    let rel = Some rel in
    make ~rfc7033 ~title ~rel href
end

module Inreplyto = struct
  type t = {
    ref_         : Uri.t;
    href         : Uri.t option;
    source       : Uri.t option;
    type_        : string option;
  }
  let make ?(href = None) ?(source = None) ?(type_ = None) ref_ = { ref_; href; source; type_; }
  let encode (r : t) =
    let open Csexp in
    let str n v l = Atom n :: Atom v :: l in
    let uri n v l = l |> str n (v |> Uri.to_string) in
    let opt f n v l = match v with | None -> l
                                   | Some u -> l |> f n u in
    List ([]
          |> opt str "type"   r.type_
          |> opt uri "source" r.source
          |> opt uri "href"   r.href
          |> uri     "ref"    r.ref_)

  let decode s =
    let open Csexp in
    let rec pairs xs r =
      match xs with
      | Atom "href"  :: Atom x :: tl -> pairs tl {r with href=Some (Uri.of_string x)}
      | Atom "source":: Atom x :: tl -> pairs tl {r with source=Some (Uri.of_string x)}
      | Atom "type"  :: Atom x :: tl -> pairs tl {r with type_=Some x}
      | [] -> Ok r
      | _ -> Error "unexpected field"
    in
    match s with
    | List ( Atom "ref" :: Atom ref_ :: tl ) ->
      ref_
      |> Uri.of_string
      |> make
      |> pairs tl
    | _ -> Error "unexpected field"
end

module Category = struct
  type label    = Label of single
  type term     = Term  of single
  type t        = label * term * Uri.t

  let encode (Label (Single l), Term (Single t), u) =
    Csexp.(List [
        Atom "label";  Atom l;
        Atom "term";   Atom t;
        Atom "scheme"; Atom (u |> Uri.to_string)
      ])

  let decode s =
    match s with
    | Csexp.(List [
        Atom "label";  Atom l;
        Atom "term";   Atom t;
        Atom "scheme"; Atom u
      ]) -> Ok (Label (Single l), Term (Single t), u |> Uri.of_string)
    | _ -> Error "expected category but found none"

  let to_atom ?(base = Uri.empty) (Label (Single lbl),Term (Single trm),sch) =
    let sch = sch |> Http.reso ~base |> Uri.to_string in
    `El (((Xml.ns_a,"category"),[
        (("","label"),lbl);
        (("","term"),trm);
        (("","scheme"),sch);
      ]),[])
end

type id      = Id of string

(* Being "super-careful" https://code.mro.name/mro/ProgrammableWebSwartz2013/src/master/content/pages/2-building-for-users.md
 *
 * geohash uses a base 32 https://codeberg.org/mro/geohash/src/commit/ed8e71a03e377b472054a3468979a1cd77fc090d/lib/geohash.ml#L73
 *
 * See also https://opam.ocaml.org/packages/base32/ for int (we need more bits)
*)
module Base24 = struct
  open Optint.Int63

  let alphabet = Bytes.of_string "23456789abcdefghkrstuxyz"
  let base     = 24 |> of_int

  (* encode the n right chars of x *)
  let encode chars x =
    let int_to_char i = i |> Bytes.get alphabet in
    let rec f i x' b =
      match i with
      | -1 -> b
      | _ ->
        rem x' base |> to_int |> int_to_char |> Bytes.set b i;
        f (i - 1) (div x' base) b
    in
    chars |> Bytes.create |> f (chars - 1) x |> Bytes.to_string

  let decode hash =
    let int_of_char c =
      (* if we want it fast, either do binary search or construct a sparse LUT from chars 0-z -> int *)
      match c |> Bytes.index_opt alphabet with
      | None   -> Error c
      | Some i -> Ok i
    and len = hash |> String.length in
    match len <= 7 with
    | false -> Error '_'
    | true  ->
      let rec f idx x =
        match len - idx with
        | 0 -> Ok x
        | _ ->
          let* v = hash.[idx] |> int_of_char in
          v |> of_int
          |> add (mul x base)
          |> f (idx + 1)
      in
      f 0 zero
end

let mk_auth ~base a =
  let host = Uri.host base |> Option.value ~default:"-" in
  let userinfo = Uri.user a |> Option.value ~default:"-" in
  let s = Uri.make ~host ~userinfo () |> Uri.to_string in
  let le = s |> String.length in
  "@" ^ String.sub s 2 (le-2)

(* RFC7565 *)
let mk_auth_acct ~base a =
  let host = Uri.host base |> Option.value ~default:"-" in
  let userinfo = Uri.user a |> Option.value ~default:"-" in
  let s = Uri.make ~host ~userinfo () |> Uri.to_string in
  let le = s |> String.length in
  "acct:" ^ String.sub s 2 (le-2)

open Xml

let sep n = `Data ("\n" ^ String.make (2*n) ' ')

let xsl fn_xsl fn_xml =
  let x = fn_xml
          |> String.split_on_char '/'
          |> List.tl
          |> List.fold_left (fun a _ -> ".." :: a) ["themes";"current";fn_xsl]
          |> String.concat "/" in
  Some x

module Entry = struct
  type t = {
    id         : Uri.t;
    in_reply_to: Inreplyto.t list;
    (* assumes an antry has one language for title, tags, content. *)
    lang       : rfc4646;
    author     : Uri.t;
    title      : string;
    published  : Rfc3339.t;
    updated    : Rfc3339.t;
    links      : Link.t list;
    categories : Category.t list;
    content    : string;
  }

  (** inspired by https://code.mro.name/mro/ShaarliGo/src/cb798ebfae17431732e37a94ee80b29bd3b78911/atom.go#L302 *)
  let id_make t =
    let secs_since_epoch t : Optint.Int63.t =
      let (d',ps') = Ptime.epoch |> Ptime.diff t |> Ptime.Span.to_d_ps in
      let open Optint.Int63 in
      let ( +. ) = add
      and ( *. ) = mul
      and s = Int64.div ps' 1_000_000_000_000L |> of_int64
      and day_s = 24 * 60 * 60 |> of_int
      and d' = d' |> of_int in
      d' *. day_s +. s
    in
    let path = t |> secs_since_epoch |> Base24.encode 7 in
    Logr.debug (fun m -> m "id_make %s" path);
    Uri.make ~path ()

  let compare_published_desc a b =
    let Rfc3339.T a' = a.published
    and Rfc3339.T b' = b.published in 
    let r = String.compare b' a' in
    Logr.debug (fun m -> m "%s.%s %s %s = %d" "Rfc4287" "compare_published_desc" b' a' r);
    r

  let encode e =
    let Rfc4646 lang  = e.lang
    and Rfc3339.T published = e.published
    and Rfc3339.T updated   = e.updated
    in
    Csexp.(
      List [
        Atom "id";         Atom (e.id |> Uri.to_string);
        Atom "in-reply-to";List (e.in_reply_to |> List.map Inreplyto.encode);
        Atom "lang";       Atom lang;
        Atom "title";      Atom e.title;
        Atom "author";     Atom (e.author |> Uri.to_string);
        Atom "published";  Atom published;
        Atom "updated";    Atom updated;
        Atom "links";      List (e.links      |> List.map Link.encode);
        Atom "categories"; List (e.categories |> List.map Category.encode);
        Atom "content";    Atom e.content;
      ] )

  (* I am unsure if similar to https://opam.ocaml.org/packages/decoders-sexplib/
   * could help.
  *)
  let decode s =
    match s with
    | Csexp.(List [Atom _; Atom _]) -> Error "deleted"
    | Csexp.(List [
        Atom "id";         Atom id;
        Atom "in-reply-to";List in_reply_to;
        Atom "lang";       Atom lang;
        Atom "title";      Atom title;
        Atom "author";     Atom author;
        Atom "published";  Atom published;
        Atom "updated";    Atom updated;
        Atom "links";      List links;
        Atom "categories"; List categories;
        Atom "content";    Atom content;
      ]) ->
      let id           = id |> Uri.of_string
      and lang         = Rfc4646 lang
      and author       = author |> Uri.of_string
      and published    = Rfc3339.T published
      and updated      = Rfc3339.T updated in
      let* in_reply_to = in_reply_to|> list Inreplyto.decode in
      let* links       = links      |> list Link.decode in
      let* categories  = categories |> list Category.decode in
      Ok { id; in_reply_to; lang; author; title; published; updated; links; categories; content }
    | _ -> Error ("can't decode '" ^ (Csexp.to_string s) ^ "'")

  let decode_channel ic =
    let* lst = ic |> Csexp.input_many in
    let* lst = lst |> list decode in
    Ok lst

  let one_from_channel ic =
    let* r = ic |> Csexp.input in
    r |> decode

  let from_text_plain ~published ~author ~lang ~uri title content =
    Logr.debug (fun m -> m "new note %s\n%s" title content);
    let in_reply_to = [] in
    let links      = [] in
    let categories = []
    and links = (if uri |> Uri.host |> Option.is_none
                 then links
                 else (uri |> Link.make) :: links)
    and updated    = published in
    let* t         = published |> Rfc3339.to_ptime in
    let id         = t |> id_make in
    (*
     * - add attributedTo, id
     * - extract microformats (tags, mentions)
     * - via and thanks -> link via
     * - emojis -> tags
     *)
    Ok { id; in_reply_to; lang; author; published; updated; links; title; categories; content }

  let from_channel ?(published = Ptime_clock.now ()) ?(author = Uri.make ()) ~lang ~tz ic =
    Logr.debug (fun m -> m "Rfc4287.from_channel");
    let l1  = input_line ic
    and buf = Buffer.create 512
    and published = published |> Rfc3339.of_ptime ~tz in
    let uri = l1 |> Uri.of_string in
    let l1,uri = (if uri |> Uri.host |> Option.is_none
                  then (l1, Uri.empty)
                  else
                    let l1 = try
                        input_line ic
                      with End_of_file -> "" in
                    (l1,uri) ) in
    (try
       while true do
         ic
         |> input_line
         |> Buffer.add_string buf;
         Buffer.add_char buf '\n'
       done
     with End_of_file -> ());
    buf
    |> Buffer.contents
    |> from_text_plain ~published ~author ~lang ~uri l1

  let save _ =
  (*
   * - apend to storage csexp (tag feed
   * - update indices (id & url cdbs)
   * - recreate recent pages
   * - queue subscriber notification (aka followers)
   *)
    Error ("not implemented yet " ^ __LOC__)

  let to_atom ?(attr = []) ~base e : _ Xmlm.frag =
    let Rfc4646 lang = e.lang in
    let self = e.id |> Http.reso ~base in
    let id = self |> Uri.to_string in
    let lifo init item = sep 2 :: Link.to_atom ~base item :: init in
    let cafo init item = sep 2 :: Category.to_atom ~base item :: init in
    `El (((ns_a,"entry"),
          ((Xmlm.ns_xml,"lang"),lang)
          :: attr),
         sep 2 :: `El (((ns_a,"id"),[]),[`Data id])
         :: sep 2 :: `El (((ns_a,"title"),[(("","type"),"text")]),[`Data e.title])
         :: sep 2 :: Rfc3339.to_xml "updated" e.updated
         :: sep 2 :: Rfc3339.to_xml "published" e.published
         :: sep 2 :: `El (((ns_a,"author"),[]),
                          sep 3 :: `El (((ns_a,"name"),[]),[`Data (e.author |> mk_auth ~base)])
                          :: sep 3 :: `El (((ns_rfc7033,"uri"),[]),[`Data (e.author |> mk_auth_acct ~base)])
                          :: sep 3 :: `El (((ns_a,"uri"),[]),[`Data (base |> Uri.to_string)])
                          :: []
                         )
         :: sep 2 :: (Link.link ~rfc7033:None ~title:None ~href:self ~rel:Link.self |> Link.to_atom)
         :: (e.links |> List.fold_left lifo (
             e.categories |> List.fold_left cafo
               (sep 2
                :: `El (((ns_a,"content"),[(("","type"),"text")]),[`Data (match e.content with "" -> " " | c -> c)])
                :: sep 1
                :: [])))
        )

  let to_atom' ~base e = Ok (to_atom ~base e)
end

module Feed = struct
  let compute_links ?(min = 0) ~max ~base (a,b : string * int) =
    let j = ["";"-";"/index.xml"] in
    let compute_self ~base j v =
      let p0 = v |> Make.Jig.paste j |> Option.value ~default:"-" in
      let p0 = p0 |> St.before ~suffix:"/index.xml" |> Option.value ~default:"" in
      let path = base |> Uri.path in
      Uri.with_path base (path ^ p0 ^ "/")
    in
    let compute_first ~base j v =
      let v = match v with
        | [x;_] -> [x;"dirt"]
        | x     -> x in
      let p0 = v |> Make.Jig.paste j |> Option.value ~default:"-" in
      let p0 = p0 |> St.before ~suffix:"-dirt/index.xml" |> Option.value ~default:"" in
      let path = base |> Uri.path in
      Uri.with_path base (path ^ p0 ^ "/")
    in
    let compute_last ~base j v =
      let v = match v with
        | [x;_] -> [x;"0"]
        | x     -> x in
      let p0 = v |> Make.Jig.paste j |> Option.value ~default:"-" in
      let p0 = p0 |> St.before ~suffix:"/index.xml" |> Option.value ~default:"" in
      let path = base |> Uri.path in
      Uri.with_path base (path ^ p0 ^ "/")
    in
    let compute_prev ~max ~base j v =
      match v with
      | [a;b] -> let b = b |> int_of_string in
        if b <= max
        then
          let v = [a;b + 1 |> string_of_int] in
          let p0 = v |> Make.Jig.paste j |> Option.value ~default:"-" in
          let p0 = p0 |> St.before ~suffix:"/index.xml" |> Option.value ~default:"" in
          let path = base |> Uri.path in
          Some (Uri.with_path base (path ^ p0 ^ "/"))
        else None
      | _ -> None
    in
    let compute_next ?(min = 0) ~base j v =
      match v with
      | [a;b] -> let b = b |> int_of_string in
        if b > min
        then
          let v = [a;b - 1 |> string_of_int] in
          let p0 = v |> Make.Jig.paste j |> Option.value ~default:"-" in
          let p0 = p0 |> St.before ~suffix:"/index.xml" |> Option.value ~default:"" in
          let path = base |> Uri.path in
          Some (Uri.with_path base (path ^ p0 ^ "/"))
        else None
      | _ -> None
    in
    assert (Uri.empty |> Uri.equal base || base |> Uri.to_string |> St.ends_with ~suffix:"/");
    let v = [a;b |> string_of_int] in
    compute_self ~base j v,
    compute_first ~base j v,
    compute_last ~base j v,
    compute_prev ~max ~base j v,
    compute_next ~min ~base j v

  let head_to_atom
      ~base
      ~(self : Uri.t)
      ~prev
      ~next
      ~first
      ~last
      ~title
      ~updated
      ~lang
      ~(author : Uri.t)
      (init : _ Xmlm.frag list) : _ Xmlm.frag =
    let _ = author in
    let id = self |> Http.reso ~base |> Uri.to_string in
    let Rfc4646 lang = lang in
    let uri_to_page_num u =
      let u = u |> Uri.to_string in
      try Scanf.sscanf u "%[^-]-%d/" (fun _ num -> Some (string_of_int (num + 1)))
      with | _ -> None
    in
    let init = match next with
      | None      -> init
      | Some href -> (Link.link ~rfc7033:None ~title:(uri_to_page_num href) ~href ~rel:Link.next |> Link.to_atom) :: sep 1 :: init in
    let init = match prev with
      | None      -> init
      | Some href -> (Link.link ~rfc7033:None ~title:(uri_to_page_num href) ~href ~rel:Link.prev |> Link.to_atom) :: sep 1 :: init in
    `El (((ns_a,"feed"),[
        ((Xmlm.ns_xmlns,"xmlns"),ns_a);
        ((Xmlm.ns_xmlns,"wf"),ns_rfc7033);
        ((Xmlm.ns_xml,"lang"),lang);
        ((Xmlm.ns_xml,"base"),base |> Uri.to_string);
      ]),
         sep 1 :: `El (((ns_a,"id"),[]),[`Data id])
         :: sep 1 :: `El (((ns_a,"title"),[(("","type"),"text")]),[`Data title])
         :: sep 1 :: Rfc3339.to_xml "updated" updated
         :: sep 1 :: `El (((ns_a,"generator"),[ (("","uri"),St.seppo_s) ]),
                          `Data St.seppo_c :: [] )
         :: sep 1 :: (Link.link ~rfc7033:None ~title:(uri_to_page_num self) ~href:self  ~rel:Link.self |> Link.to_atom)
         :: sep 1 :: (Link.link ~rfc7033:None ~title:(Some "last") ~href:first ~rel:Link.first |> Link.to_atom)
         :: sep 1 :: (Link.link ~rfc7033:None ~title:(Some "1")    ~href:last  ~rel:Link.last  |> Link.to_atom)
         :: sep 1 :: init)

  let to_atom
      ~base
      ~self
      ~prev
      ~next
      ~first
      ~last
      ~title
      ~updated
      ~lang
      ~author
      entries : _ Xmlm.frag =
    let entry init item = Entry.to_atom ~base item :: sep 1 :: init in
    entries |> List.fold_left entry []
    |> head_to_atom
      ~base
      ~self
      ~prev
      ~next
      ~first
      ~last
      ~title
      ~updated
      ~lang
      ~author

  let to_atom_
      ~base
      ~self
      ~prev
      ~next
      ~first
      ~last
      ~title
      ~updated
      ~lang
      ~author
      _dst (es : (Entry.t,string) result list) : _ Xmlm.frag =
    es |> List.fold_left (fun a e ->
        match e with
        | Error e ->
          Logr.warn (fun m -> m "%s.%s ignore broken entry: %s" "Rfc4287.Feed" "to_atom_" e);
          a
        | Ok e    -> e :: a) []
    |> to_atom
      ~base
      ~self
      ~prev
      ~next
      ~first
      ~last
      ~title
      ~updated
      ~lang
      ~author

  let to_file fn (x : _ Xmlm.frag) =
    let xsl = fn |> xsl "posts.xsl" in
    File.out_channel fn (Xml.to_chan ~xsl x);
    Ok fn
end