(** JMAP Email Validation Rules Implementation.
    
    Implements comprehensive validation for JMAP email objects and ensures
    RFC compliance for all data structures.
*)

type validation_error = [
  | `InvalidKeyword of string * string
  | `InvalidEmailAddress of string
  | `InvalidSize of int * int
  | `InvalidMailboxId of string
  | `InvalidMessageId of string
  | `InvalidHeader of string * string
  | `InvalidDate of string
  | `DuplicateRole of string
  | `InvalidRole of string
  | `MailboxHierarchyCycle of string list
  | `InvalidIdentityPermission of string
  | `InvalidSubmissionTime of string
]

let string_of_validation_error = function
  | `InvalidKeyword (keyword, reason) -> Printf.sprintf "Invalid keyword '%s': %s" keyword reason
  | `InvalidEmailAddress addr -> Printf.sprintf "Invalid email address: %s" addr
  | `InvalidSize (actual, max) -> Printf.sprintf "Size %d exceeds maximum %d" actual max
  | `InvalidMailboxId id -> Printf.sprintf "Invalid mailbox ID: %s" id
  | `InvalidMessageId id -> Printf.sprintf "Invalid Message-ID: %s" id
  | `InvalidHeader (name, reason) -> Printf.sprintf "Invalid header '%s': %s" name reason
  | `InvalidDate date -> Printf.sprintf "Invalid date format: %s" date
  | `DuplicateRole role -> Printf.sprintf "Duplicate mailbox role: %s" role
  | `InvalidRole role -> Printf.sprintf "Invalid mailbox role: %s" role
  | `MailboxHierarchyCycle path -> Printf.sprintf "Mailbox hierarchy cycle: %s" (String.concat " -> " path)
  | `InvalidIdentityPermission perm -> Printf.sprintf "Invalid identity permission: %s" perm
  | `InvalidSubmissionTime time -> Printf.sprintf "Invalid submission time: %s" time

(** {1 Keywords Validation} *)

let standard_keywords = [
  "$answered"; "$flagged"; "$draft"; "$seen"; "$recent";
  "$forwarded"; "$phishing"; "$junk"; "$notjunk"
]

let is_system_keyword keyword =
  List.mem keyword standard_keywords

let validate_keyword_format keyword =
  (* Check maximum length *)
  if String.length keyword > 255 then
    Error (`InvalidKeyword (keyword, "exceeds maximum length of 255 characters"))
  else if String.length keyword = 0 then
    Error (`InvalidKeyword (keyword, "keyword cannot be empty"))
  else
    (* Check for valid characters: lowercase ASCII, no whitespace/control *)
    let is_valid_char c =
      let code = Char.code c in
      (code >= 97 && code <= 122) ||  (* a-z *)
      (code >= 48 && code <= 57) ||   (* 0-9 *)
      code = 36 ||                    (* $ *)
      code = 45 ||                    (* - *)
      code = 95                       (* _ *)
    in
    let invalid_chars = ref [] in
    String.iteri (fun i c ->
      if not (is_valid_char c) then
        invalid_chars := (i, c) :: !invalid_chars
    ) keyword;
    
    match !invalid_chars with
    | [] ->
        (* Check if it starts with lowercase letter or $ *)
        let first_char = keyword.[0] in
        if first_char = '$' || (first_char >= 'a' && first_char <= 'z') then
          Ok ()
        else
          Error (`InvalidKeyword (keyword, "must start with lowercase letter or $"))
    | (i, c) :: _ ->
        Error (`InvalidKeyword (keyword, Printf.sprintf "invalid character '%c' at position %d" c i))

let validate_keywords keywords =
  let errors = ref [] in
  Hashtbl.iter (fun keyword _ ->
    match validate_keyword_format keyword with
    | Ok () -> ()
    | Error err -> errors := err :: !errors
  ) (Jmap_email.Keywords.to_hashtbl keywords);
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)

(** {1 Email Address Validation} *)

