lib/url.ml

   1
   2 (*
   3  * https://tools.ietf.org/html/rfc1738
   4  *)
   5
   6 type scheme = Scheme of string
   7 type uid    = Uid    of string
   8 type pwd    = Pwd    of string
   9 type host   = Host   of string
  10 type port   = Port   of string
  11 type path   = Path   of string
  12 type name   = Name   of string
  13 type value  = Value  of string
  14
  15 type par    = {
  16   name     : name ;
  17   value    : value ;
  18 }
  19
  20 type t = {
  21   scheme   : scheme ;
  22   uid      : uid ;
  23   pwd      : pwd ;
  24   host     : host ;
  25   port     : port ;
  26   path     : path ;
  27   query    : par list ;
  28   (* no fragment *)
  29 }
  30
  31 module P = struct
  32   open Tyre
  33
  34   let scheme' =
  35     let to_ s = Scheme s
  36     and of_ (Scheme o) = o in
  37     conv to_ of_ (pcre "https?")
  38
  39   let uid' =
  40     let to_ s = Uid s
  41     and of_ (Uid o) = o in
  42     conv to_ of_ (pcre "[^:]*")
  43
  44   let pwd' =
  45     let to_ s = Pwd s
  46     and of_ (Pwd o) = o in
  47     conv to_ of_ (pcre "[^@]*")
  48
  49   let host' =
  50     let to_ s = Host s
  51     and of_ (Host o) = o in
  52     conv to_ of_ (pcre "[^:/?]*")
  53
  54   let port' =
  55     let to_ s = Port s
  56     and of_ (Port o) = o in
  57     conv to_ of_ (pcre "[0-9]+")
  58
  59   let path' =
  60     let to_ s = Path s
  61     and of_ (Path o) = o in
  62     conv to_ of_ (pcre "[^?&]*")
  63
  64   let name' =
  65     let to_ s = Name s
  66     and of_ (Name o) = o in
  67     conv to_ of_ (pcre "[^=&]+")
  68
  69   let value' =
  70     let to_ s = Value s
  71     and of_ (Value o) = o in
  72     conv to_ of_ (pcre "[^&]*")
  73
  74   let par' =
  75     let to_ (name, value) = {name; value}
  76     and of_ {name; value} = (name, value)
  77     in
  78     conv to_ of_ (str "&" *> name' <&> str "=" *> value')
  79
  80   let query' =
  81     list par'
  82
  83   (* https://gabriel.radanne.net/papers/tyre/tyre_paper.pdf#page=9 *)
  84   let full =
  85     let to_ ((scheme, ((uid, pwd), (host, port))), (path, query)) =
  86       {scheme; uid; pwd; host; port; path; query}
  87     and of_ {scheme; uid; pwd; host; port; path; query} =
  88       ((scheme, ((uid, pwd), (host, port))), (path, query))
  89     in
  90     conv to_ of_ (
  91       (scheme' <* char ':' <* str "//" <&>
  92        ((uid' <* char ':' <&> pwd' <* char '@') <&>
  93        (host' <* char ':' <&> port'))) <&>
  94        (path' <&> query') <*
  95        stop)
  96
  97   let full' = compile full
  98 end
  99
 100 let parse str : t =
 101   match Tyre.exec P.full' str with
 102   | Error _ -> failwith "gibt's nicht."
 103   | Ok n -> n
 104