(*---------------------------------------------------------------------------
   Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

type priority_pred = Bulk | Normal | Expedited | Any_priority

type t =
  | True
  | False
  | Source of Eid_pattern.t
  | Dest of Eid_pattern.t
  | Is_admin
  | Is_fragment
  | Priority of priority_pred
  | Lifetime_remaining of float
  | Tenant of Delegation.Name.t
  | And of t * t
  | Or of t * t
  | Not of t

let true_ = True
let false_ = False
let source pat = Source pat
let dest pat = Dest pat
let is_admin = Is_admin
let is_fragment = Is_fragment
let is_expedited = Priority Expedited
let is_bulk = Priority Bulk

let tenant name =
  match Delegation.Name.of_string name with
  | Ok n -> Tenant n
  | Error (`Msg m) -> invalid_arg ("Invalid tenant name: " ^ m)

let lifetime_remaining secs = Lifetime_remaining secs

(* Define is_expedited_bundle before shadowing || *)
let is_expedited_bundle (flags : Bundle.bundle_flags) =
  (* Expedited bundles typically request acknowledgments *)
  flags.ack_requested || flags.report_delivery

(* Now shadow || for predicate composition *)
let ( && ) a b = And (a, b)
let ( || ) a b = Or (a, b)
let not_ p = Not p

type context = {
  bundle : Bundle.t;
  current_time : float;
  tenant : Delegation.Name.t option;
}

let rec eval ctx = function
  | True -> true
  | False -> false
  | Source pat -> Eid_pattern.matches pat ctx.bundle.primary.source
  | Dest pat -> Eid_pattern.matches pat ctx.bundle.primary.destination
  | Is_admin -> ctx.bundle.primary.flags.is_admin_record
  | Is_fragment -> ctx.bundle.primary.flags.is_fragment
  | Priority Bulk -> not (is_expedited_bundle ctx.bundle.primary.flags)
  | Priority Normal -> not (is_expedited_bundle ctx.bundle.primary.flags)
  | Priority Expedited -> is_expedited_bundle ctx.bundle.primary.flags
  | Priority Any_priority -> true
  | Lifetime_remaining secs ->
      let creation_ms = ctx.bundle.primary.creation_timestamp.time in
      let lifetime_ms = ctx.bundle.primary.lifetime in
      let expiry_ms = Int64.add creation_ms lifetime_ms in
      let current_ms = Int64.of_float (ctx.current_time *. 1000.) in
      let remaining_ms = Int64.sub expiry_ms current_ms in
      Int64.to_float remaining_ms /. 1000. >= secs
  | Tenant name -> (
      match ctx.tenant with
      | None -> false
      | Some t -> Delegation.Name.equal t name)
  | And (a, b) ->
      (* Use if-then-else to avoid shadowed && *)
      if eval ctx a then eval ctx b else false
  | Or (a, b) ->
      (* Use if-then-else to avoid shadowed || *)
      if eval ctx a then true else eval ctx b
  | Not p -> not (eval ctx p)

let rec pp ppf = function
  | True -> Fmt.string ppf "true"
  | False -> Fmt.string ppf "false"
  | Source pat -> Fmt.pf ppf "source(%a)" Eid_pattern.pp pat
  | Dest pat -> Fmt.pf ppf "dest(%a)" Eid_pattern.pp pat
  | Is_admin -> Fmt.string ppf "is_admin"
  | Is_fragment -> Fmt.string ppf "is_fragment"
  | Priority Bulk -> Fmt.string ppf "bulk"
  | Priority Normal -> Fmt.string ppf "normal"
  | Priority Expedited -> Fmt.string ppf "expedited"
  | Priority Any_priority -> Fmt.string ppf "any_priority"
  | Lifetime_remaining secs -> Fmt.pf ppf "lifetime_remaining(%.1fs)" secs
  | Tenant name -> Fmt.pf ppf "tenant(%a)" Delegation.Name.pp name
  | And (a, b) -> Fmt.pf ppf "(%a && %a)" pp a pp b
  | Or (a, b) -> Fmt.pf ppf "(%a || %a)" pp a pp b
  | Not p -> Fmt.pf ppf "!%a" pp p

let equal_priority_pred a b =
  match (a, b) with
  | Bulk, Bulk -> true
  | Normal, Normal -> true
  | Expedited, Expedited -> true
  | Any_priority, Any_priority -> true
  | _ -> false

let rec equal a b =
  match (a, b) with
  | True, True -> true
  | False, False -> true
  | Source p1, Source p2 -> Eid_pattern.equal p1 p2
  | Dest p1, Dest p2 -> Eid_pattern.equal p1 p2
  | Is_admin, Is_admin -> true
  | Is_fragment, Is_fragment -> true
  | Priority p1, Priority p2 -> equal_priority_pred p1 p2
  | Lifetime_remaining s1, Lifetime_remaining s2 -> Float.equal s1 s2
  | Tenant n1, Tenant n2 -> Delegation.Name.equal n1 n2
  | And (a1, b1), And (a2, b2) -> if equal a1 a2 then equal b1 b2 else false
  | Or (a1, b1), Or (a2, b2) -> if equal a1 a2 then equal b1 b2 else false
  | Not p1, Not p2 -> equal p1 p2
  | _ -> false