let validate_email_address_string addr_str =
  (* Basic email address validation according to RFC 5322 *)
  let email_regex = 
    Str.regexp "^[a-zA-Z0-9.!#$%&'*+/=?^_`{|}~-]+@[a-zA-Z0-9]\\([a-zA-Z0-9-]*[a-zA-Z0-9]\\)?\\(\\.[a-zA-Z0-9]\\([a-zA-Z0-9-]*[a-zA-Z0-9]\\)?\\)*$"
  in
  if String.length addr_str > 320 then  (* RFC 5321 limit *)
    Error (`InvalidEmailAddress "exceeds maximum length of 320 characters")
  else if String.length addr_str = 0 then
    Error (`InvalidEmailAddress "email address cannot be empty")  
  else if not (Str.string_match email_regex addr_str 0) then
    Error (`InvalidEmailAddress "invalid email address format")
  else
    (* Check local part length (before @) *)
    match String.index_opt addr_str '@' with
    | Some at_pos ->
        let local_part = String.sub addr_str 0 at_pos in
        if String.length local_part > 64 then
          Error (`InvalidEmailAddress "local part exceeds 64 characters")
        else
          Ok ()
    | None ->
        Error (`InvalidEmailAddress "missing @ symbol")

let validate_email_address addr =
  let addr_str = match Jmap_email.Address.email addr with
    | Some email -> email
    | None -> ""
  in
  validate_email_address_string addr_str

(** {1 Size Constraints Validation} *)

let validate_size_constraints email =
  let errors = ref [] in
  
  (* Check email size (if available) *)
  (match Jmap_email.Email.Email.size email with
   | Some size ->
       let size_int = Jmap.UInt.to_int size in
       if size_int > 50_000_000 then  (* 50MB limit *)
         errors := `InvalidSize (size_int, 50_000_000) :: !errors
   | None -> ());
  
  (* Check subject length *)
  (match Jmap_email.Email.Email.subject email with
   | Some subject ->
       if String.length subject > 10000 then  (* Reasonable subject limit *)
         errors := `InvalidSize (String.length subject, 10000) :: !errors
   | None -> ());
  
  (* Check attachment count *)
  (match Jmap_email.Email.Email.attachments email with
   | Some attachments ->
       let count = List.length attachments in
       if count > 100 then  (* Reasonable attachment limit *)
         errors := `InvalidSize (count, 100) :: !errors
   | None -> ());
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)

let validate_mailbox_name_size name =
  if String.length name > 255 then
    Error (`InvalidSize (String.length name, 255))
  else if String.length name = 0 then
    Error (`InvalidSize (0, 1))  (* Name cannot be empty *)
  else
    Ok ()

(** {1 Mailbox Validation} *)

let validate_mailbox_role_uniqueness mailboxes =
  let role_counts = Hashtbl.create 10 in
  let errors = ref [] in
  
  List.iter (fun mailbox ->
    match Jmap_email.Mailbox.Mailbox.role mailbox with
    | Some role ->
        let role_str = Jmap_email.Mailbox.Role.to_string role in
        let current_count = try Hashtbl.find role_counts role_str with Not_found -> 0 in
        if current_count > 0 then
          errors := `DuplicateRole role_str :: !errors;
        Hashtbl.replace role_counts role_str (current_count + 1)
    | None -> ()
  ) mailboxes;
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)

let validate_mailbox_hierarchy mailboxes =
  (* Build parent-child map *)
  let parent_map = Hashtbl.create 50 in
  let id_to_name = Hashtbl.create 50 in
  
  List.iter (fun mailbox ->
    match Jmap_email.Mailbox.Mailbox.id mailbox with
    | Some id ->
        let id_str = Jmap.Id.to_string id in
        let name = match Jmap_email.Mailbox.Mailbox.name mailbox with
          | Some n -> n
          | None -> id_str
        in
        Hashtbl.add id_to_name id_str name;
        
        (match Jmap_email.Mailbox.Mailbox.parent_id mailbox with
         | Some parent_id ->
             let parent_str = Jmap.Id.to_string parent_id in
             Hashtbl.add parent_map id_str parent_str
         | None -> ())
    | None -> ()
  ) mailboxes;
  
  (* Detect cycles using DFS *)
  let visited = Hashtbl.create 50 in
  let rec_stack = Hashtbl.create 50 in
  let errors = ref [] in
  
  let rec dfs_cycle_check node path =
    if Hashtbl.mem rec_stack node then
      (* Found cycle *)
      let cycle_path = node :: path in
      let cycle_names = List.map (fun id ->
        try Hashtbl.find id_to_name id
        with Not_found -> id
      ) cycle_path in
      errors := `MailboxHierarchyCycle cycle_names :: !errors
    else if not (Hashtbl.mem visited node) then begin
      Hashtbl.add visited node true;
      Hashtbl.add rec_stack node true;
      
      (try
         let parent = Hashtbl.find parent_map node in
         dfs_cycle_check parent (node :: path)
       with Not_found -> ());
      
      Hashtbl.remove rec_stack node
    end
  in
  
  Hashtbl.iter (fun node _ ->
    if not (Hashtbl.mem visited node) then
      dfs_cycle_check node []
  ) id_to_name;
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)

