Native OCaml Rego/OPA policy engine
ocaml-rego: evaluator semantics, destructuring, and OPA builtins
Core semantics:
- structural unification now destructures arrays/objects against bound
values, and exposes [bind_value_pattern] for matching AST patterns
against concrete [Value.t]s.
- function-rule parameters are unified with [bind_value_pattern], so
literal patterns ([multi(1, x)], [arrays([a, b])], [objects({...})])
match by value; function rules with [default] fall back when no spec
matches; body-less function rules return the head value directly.
- the call output-arg form destructures [Array]/[Object] patterns at
the result position, so [split(s, sep, [x])] binds [x] correctly.
- [Membership] is evaluated by walking the collection and pairing
values with their indices/keys for the [k, v in c] form.
- [object.remove] accepts object/set/array key collections and errors
on non-object subjects; [array.flatten]/[array.concat]/[array.reverse]
reject non-array inputs.
New builtins (with the helpers they need at file scope):
- glob.match / glob.quote_meta with a backtracking matcher honouring
`**` and the `[a-z]` character classes.
- units.parse and units.parse_bytes with case-insensitive binary
suffixes and quote stripping; [m] vs [M] disambiguates milli/mega.
- time.now_ns, time.parse_duration_ns, time.parse_rfc3339_ns,
time.parse_ns, time.date, time.clock, time.weekday, time.add_date,
time.diff. Calendar math uses [days_from_civil] (Howard Hinnant)
instead of [Unix.mktime] to stay timezone-independent. Adds [unix]
to the library's deps.
- net.cidr_contains parsing IPv4 and IPv6 (mapped through v4-in-v6).
- json.filter, json.remove, json.patch (RFC 6902: add/replace/remove/
move/copy/test) with a JSON-pointer parser.
- strings.any_prefix_match, strings.any_suffix_match, strings.count,
strings.reverse (UTF-8 code-point reversal), indexof_n, format_int.
- substring indexes by UTF-8 code points and rejects negative offsets.
+1077
-53
+1
-1
lib/dune
+1
-1
lib/dune
+1076
-52
lib/eval.ml
+1076
-52
lib/eval.ml
···
476
476
done;
477
477
Buffer.contents buf
478
478
479
+
(* ── Glob ──────────────────────────────────────────────────────────────── *)
480
+
481
+
(** [glob_match ~delims pattern s] matches a glob pattern against a string. [*]
482
+
matches any sequence of non-delimiter chars; [**] matches anything; [?]
483
+
matches one non-delimiter char; [[...]] matches a character class. Used by
484
+
the [glob.match] builtin (see OPA's policy reference). *)
485
+
let glob_match ~delims pattern s =
486
+
let is_delim c = String.contains delims c in
487
+
let plen = String.length pattern in
488
+
let slen = String.length s in
489
+
let rec parse_class i =
490
+
if i >= plen then raise (Eval_error "glob: unterminated character class");
491
+
if pattern.[i] = ']' then ([], i + 1)
492
+
else
493
+
let lo = pattern.[i] in
494
+
let hi, next =
495
+
if i + 2 < plen && pattern.[i + 1] = '-' && pattern.[i + 2] <> ']' then
496
+
(pattern.[i + 2], i + 3)
497
+
else (lo, i + 1)
498
+
in
499
+
let rest, end_i = parse_class next in
500
+
((lo, hi) :: rest, end_i)
501
+
in
502
+
let class_match ranges c =
503
+
List.exists (fun (lo, hi) -> c >= lo && c <= hi) ranges
504
+
in
505
+
let rec m pi si =
506
+
if pi = plen then si = slen
507
+
else
508
+
let c = pattern.[pi] in
509
+
match c with
510
+
| '*' when pi + 1 < plen && pattern.[pi + 1] = '*' ->
511
+
let rec try_ si =
512
+
if m (pi + 2) si then true
513
+
else if si < slen then try_ (si + 1)
514
+
else false
515
+
in
516
+
try_ si
517
+
| '*' ->
518
+
let rec try_ si =
519
+
if m (pi + 1) si then true
520
+
else if si < slen && not (is_delim s.[si]) then try_ (si + 1)
521
+
else false
522
+
in
523
+
try_ si
524
+
| '?' -> si < slen && (not (is_delim s.[si])) && m (pi + 1) (si + 1)
525
+
| '[' ->
526
+
let ranges, next_pi = parse_class (pi + 1) in
527
+
si < slen && class_match ranges s.[si] && m next_pi (si + 1)
528
+
| '\\' when pi + 1 < plen ->
529
+
si < slen && s.[si] = pattern.[pi + 1] && m (pi + 2) (si + 1)
530
+
| _ -> si < slen && c = s.[si] && m (pi + 1) (si + 1)
531
+
in
532
+
m 0 0
533
+
534
+
(* ── Unit/byte suffixes ────────────────────────────────────────────────── *)
535
+
536
+
(** Pair a sorted list of suffixes with their multipliers; longest match wins.
537
+
Returns the suffix length and multiplier. *)
538
+
let units_match suffixes s =
539
+
let n = String.length s in
540
+
match
541
+
List.find_opt
542
+
(fun (suf, _) ->
543
+
let l = String.length suf in
544
+
n >= l && String.sub s (n - l) l = suf)
545
+
suffixes
546
+
with
547
+
| Some (suf, mult) -> (String.length suf, mult)
548
+
| None -> (0, 1.)
549
+
550
+
let strip_quotes s =
551
+
let n = String.length s in
552
+
if n >= 2 && s.[0] = '"' && s.[n - 1] = '"' then String.sub s 1 (n - 2) else s
553
+
554
+
let units_parse s =
555
+
(* OPA strips surrounding ASCII quotes from the input. Binary suffixes
556
+
([Ki], [Mi], ...) match case-insensitively; case is significant
557
+
only for [m] (milli) vs [M] (mega). *)
558
+
let s = strip_quotes s in
559
+
let n = String.length s in
560
+
let binary =
561
+
[
562
+
("ki", 1024.);
563
+
("mi", 1024. ** 2.);
564
+
("gi", 1024. ** 3.);
565
+
("ti", 1024. ** 4.);
566
+
("pi", 1024. ** 5.);
567
+
("ei", 1024. ** 6.);
568
+
]
569
+
in
570
+
let suffix_len, mult =
571
+
if n >= 2 then
572
+
let tail2 = String.lowercase_ascii (String.sub s (n - 2) 2) in
573
+
match List.assoc_opt tail2 binary with
574
+
| Some m -> (2, m)
575
+
| None -> (
576
+
match s.[n - 1] with
577
+
| 'K' | 'k' -> (1, 1e3)
578
+
| 'M' -> (1, 1e6)
579
+
| 'G' | 'g' -> (1, 1e9)
580
+
| 'T' | 't' -> (1, 1e12)
581
+
| 'P' | 'p' -> (1, 1e15)
582
+
| 'E' | 'e' -> (1, 1e18)
583
+
| 'm' -> (1, 1e-3)
584
+
| _ -> (0, 1.))
585
+
else (0, 1.)
586
+
in
587
+
let num_str = String.sub s 0 (n - suffix_len) in
588
+
if num_str = "" then 0.
589
+
else
590
+
try float_of_string num_str *. mult
591
+
with _ -> raise (Eval_error "units.parse: invalid number")
592
+
593
+
let units_parse_bytes s =
594
+
let lower = String.lowercase_ascii (strip_quotes (Astring.String.trim s)) in
595
+
let suffixes =
596
+
[
597
+
("kib", 1024.);
598
+
("mib", 1024. ** 2.);
599
+
("gib", 1024. ** 3.);
600
+
("tib", 1024. ** 4.);
601
+
("pib", 1024. ** 5.);
602
+
("eib", 1024. ** 6.);
603
+
("kb", 1e3);
604
+
("mb", 1e6);
605
+
("gb", 1e9);
606
+
("tb", 1e12);
607
+
("pb", 1e15);
608
+
("eb", 1e18);
609
+
("ki", 1024.);
610
+
("mi", 1024. ** 2.);
611
+
("gi", 1024. ** 3.);
612
+
("ti", 1024. ** 4.);
613
+
("k", 1e3);
614
+
("m", 1e6);
615
+
("g", 1e9);
616
+
("t", 1e12);
617
+
("p", 1e15);
618
+
("e", 1e18);
619
+
]
620
+
in
621
+
let suffix_len, mult = units_match suffixes lower in
622
+
let num_str = String.sub lower 0 (String.length lower - suffix_len) in
623
+
if num_str = "" then 0.
624
+
else
625
+
try Float.round (float_of_string num_str *. mult)
626
+
with _ -> raise (Eval_error "units.parse_bytes: invalid number")
627
+
628
+
(* ── Time ──────────────────────────────────────────────────────────────── *)
629
+
630
+
(** OPA's time builtins use nanoseconds since the Unix epoch. We rely on
631
+
{!Unix.gmtime} for calendar math and a small named-zone table for the
632
+
explicit-timezone overloads (the full IANA database isn't bundled). *)
633
+
634
+
let parse_time_arg = function
635
+
| Value.Number n -> (n, "UTC")
636
+
| Value.Array [ Value.Number n; Value.String tz ] -> (n, tz)
637
+
| _ -> raise (Eval_error "time: invalid timestamp argument")
638
+
639
+
(** Days-of-week as Go's time package returns them. Sunday = 0. *)
640
+
let weekday_name = function
641
+
| 0 -> "Sunday"
642
+
| 1 -> "Monday"
643
+
| 2 -> "Tuesday"
644
+
| 3 -> "Wednesday"
645
+
| 4 -> "Thursday"
646
+
| 5 -> "Friday"
647
+
| 6 -> "Saturday"
648
+
| _ -> "Unknown"
649
+
650
+
let unix_tm_of_ns ?(tz = "UTC") ns =
651
+
let secs = ns /. 1e9 in
652
+
if tz = "" || tz = "UTC" then Unix.gmtime secs
653
+
else
654
+
let offset_minutes =
655
+
match tz with
656
+
| "America/Los_Angeles" -> -480
657
+
| "America/Denver" -> -420
658
+
| "America/Chicago" -> -360
659
+
| "America/New_York" -> -300
660
+
| "Europe/London" -> 0
661
+
| "Europe/Paris" | "Europe/Berlin" -> 60
662
+
| "Asia/Tokyo" -> 540
663
+
| "Asia/Shanghai" | "Asia/Hong_Kong" -> 480
664
+
| "Australia/Sydney" -> 660
665
+
| _ -> 0
666
+
in
667
+
Unix.gmtime (secs +. (float_of_int offset_minutes *. 60.))
668
+
669
+
let parse_duration s =
670
+
let n = String.length s in
671
+
let total = ref 0.0 in
672
+
let i = ref 0 in
673
+
let neg =
674
+
!i < n
675
+
&& s.[!i] = '-'
676
+
&&
677
+
(incr i;
678
+
true)
679
+
in
680
+
while !i < n do
681
+
let start = !i in
682
+
while !i < n && ((s.[!i] >= '0' && s.[!i] <= '9') || s.[!i] = '.') do
683
+
incr i
684
+
done;
685
+
if start = !i then raise (Eval_error "parse_duration: missing number");
686
+
let num =
687
+
try float_of_string (String.sub s start (!i - start))
688
+
with _ -> raise (Eval_error "parse_duration: invalid number")
689
+
in
690
+
let unit_start = !i in
691
+
while !i < n && not (s.[!i] >= '0' && s.[!i] <= '9') do
692
+
incr i
693
+
done;
694
+
let mult =
695
+
match String.sub s unit_start (!i - unit_start) with
696
+
| "ns" -> 1.0
697
+
| "us" | "µs" -> 1e3
698
+
| "ms" -> 1e6
699
+
| "s" -> 1e9
700
+
| "m" -> 60. *. 1e9
701
+
| "h" -> 3600. *. 1e9
702
+
| "d" -> 86400. *. 1e9
703
+
| "w" -> 7. *. 86400. *. 1e9
704
+
| "y" -> 365. *. 86400. *. 1e9
705
+
| u -> raise (Eval_error (Fmt.str "parse_duration: invalid unit %S" u))
706
+
in
707
+
total := !total +. (num *. mult)
708
+
done;
709
+
if neg then -. !total else !total
710
+
711
+
(** Days since the Unix epoch for a Y/M/D civil date in UTC, using Howard
712
+
Hinnant's algorithm. Avoids timezone-dependent {!Unix.mktime}. *)
713
+
let days_from_civil y m d =
714
+
let y = if m <= 2 then y - 1 else y in
715
+
let era = (if y >= 0 then y else y - 399) / 400 in
716
+
let yoe = y - (era * 400) in
717
+
let mp = if m > 2 then -3 else 9 in
718
+
let doy = (((153 * (m + mp)) + 2) / 5) + d - 1 in
719
+
let doe = (yoe * 365) + (yoe / 4) - (yoe / 100) + doy in
720
+
(era * 146097) + doe - 719468
721
+
722
+
let parse_rfc3339_ns s =
723
+
let n = String.length s in
724
+
if n < 19 then raise (Eval_error "parse_rfc3339_ns: too short");
725
+
let int_at off len =
726
+
try int_of_string (String.sub s off len)
727
+
with _ -> raise (Eval_error "parse_rfc3339_ns: invalid digits")
728
+
in
729
+
let year = int_at 0 4 in
730
+
let month = int_at 5 2 in
731
+
let day = int_at 8 2 in
732
+
let hour = int_at 11 2 in
733
+
let min = int_at 14 2 in
734
+
let sec = int_at 17 2 in
735
+
let frac_str, after_frac =
736
+
if 19 < n && s.[19] = '.' then (
737
+
let j = ref 20 in
738
+
while !j < n && s.[!j] >= '0' && s.[!j] <= '9' do
739
+
incr j
740
+
done;
741
+
(String.sub s 20 (!j - 20), !j))
742
+
else ("", 19)
743
+
in
744
+
let tz_offset_sec =
745
+
if after_frac >= n then 0
746
+
else if s.[after_frac] = 'Z' then 0
747
+
else if s.[after_frac] = '+' || s.[after_frac] = '-' then
748
+
let sign = if s.[after_frac] = '+' then 1 else -1 in
749
+
let oh = int_at (after_frac + 1) 2 in
750
+
let om =
751
+
if after_frac + 3 < n && s.[after_frac + 3] = ':' then
752
+
int_at (after_frac + 4) 2
753
+
else int_at (after_frac + 3) 2
754
+
in
755
+
sign * ((oh * 3600) + (om * 60))
756
+
else raise (Eval_error "parse_rfc3339_ns: bad timezone")
757
+
in
758
+
let days = days_from_civil year month day in
759
+
let utc_secs =
760
+
(float_of_int days *. 86400.)
761
+
+. float_of_int ((hour * 3600) + (min * 60) + sec)
762
+
-. float_of_int tz_offset_sec
763
+
in
764
+
let frac_ns =
765
+
if frac_str = "" then 0.0
766
+
else
767
+
let m = String.length frac_str in
768
+
let trunc = if m > 9 then String.sub frac_str 0 9 else frac_str in
769
+
let pad = trunc ^ String.make (9 - String.length trunc) '0' in
770
+
float_of_string pad
771
+
in
772
+
(utc_secs *. 1e9) +. frac_ns
773
+
774
+
(* ── Net.CIDR ──────────────────────────────────────────────────────────── *)
775
+
776
+
(** Parse an IPv4 dotted-quad or IPv6 colon-hex address into a 16-byte
777
+
representation (IPv4 mapped into the v4-in-v6 prefix), with a flag
778
+
indicating which family was used. *)
779
+
let parse_ip s =
780
+
let v4 s =
781
+
let parts = String.split_on_char '.' s in
782
+
if List.length parts <> 4 then None
783
+
else
784
+
try
785
+
let bs =
786
+
List.map
787
+
(fun p ->
788
+
let n = int_of_string p in
789
+
if n < 0 || n > 255 then raise Exit;
790
+
n)
791
+
parts
792
+
in
793
+
let arr = Bytes.make 16 '\x00' in
794
+
Bytes.set arr 10 '\xff';
795
+
Bytes.set arr 11 '\xff';
796
+
List.iteri (fun i b -> Bytes.set arr (12 + i) (Char.chr b)) bs;
797
+
Some (Bytes.to_string arr, `V4)
798
+
with _ -> None
799
+
in
800
+
let v6 s =
801
+
let halves =
802
+
match Astring.String.cuts ~sep:"::" s with
803
+
| [ one ] -> Some (String.split_on_char ':' one, [])
804
+
| [ a; b ] ->
805
+
let lhs = if a = "" then [] else String.split_on_char ':' a in
806
+
let rhs = if b = "" then [] else String.split_on_char ':' b in
807
+
Some (lhs, rhs)
808
+
| _ -> None
809
+
in
810
+
match halves with
811
+
| None -> None
812
+
| Some (lhs, rhs) -> (
813
+
let total = List.length lhs + List.length rhs in
814
+
if total > 8 then None
815
+
else
816
+
let zeros = 8 - total in
817
+
let groups = lhs @ List.init zeros (fun _ -> "0") @ rhs in
818
+
if List.length groups <> 8 then None
819
+
else
820
+
try
821
+
let arr = Bytes.make 16 '\x00' in
822
+
List.iteri
823
+
(fun i g ->
824
+
let v = int_of_string ("0x" ^ g) in
825
+
if v < 0 || v > 0xffff then raise Exit;
826
+
Bytes.set arr (i * 2) (Char.chr (v lsr 8));
827
+
Bytes.set arr ((i * 2) + 1) (Char.chr (v land 0xff)))
828
+
groups;
829
+
Some (Bytes.to_string arr, `V6)
830
+
with _ -> None)
831
+
in
832
+
match v4 s with Some _ as r -> r | None -> v6 s
833
+
834
+
let parse_cidr s =
835
+
match String.split_on_char '/' s with
836
+
| [ ip ] ->
837
+
Option.map
838
+
(fun (b, fam) -> (b, (if fam = `V4 then 32 else 128), fam))
839
+
(parse_ip ip)
840
+
| [ ip; mask ] -> (
841
+
match parse_ip ip with
842
+
| None -> None
843
+
| Some (b, fam) -> (
844
+
try
845
+
let max_bits = if fam = `V4 then 32 else 128 in
846
+
let m = int_of_string mask in
847
+
if m < 0 || m > max_bits then None else Some (b, m, fam)
848
+
with _ -> None))
849
+
| _ -> None
850
+
851
+
(** True iff every address in [inner] is also in [outer]. *)
852
+
let cidr_contains outer inner =
853
+
match (parse_cidr outer, parse_cidr inner) with
854
+
| Some (a_b, a_bits, a_fam), Some (b_b, b_bits, b_fam) ->
855
+
a_fam = b_fam && a_bits <= b_bits
856
+
&&
857
+
let bit_offset = if a_fam = `V4 then 96 else 0 in
858
+
let full = a_bits / 8 in
859
+
let extra = a_bits mod 8 in
860
+
let prefix_match = ref true in
861
+
for i = 0 to full - 1 do
862
+
if a_b.[(bit_offset / 8) + i] <> b_b.[(bit_offset / 8) + i] then
863
+
prefix_match := false
864
+
done;
865
+
if !prefix_match && extra > 0 then begin
866
+
let pos = (bit_offset / 8) + full in
867
+
let mask = (0xff lsl (8 - extra)) land 0xff in
868
+
if Char.code a_b.[pos] land mask <> Char.code b_b.[pos] land mask then
869
+
prefix_match := false
870
+
end;
871
+
!prefix_match
872
+
| _ -> false
873
+
874
+
(* ── JSON path helpers ─────────────────────────────────────────────────── *)
875
+
876
+
(** Render a number as an integer if it has no fractional part. *)
877
+
let string_of_float_int n =
878
+
if Float.is_integer n then string_of_int (int_of_float n)
879
+
else Float.to_string n
880
+
881
+
(** RFC 6901 unescape: [~1] -> [/], [~0] -> [~]. *)
882
+
let unescape_pointer_segment s =
883
+
let buf = Buffer.create (String.length s) in
884
+
let n = String.length s in
885
+
let i = ref 0 in
886
+
while !i < n do
887
+
if s.[!i] = '~' && !i + 1 < n then (
888
+
(match s.[!i + 1] with
889
+
| '0' -> Buffer.add_char buf '~'
890
+
| '1' -> Buffer.add_char buf '/'
891
+
| c ->
892
+
Buffer.add_char buf '~';
893
+
Buffer.add_char buf c);
894
+
i := !i + 2)
895
+
else (
896
+
Buffer.add_char buf s.[!i];
897
+
incr i)
898
+
done;
899
+
Buffer.contents buf
900
+
901
+
let parse_json_pointer s =
902
+
let s =
903
+
if String.length s > 0 && s.[0] = '/' then
904
+
String.sub s 1 (String.length s - 1)
905
+
else s
906
+
in
907
+
if s = "" then []
908
+
else List.map unescape_pointer_segment (String.split_on_char '/' s)
909
+
910
+
(** Lookup a JSON-pointer path. Object segments are string keys; array segments
911
+
are decimal indices. *)
912
+
let rec json_lookup v = function
913
+
| [] -> Some v
914
+
| seg :: rest -> (
915
+
match v with
916
+
| Value.Object pairs -> (
917
+
match List.assoc_opt (Value.String seg) pairs with
918
+
| Some sub -> json_lookup sub rest
919
+
| None -> None)
920
+
| Value.Array xs -> (
921
+
match int_of_string_opt seg with
922
+
| Some i when i >= 0 && i < List.length xs ->
923
+
json_lookup (List.nth xs i) rest
924
+
| _ -> None)
925
+
| _ -> None)
926
+
927
+
(** Insert [v] at [path] inside [tree], creating intermediate objects. Sets are
928
+
extended (deduplicated). The semantics match RFC 6902's [add] op. *)
929
+
let rec json_insert tree path v =
930
+
match path with
931
+
| [] -> v
932
+
| seg :: rest -> (
933
+
match tree with
934
+
| Value.Object pairs ->
935
+
let existing =
936
+
match List.assoc_opt (Value.String seg) pairs with
937
+
| Some x -> x
938
+
| None -> Value.Object []
939
+
in
940
+
let updated = json_insert existing rest v in
941
+
let rest_pairs =
942
+
List.filter
943
+
(fun (k, _) -> not (Value.equal k (Value.String seg)))
944
+
pairs
945
+
in
946
+
Value.Object (rest_pairs @ [ (Value.String seg, updated) ])
947
+
| Value.Set xs when rest = [] ->
948
+
let target = Value.String seg in
949
+
if List.exists (Value.equal target) xs then tree
950
+
else Value.Set (List.sort Value.compare (target :: xs))
951
+
| Value.Array xs -> (
952
+
match (int_of_string_opt seg, seg) with
953
+
| _, "-" ->
954
+
let nv = json_insert (Value.Object []) rest v in
955
+
Value.Array (xs @ [ nv ])
956
+
| Some i, _ when i >= 0 && i <= List.length xs ->
957
+
let before = List.filteri (fun j _ -> j < i) xs in
958
+
let after = List.filteri (fun j _ -> j >= i) xs in
959
+
if rest = [] then Value.Array (before @ [ v ] @ after)
960
+
else
961
+
let item =
962
+
if i < List.length xs then List.nth xs i else Value.Object []
963
+
in
964
+
let updated = json_insert item rest v in
965
+
let after' =
966
+
if i < List.length xs then List.tl after else after
967
+
in
968
+
Value.Array (before @ [ updated ] @ after')
969
+
| _ -> tree)
970
+
| _ -> json_insert (Value.Object []) path v)
971
+
972
+
(** Remove the value at [path]. Missing paths are no-ops. *)
973
+
let rec json_delete tree path =
974
+
match path with
975
+
| [] -> Value.Undefined
976
+
| [ seg ] -> (
977
+
match tree with
978
+
| Value.Object pairs ->
979
+
Value.Object
980
+
(List.filter
981
+
(fun (k, _) -> not (Value.equal k (Value.String seg)))
982
+
pairs)
983
+
| Value.Set xs ->
984
+
Value.Set
985
+
(List.filter (fun x -> not (Value.equal x (Value.String seg))) xs)
986
+
| Value.Array xs -> (
987
+
match int_of_string_opt seg with
988
+
| Some i when i >= 0 && i < List.length xs ->
989
+
Value.Array (List.filteri (fun j _ -> j <> i) xs)
990
+
| _ -> tree)
991
+
| _ -> tree)
992
+
| seg :: rest -> (
993
+
match tree with
994
+
| Value.Object pairs ->
995
+
Value.Object
996
+
(List.map
997
+
(fun (k, vv) ->
998
+
if Value.equal k (Value.String seg) then
999
+
(k, json_delete vv rest)
1000
+
else (k, vv))
1001
+
pairs)
1002
+
| Value.Array xs -> (
1003
+
match int_of_string_opt seg with
1004
+
| Some i when i >= 0 && i < List.length xs ->
1005
+
Value.Array
1006
+
(List.mapi
1007
+
(fun j vv -> if j = i then json_delete vv rest else vv)
1008
+
xs)
1009
+
| _ -> tree)
1010
+
| _ -> tree)
1011
+
1012
+
let json_filter doc paths =
1013
+
List.fold_left
1014
+
(fun acc path ->
1015
+
match json_lookup doc path with
1016
+
| Some v -> json_insert acc path v
1017
+
| None -> acc)
1018
+
(Value.Object []) paths
1019
+
1020
+
let json_remove doc paths =
1021
+
List.fold_left (fun acc path -> json_delete acc path) doc paths
1022
+
1023
+
let json_patch_op_path = function
1024
+
| Value.String s -> parse_json_pointer s
1025
+
| Value.Array xs ->
1026
+
List.map
1027
+
(function
1028
+
| Value.String s -> s
1029
+
| Value.Number n -> string_of_float_int n
1030
+
| _ -> raise (Eval_error "json.patch: bad path segment"))
1031
+
xs
1032
+
| _ -> raise (Eval_error "json.patch: bad path")
1033
+
1034
+
(** Apply one RFC 6902 operation to a document. *)
1035
+
let json_patch_apply doc op =
1036
+
match op with
1037
+
| Value.Object fields -> (
1038
+
let assoc k = List.assoc_opt (Value.String k) fields in
1039
+
let need k =
1040
+
match assoc k with
1041
+
| Some v -> v
1042
+
| None -> raise (Eval_error (Fmt.str "json.patch: missing %s" k))
1043
+
in
1044
+
let op_str =
1045
+
match assoc "op" with
1046
+
| Some (Value.String s) -> s
1047
+
| _ -> raise (Eval_error "json.patch: missing op")
1048
+
in
1049
+
let path = json_patch_op_path (need "path") in
1050
+
match op_str with
1051
+
| "add" | "replace" -> json_insert doc path (need "value")
1052
+
| "remove" -> json_delete doc path
1053
+
| "move" -> (
1054
+
let from_path = json_patch_op_path (need "from") in
1055
+
match json_lookup doc from_path with
1056
+
| Some v -> json_insert (json_delete doc from_path) path v
1057
+
| None -> doc)
1058
+
| "copy" -> (
1059
+
let from_path = json_patch_op_path (need "from") in
1060
+
match json_lookup doc from_path with
1061
+
| Some v -> json_insert doc path v
1062
+
| None -> doc)
1063
+
| "test" -> (
1064
+
let expected = need "value" in
1065
+
match json_lookup doc path with
1066
+
| Some v when Value.equal v expected -> doc
1067
+
| _ -> raise (Eval_error "json.patch: test failed"))
1068
+
| _ -> raise (Eval_error (Fmt.str "json.patch: unknown op %s" op_str)))
1069
+
| _ -> raise (Eval_error "json.patch: op must be object")
1070
+
479
1071
(* ── Walk ──────────────────────────────────────────────────────────────── *)
480
1072
481
1073
let walk_pairs v =
···
540
1132
| Ast.ObjectCompr (_, k, v, q) -> [ (eval_object_compr env bnds k v q, bnds) ]
541
1133
| Ast.AssignExpr _ ->
542
1134
raise (Eval_error "assignment is only valid inside a body")
543
-
| Ast.Membership (_, _, _, _) ->
544
-
raise (Eval_error "membership is only valid as a body literal")
1135
+
| Ast.Membership (_, key_opt, value, coll) ->
1136
+
eval_membership env bnds key_opt value coll
545
1137
546
1138
and eval_var env bnds = function
547
1139
| "_" -> [ (Value.Undefined, bnds) ]
···
606
1198
eval_expr env bnds l
607
1199
|> List.concat_map (fun (lv, b1) ->
608
1200
eval_expr env b1 r |> List.map (fun (rv, b2) -> (f lv rv, b2)))
1201
+
1202
+
(** [v in c] returns true iff [v] is contained in collection [c]; with a key,
1203
+
[k, v in c] also requires the matching index/key to be [k]. *)
1204
+
and eval_membership env bnds key_opt value coll =
1205
+
eval_expr env bnds value
1206
+
|> List.concat_map (fun (v, b1) ->
1207
+
eval_expr env b1 coll
1208
+
|> List.map (fun (c, b2) ->
1209
+
let entries =
1210
+
match c with
1211
+
| Value.Array xs ->
1212
+
List.mapi (fun i x -> (Value.Number (float_of_int i), x)) xs
1213
+
| Value.Set xs -> List.map (fun x -> (x, x)) xs
1214
+
| Value.Object pairs -> pairs
1215
+
| _ -> []
1216
+
in
1217
+
let key_matches k =
1218
+
match key_opt with
1219
+
| None -> true
1220
+
| Some ke -> (
1221
+
match eval_expr env b2 ke with
1222
+
| [] -> false
1223
+
| (kv, _) :: _ -> Value.equal kv k)
1224
+
in
1225
+
let hit =
1226
+
List.exists
1227
+
(fun (k, vv) -> Value.equal vv v && key_matches k)
1228
+
entries
1229
+
in
1230
+
(Value.Bool hit, b2)))
609
1231
610
1232
(* ── Data resolution ───────────────────────────────────────────────────── *)
611
1233
···
883
1505
|> List.concat_map (fun b' -> go b' rest)
884
1506
in
885
1507
go bnds (List.combine la ra)
1508
+
| Ast.Array (_, items), _ ->
1509
+
eval_expr env bnds rhs
1510
+
|> List.concat_map (fun (v, b) -> destructure_array env b items v)
1511
+
| _, Ast.Array _ -> unify_structural env bnds rhs lhs
886
1512
| Ast.Object (_, lp), Ast.Object (_, rp) when List.length lp = List.length rp
887
1513
->
888
1514
let to_const_key (k, v) =
···
903
1529
in
904
1530
go bnds lps
905
1531
else unify_by_value env bnds lhs rhs
1532
+
| Ast.Object (_, lp), _ ->
1533
+
eval_expr env bnds rhs
1534
+
|> List.concat_map (fun (v, b) -> destructure_object env b lp v)
1535
+
| _, Ast.Object _ -> unify_structural env bnds rhs lhs
906
1536
| _ -> unify_by_value env bnds lhs rhs
907
1537
1538
+
(** Match an array of patterns against a {!Value.t} array, threading bindings.
1539
+
*)
1540
+
and destructure_array env bnds items v =
1541
+
match v with
1542
+
| Value.Array vs when List.length vs = List.length items ->
1543
+
let rec go bnds = function
1544
+
| [] -> [ bnds ]
1545
+
| (p, ev) :: rest ->
1546
+
bind_value_pattern env bnds p ev
1547
+
|> List.concat_map (fun b' -> go b' rest)
1548
+
in
1549
+
go bnds (List.combine items vs)
1550
+
| _ -> []
1551
+
1552
+
(** Match an object's key/value patterns against a {!Value.Object}. Keys must be
1553
+
ground constants; missing keys make the destructure fail. *)
1554
+
and destructure_object env bnds lp v =
1555
+
match v with
1556
+
| Value.Object pairs ->
1557
+
let rec go bnds = function
1558
+
| [] -> [ bnds ]
1559
+
| (kp, vp) :: rest -> (
1560
+
let key_const =
1561
+
match kp with
1562
+
| Ast.String (_, s) -> Some (Value.String s)
1563
+
| Ast.Number (_, n) -> Some (Value.Number n)
1564
+
| _ -> None
1565
+
in
1566
+
match key_const with
1567
+
| None -> []
1568
+
| Some kv -> (
1569
+
match List.assoc_opt kv pairs with
1570
+
| None -> []
1571
+
| Some vv ->
1572
+
bind_value_pattern env bnds vp vv
1573
+
|> List.concat_map (fun b' -> go b' rest)))
1574
+
in
1575
+
go bnds lp
1576
+
| _ -> []
1577
+
1578
+
(** Bind an AST pattern against a concrete {!Value.t}. Used when one side of a
1579
+
unification has already been reduced to a value. *)
1580
+
and bind_value_pattern env bnds pat v =
1581
+
match pat with
1582
+
| Ast.Var (_, "_") -> [ bnds ]
1583
+
| Ast.Var (_, n) when not (List.mem_assoc n bnds) -> [ (n, v) :: bnds ]
1584
+
| Ast.Var (_, n) -> (
1585
+
match List.assoc_opt n bnds with
1586
+
| Some v' when Value.equal v' v -> [ bnds ]
1587
+
| _ -> [])
1588
+
| Ast.Array (_, items) -> destructure_array env bnds items v
1589
+
| Ast.Object (_, lp) -> destructure_object env bnds lp v
1590
+
| _ ->
1591
+
eval_expr env bnds pat
1592
+
|> List.filter_map (fun (pv, b) ->
1593
+
if Value.equal pv v then Some b else None)
1594
+
908
1595
and unify_by_value env bnds a b =
909
1596
eval_expr env bnds a
910
1597
|> List.concat_map (fun (av, b1) ->
···
1088
1775
when out <> "_" && out <> "input" && out <> "data"
1089
1776
&& not (List.mem_assoc out b) ->
1090
1777
[ (Value.Bool true, (out, v) :: b) ]
1778
+
| Ast.Array _ | Ast.Object _ ->
1779
+
(* Destructure the result into an array/object
1780
+
pattern, the OPA output-arg form lets you
1781
+
bind sub-pieces directly. *)
1782
+
bind_value_pattern env b last_expr v
1783
+
|> List.map (fun b' -> (Value.Bool true, b'))
1091
1784
| _ ->
1092
1785
if Value.equal v last_v then [ (Value.Bool true, b) ]
1093
1786
else [ (Value.Undefined, b) ])
···
1110
1803
let modules =
1111
1804
List.filter (fun m -> module_pkg_path m = pkg) env.modules
1112
1805
in
1113
-
let rules =
1806
+
let same_name r =
1807
+
match rule_name r with Some n -> n = name | None -> false
1808
+
in
1809
+
let specs =
1114
1810
List.concat_map (fun m -> m.Ast.mod_rules) modules
1115
1811
|> List.filter (fun r ->
1812
+
same_name r
1813
+
&&
1116
1814
match r with
1117
-
| Ast.RuleSpec (_, Ast.RuleHeadFunc _, _) -> (
1118
-
match rule_name r with Some n -> n = name | _ -> false)
1815
+
| Ast.RuleSpec (_, Ast.RuleHeadFunc _, _) -> true
1119
1816
| _ -> false)
1120
1817
in
1121
-
if rules = [] then None else Some (pkg, name, rules)
1818
+
let defaults =
1819
+
List.concat_map (fun m -> m.Ast.mod_rules) modules
1820
+
|> List.filter (fun r ->
1821
+
same_name r && match r with Ast.RuleDefault _ -> true | _ -> false)
1822
+
in
1823
+
if specs = [] && defaults = [] then None
1824
+
else Some (pkg, name, specs, defaults)
1122
1825
in
1123
1826
let rec first = function
1124
1827
| [] -> None
···
1127
1830
in
1128
1831
match first candidates with
1129
1832
| None -> None
1130
-
| Some (pkg, name, rules) -> (
1833
+
| Some (pkg, name, specs, defaults) -> (
1131
1834
let qualified = String.concat "." (pkg @ [ name ]) in
1132
1835
if List.mem qualified env.evaluating then
1133
1836
raise (Eval_error (Fmt.str "recursive function call: %s" qualified))
···
1140
1843
}
1141
1844
in
1142
1845
let values =
1143
-
List.filter_map (fun r -> eval_function_rule env' vargs r) rules
1846
+
List.filter_map (fun r -> eval_function_rule env' vargs r) specs
1144
1847
in
1145
1848
match values with
1146
-
| [] -> None
1147
-
| v :: rest ->
1148
-
if List.for_all (Value.equal v) rest then Some v
1149
-
else raise (Eval_error "function rule produces conflicting values"))
1849
+
| v :: rest when List.for_all (Value.equal v) rest -> Some v
1850
+
| _ :: _ :: _ ->
1851
+
raise (Eval_error "function rule produces conflicting values")
1852
+
| [ v ] -> Some v
1853
+
| [] -> (
1854
+
match defaults with
1855
+
| Ast.RuleDefault (_, _, _, _, e) :: _ ->
1856
+
let v = first_value env' empty e in
1857
+
if Value.equal v Value.Undefined then None else Some v
1858
+
| _ -> None))
1150
1859
1151
1860
and eval_function_rule env vargs = function
1152
1861
| Ast.RuleSpec (_, Ast.RuleHeadFunc (_, _, params, ra_opt), bodies) ->
···
1154
1863
else
1155
1864
let init =
1156
1865
try
1157
-
Some
1158
-
(List.fold_left2
1159
-
(fun acc p v ->
1160
-
match p with
1161
-
| Ast.Var (_, name) -> (name, v) :: acc
1162
-
| _ ->
1163
-
raise
1164
-
(Eval_error "function rule params must be identifiers"))
1165
-
empty params vargs)
1866
+
List.fold_left2
1867
+
(fun acc p v ->
1868
+
match acc with
1869
+
| None -> None
1870
+
| Some bnds -> (
1871
+
match bind_value_pattern env bnds p v with
1872
+
| [] -> None
1873
+
| b :: _ -> Some b))
1874
+
(Some empty) params vargs
1166
1875
with Invalid_argument _ -> None
1167
1876
in
1168
1877
Option.bind init (fun bnds ->
1169
-
let rec try_bodies = function
1170
-
| [] -> None
1171
-
| body :: rest -> (
1172
-
let vs =
1173
-
eval_body env bnds body.Ast.rb_query
1174
-
|> List.filter_map (fun b ->
1175
-
let v =
1176
-
match body.Ast.rb_assign with
1177
-
| Some ra -> first_value env b ra.Ast.ra_value
1178
-
| None -> (
1179
-
match ra_opt with
1180
-
| Some ra -> first_value env b ra.Ast.ra_value
1181
-
| None -> Value.Bool true)
1182
-
in
1183
-
if Value.equal v Value.Undefined then None else Some v)
1184
-
in
1185
-
match vs with
1186
-
| [] -> try_bodies rest
1187
-
| v :: tl when List.for_all (Value.equal v) tl -> Some v
1188
-
| _ -> raise (Eval_error "function rule values disagree"))
1189
-
in
1190
-
try_bodies bodies)
1878
+
(* No body and a value: [f(x) = expr] always returns [expr]. *)
1879
+
if bodies = [] then
1880
+
match ra_opt with
1881
+
| Some ra ->
1882
+
let v = first_value env bnds ra.Ast.ra_value in
1883
+
if Value.equal v Value.Undefined then None else Some v
1884
+
| None -> None
1885
+
else
1886
+
let rec try_bodies = function
1887
+
| [] -> None
1888
+
| body :: rest -> (
1889
+
let vs =
1890
+
eval_body env bnds body.Ast.rb_query
1891
+
|> List.filter_map (fun b ->
1892
+
let v =
1893
+
match body.Ast.rb_assign with
1894
+
| Some ra -> first_value env b ra.Ast.ra_value
1895
+
| None -> (
1896
+
match ra_opt with
1897
+
| Some ra -> first_value env b ra.Ast.ra_value
1898
+
| None -> Value.Bool true)
1899
+
in
1900
+
if Value.equal v Value.Undefined then None else Some v)
1901
+
in
1902
+
match vs with
1903
+
| [] -> try_bodies rest
1904
+
| v :: tl when List.for_all (Value.equal v) tl -> Some v
1905
+
| _ -> raise (Eval_error "function rule values disagree"))
1906
+
in
1907
+
try_bodies bodies)
1191
1908
| _ -> None
1192
1909
1193
1910
and eval_builtin name args =
···
1310
2027
match Astring.String.find_sub ~sub s with
1311
2028
| Some i -> Value.Number (float_of_int i)
1312
2029
| None -> Value.Number (-1.))
1313
-
| "substring", [ Value.String s; Value.Number o; Value.Number l ] ->
1314
-
let max_len = String.length s in
1315
-
let off = Stdlib.max 0 (Stdlib.min (int_of_float o) max_len) in
1316
-
let len_i = int_of_float l in
1317
-
let end_ =
1318
-
if len_i < 0 then max_len else Stdlib.min max_len (off + len_i)
2030
+
| "indexof_n", [ Value.String s; Value.String sub ] ->
2031
+
let slen = String.length s in
2032
+
let sublen = String.length sub in
2033
+
if sublen = 0 then Value.Array []
2034
+
else
2035
+
let acc = ref [] in
2036
+
let i = ref 0 in
2037
+
while !i + sublen <= slen do
2038
+
if String.sub s !i sublen = sub then begin
2039
+
acc := Value.Number (float_of_int !i) :: !acc;
2040
+
i := !i + sublen
2041
+
end
2042
+
else incr i
2043
+
done;
2044
+
Value.Array (List.rev !acc)
2045
+
| "strings.count", [ Value.String s; Value.String sub ] ->
2046
+
let slen = String.length s in
2047
+
let sublen = String.length sub in
2048
+
if sublen = 0 then Value.Number (float_of_int (slen + 1))
2049
+
else
2050
+
let count = ref 0 in
2051
+
let i = ref 0 in
2052
+
while !i + sublen <= slen do
2053
+
if String.sub s !i sublen = sub then begin
2054
+
incr count;
2055
+
i := !i + sublen
2056
+
end
2057
+
else incr i
2058
+
done;
2059
+
Value.Number (float_of_int !count)
2060
+
| "strings.reverse", [ Value.String s ] ->
2061
+
(* Reverse by Unicode code points (UTF-8), not bytes. Continuation
2062
+
bytes have top bits [10]; everything else starts a new code
2063
+
point. *)
2064
+
let n = String.length s in
2065
+
let starts =
2066
+
let acc = ref [] in
2067
+
for i = n - 1 downto 0 do
2068
+
let b = Char.code s.[i] in
2069
+
if b land 0xc0 <> 0x80 then acc := i :: !acc
2070
+
done;
2071
+
Array.of_list !acc
1319
2072
in
1320
-
Value.String (String.sub s off (end_ - off))
2073
+
let buf = Buffer.create n in
2074
+
for k = Array.length starts - 1 downto 0 do
2075
+
let start = starts.(k) in
2076
+
let stop = if k = Array.length starts - 1 then n else starts.(k + 1) in
2077
+
Buffer.add_substring buf s start (stop - start)
2078
+
done;
2079
+
Value.String (Buffer.contents buf)
2080
+
| "strings.any_prefix_match", [ a; b ] ->
2081
+
let to_strs name = function
2082
+
| Value.String s -> [ s ]
2083
+
| Value.Array xs | Value.Set xs ->
2084
+
List.map
2085
+
(function
2086
+
| Value.String s -> s
2087
+
| _ -> raise (Eval_error (name ^ ": expected string")))
2088
+
xs
2089
+
| _ -> raise (Eval_error (name ^ ": expected string or set/array"))
2090
+
in
2091
+
let strings = to_strs "any_prefix_match" a in
2092
+
let prefixes = to_strs "any_prefix_match" b in
2093
+
Value.Bool
2094
+
(List.exists
2095
+
(fun s ->
2096
+
List.exists (fun p -> Astring.String.is_prefix ~affix:p s) prefixes)
2097
+
strings)
2098
+
| "strings.any_suffix_match", [ a; b ] ->
2099
+
let to_strs name = function
2100
+
| Value.String s -> [ s ]
2101
+
| Value.Array xs | Value.Set xs ->
2102
+
List.map
2103
+
(function
2104
+
| Value.String s -> s
2105
+
| _ -> raise (Eval_error (name ^ ": expected string")))
2106
+
xs
2107
+
| _ -> raise (Eval_error (name ^ ": expected string or set/array"))
2108
+
in
2109
+
let strings = to_strs "any_suffix_match" a in
2110
+
let suffixes = to_strs "any_suffix_match" b in
2111
+
Value.Bool
2112
+
(List.exists
2113
+
(fun s ->
2114
+
List.exists (fun p -> Astring.String.is_suffix ~affix:p s) suffixes)
2115
+
strings)
2116
+
| "format_int", [ Value.Number n; Value.Number base ] ->
2117
+
let b = int_of_float base in
2118
+
if b <> 2 && b <> 8 && b <> 10 && b <> 16 then
2119
+
raise (Eval_error "format_int: invalid base");
2120
+
let i = int_of_float (Float.trunc n) in
2121
+
let abs_i = abs i in
2122
+
if abs_i = 0 then Value.String "0"
2123
+
else begin
2124
+
let buf = Buffer.create 16 in
2125
+
let rec loop x =
2126
+
if x = 0 then ()
2127
+
else
2128
+
let d = x mod b in
2129
+
loop (x / b);
2130
+
Buffer.add_char buf
2131
+
(if d < 10 then Char.chr (Char.code '0' + d)
2132
+
else Char.chr (Char.code 'a' + d - 10))
2133
+
in
2134
+
loop abs_i;
2135
+
let s = Buffer.contents buf in
2136
+
Value.String (if i < 0 then "-" ^ s else s)
2137
+
end
2138
+
| "substring", [ Value.String s; Value.Number o; Value.Number l ] ->
2139
+
let off_i = int_of_float o in
2140
+
if off_i < 0 then raise (Eval_error "substring: negative offset")
2141
+
else
2142
+
(* OPA's [substring] indexes by Unicode code points, not bytes.
2143
+
Find the byte offsets of the requested code-point range. *)
2144
+
let n = String.length s in
2145
+
let cp_starts =
2146
+
let acc = ref [] in
2147
+
for i = n - 1 downto 0 do
2148
+
let b = Char.code s.[i] in
2149
+
if b land 0xc0 <> 0x80 then acc := i :: !acc
2150
+
done;
2151
+
!acc @ [ n ]
2152
+
in
2153
+
let cp_count = List.length cp_starts - 1 in
2154
+
let off = Stdlib.min off_i cp_count in
2155
+
let len_i = int_of_float l in
2156
+
let stop_cp =
2157
+
if len_i < 0 then cp_count else Stdlib.min cp_count (off + len_i)
2158
+
in
2159
+
let start_byte = List.nth cp_starts off in
2160
+
let stop_byte = List.nth cp_starts stop_cp in
2161
+
Value.String (String.sub s start_byte (stop_byte - start_byte))
1321
2162
| "concat", [ Value.String sep; Value.Array xs ]
1322
2163
| "concat", [ Value.String sep; Value.Set xs ] ->
1323
2164
Value.String
···
1388
2229
match Value.of_json_string s with
1389
2230
| Ok _ -> Value.Bool true
1390
2231
| Error _ -> Value.Bool false)
2232
+
| "json.is_valid", [ _ ] -> Value.Bool false
2233
+
| "json.filter", [ doc; paths ] ->
2234
+
let to_path = function
2235
+
| Value.String s -> parse_json_pointer s
2236
+
| Value.Array segs ->
2237
+
List.map
2238
+
(function
2239
+
| Value.String s -> s
2240
+
| Value.Number n -> string_of_float_int n
2241
+
| _ -> raise (Eval_error "json.filter: bad path segment"))
2242
+
segs
2243
+
| _ -> raise (Eval_error "json.filter: bad path")
2244
+
in
2245
+
let paths =
2246
+
match paths with
2247
+
| Value.Array xs | Value.Set xs -> List.map to_path xs
2248
+
| _ -> raise (Eval_error "json.filter: paths must be array/set")
2249
+
in
2250
+
json_filter doc paths
2251
+
| "json.remove", [ doc; paths ] ->
2252
+
let to_path = function
2253
+
| Value.String s -> parse_json_pointer s
2254
+
| Value.Array segs ->
2255
+
List.map
2256
+
(function
2257
+
| Value.String s -> s
2258
+
| Value.Number n -> string_of_float_int n
2259
+
| _ -> raise (Eval_error "json.remove: bad path segment"))
2260
+
segs
2261
+
| _ -> raise (Eval_error "json.remove: bad path")
2262
+
in
2263
+
let paths =
2264
+
match paths with
2265
+
| Value.Array xs | Value.Set xs -> List.map to_path xs
2266
+
| _ -> raise (Eval_error "json.remove: paths must be array/set")
2267
+
in
2268
+
json_remove doc paths
2269
+
| "json.patch", [ doc; ops ] ->
2270
+
let op_list =
2271
+
match ops with
2272
+
| Value.Array xs -> xs
2273
+
| _ -> raise (Eval_error "json.patch: ops must be array")
2274
+
in
2275
+
List.fold_left json_patch_apply doc op_list
2276
+
(* Glob *)
2277
+
| "glob.match", [ Value.String pattern; delims_v; Value.String value ] ->
2278
+
let delims =
2279
+
match delims_v with
2280
+
| Value.Null -> "/"
2281
+
| Value.Array xs | Value.Set xs ->
2282
+
String.concat ""
2283
+
(List.map
2284
+
(function
2285
+
| Value.String s -> s
2286
+
| _ -> raise (Eval_error "glob.match: delimiter not string"))
2287
+
xs)
2288
+
| _ -> raise (Eval_error "glob.match: delimiters must be array or null")
2289
+
in
2290
+
Value.Bool (glob_match ~delims pattern value)
2291
+
| "glob.quote_meta", [ Value.String s ] ->
2292
+
let buf = Buffer.create (String.length s * 2) in
2293
+
String.iter
2294
+
(fun c ->
2295
+
(match c with
2296
+
| '\\' | '*' | '?' | '[' | ']' | '{' | '}' | '(' | ')' | '|' | '!' ->
2297
+
Buffer.add_char buf '\\'
2298
+
| _ -> ());
2299
+
Buffer.add_char buf c)
2300
+
s;
2301
+
Value.String (Buffer.contents buf)
2302
+
(* Net *)
2303
+
| "net.cidr_contains", [ Value.String outer; Value.String inner ] ->
2304
+
Value.Bool (cidr_contains outer inner)
2305
+
(* Units *)
2306
+
| "units.parse", [ Value.String s ] -> Value.Number (units_parse s)
2307
+
| "units.parse_bytes", [ Value.String s ] ->
2308
+
Value.Number (units_parse_bytes s)
2309
+
(* Time *)
2310
+
| "time.now_ns", [] -> Value.Number (Unix.gettimeofday () *. 1e9)
2311
+
| "time.parse_duration_ns", [ Value.String s ] ->
2312
+
Value.Number (parse_duration s)
2313
+
| "time.parse_rfc3339_ns", [ Value.String s ] ->
2314
+
Value.Number (parse_rfc3339_ns s)
2315
+
| "time.parse_ns", [ Value.String _; Value.String s ] ->
2316
+
(* OPA layouts mirror Go's reference date. We accept any of:
2317
+
RFC3339 ([YYYY-MM-DDTHH:MM:SS...]), date-only ([YYYY-MM-DD]),
2318
+
or [YYYY-MM-DDTHH:MM:SS] without timezone. *)
2319
+
let n = String.length s in
2320
+
let padded =
2321
+
if n = 10 then s ^ "T00:00:00Z" else if n = 19 then s ^ "Z" else s
2322
+
in
2323
+
Value.Number (parse_rfc3339_ns padded)
2324
+
| "time.date", [ arg ] ->
2325
+
let ns, tz = parse_time_arg arg in
2326
+
let tm = unix_tm_of_ns ~tz ns in
2327
+
Value.Array
2328
+
[
2329
+
Value.Number (float_of_int (tm.Unix.tm_year + 1900));
2330
+
Value.Number (float_of_int (tm.Unix.tm_mon + 1));
2331
+
Value.Number (float_of_int tm.Unix.tm_mday);
2332
+
]
2333
+
| "time.clock", [ arg ] ->
2334
+
let ns, tz = parse_time_arg arg in
2335
+
let tm = unix_tm_of_ns ~tz ns in
2336
+
Value.Array
2337
+
[
2338
+
Value.Number (float_of_int tm.Unix.tm_hour);
2339
+
Value.Number (float_of_int tm.Unix.tm_min);
2340
+
Value.Number (float_of_int tm.Unix.tm_sec);
2341
+
]
2342
+
| "time.weekday", [ arg ] ->
2343
+
let ns, tz = parse_time_arg arg in
2344
+
let tm = unix_tm_of_ns ~tz ns in
2345
+
Value.String (weekday_name tm.Unix.tm_wday)
2346
+
| ( "time.add_date",
2347
+
[ Value.Number ns; Value.Number y; Value.Number m; Value.Number d ] ) ->
2348
+
let tm = unix_tm_of_ns ns in
2349
+
let new_year = tm.Unix.tm_year + 1900 + int_of_float y in
2350
+
let new_month = tm.Unix.tm_mon + 1 + int_of_float m in
2351
+
let new_day = tm.Unix.tm_mday + int_of_float d in
2352
+
let days = days_from_civil new_year new_month new_day in
2353
+
let frac_secs =
2354
+
float_of_int
2355
+
((tm.Unix.tm_hour * 3600) + (tm.Unix.tm_min * 60) + tm.Unix.tm_sec)
2356
+
in
2357
+
let utc_secs = (float_of_int days *. 86400.) +. frac_secs in
2358
+
let frac_ns = ns -. (Float.floor (ns /. 1e9) *. 1e9) in
2359
+
Value.Number ((utc_secs *. 1e9) +. frac_ns)
2360
+
| "time.diff", [ a; b ] ->
2361
+
let ns_a, _ = parse_time_arg a in
2362
+
let ns_b, _ = parse_time_arg b in
2363
+
let lo, hi = if ns_a <= ns_b then (ns_a, ns_b) else (ns_b, ns_a) in
2364
+
let tm_lo = unix_tm_of_ns lo in
2365
+
let tm_hi = unix_tm_of_ns hi in
2366
+
let yrs = ref (tm_hi.Unix.tm_year - tm_lo.Unix.tm_year) in
2367
+
let mos = ref (tm_hi.Unix.tm_mon - tm_lo.Unix.tm_mon) in
2368
+
let days = ref (tm_hi.Unix.tm_mday - tm_lo.Unix.tm_mday) in
2369
+
let hrs = ref (tm_hi.Unix.tm_hour - tm_lo.Unix.tm_hour) in
2370
+
let mns = ref (tm_hi.Unix.tm_min - tm_lo.Unix.tm_min) in
2371
+
let scs = ref (tm_hi.Unix.tm_sec - tm_lo.Unix.tm_sec) in
2372
+
if !scs < 0 then begin
2373
+
scs := !scs + 60;
2374
+
decr mns
2375
+
end;
2376
+
if !mns < 0 then begin
2377
+
mns := !mns + 60;
2378
+
decr hrs
2379
+
end;
2380
+
if !hrs < 0 then begin
2381
+
hrs := !hrs + 24;
2382
+
decr days
2383
+
end;
2384
+
if !days < 0 then begin
2385
+
days := !days + 30;
2386
+
decr mos
2387
+
end;
2388
+
if !mos < 0 then begin
2389
+
mos := !mos + 12;
2390
+
decr yrs
2391
+
end;
2392
+
Value.Array
2393
+
(List.map
2394
+
(fun n -> Value.Number (float_of_int n))
2395
+
[ !yrs; !mos; !days; !hrs; !mns; !scs ])
1391
2396
(* Semver *)
1392
2397
| "semver.is_valid", [ Value.String s ] -> Value.Bool (parse_semver s <> None)
1393
2398
| "semver.compare", [ Value.String a; Value.String b ] -> (
···
1399
2404
| _ -> raise (Eval_error "semver: invalid version"))
1400
2405
(* Array / object *)
1401
2406
| "array.concat", [ Value.Array xs; Value.Array ys ] -> Value.Array (xs @ ys)
2407
+
| "array.concat", [ _; _ ] ->
2408
+
raise (Eval_error "array.concat: arguments must be arrays")
1402
2409
| "array.slice", [ Value.Array xs; Value.Number s; Value.Number e ] ->
1403
2410
let n = List.length xs in
1404
2411
let s = Stdlib.max 0 (Stdlib.min n (int_of_float s)) in
1405
2412
let e = Stdlib.max s (Stdlib.min n (int_of_float e)) in
1406
2413
Value.Array (List.filteri (fun i _ -> i >= s && i < e) xs)
1407
2414
| "array.reverse", [ Value.Array xs ] -> Value.Array (List.rev xs)
2415
+
| "array.reverse", [ _ ] ->
2416
+
raise (Eval_error "array.reverse: argument must be an array")
2417
+
| "array.flatten", [ Value.Array xs ] ->
2418
+
let rec flatten = function
2419
+
| Value.Array ys -> List.concat_map flatten ys
2420
+
| v -> [ v ]
2421
+
in
2422
+
Value.Array (List.concat_map flatten xs)
2423
+
| "array.flatten", [ _ ] ->
2424
+
raise (Eval_error "array.flatten: argument must be an array")
1408
2425
| "object.keys", [ Value.Object pairs ] ->
1409
2426
Value.Set (List.sort_uniq Value.compare (List.map fst pairs))
1410
2427
| "object.values", [ Value.Object pairs ] -> Value.Array (List.map snd pairs)
1411
2428
| "object.get", [ Value.Object pairs; key; default ] -> (
1412
2429
match List.assoc_opt key pairs with Some v -> v | None -> default)
1413
-
| "object.remove", [ Value.Object pairs; Value.Set keys ]
1414
-
| "object.remove", [ Value.Object pairs; Value.Array keys ] ->
2430
+
| "object.remove", [ Value.Object pairs; keys_v ] ->
2431
+
let keys =
2432
+
match keys_v with
2433
+
| Value.Set ks | Value.Array ks -> ks
2434
+
| Value.Object kvs -> List.map fst kvs
2435
+
| _ -> raise (Eval_error "object.remove: keys must be set/array/object")
2436
+
in
1415
2437
Value.Object
1416
2438
(List.filter
1417
2439
(fun (k, _) -> not (List.exists (Value.equal k) keys))
1418
2440
pairs)
2441
+
| "object.remove", [ _; _ ] ->
2442
+
raise (Eval_error "object.remove: first argument must be an object")
1419
2443
| "object.union", [ Value.Object a; Value.Object b ] ->
1420
2444
let keys_b = List.map fst b in
1421
2445
let a' =