Source file link.ml

(*{{{ Copyright (c) 2015 David Sheets <sheets@alum.mit.edu>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
  }}}*)

open Sexplib.Std

(* From <https://tools.ietf.org/html/rfc5988> *)
module Rel = struct
  type t =
    | Extension of Uri.t
    | Alternate
    | Appendix
    | Bookmark
    | Chapter
    | Contents
    | Copyright
    | Current
    | Described_by
    | Edit
    | Edit_media
    | Enclosure
    | First
    | Glossary
    | Help
    | Hub
    | Index
    | Last
    | Latest_version
    | License
    | Next
    | Next_archive
    | Payment
    | Predecessor_version
    | Prev
    | Prev_archive
    | Related
    | Replies
    | Section
    | Self
    | Service
    | Start
    | Stylesheet
    | Subsection
    | Successor_version
    | Up
    | Version_history
    | Via
    | Working_copy
    | Working_copy_of
  [@@deriving sexp]

  let extension uri = Extension uri
  let alternate = Alternate
  let appendix = Appendix
  let bookmark = Bookmark
  let chapter = Chapter
  let contents = Contents
  let copyright = Copyright
  let current = Current
  let described_by = Described_by
  let edit = Edit
  let edit_media = Edit_media
  let enclosure = Enclosure
  let first = First
  let glossary = Glossary
  let help = Help
  let hub = Hub
  let index = Index
  let last = Last
  let latest_version = Latest_version
  let license = License
  let next = Next
  let next_archive = Next_archive
  let payment = Payment
  let predecessor_version = Predecessor_version
  let prev = Prev
  let prev_archive = Prev_archive
  let related = Related
  let replies = Replies
  let section = Section
  let self = Self
  let service = Service
  let start = Start
  let stylesheet = Stylesheet
  let subsection = Subsection
  let successor_version = Successor_version
  let up = Up
  let version_history = Version_history
  let via = Via
  let working_copy = Working_copy
  let working_copy_of = Working_copy_of
end

module Language = struct
  type t = string
  [@@deriving sexp]

  let to_string x = x
  let of_string x = x
end

module Charset = struct
  type t = string
  [@@deriving sexp]

  let to_string x = x
  let of_string x = x
end

module Ext = struct
  type 'a t = {
    charset : Charset.t;
    language : Language.t;
    value : 'a;
  } [@@deriving sexp, fields]

  let make ?(charset="") ?(language="") value = { charset; language; value }

  let map f x = { x with value = f x.value }
end

module Arc = struct
  type t = {
    reverse : bool;
    relation : Rel.t list;
    hreflang : string option;
    media : string option;
    title : string option;
    title_ext : string Ext.t option;
    media_type : (string * string) option;
    extensions : (string * string) list;
    extension_exts : (string * string Ext.t) list;
  } [@@deriving sexp]

  let empty = {
    reverse = false;
    relation = [];
    hreflang = None;
    media = None;
    title = None;
    title_ext = None;
    media_type = None;
    extensions = [];
    extension_exts = [];
  }

end

type t = {
  context : Uri.t;
  arc : Arc.t;
  target : Uri.t;
}
[@@deriving sexp]

(* TODO: this could be replaced with empty t/arc fupdate *)
type param =
  | Rel of Rel.t list
  | Anchor of Uri.t
  | Rev of Rel.t list
  | Hreflang of Language.t
  | Media of string
  | Title of string
  | Star of param Ext.t
  | Type of (string * string)
  | Link_extension of string * string

let until s start cl =
  let nextl = List.map (fun c ->
    let pattern = String.make 1 c in
    Stringext.find_from ~start s ~pattern
  ) cl in
  let min = List.fold_left (fun min_opt i_opt -> match min_opt, i_opt with
    | None, None -> None
    | Some i, None | None, Some i -> Some i
    | Some i, Some j -> Some (min i j)
  ) None nextl in
  match min with
  | None -> Stringext.string_after s start, String.length s
  | Some i -> String.sub s start (i - start), i

let string_of_rel = Rel.(function
  | Alternate -> "alternate"
  | Appendix -> "appendix"
  | Bookmark -> "bookmark"
  | Chapter -> "chapter"
  | Contents -> "contents"
  | Copyright -> "copyright"
  | Current -> "current"
  | Described_by -> "describedby"
  | Edit -> "edit"
  | Edit_media -> "edit-media"
  | Enclosure -> "enclosure"
  | First -> "first"
  | Glossary -> "glossary"
  | Help -> "help"
  | Hub -> "hub"
  | Index -> "index"
  | Last -> "last"
  | Latest_version -> "latest-version"
  | License -> "license"
  | Next -> "next"
  | Next_archive -> "next-archive"
  | Payment -> "payment"
  | Predecessor_version -> "predecessor-version"
  | Prev -> "prev"
  | Prev_archive -> "prev-archive"
  | Related -> "related"
  | Replies -> "replies"
  | Section -> "section"
  | Self -> "self"
  | Service -> "service"
  | Start -> "start"
  | Stylesheet -> "stylesheet"
  | Subsection -> "subsection"
  | Successor_version -> "successor-version"
  | Up -> "up"
  | Version_history -> "version-history"
  | Via -> "via"
  | Working_copy -> "working-copy"
  | Working_copy_of -> "working-copy-of"
  | Extension uri -> Uri.to_string uri
)

