Export regexp in Lang, add to_string

src/core/builtins/builtins_harbor.ml

@@ -56,7 +56,7 @@ module Make (Harbor : T) = struct
           Some
             "Accepted method (\"GET\" / \"POST\" / \"PUT\" / \"DELETE\" / \
              \"HEAD\" / \"OPTIONS\")." );
-        ("", Lang.string_t, None, Some "URI to serve.");
+        ("", Lang.regexp_t, None, Some "URI to serve.");
         ( "",
           Lang.fun_t
             [
@@ -82,7 +82,7 @@ module Make (Harbor : T) = struct
         let verb =
           Harbor.verb_of_string (Lang.to_string (List.assoc "method" p))
         in
-        let uri = Lang.to_string (Lang.assoc "" 1 p) in
+        let uri = Lang.to_regexp (Lang.assoc "" 1 p) in
         let f = Lang.assoc "" 2 p in
         let f ~protocol ~data ~headers ~socket:_ uri =
           let l =
@@ -118,12 +118,12 @@ module Make (Harbor : T) = struct
           Lang.string_t,
           Some (Lang.string "GET"),
           Some "Method served." );
-        ("", Lang.string_t, None, Some "URI served.");
+        ("", Lang.regexp_t, None, Some "URI served.");
       ]
       Lang.unit_t
       (fun p ->
         let port = Lang.to_int (List.assoc "port" p) in
-        let uri = Lang.to_string (Lang.assoc "" 1 p) in
+        let uri = Lang.to_regexp (Lang.assoc "" 1 p) in
         let verb =
           Harbor.verb_of_string (Lang.to_string (List.assoc "method" p))
         in

src/core/harbor/harbor.ml

@@ -23,6 +23,7 @@
 open Harbor_base
 module Monad = Duppy.Monad
 module Type = Liquidsoap_lang.Type
+module Regexp = Liquidsoap_lang.Regexp
 
 let ( let* ) = Duppy.Monad.bind
 
@@ -102,10 +103,10 @@ module type T = sig
   val reply : (unit -> string) -> ('a, reply) Duppy.Monad.t
 
   val add_http_handler :
-    port:int -> verb:http_verb -> uri:string -> http_handler -> unit
+    port:int -> verb:http_verb -> uri:Lang.regexp -> http_handler -> unit
 
   val remove_http_handler :
-    port:int -> verb:http_verb -> uri:string -> unit -> unit
+    port:int -> verb:http_verb -> uri:Lang.regexp -> unit -> unit
 
   (* Source input *)
 
@@ -265,7 +266,7 @@ module Make (T : Transport_t) : T with type socket = T.socket = struct
     string ->
     (reply, reply) Duppy.Monad.t
 
-  type http_handlers = (http_verb * string, http_handler) Hashtbl.t
+  type http_handlers = (http_verb * Lang.regexp, http_handler) Hashtbl.t
   type handler = { sources : sources; http : http_handlers }
   type open_port = handler * Unix.file_descr list
 
@@ -727,10 +728,11 @@ module Make (T : Transport_t) : T with type socket = T.socket = struct
 
     (* First, try with a registered handler. *)
     let handler, _ = find_handler port in
-    let f (verb, reg_uri) handler =
-      let rex = Pcre.regexp reg_uri in
-      if (verb :> verb) = hmethod && Pcre.pmatch ~rex uri then (
-        log#info "Found handler '%s %s' on port %d." smethod reg_uri port;
+    let f (verb, rex) handler =
+      if (verb :> verb) = hmethod && Regexp.test ~rex:rex.Lang.regexp uri then (
+        log#info "Found handler '%s %s' on port %d." smethod
+          (Regexp.to_string rex.Lang.regexp)
+          port;
         raise (Handled handler))
       else ()
     in
@@ -1030,7 +1032,9 @@ module Make (T : Transport_t) : T with type socket = T.socket = struct
     let exec () =
       let handler = get_handler ~icy:false port in
       log#important "Adding handler for '%s %s' on port %i"
-        (string_of_verb verb) uri port;
+        (string_of_verb verb)
+        (Regexp.to_string uri.Lang.regexp)
+        port;
       if Hashtbl.mem handler.http (verb, uri) then
         log#important "WARNING: Handler already registered, old one removed!"
       else ();
@@ -1044,7 +1048,9 @@ module Make (T : Transport_t) : T with type socket = T.socket = struct
       let handler, socks = Hashtbl.find opened_ports port in
       assert (Hashtbl.mem handler.http (verb, uri));
       log#important "Removing handler for '%s %s' on port %i"
-        (string_of_verb verb) uri port;
+        (string_of_verb verb)
+        (Regexp.to_string uri.Lang.regexp)
+        port;
       Hashtbl.remove handler.http (verb, uri);
       if Hashtbl.length handler.sources = 0 && Hashtbl.length handler.http = 0
       then (

src/core/hooks_implementations.ml

@@ -14,7 +14,8 @@ let () =
 module Regexp = struct
   open Liquidsoap_lang.Regexp
 
-  type t += Regexp of Pcre.regexp
+  type regexp = { string : string; regexp : Pcre.regexp }
+  type t += Regexp of regexp
   type sub += Sub of Pcre.substrings
 
   let cflags_of_flags (flags : flag list) =
@@ -28,16 +29,31 @@ module Regexp = struct
           | `m -> `MULTILINE :: l)
       [] flags
 
+  let string_of_flags (flags : flag list) =
+    String.concat ""
+      (List.map
+         (function `i -> "i" | `g -> "g" | `s -> "s" | `m -> "m")
+         flags)
+
   let regexp ?(flags = []) s =
     let iflags = Pcre.cflags (cflags_of_flags flags) in
-    Regexp (Pcre.regexp ~iflags s)
+    let regexp = Pcre.regexp ~iflags s in
+    let string = Printf.sprintf "/%s/%s" s (string_of_flags flags) in
+    Regexp { string; regexp }
 
   let regexp_or ?(flags = []) l =
     let iflags = Pcre.cflags (cflags_of_flags flags) in
-    Regexp (Pcre.regexp_or ~iflags l)
+    let regexp = Pcre.regexp_or ~iflags l in
+    let string =
+      Printf.sprintf "/%s/%s" (String.concat "|" l) (string_of_flags flags)
+    in
+    Regexp { string; regexp }
+
+  let get_rex =
+    Option.map (function Regexp { regexp } -> regexp | _ -> assert false)
 
-  let get_rex = Option.map (function Regexp r -> r | _ -> assert false)
   let get_sub = function Sub s -> s | _ -> assert false
+  let to_string = function Regexp { string } -> string | _ -> assert false
   let split ?pat ?rex s = Pcre.split ?pat ?rex:(get_rex rex) s
   let exec ?pat ?rex s = Sub (Pcre.exec ?pat ?rex:(get_rex rex) s)
   let test ?pat ?rex s = Pcre.pmatch ?pat ?rex:(get_rex rex) s

src/core/lang.mli

@@ -29,6 +29,12 @@ type t = Liquidsoap_lang.Type.t
 
 type scheme = Liquidsoap_lang.Type.scheme
 
+type regexp = Liquidsoap_lang.Lang.regexp = {
+  descr : string;
+  flags : [ `i | `g | `s | `m ] list;
+  regexp : Liquidsoap_lang.Regexp.t;
+}
+
 (** {2 Values} *)
 
 (** A typed value. *)
@@ -170,6 +176,7 @@ val to_bool : value -> bool
 val to_bool_getter : value -> unit -> bool
 val to_string : value -> string
 val to_string_getter : value -> unit -> string
+val to_regexp : value -> regexp
 val to_float : value -> float
 val to_float_getter : value -> unit -> float
 val to_error : value -> Runtime_error.runtime_error
@@ -202,6 +209,7 @@ val unit_t : t
 val float_t : t
 val bool_t : t
 val string_t : t
+val regexp_t : t
 val product_t : t -> t -> t
 val of_product_t : t -> t * t
 val tuple_t : t list -> t
@@ -241,6 +249,7 @@ val int : int -> value
 val bool : bool -> value
 val float : float -> value
 val string : string -> value
+val regexp : regexp -> value
 val list : value list -> value
 val null : value
 val error : Runtime_error.runtime_error -> value

src/core/outputs/harbor_output.ml

@@ -350,6 +350,13 @@ module Make (T : T) = struct
     let uri =
       match mount.[0] with '/' -> mount | _ -> Printf.sprintf "%c%s" '/' mount
     in
+    let uri_rex =
+      {
+        Lang.descr = uri;
+        flags = [];
+        regexp = Liquidsoap_lang.Regexp.regexp uri;
+      }
+    in
     let autostart = Lang.to_bool (List.assoc "start" p) in
     let infallible = not (Lang.to_bool (List.assoc "fallible" p)) in
     let on_start =
@@ -607,15 +614,15 @@ module Make (T : T) = struct
           let args = Http.args_split args in
           self#add_client ~protocol ~headers ~uri ~args socket
         in
-        Harbor.add_http_handler ~port ~verb:`Get ~uri handler;
+        Harbor.add_http_handler ~port ~verb:`Get ~uri:uri_rex handler;
         match dumpfile with
           | Some f -> dump <- Some (open_out_bin f)
           | None -> ()
 
       method stop =
         ignore ((Option.get encoder).Encoder.stop ());
         encoder <- None;
-        Harbor.remove_http_handler ~port ~verb:`Get ~uri ();
+        Harbor.remove_http_handler ~port ~verb:`Get ~uri:uri_rex ();
         let new_clients = Queue.create () in
         Tutils.mutexify clients_m
           (fun () ->

src/js/regexp_js.ml

@@ -11,6 +11,8 @@ let string_of_flag = function `i -> "i" | `g -> "g" | `s -> "s" | `m -> "m"
 let flags_of_flags flags =
   Js.string (String.concat "" (List.map string_of_flag flags))
 
+let to_string r = Js.to_string (get_regexp r)##toString
+
 let regexp ?(flags = []) s =
   Regexp (new%js Js.regExp_withFlags (Js.string s) (flags_of_flags flags))
 

src/lang/builtins_regexp.ml

@@ -20,7 +20,7 @@
 
  *****************************************************************************)
 
-type regexp = {
+type regexp = Lang_core.regexp = {
   descr : string;
   flags : [ `i | `g | `s | `m ] list;
   regexp : Regexp.t;
@@ -77,29 +77,31 @@ module RegExp = Value.MkAbstract (struct
       (r'.descr, List.sort Stdlib.compare r'.flags)
 end)
 
-let test_t = Lang.fun_t [(false, "", Lang.string_t)] Lang.bool_t
+let test_t = Lang_core.fun_t [(false, "", Lang_core.string_t)] Lang_core.bool_t
 
 let test_fun ~flags:_ rex =
-  Lang.val_fun [("", "", None)] (fun p ->
-      let string = Lang.to_string (List.assoc "" p) in
-      Lang.bool (Regexp.test ~rex string))
+  Lang_core.val_fun [("", "", None)] (fun p ->
+      let string = Lang_core.to_string (List.assoc "" p) in
+      Lang_core.bool (Regexp.test ~rex string))
 
 let split_t =
-  Lang.fun_t [(false, "", Lang.string_t)] (Lang.list_t Lang.string_t)
+  Lang_core.fun_t
+    [(false, "", Lang_core.string_t)]
+    (Lang_core.list_t Lang_core.string_t)
 
 let split_fun ~flags:_ rex =
-  Lang.val_fun [("", "", None)] (fun p ->
-      let string = Lang.to_string (List.assoc "" p) in
-      Lang.list (List.map Lang.string (Regexp.split ~rex string)))
+  Lang_core.val_fun [("", "", None)] (fun p ->
+      let string = Lang_core.to_string (List.assoc "" p) in
+      Lang_core.list (List.map Lang_core.string (Regexp.split ~rex string)))
 
 let exec_t =
-  Lang.fun_t
-    [(false, "", Lang.string_t)]
-    (Lang.list_t (Lang.product_t Lang.int_t Lang.string_t))
+  Lang_core.fun_t
+    [(false, "", Lang_core.string_t)]
+    (Lang_core.list_t (Lang_core.product_t Lang_core.int_t Lang_core.string_t))
 
 let exec_fun ~flags:_ regexp =
-  Lang.val_fun [("", "", None)] (fun p ->
-      let string = Lang.to_string (List.assoc "" p) in
+  Lang_core.val_fun [("", "", None)] (fun p ->
+      let string = Lang_core.to_string (List.assoc "" p) in
       try
         let sub = Regexp.exec ~rex:regexp string in
         let n = Regexp.num_of_subs sub in
@@ -110,27 +112,34 @@ let exec_fun ~flags:_ regexp =
           else List.rev acc
         in
         let l = extract [] 1 in
-        Lang.list
-          (List.map (fun (x, y) -> Lang.product (Lang.int x) (Lang.string y)) l)
-      with Not_found -> Lang.list [])
+        Lang_core.list
+          (List.map
+             (fun (x, y) ->
+               Lang_core.product (Lang_core.int x) (Lang_core.string y))
+             l)
+      with Not_found -> Lang_core.list [])
 
 let replace_t =
-  Lang.fun_t
+  Lang_core.fun_t
     [
-      (false, "", Lang.fun_t [(false, "", Lang.string_t)] Lang.string_t);
-      (false, "", Lang.string_t);
+      ( false,
+        "",
+        Lang_core.fun_t [(false, "", Lang_core.string_t)] Lang_core.string_t );
+      (false, "", Lang_core.string_t);
     ]
-    Lang.string_t
+    Lang_core.string_t
 
 let replace_fun ~flags regexp =
-  Lang.val_fun [("", "", None); ("", "", None)] (fun p ->
-      let subst = Lang.assoc "" 1 p in
-      let pos = match subst.Lang.pos with Some pos -> [pos] | None -> [] in
+  Lang_core.val_fun [("", "", None); ("", "", None)] (fun p ->
+      let subst = Lang_core.assoc "" 1 p in
+      let pos =
+        match subst.Lang_core.pos with Some pos -> [pos] | None -> []
+      in
       let subst s =
-        let ret = Lang.apply subst [("", Lang.string s)] in
-        Lang.to_string ret
+        let ret = Lang_core.apply subst [("", Lang_core.string s)] in
+        Lang_core.to_string ret
       in
-      let string = Lang.to_string (Lang.assoc "" 2 p) in
+      let string = Lang_core.to_string (Lang_core.assoc "" 2 p) in
       let sub =
         if List.mem `g flags then Regexp.substitute else Regexp.substitute_first
       in
@@ -147,7 +156,7 @@ let replace_fun ~flags regexp =
                  pos;
                })
       in
-      Lang.string string)
+      Lang_core.string string)
 
 let () =
   let meth =
@@ -171,37 +180,37 @@ let () =
     ]
   in
   let t =
-    Lang.method_t RegExp.t
+    Lang_core.method_t RegExp.t
       (List.map (fun (name, typ, doc, _) -> (name, typ, doc)) meth)
   in
-  Lang.add_builtin "regexp" ~category:`String
+  Lang_core.add_builtin "regexp" ~category:`String
     ~descr:"Create a regular expression"
     [
       ( "flags",
-        Lang.list_t Lang.string_t,
-        Some (Lang.list []),
+        Lang_core.list_t Lang_core.string_t,
+        Some (Lang_core.list []),
         Some
           (Printf.sprintf "List of flags. Valid flags: %s."
              (String.concat ", "
                 (List.map
                    (fun f ->
                      Printf.sprintf "`\"%s\"`" (string_of_regexp_flag f))
                    all_regexp_flags))) );
-      ("", Lang.string_t, None, None);
+      ("", Lang_core.string_t, None, None);
     ]
     t
     (fun p ->
       let flags =
         List.map
           (fun v ->
-            try regexp_flag_of_string (Lang.to_string v)
+            try regexp_flag_of_string (Lang_core.to_string v)
             with _ -> raise (Error.Invalid_value (v, "Invalid regexp flag")))
-          (Lang.to_list (List.assoc "flags" p))
+          (Lang_core.to_list (List.assoc "flags" p))
       in
-      let descr = Lang.to_string (List.assoc "" p) in
+      let descr = Lang_core.to_string (List.assoc "" p) in
       let regexp = Regexp.regexp ~flags descr in
       let v = RegExp.to_value { descr; flags; regexp } in
       let meth =
         List.map (fun (name, _, _, fn) -> (name, fn ~flags regexp)) meth
       in
-      Lang.meth v meth)
+      Lang_core.meth v meth)

src/lang/lang.ml

@@ -1,2 +1,6 @@
 include Lang_core
 include Lang_error
+
+let regexp_t = Builtins_regexp.RegExp.t
+let to_regexp = Builtins_regexp.RegExp.of_value
+let regexp = Builtins_regexp.RegExp.to_value