let validate_mailbox_name_collisions mailboxes =
  let name_map = Hashtbl.create 50 in
  let errors = ref [] in
  
  List.iter (fun mailbox ->
    match Jmap_email.Mailbox.Mailbox.name mailbox with
    | Some name ->
        let parent_str = match Jmap_email.Mailbox.Mailbox.parent_id mailbox with
          | Some parent_id -> Jmap.Id.to_string parent_id
          | None -> "root"
        in
        let full_path = parent_str ^ "/" ^ name in
        
        if Hashtbl.mem name_map full_path then
          errors := `InvalidRole ("name collision: " ^ name) :: !errors
        else
          Hashtbl.add name_map full_path true
    | None -> ()
  ) mailboxes;
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)

(** {1 Email Submission Validation} *)

let validate_smtp_envelope envelope =
  let errors = ref [] in
  
  (* Validate sender email *)
  (match Jmap_email.Submission.Envelope.mail_from envelope with
   | Some sender ->
       (match validate_email_address_string sender with
        | Error err -> errors := err :: !errors
        | Ok () -> ())
   | None ->
       errors := `InvalidEmailAddress "SMTP envelope must have mail_from" :: !errors);
  
  (* Validate recipient emails *)
  let recipients = Jmap_email.Submission.Envelope.rcpt_to envelope in
  List.iter (fun recipient ->
    match validate_email_address_string recipient with
    | Error err -> errors := err :: !errors
    | Ok () -> ()
  ) recipients;
  
  (* Check recipient count *)
  if List.length recipients = 0 then
    errors := `InvalidEmailAddress "SMTP envelope must have at least one recipient" :: !errors;
  
  if List.length recipients > 100 then  (* Reasonable limit *)
    errors := `InvalidSize (List.length recipients, 100) :: !errors;
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)