let rel_of_string s = Rel.(
  try ignore (String.index s ':'); Extension (Uri.of_string s)
  with Not_found -> match s with
    | "alternate" -> Alternate
    | "appendix" -> Appendix
    | "bookmark" -> Bookmark
    | "chapter" -> Chapter
    | "contents" -> Contents
    | "copyright" -> Copyright
    | "current" -> Current
    | "describedby" -> Described_by
    | "edit" -> Edit
    | "edit-media" -> Edit_media
    | "enclosure" -> Enclosure
    | "first" -> First
    | "glossary" -> Glossary
    | "help" -> Help
    | "hub" -> Hub
    | "index" -> Index
    | "last" -> Last
    | "latest-version" -> Latest_version
    | "license" -> License
    | "next" -> Next
    | "next-archive" -> Next_archive
    | "payment" -> Payment
    | "predecessor-version" -> Predecessor_version
    | "prev" | "previous" -> Prev
    | "prev-archive" -> Prev_archive
    | "related" -> Related
    | "replies" -> Replies
    | "section" -> Section
    | "self" -> Self
    | "service" -> Service
    | "start" -> Start
    | "stylesheet" -> Stylesheet
    | "subsection" -> Subsection
    | "successor-version" -> Successor_version
    | "up" -> Up
    | "version-history" -> Version_history
    | "via" -> Via
    | "working-copy" -> Working_copy
    | "working-copy-of" -> Working_copy_of
    | _ -> Extension (Uri.of_string s)
)

let quoted_string_of_string s q =
  let rec first_quote q =
    match String.get s q with
    | ' ' -> first_quote (q + 1)
    | '"' ->
      let q = q + 1 in
      begin match Stringext.find_from ~start:q s ~pattern:"\"" with
        | None -> Stringext.string_after s q, String.length s
        | Some q' -> String.sub s q (q' - q), q' + 1
      end
    | _   -> until s q [';';',']
  in
  first_quote q

let rels_of_string_ s q =
  let qs, i = quoted_string_of_string s q in
  let rels = Stringext.split qs ~on:' ' in
  List.map rel_of_string (List.filter (fun s -> String.length s > 0) rels), i

let rels_of_string s i =
  match Stringext.find_from ~start:i s ~pattern:"\"",
        until s i [';';',']
  with
  | Some q, (_,d) when q < d -> rels_of_string_ s q
  | _, (s,d) -> [rel_of_string s], d

let anchor_of_string s i =
  let qs, i = quoted_string_of_string s i in
  Uri.of_string qs, i

let star_of_string s i =
  match Stringext.find_from ~start:i s ~pattern:"'" with
  | None -> let s, i = quoted_string_of_string s i in "","",s,i
  | Some a ->
    let charset = String.sub s i (a - i) in
    let i = a + 1 in
    match Stringext.find_from ~start:i s ~pattern:"'" with
    | None -> let s, i = quoted_string_of_string s i in charset,"",s,i
    | Some a ->
      let language = String.sub s i (a - i) in
      let i = a + 1 in
      let s, i = quoted_string_of_string s i in
      charset, language, s, i

let media_type_of_string s i =
  let mt, i = quoted_string_of_string s i in
  match Stringext.split ~max:2 mt ~on:'/' with
  | [] -> ("",""), i
  | [t] -> (t,""), i
  | t::st::_ -> (t,st), i

let rec params_of_string s i ps =
  let _,d = until s i [';';','] in
  if d = String.length s
  then ps, None
  else if String.get s d = ','
  then ps, Some d
  else
    let i = d + 1 in
    let param, i = until s i ['='] in
    let i = i + 1 in
    match String.trim param with
    | "rel" ->
      let rels, i = rels_of_string s i in
      params_of_string s i ((Rel rels)::ps)
    | "anchor" ->
      let uri, i = anchor_of_string s i in
      params_of_string s i ((Anchor uri)::ps)
    | "rev" ->
      let rels, i = rels_of_string s i in
      params_of_string s i ((Rev rels)::ps)
    | "hreflang" ->
      let hreflang, i = until s i [',';';'] in
      params_of_string s i ((Hreflang hreflang)::ps)
    | "media" ->
      let media, i = quoted_string_of_string s i in
      params_of_string s i ((Media media)::ps)
    | "title" ->
      let title, i = quoted_string_of_string s i in
      params_of_string s i ((Title title)::ps)
    | "title*" ->
      let charset, language, v, i = star_of_string s i in
      params_of_string s i ((Star { Ext.charset; language; value = Title v })::ps)
    | "type" ->
      let media_type, i = media_type_of_string s i in
      params_of_string s i ((Type media_type)::ps)
    | other when String.length other = 0 ->
      let s, i = quoted_string_of_string s i in
      params_of_string s i ((Link_extension ("", s))::ps)
    | other ->
      let last = String.length other - 1 in
      if String.get other last = '*'
      then
        let main = String.sub other 0 last in
        let charset, language, v, i = star_of_string s i in
        params_of_string s i
          ((Star { Ext.charset; language; value = Link_extension (main, v) })::ps)
      else
        let v, i = quoted_string_of_string s i in
        params_of_string s i ((Link_extension (other, v))::ps)

