blob: f70d0483c2f47e8a3baa43ae1911637e68636df1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
(*─────────────────────────────────────────────────────────────────────────────┐
│ SPDX-FileCopyrightText: 2025 toastal <https://toast.al/contact/> │
│ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception │
└─────────────────────────────────────────────────────────────────────────────*)
(* extend & fix naming for ocaml-uri *)
include Uri
let jsont : t Jsont.t =
Jsont.string
|> Jsont.map ~kind: "URI" ~dec: of_string ~enc: to_string
(* Validate URI for security concerns *)
let acceptable_schemes = ["http"; "https"; "ftp"; "sftp"; "file"; "ssh"; "git"; "darcs"; "pijul"; "fossil"]
let is_acceptable_scheme scheme =
List.mem (String.lowercase_ascii scheme) acceptable_schemes
let contains_substring s substr =
let re = Str.regexp_string substr in
try
ignore (Str.search_forward re s 0);
true
with Not_found -> false
let has_path_traversal uri =
let path_str = path uri in
contains_substring path_str ".." && (
contains_substring path_str "/../" ||
contains_substring path_str "\\..\\" ||
String.starts_with ~prefix:"../" path_str ||
String.ends_with ~suffix:"/.." path_str
)
let validate uri =
match scheme uri with
| Some scheme when is_acceptable_scheme scheme ->
if has_path_traversal uri then
Error (`Path_traversal (path uri))
else
Ok ()
| Some scheme ->
Error (`Invalid_scheme scheme)
| None ->
Error (`Invalid_scheme "missing")
(* good enough URI generation for now for this *)
let gen =
let open QCheck.Gen in
let a_to_z = (char_range 'a' 'z') in
let* scheme = QCheck.Gen.oneof_list ["http"; "https"; "ftp"; "sftp"] in
let* host = string_size ~gen: a_to_z (int_bound 20) in
let* tld = string_size ~gen: a_to_z (int_bound 5) in
let* path_opt = option (string_size ~gen: a_to_z (int_bound 10)) in
let uri =
of_string @@
Fmt.str "%s://%s.%s/%s" scheme host tld (Option.value ~default: "" path_opt)
in
return uri
|
