gazagnaire.org
DTN controller and policy language for satellite networks
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6type priority_pred = Bulk | Normal | Expedited | Any_priority
7
8type t =
9 | True
10 | False
11 | Source of Eid_pattern.t
12 | Dest of Eid_pattern.t
13 | Is_admin
14 | Is_fragment
15 | Priority of priority_pred
16 | Lifetime_remaining of float
17 | Tenant of Delegation.Name.t
18 | And of t * t
19 | Or of t * t
20 | Not of t
21
22let true_ = True
23let false_ = False
24let source pat = Source pat
25let dest pat = Dest pat
26let is_admin = Is_admin
27let is_fragment = Is_fragment
28let is_expedited = Priority Expedited
29let is_bulk = Priority Bulk
30
31let tenant name =
32 match Delegation.Name.of_string name with
33 | Ok n -> Tenant n
34 | Error (`Msg m) -> invalid_arg ("Invalid tenant name: " ^ m)
35
36let lifetime_remaining secs = Lifetime_remaining secs
37
38(* Define is_expedited_bundle before shadowing || *)
39let is_expedited_bundle (flags : Bundle.bundle_flags) =
40 (* Expedited bundles typically request acknowledgments *)
41 flags.ack_requested || flags.report_delivery
42
43(* Now shadow || for predicate composition *)
44let ( && ) a b = And (a, b)
45let ( || ) a b = Or (a, b)
46let not_ p = Not p
47
48type context = {
49 bundle : Bundle.t;
50 current_time : float;
51 tenant : Delegation.Name.t option;
52}
53
54let rec eval ctx = function
55 | True -> true
56 | False -> false
57 | Source pat -> Eid_pattern.matches pat ctx.bundle.primary.source
58 | Dest pat -> Eid_pattern.matches pat ctx.bundle.primary.destination
59 | Is_admin -> ctx.bundle.primary.flags.is_admin_record
60 | Is_fragment -> ctx.bundle.primary.flags.is_fragment
61 | Priority Bulk -> not (is_expedited_bundle ctx.bundle.primary.flags)
62 | Priority Normal -> not (is_expedited_bundle ctx.bundle.primary.flags)
63 | Priority Expedited -> is_expedited_bundle ctx.bundle.primary.flags
64 | Priority Any_priority -> true
65 | Lifetime_remaining secs ->
66 let creation_ms = ctx.bundle.primary.creation_timestamp.time in
67 let lifetime_ms = ctx.bundle.primary.lifetime in
68 let expiry_ms = Int64.add creation_ms lifetime_ms in
69 let current_ms = Int64.of_float (ctx.current_time *. 1000.) in
70 let remaining_ms = Int64.sub expiry_ms current_ms in
71 Int64.to_float remaining_ms /. 1000. >= secs
72 | Tenant name -> (
73 match ctx.tenant with
74 | None -> false
75 | Some t -> Delegation.Name.equal t name)
76 | And (a, b) ->
77 (* Use if-then-else to avoid shadowed && *)
78 if eval ctx a then eval ctx b else false
79 | Or (a, b) ->
80 (* Use if-then-else to avoid shadowed || *)
81 if eval ctx a then true else eval ctx b
82 | Not p -> not (eval ctx p)
83
84let rec pp ppf = function
85 | True -> Fmt.string ppf "true"
86 | False -> Fmt.string ppf "false"
87 | Source pat -> Fmt.pf ppf "source(%a)" Eid_pattern.pp pat
88 | Dest pat -> Fmt.pf ppf "dest(%a)" Eid_pattern.pp pat
89 | Is_admin -> Fmt.string ppf "is_admin"
90 | Is_fragment -> Fmt.string ppf "is_fragment"
91 | Priority Bulk -> Fmt.string ppf "bulk"
92 | Priority Normal -> Fmt.string ppf "normal"
93 | Priority Expedited -> Fmt.string ppf "expedited"
94 | Priority Any_priority -> Fmt.string ppf "any_priority"
95 | Lifetime_remaining secs -> Fmt.pf ppf "lifetime_remaining(%.1fs)" secs
96 | Tenant name -> Fmt.pf ppf "tenant(%a)" Delegation.Name.pp name
97 | And (a, b) -> Fmt.pf ppf "(%a && %a)" pp a pp b
98 | Or (a, b) -> Fmt.pf ppf "(%a || %a)" pp a pp b
99 | Not p -> Fmt.pf ppf "!%a" pp p
100
101let equal_priority_pred a b =
102 match (a, b) with
103 | Bulk, Bulk -> true
104 | Normal, Normal -> true
105 | Expedited, Expedited -> true
106 | Any_priority, Any_priority -> true
107 | _ -> false
108
109let rec equal a b =
110 match (a, b) with
111 | True, True -> true
112 | False, False -> true
113 | Source p1, Source p2 -> Eid_pattern.equal p1 p2
114 | Dest p1, Dest p2 -> Eid_pattern.equal p1 p2
115 | Is_admin, Is_admin -> true
116 | Is_fragment, Is_fragment -> true
117 | Priority p1, Priority p2 -> equal_priority_pred p1 p2
118 | Lifetime_remaining s1, Lifetime_remaining s2 -> Float.equal s1 s2
119 | Tenant n1, Tenant n2 -> Delegation.Name.equal n1 n2
120 | And (a1, b1), And (a2, b2) -> if equal a1 a2 then equal b1 b2 else false
121 | Or (a1, b1), Or (a2, b2) -> if equal a1 a2 then equal b1 b2 else false
122 | Not p1, Not p2 -> equal p1 p2
123 | _ -> false