let validate_send_time_constraints send_at =
  match send_at with
  | None -> Ok ()
  | Some send_time ->
      let now = Unix.time () in
      let send_timestamp = Jmap.Date.to_timestamp send_time in
      
      (* Don't allow sending emails too far in the future (1 year) *)
      if send_timestamp > now +. (365.0 *. 24.0 *. 3600.0) then
        Error (`InvalidSubmissionTime "send time too far in future")
      (* Don't allow sending emails in the past (with 5 minute tolerance) *)
      else if send_timestamp < now -. 300.0 then
        Error (`InvalidSubmissionTime "send time cannot be in the past")
      else
        Ok ()

let validate_identity_permission identity sender_email =
  match Jmap_email.Identity.Identity.email identity with
  | Some identity_email ->
      if identity_email = sender_email then
        Ok ()
      else
        Error (`InvalidIdentityPermission ("identity email does not match sender: " ^ identity_email ^ " vs " ^ sender_email))
  | None ->
      Error (`InvalidIdentityPermission "identity must have an email address")

(** {1 Header Validation} *)

let validate_header header =
  let name = Jmap_email.Header.name header in
  let value = Jmap_email.Header.value header in
  
  (* Check header name format *)
  let name_errors = 
    if String.length name = 0 then
      [`InvalidHeader (name, "header name cannot be empty")]
    else if String.length name > 255 then
      [`InvalidHeader (name, "header name too long")]
    else
      (* Check for valid header name characters *)
      let invalid_chars = ref [] in
      String.iteri (fun i c ->
        let code = Char.code c in
        if not ((code >= 33 && code <= 126) && code <> 58) then  (* Printable ASCII except : *)
          invalid_chars := (i, c) :: !invalid_chars
      ) name;
      match !invalid_chars with
      | [] -> []
      | (i, c) :: _ -> [`InvalidHeader (name, Printf.sprintf "invalid character '%c' at position %d" c i)]
  in
  
  (* Check header value length *)
  let value_errors = 
    if String.length value > 10000 then  (* Reasonable header value limit *)
      [`InvalidHeader (name, "header value too long")]
    else
      []
  in
  
  match name_errors @ value_errors with
  | [] -> Ok ()
  | err :: _ -> Error err

let validate_message_id message_id =
  (* Basic Message-ID format: <unique@domain> *)
  let msg_id_regex = Str.regexp "^<[^<>@]+@[^<>@]+>$" in
  if String.length message_id > 255 then
    Error (`InvalidMessageId "Message-ID too long")
  else if not (Str.string_match msg_id_regex message_id 0) then
    Error (`InvalidMessageId "invalid Message-ID format, must be <unique@domain>")
  else
    Ok ()

let validate_references references =
  (* References should be space-separated Message-IDs *)
  let msg_ids = String.split_on_char ' ' references in
  let filtered_ids = List.filter (fun s -> String.length s > 0) msg_ids in
  
  let rec validate_all = function
    | [] -> Ok ()
    | id :: rest ->
        (match validate_message_id id with
         | Ok () -> validate_all rest
         | Error err -> Error err)
  in
  
  if List.length filtered_ids > 50 then  (* Reasonable limit on references *)
    Error (`InvalidMessageId "too many references (maximum 50)")
  else
    validate_all filtered_ids

(** {1 Date Validation} *)

let validate_date_string date_str =
  (* Try to parse the date string *)
  try
    let _ = Jmap.Date.of_string date_str in
    Ok ()
  with
  | _ -> Error (`InvalidDate ("cannot parse date: " ^ date_str))

let validate_date date =
  let timestamp = Jmap.Date.to_timestamp date in
  (* Check reasonable date range (1970 to 2100) *)
  if timestamp < 0.0 then
    Error (`InvalidDate "date before Unix epoch")
  else if timestamp > 4102444800.0 then  (* 2100-01-01 *)
    Error (`InvalidDate "date too far in future")
  else
    Ok ()

(** {1 Comprehensive Validation} *)

let validate_email_complete email =
  let errors = ref [] in
  
  (* Validate keywords *)
  (match Jmap_email.Email.Email.keywords email with
   | Some keywords ->
       (match validate_keywords keywords with
        | Error errs -> errors := errs @ !errors
        | Ok () -> ())
   | None -> ());
  
  (* Validate sender addresses *)
  (match Jmap_email.Email.Email.from email with
   | Some from_addrs ->
       List.iter (fun addr ->
         match validate_email_address addr with
         | Error err -> errors := err :: !errors
         | Ok () -> ()
       ) from_addrs
   | None -> ());
  
  (* Validate recipient addresses *)
  (match Jmap_email.Email.Email.to_ email with
   | Some to_addrs ->
       List.iter (fun addr ->
         match validate_email_address addr with
         | Error err -> errors := err :: !errors
         | Ok () -> ()
       ) to_addrs
   | None -> ());
  
  (* Validate size constraints *)
  (match validate_size_constraints email with
   | Error errs -> errors := errs @ !errors
   | Ok () -> ());
  
  (* Validate date *)
  (match Jmap_email.Email.Email.received_at email with
   | Some date ->
       (match validate_date date with
        | Error err -> errors := err :: !errors
        | Ok () -> ())
   | None -> ());
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)

let validate_mailbox_complete mailbox =
  let errors = ref [] in
  
  (* Validate name *)
  (match Jmap_email.Mailbox.Mailbox.name mailbox with
   | Some name ->
       (match validate_mailbox_name_size name with
        | Error err -> errors := err :: !errors
        | Ok () -> ())
   | None ->
       errors := `InvalidSize (0, 1) :: !errors);  (* Name required *)
  
  (* Additional mailbox validations would go here *)
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)

let validate_submission_complete submission =
  let errors = ref [] in
  
  (* Validate envelope *)
  (match Jmap_email.Submission.EmailSubmission.envelope submission with
   | Some envelope ->
       (match validate_smtp_envelope envelope with
        | Error errs -> errors := errs @ !errors
        | Ok () -> ())
   | None -> ());
  
  (* Validate send time *)
  let send_at = Jmap_email.Submission.EmailSubmission.send_at submission in
  (match validate_send_time_constraints send_at with
   | Error err -> errors := err :: !errors
   | Ok () -> ());
  
  match !errors with
  | [] -> Ok ()
  | errs -> Error (List.rev errs)