let rec find_or_default f d = function
  | [] -> d
  | h::t -> match f h with
    | None -> find_or_default f d t
    | Some v -> v

let arc_of_relation_params ?(reverse=false) relation params =
  let extensions, extension_exts = List.fold_left (fun (x,xx) -> function
    | Link_extension (k, v) -> ((k, v)::x,xx)
    | Star { Ext.charset; language; value = Link_extension (k, value) } ->
      (x,(k,{ Ext.charset; language; value })::xx)
    | _ -> (x,xx)
  ) ([],[]) params in
  {
    Arc.reverse;
    relation;
    hreflang=find_or_default
        (function Hreflang l -> Some (Some l) | _ -> None) None params;
    media=find_or_default
        (function Media m -> Some (Some m) | _ -> None) None params;
    title=find_or_default
        (function Title t -> Some (Some t) | _ -> None) None params;
    title_ext=find_or_default
        (function
          | Star { Ext.charset; language; value = Title t } ->
            Some (Some { Ext.charset; language; value = t })
          | _ -> None
        )
        None params;
    media_type=find_or_default
        (function Type mt -> Some (Some mt) | _ -> None) None params;
    extensions;
    extension_exts;
  }

let empty = {
  context = Uri.of_string "";
  arc = Arc.empty;
  target = Uri.of_string "";
}

let rec unfold s list start =
  match Stringext.find_from ~start s ~pattern:"<" with
  | None -> list
  | Some i ->
    let uri_ref, i = until s (i + 1) ['>'] in
    let i = i + 1 in
    let target = Uri.of_string uri_ref in
    let params, c_opt = params_of_string s i [] in
    let params = List.rev params in
    let context = find_or_default
        (function Anchor uri -> Some uri | _ -> None)
        (Uri.of_string "")
        params
    in
    let link = match find_or_default
                       (function Rel rels -> Some rels | _ -> None) [] params
      with
      | (_::_) as relation ->
        let arc = arc_of_relation_params relation params in
        { context; arc; target }
      | [] ->
        match find_or_default
                (function Rev rels -> Some rels | _ -> None) [] params
        with
        | [] ->
          let arc = arc_of_relation_params [] params in
          { context; arc; target }
        | rev ->
          let arc = arc_of_relation_params ~reverse:true rev params in
          { context = target; arc; target = context }
    in
    let list = link::list in
    match c_opt with
    | None -> list
    | Some c -> unfold s list c

let of_string s =
  List.rev (unfold s [] 0)

open Printf

let arc_to_string context arc = Arc.(
  let attrs = match arc.relation with
    | [] -> []
    | rels -> [
        sprintf "%s=\"%s\"" (if arc.reverse then "rev" else "rel")
          (String.concat " " (List.map string_of_rel rels))
      ]
  in
  let attrs = match arc.hreflang with
    | None -> attrs
    | Some s -> ("hreflang="^s)::attrs
  in
  let attrs = match arc.media with
    | None -> attrs
    | Some s -> (sprintf "media=\"%s\"" s)::attrs
  in
  let attrs = match arc.title with
    | None -> attrs
    | Some s -> (sprintf "title=%S" s)::attrs (* TODO: this isn't quite right...*)
  in
  let attrs = match arc.title_ext with
    | None -> attrs
    | Some { Ext.charset; language; value } ->
      (sprintf "title*=%s'%s'%s" charset language value)::attrs
  in
  let attrs = match arc.media_type with
    | None -> attrs
    | Some (typ,sub) -> (sprintf "type=%s/%s" typ sub)::attrs
  in
  let attrs =
    (List.map (fun (k,v) -> sprintf "%s=%S" k v) arc.extensions)@attrs
  in
  let attrs = (List.map (fun (k,{ Ext.charset; language; value }) ->
    sprintf "%s=%s'%s'%s" k charset language value
  ) arc.extension_exts)@attrs in
  let attrs =
    if context = Uri.of_string ""
    then attrs
    else (sprintf "anchor=\"%s\"" (Uri.to_string context))::attrs
  in String.concat "; " attrs
)

let to_string ({ context; arc; target }) =
  sprintf "<%s>; %s" (Uri.to_string target) (arc_to_string context arc)