summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDaniil Baturin <daniil@baturin.org>2022-10-19 17:48:09 +0100
committerDaniil Baturin <daniil@baturin.org>2022-11-04 14:20:46 +0000
commit986c556c28976bcd7add93f3b08908a79dd21a5c (patch)
treebf74e9551f092e3b26ec109e947dc6623a81c56c
parentea7d9ad2e3aa97c9d5d2f0b2ee91ae5787bb9fc3 (diff)
downloadvyos-utils-986c556c28976bcd7add93f3b08908a79dd21a5c.tar.gz
vyos-utils-986c556c28976bcd7add93f3b08908a79dd21a5c.zip
T4761: add a URL value validator
-rwxr-xr-xdebian/rules1
-rw-r--r--src/url.ml73
2 files changed, 74 insertions, 0 deletions
diff --git a/debian/rules b/debian/rules
index c6e8920..22202e9 100755
--- a/debian/rules
+++ b/debian/rules
@@ -9,6 +9,7 @@ override_dh_auto_build:
eval `opam env`
mkdir -p _build
ocamlfind ocamlopt -o _build/numeric -package pcre -linkpkg src/numeric.ml
+ ocamlfind ocamlopt -o _build/url -package pcre -linkpkg src/url.ml
ocamlfind ocamlopt -o _build/validate-value -package pcre,unix,containers -linkpkg src/validate_value.ml
override_dh_auto_install:
diff --git a/src/url.ml b/src/url.ml
new file mode 100644
index 0000000..1985ff0
--- /dev/null
+++ b/src/url.ml
@@ -0,0 +1,73 @@
+(* Extract and validate the scheme part.
+ As per the RFC:
+
+ Scheme names consist of a sequence of characters. The lower case
+ letters "a"--"z", digits, and the characters plus ("+"), period
+ ("."), and hyphen ("-") are allowed. For resiliency, programs
+ interpreting URLs should treat upper case letters as equivalent to
+ lower case in scheme names (e.g., allow "HTTP" as well as "http").
+ *)
+let split_scheme url =
+ let aux url =
+ let res = Pcre.exec ~pat:{|^([a-zA-Z0-9\.\-]+):(.*)$|} url in
+ let scheme = Pcre.get_substring res 1 in
+ let uri = Pcre.get_substring res 2 in
+ (String.lowercase_ascii scheme, uri)
+ in
+ try Ok (aux url)
+ with Not_found -> Error (Printf.sprintf {|"%s" is not a valid URL|} url)
+
+let is_scheme_allowed allowed_schemes scheme =
+ match List.find_opt ((=) scheme) allowed_schemes with
+ | Some _ -> Ok ()
+ | None -> Error (Printf.sprintf {|URL scheme "%s:" is not allowed|} scheme)
+
+let regex_matches regex s =
+ try
+ let _ = Pcre.exec ~pat:regex s in
+ true
+ with Not_found -> false
+
+let validate_uri scheme uri =
+ match scheme with
+ | "http" | "https" ->
+ if regex_matches {|//[a-z0-9]+([\-\.]{1}[a-z0-9]+)*(:[0-9]+)*(/.* )?|} uri then Ok ()
+ else Error (Printf.sprintf {|"%s" is not a valid URI for the %s URL scheme|} uri scheme)
+ | _ -> Ok ()
+
+let validate_url allowed_schemes url =
+ let (let*) = Result.bind in
+ let* scheme, uri = split_scheme url in
+ let* () = is_scheme_allowed allowed_schemes scheme in
+ let* () = validate_uri scheme uri in
+ Ok ()
+
+let file_transport_schemes = ["http"; "https"; "ftp"; "sftp"; "scp"; "tftp"]
+
+let message_schemes = ["mailto"; "tel"; "sms"]
+
+let allowed_schemes = ref []
+let url = ref ""
+
+let args = [
+ ("--scheme",
+ Arg.String (fun s -> allowed_schemes := s :: !allowed_schemes),
+ "Allow only specified schemes");
+ ("--file-transport",
+ Arg.Unit (fun () -> allowed_schemes := (List.append !allowed_schemes file_transport_schemes)),
+ "Allow only file transport protocols (HTTP/S, FTP, SCP/SFTP, TFTP)");
+ ("--", Arg.Rest (fun s -> url := s), "Interpret next item as an argument");
+]
+
+let usage = Printf.sprintf "Usage: %s [OPTIONS] <URL>" Sys.argv.(0)
+
+let () =
+ let () = Arg.parse args (fun s -> url := s) usage in
+ (* Force all allowed scheme named to lowercase for ease of comparison. *)
+ let allowed_schemes = List.map String.lowercase_ascii !allowed_schemes in
+ let res = validate_url allowed_schemes !url in
+ match res with
+ | Ok () -> ()
+ | Error msg ->
+ let () = Printf.fprintf stdout "%s" msg in
+ exit 1