builder-web/lib/utils.ml

module String_map = struct
  include Map.Make(String)

  let add_or_create key v t=
    update key (function None -> Some [ v ] | Some xs -> Some (v :: xs)) t
end

let diff_map a b =
  let diff a b =
    String_map.fold (fun k v acc ->
      if not (String_map.mem k b) then (k, v) :: acc else acc)
      a [] |> List.rev
  in
  let added = diff b a
  and removed = diff a b
  and changed =
    String_map.fold (fun k v acc ->
      match String_map.find_opt k b with
      | None -> acc
      | Some v' -> if String.equal v v' then acc else (k, v, v') :: acc)
    a [] |> List.rev
  in
  (added, removed, changed)

let compare_env env1 env2 =
  let parse_env e =
    List.fold_left (fun m s ->
      match Astring.String.cut ~sep:"=" s with
      | Some (key, value) -> String_map.add key value m
      | None -> String_map.add s "" m)
    String_map.empty (Astring.String.cuts ~sep:"\n" e)
  in
  diff_map (parse_env env1) (parse_env env2)

let compare_pkgs p1 p2 =
  let parse_pkgs p =
    List.fold_left (fun m s ->
      match Astring.String.cut ~sep:"=" s with
      | Some (name, version) -> String_map.add name version m
      | None -> match Astring.String.cut ~sep:"-" s with
        | Some (name, version) -> String_map.add name version m
        | None -> String_map.add s "" m)
    String_map.empty (Astring.String.cuts ~sep:"\n" p)
  in
  diff_map (parse_pkgs p1) (parse_pkgs p2)

module Omd = struct

  let make_safe omd =
    let rec safe_block = function
      | Omd.Paragraph (attr, inline) ->
        safe_inline inline
        |> Option.map (fun inline -> Omd.Paragraph (attr, inline))
      | Omd.List (attr, typ, spacing, blocks) ->
        let blocks = List.filter_map (fun b ->
          let b = List.filter_map safe_block b in
          if b = [] then None else Some b)
          blocks
        in
        if blocks = [] then None else
          Some (Omd.List (attr, typ, spacing, blocks))
      | Omd.Blockquote (attr, blocks) ->
        let blocks = List.filter_map safe_block blocks in
        if blocks = [] then None else
          Some (Omd.Blockquote (attr, blocks))
      | Omd.Heading (attr, level, inline) ->
        safe_inline inline
        |> Option.map (fun inline -> Omd.Heading (attr, level, inline))
      | Omd.Html_block _ -> None
      | Omd.Definition_list (attr, def_elts) ->
        let def_elts = List.filter_map safe_def_elts def_elts in
        if def_elts = [] then None else
          Some (Omd.Definition_list (attr, def_elts))
      | Omd.Code_block _
      | Omd.Thematic_break _ as v -> Some v
      | Omd.Table (attr, header_row, rows) ->
        let header_row =
          List.fold_left (fun acc (cell, alignment) ->
              match acc with
              | None -> None
              | Some xs ->
                Option.map (fun cell -> xs @ [ cell, alignment ])
                  (safe_inline cell))
            (Some []) header_row
        in
        Option.map
          (fun header_row ->
             let rows =
               List.filter_map (fun row ->
                   List.fold_left (fun acc cell ->
                       match acc with
                       | None -> None
                       | Some xs -> Option.map (fun cell -> xs @ [ cell ])
                                      (safe_inline cell))
                     (Some []) row)
                 rows
             in
             Omd.Table (attr, header_row, rows))
          header_row
    and safe_def_elts { term ; defs } =
      let defs = List.filter_map safe_inline defs in
      safe_inline term
      |> Option.map (fun term -> { Omd.term ; defs })
    and safe_inline = function
      | Concat (attr, inline) ->
        Some (Concat (attr, List.filter_map safe_inline inline))
      | Emph (attr, inline) ->
        safe_inline inline
        |> Option.map (fun inline -> Omd.Emph (attr, inline))
      | Strong (attr, inline) ->
        safe_inline inline
        |> Option.map (fun inline -> Omd.Strong (attr, inline))
      | Link (attr, link) ->
        begin match safe_link link with
          | `No_label | `Relative -> safe_inline link.Omd.label
          | `Link l -> Some (Omd.Link (attr, l))
        end
      | Image (attr, link) ->
        begin match safe_link link with
          | `No_label | `Relative -> None
          | `Link l -> Some (Omd.Image (attr, l))
        end
      | Html _ -> None
      | Text _
      | Code _
      | Hard_break _
      | Soft_break _ as v -> Some v
    and safe_link ({ label ; destination ; _ } as l) =
      let absolute_link =
        String.(length destination >= 2 && equal (sub destination 0 2) "//") ||
        String.(length destination >= 7 && equal (sub destination 0 7) "http://") ||
        String.(length destination >= 8 && equal (sub destination 0 8) "https://")
      in
      if absolute_link then
        match safe_inline label with
        | None -> `No_label
        | Some label -> `Link { l with label }
      else
        `Relative
    in
    List.filter_map safe_block omd

  let html_of_string markdown =
    markdown
    |> Omd.of_string
    |> make_safe
    |> Omd.to_html

end

module Path = struct

  let to_url ~path ~queries =
    let path = match path with
      | "" :: [] -> "/"
      | path -> "/" ^ String.concat "/" path
    in
    let query = queries |> List.map (fun (k, v) -> k, [v]) in
    Uri.make ~path ~query () |> Uri.to_string

  (* Like Dream.path in 1.0.0~alpha2 but on Dream.target *)
  let of_url uri_str =
    let path_str = uri_str |> Uri.of_string |> Uri.path in
    match String.split_on_char '/' path_str with
    | "" :: (_ :: _ as tail) -> tail
    | path -> path

  let matches_dreamroute ~path dreamroute =
    let is_match path_elem dpath_elem =
      (dpath_elem |> String.starts_with ~prefix:":")
      || path_elem = dpath_elem
    in
    let rec aux path dreampath =
      match path, dreampath with
      | []     , _ :: _   -> false   (*length path < length dreampath*)
      | _      , []       -> true    (*length path >= length dreampath *)
      | _ :: _ , "" :: [] -> true    (*dreampath ends in '/'*)
      | p_elem :: path, dp_elem :: dreampath ->
        is_match p_elem dp_elem
        && aux path dreampath
    in
    let dreampath = dreamroute |> of_url in
    aux path dreampath

end