Wrap it up!

src/core/builtins/builtins_files_extra.ml

@@ -51,8 +51,8 @@ let () =
       let file_perms = Lang.to_int (List.assoc "perms" p) in
       let path = Lang_string.home_unrelate (Lang.to_string (List.assoc "" p)) in
       try
-        Builtins_socket.SocketValue.to_value
-          (Unix.openfile path flags file_perms)
+        Builtins_socket.SocketValue.(
+          to_value (of_unix_file_descr (Unix.openfile path flags file_perms)))
       with exn ->
         let bt = Printexc.get_raw_backtrace () in
         Lang.raise_as_runtime ~bt ~kind:"file" exn)

src/core/builtins/builtins_harbor.ml

@@ -29,81 +29,221 @@ end
 
 module Make (Harbor : T) = struct
   let name_up = String.uppercase_ascii Harbor.name
-  let resp_t = Lang.getter_t Lang.string_t
   let () = Lang.add_module ("harbor." ^ Harbor.name)
 
+  let request_t =
+    Lang.record_t
+      [
+        ("protocol", Lang.string_t);
+        ("method", Lang.string_t);
+        ("data", Lang.string_t);
+        ("headers", Lang.list_t (Lang.product_t Lang.string_t Lang.string_t));
+        ("query", Lang.list_t (Lang.product_t Lang.string_t Lang.string_t));
+        ("socket", Builtins_socket.SocketValue.t);
+        ("path", Lang.string_t);
+      ]
+
+  let response_t =
+    let getter_setter_t ty =
+      Lang.method_t
+        (Lang.fun_t [(false, "", ty)] Lang.unit_t)
+        [("current", ([], Lang.fun_t [] ty), "Get current value")]
+    in
+    Lang.record_t
+      [
+        ("protocol", getter_setter_t Lang.string_t);
+        ("code", getter_setter_t Lang.int_t);
+        ("status", getter_setter_t (Lang.nullable_t Lang.string_t));
+        ("data", getter_setter_t (Lang.getter_t Lang.string_t));
+        ("content_type", getter_setter_t (Lang.nullable_t Lang.string_t));
+        ( "headers",
+          getter_setter_t
+            (Lang.list_t (Lang.product_t Lang.string_t Lang.string_t)) );
+        ("custom", getter_setter_t Lang.bool_t);
+      ]
+
+  let register_args =
+    [
+      ("port", Lang.int_t, Some (Lang.int 8000), Some "Port to server.");
+      ( "method",
+        Lang.string_t,
+        Some (Lang.string "GET"),
+        Some
+          "Accepted method (\"GET\" / \"POST\" / \"PUT\" / \"DELETE\" / \
+           \"HEAD\" / \"OPTIONS\")." );
+      ( "",
+        Lang.fun_t [(false, "", request_t); (false, "", response_t)] Lang.unit_t,
+        None,
+        Some "Handler function" );
+    ]
+
+  let parse_register_args p =
+    let port = Lang.to_int (List.assoc "port" p) in
+    let verb = Harbor.verb_of_string (Lang.to_string (List.assoc "method" p)) in
+    let f = Lang.assoc "" 2 p in
+    let handler ~protocol ~meth ~data ~headers ~query ~socket path =
+      let meth = Harbor.string_of_verb meth in
+      let headers =
+        List.map
+          (fun (x, y) -> Lang.product (Lang.string x) (Lang.string y))
+          headers
+      in
+      let headers = Lang.list headers in
+      let query =
+        List.map
+          (fun (x, y) -> Lang.product (Lang.string x) (Lang.string y))
+          query
+      in
+      let query = Lang.list query in
+      let socket =
+        object
+          method typ = Harbor.socket_type
+          method read = Harbor.read socket
+          method write = Harbor.write socket
+          method close = Harbor.close socket
+        end
+      in
+      let socket = Builtins_socket.SocketValue.to_value socket in
+      let request =
+        Lang.record
+          [
+            ("protocol", Lang.string protocol);
+            ("method", Lang.string meth);
+            ("headers", headers);
+            ("query", query);
+            ("socket", socket);
+            ("data", Lang.string data);
+            ("path", Lang.string path);
+          ]
+      in
+
+      let resp_protocol = Atomic.make protocol in
+      let resp_code = Atomic.make 200 in
+      let resp_status = Atomic.make None in
+      let resp_headers = Atomic.make [] in
+      let resp_content_type = Atomic.make None in
+      let resp_data = Atomic.make (fun () -> "") in
+      let resp_custom = Atomic.make false in
+
+      let getter_setter to_v of_v v =
+        Lang.meth
+          (Lang.val_fun [("", "", None)] (fun p ->
+               Atomic.set v (of_v (List.assoc "" p));
+               Lang.unit))
+          [("current", Lang.val_fun [] (fun _ -> to_v (Atomic.get v)))]
+      in
+
+      let response =
+        Lang.record
+          [
+            ("protocol", getter_setter Lang.string Lang.to_string resp_protocol);
+            ("code", getter_setter Lang.int Lang.to_int resp_code);
+            ( "status",
+              getter_setter
+                (function None -> Lang.null | Some s -> Lang.string s)
+                Lang.(to_valued_option to_string)
+                resp_status );
+            ( "headers",
+              getter_setter
+                (fun headers ->
+                  Lang.(
+                    list
+                      (List.map
+                         (fun (v, v') -> product (string v) (string v'))
+                         headers)))
+                (fun headers ->
+                  Lang.(
+                    List.map
+                      (fun v ->
+                        let v, v' = to_product v in
+                        (to_string v, to_string v'))
+                      (to_list headers)))
+                resp_headers );
+            ( "content_type",
+              getter_setter
+                (function None -> Lang.null | Some s -> Lang.string s)
+                Lang.(to_valued_option to_string)
+                resp_content_type );
+            ("custom", getter_setter Lang.bool Lang.to_bool resp_custom);
+            ( "data",
+              getter_setter
+                (fun fn -> Lang.(val_fun [] (fun _ -> string (fn ()))))
+                Lang.to_string_getter resp_data );
+            ("custom", getter_setter Lang.bool Lang.to_bool resp_custom);
+          ]
+      in
+
+      ignore (Lang.apply f [("", request); ("", response)]);
+      Harbor.(
+        http_reply
+          {
+            protocol = Atomic.get resp_protocol;
+            code = Atomic.get resp_code;
+            status = Atomic.get resp_status;
+            headers =
+              (Atomic.get resp_headers
+              @
+              match Atomic.get resp_content_type with
+                | None -> []
+                | Some m -> [("Content-Type", m)]);
+            data = `String_getter (Atomic.get resp_data);
+          })
+    in
+    (port, verb, handler)
+
   let () =
     Lang.add_builtin
       ("harbor." ^ Harbor.name ^ ".register")
       ~category:`Liquidsoap
       ~descr:
-        (Printf.sprintf
-           "Register a %s handler on the harbor. The given function receives \
-            as argument the full requested uri (e.g. \"foo?var=bar\"), http \
-            protocol version, possible input data and the list of HTTP headers \
-            and returns the answer sent to the client, including HTTP headers. \
-            Registered uri can be regular expressions (e.g. \".+\\.php\") and \
-            can override default metadata handlers. Response is a string \
-            getter, i.e. either of type `string` or type `()->string`. In the \
-            later case, getter function will be called until it returns an \
-            empty string."
-           name_up)
-      [
-        ("port", Lang.int_t, Some (Lang.int 8000), Some "Port to server.");
-        ( "method",
-          Lang.string_t,
-          Some (Lang.string "GET"),
-          Some
-            "Accepted method (\"GET\" / \"POST\" / \"PUT\" / \"DELETE\" / \
-             \"HEAD\" / \"OPTIONS\")." );
-        ("", Lang.regexp_t, None, Some "URI to serve.");
-        ( "",
-          Lang.fun_t
-            [
-              (false, "protocol", Lang.string_t);
-              (false, "data", Lang.string_t);
-              ( false,
-                "headers",
-                Lang.list_t (Lang.product_t Lang.string_t Lang.string_t) );
-              (false, "", Lang.string_t);
-            ]
-            resp_t,
-          None,
-          Some
-            "Function to execute. Method argument is \"PUT\" or \"GET\", \
-             protocol argument is \"HTTP/1.1\" or \"HTTP/1.0\" etc., data \
-             argument contains data passed in case of a PUT request, and \"\" \
-             otherwise. Headers argument contains the HTTP headers. Unlabeled \
-             argument contains the requested URI." );
-      ]
+        [%string
+          "Register a %{name_up} handler on the harbor. The handler function \
+           receives as argument the full requested information and returns the \
+           answer sent to the client, including HTTP headers. This function \
+           registers exact path matches, i.e. `\"/users\"`, `\"/index.hml\"`, \
+           etc. Use `harbor.%{Harbor.name}.register.regexp` to match regular \
+           expressions. Paths are resolved in the order that they are declared \
+           and can override default harbor paths such as metadata handlers. \
+           The handler receives the request details as a record and a response \
+           handler. The response handler can be used to fill up details about \
+           the http response, which will be converted into a plain HTTP \
+           response string after the handler returns. The request also \
+           contains the low-level socket associated with the query which the \
+           caller can use to implement their own custom response, if needed. \
+           In this case, one should set `custom_response` to `true` on the \
+           response handler."]
+      (("", Lang.string_t, None, Some "path to serve.") :: register_args)
       Lang.unit_t
       (fun p ->
-        let port = Lang.to_int (List.assoc "port" p) in
-        let verb =
-          Harbor.verb_of_string (Lang.to_string (List.assoc "method" p))
-        in
+        let port, verb, handler = parse_register_args p in
+        let uri = Lang.to_string (Lang.assoc "" 1 p) in
+        let uri = Lang.Regexp.regexp [%string {|^%{uri}$|}] in
+        Harbor.add_http_handler ~port ~verb ~uri handler;
+        Lang.unit);
+
+    Lang.add_builtin
+      ("harbor." ^ Harbor.name ^ ".register.regexp")
+      ~category:`Liquidsoap
+      ~descr:
+        [%string
+          "Register a %{name_up} handler on the harbor. The handler function \
+           receives as argument the full requested information and returns the \
+           answer sent to the client, including HTTP headers. This function \
+           registers regular expressions that are matched against the \
+           request's path. The handler receives the request details as a \
+           record and a response handler. The response handler can be used to \
+           fill up details about the http response, which will be converted \
+           into a plain HTTP response string after the handler returns. The \
+           request also contains the low-level socket associated with the \
+           query which the caller can use to implement their own custom \
+           response, if needed. In this case, one should set `custom_response` \
+           to `true` on the response handler."]
+      (("", Lang.regexp_t, None, Some "path to to serve.") :: register_args)
+      Lang.unit_t
+      (fun p ->
+        let port, verb, handler = parse_register_args 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 =
-            List.map
-              (fun (x, y) -> Lang.product (Lang.string x) (Lang.string y))
-              headers
-          in
-          let l = Lang.list l in
-          let resp =
-            Lang.apply f
-              [
-                ("", Lang.string uri);
-                ("headers", l);
-                ("data", Lang.string data);
-                ("protocol", Lang.string protocol);
-              ]
-          in
-          try Harbor.simple_reply (Lang.to_string resp)
-          with _ -> Harbor.reply (Lang.to_string_getter resp)
-        in
-        Harbor.add_http_handler ~port ~verb ~uri f;
+        Harbor.add_http_handler ~port ~verb ~uri handler;
         Lang.unit)
 
   let () =

src/core/builtins/builtins_socket.ml

@@ -22,7 +22,11 @@
 
 module SocketValue = struct
   include Value.MkAbstract (struct
-    type content = Unix.file_descr
+    type content =
+      < typ : string
+      ; write : bytes -> int -> int -> int
+      ; read : bytes -> int -> int -> int
+      ; close : unit >
 
     let name = "socket"
 
@@ -36,12 +40,13 @@ module SocketValue = struct
               pos = [];
             })
 
-    let descr _ = "<socket>"
+    let descr s = Printf.sprintf "<%s socket>" s#typ
     let compare = Stdlib.compare
   end)
 
   let meths =
     [
+      ("type", ([], Lang.string_t), "Socket type", fun fd -> Lang.string fd#typ);
       ( "write",
         ([], Lang.fun_t [(false, "", Lang.string_t)] Lang.unit_t),
         "Write data to a socket",
@@ -52,7 +57,7 @@ module SocketValue = struct
               let len = Bytes.length data in
               try
                 let rec f pos =
-                  let n = Unix.write fd data pos (len - pos) in
+                  let n = fd#write data pos (len - pos) in
                   if n < len then f (pos + n)
                 in
                 f 0;
@@ -63,13 +68,13 @@ module SocketValue = struct
       ( "read",
         ([], Lang.fun_t [] Lang.string_t),
         "Read data from a socket. Reading is done when the function returns an \
-         empty srring `\"\"`.",
+         empty string `\"\"`.",
         fun fd ->
           let buflen = Utils.pagesize in
           let buf = Bytes.create buflen in
           Lang.val_fun [] (fun _ ->
               try
-                let n = Unix.read fd buf 0 buflen in
+                let n = fd#read buf 0 buflen in
                 Lang.string (Bytes.sub_string buf 0 n)
               with exn ->
                 let bt = Printexc.get_raw_backtrace () in
@@ -80,7 +85,7 @@ module SocketValue = struct
         fun fd ->
           Lang.val_fun [] (fun _ ->
               try
-                Unix.close fd;
+                fd#close;
                 Lang.unit
               with exn ->
                 let bt = Printexc.get_raw_backtrace () in
@@ -90,9 +95,17 @@ module SocketValue = struct
   let t =
     Lang.method_t t (List.map (fun (lbl, t, descr, _) -> (lbl, t, descr)) meths)
 
-  let to_value err =
-    Lang.meth (to_value err)
-      (List.map (fun (lbl, _, _, m) -> (lbl, m err)) meths)
+  let to_value socket =
+    Lang.meth (to_value socket)
+      (List.map (fun (lbl, _, _, m) -> (lbl, m socket)) meths)
 
-  let of_value err = of_value (Lang.demeth err)
+  let of_unix_file_descr fd =
+    object
+      method typ = "unix"
+      method read = Unix.read fd
+      method write = Unix.write fd
+      method close = Unix.close fd
+    end
+
+  let of_value socket = of_value (Lang.demeth socket)
 end

src/core/dune

@@ -17,6 +17,8 @@
 (library
  (name liquidsoap_core)
  (public_name liquidsoap)
+ (preprocess
+  (pps ppx_string))
  (libraries
   mm
   dtools
@@ -254,6 +256,8 @@
 (library
  (name liquidsoap_builtins)
  (library_flags -linkall)
+ (preprocess
+  (pps ppx_string))
  (wrapped false)
  (libraries liquidsoap_core)
  (modules