(** JMAP Error Types and Exception Handling

    This module defines all error types from RFC 8620 (Core JMAP Protocol)
    and RFC 8621 (JMAP for Mail).

    Reference: RFC 8620 Section 3.6 (Error Handling)
    Test files: test/data/core/error_method.json
*)

(** Error classification level *)
type error_level =
  | Request_level    (** HTTP 4xx/5xx errors before request processing *)
  | Method_level     (** Method execution errors *)
  | Set_level        (** Object-level errors in /set operations *)

(** Request-level errors (RFC 8620 Section 3.6.1)
    These return HTTP error responses with JSON problem details (RFC 7807) *)
type request_error =
  | Unknown_capability of string  (** Unsupported capability in "using" *)
  | Not_json                      (** Not application/json or invalid I-JSON *)
  | Not_request                   (** JSON doesn't match Request type *)
  | Limit of string               (** Request limit exceeded, includes limit property name *)

(** Method-level errors (RFC 8620 Section 3.6.2)
    These return error Invocations in methodResponses *)
type method_error =
  (* General method errors *)
  | Server_unavailable            (** Temporary server issue, retry later *)
  | Server_fail of string option  (** Unexpected error, includes description *)
  | Server_partial_fail           (** Some changes succeeded, must resync *)
  | Unknown_method                (** Method name not recognized *)
  | Invalid_arguments of string option  (** Invalid/missing arguments *)
  | Invalid_result_reference      (** Result reference failed to resolve *)
  | Forbidden                     (** ACL/permission violation *)
  | Account_not_found             (** Invalid accountId *)
  | Account_not_supported_by_method  (** Account doesn't support this method *)
  | Account_read_only             (** Account is read-only *)

  (* Standard method-specific errors *)
  | Request_too_large             (** Too many ids/operations requested *)
  | State_mismatch                (** ifInState doesn't match current state *)
  | Cannot_calculate_changes      (** Server cannot calculate changes from state *)
  | Anchor_not_found              (** Anchor id not in query results *)
  | Unsupported_sort              (** Sort property/collation not supported *)
  | Unsupported_filter            (** Filter cannot be processed *)
  | Too_many_changes              (** More changes than maxChanges *)

  (* /copy specific errors *)
  | From_account_not_found        (** Source account not found *)
  | From_account_not_supported_by_method  (** Source account doesn't support type *)

(** Set-level errors (RFC 8620 Section 5.3)
    These appear in notCreated, notUpdated, notDestroyed maps *)
type set_error_type =
  (* Core set errors *)
  | Forbidden                     (** Permission denied *)
  | Over_quota                    (** Quota exceeded *)
  | Too_large                     (** Object too large *)
  | Rate_limit                    (** Rate limit hit *)
  | Not_found                     (** Id not found *)
  | Invalid_patch                 (** Invalid PatchObject *)
  | Will_destroy                  (** Object both updated and destroyed *)
  | Invalid_properties            (** Invalid properties *)
  | Singleton                     (** Cannot create/destroy singleton *)
  | Already_exists                (** Duplicate exists (in /copy) *)

  (* Mail-specific set errors (RFC 8621) *)
  | Mailbox_has_child             (** Cannot destroy mailbox with children *)
  | Mailbox_has_email             (** Cannot destroy mailbox with emails *)
  | Blob_not_found                (** Referenced blob doesn't exist *)
  | Too_many_keywords             (** Keyword limit exceeded *)
  | Too_many_mailboxes            (** Mailbox assignment limit exceeded *)
  | Invalid_email                 (** Email invalid for sending *)
  | Too_many_recipients           (** Recipient limit exceeded *)
  | No_recipients                 (** No recipients specified *)
  | Invalid_recipients            (** Invalid recipient addresses *)
  | Forbidden_mail_from           (** Cannot use MAIL FROM address *)
  | Forbidden_from                (** Cannot use From header address *)
  | Forbidden_to_send             (** No send permission *)
  | Cannot_unsend                 (** Cannot cancel submission *)

(** SetError detail with optional fields *)
type set_error_detail = {
  error_type : set_error_type;
  description : string option;
  properties : string list option;  (** For Invalid_properties *)
  existing_id : string option;      (** For Already_exists *)
  not_found : string list option;   (** For Blob_not_found *)
  max_recipients : int option;      (** For Too_many_recipients *)
  invalid_recipients : string list option;  (** For Invalid_recipients *)
}

(** Main JMAP exception type *)
exception Jmap_error of error_level * string * string option

(** Parse error for JSON parsing failures *)
exception Parse_error of string

(** Helper constructors for exceptions *)

let request_error err =
  let msg = match err with
    | Unknown_capability cap -> Printf.sprintf "Unknown capability: %s" cap
    | Not_json -> "Request is not valid JSON"
    | Not_request -> "JSON does not match Request structure"
    | Limit prop -> Printf.sprintf "Request limit exceeded: %s" prop
  in
  Jmap_error (Request_level, msg, None)

let method_error err =
  let msg, desc = match err with
    | Server_unavailable -> "serverUnavailable", None
    | Server_fail desc -> "serverFail", desc
    | Server_partial_fail -> "serverPartialFail", None
    | Unknown_method -> "unknownMethod", None
    | Invalid_arguments desc -> "invalidArguments", desc
    | Invalid_result_reference -> "invalidResultReference", None
    | Forbidden -> "forbidden", None
    | Account_not_found -> "accountNotFound", None
    | Account_not_supported_by_method -> "accountNotSupportedByMethod", None
    | Account_read_only -> "accountReadOnly", None
    | Request_too_large -> "requestTooLarge", None
    | State_mismatch -> "stateMismatch", None
    | Cannot_calculate_changes -> "cannotCalculateChanges", None
    | Anchor_not_found -> "anchorNotFound", None
    | Unsupported_sort -> "unsupportedSort", None
    | Unsupported_filter -> "unsupportedFilter", None
    | Too_many_changes -> "tooManyChanges", None
    | From_account_not_found -> "fromAccountNotFound", None
    | From_account_not_supported_by_method -> "fromAccountNotSupportedByMethod", None
  in
  Jmap_error (Method_level, msg, desc)

let set_error detail =
  let msg = match detail.error_type with
    | Forbidden -> "forbidden"
    | Over_quota -> "overQuota"
    | Too_large -> "tooLarge"
    | Rate_limit -> "rateLimit"
    | Not_found -> "notFound"
    | Invalid_patch -> "invalidPatch"
    | Will_destroy -> "willDestroy"
    | Invalid_properties -> "invalidProperties"
    | Singleton -> "singleton"
    | Already_exists -> "alreadyExists"
    | Mailbox_has_child -> "mailboxHasChild"
    | Mailbox_has_email -> "mailboxHasEmail"
    | Blob_not_found -> "blobNotFound"
    | Too_many_keywords -> "tooManyKeywords"
    | Too_many_mailboxes -> "tooManyMailboxes"
    | Invalid_email -> "invalidEmail"
    | Too_many_recipients -> "tooManyRecipients"
    | No_recipients -> "noRecipients"
    | Invalid_recipients -> "invalidRecipients"
    | Forbidden_mail_from -> "forbiddenMailFrom"
    | Forbidden_from -> "forbiddenFrom"
    | Forbidden_to_send -> "forbiddenToSend"
    | Cannot_unsend -> "cannotUnsend"
  in
  Jmap_error (Set_level, msg, detail.description)

let parse_error msg =
  Parse_error msg

(** Convert error type to string for serialization *)
let request_error_to_string = function
  | Unknown_capability _ -> "urn:ietf:params:jmap:error:unknownCapability"
  | Not_json -> "urn:ietf:params:jmap:error:notJSON"
  | Not_request -> "urn:ietf:params:jmap:error:notRequest"
  | Limit _ -> "urn:ietf:params:jmap:error:limit"

let method_error_to_string = function
  | Server_unavailable -> "serverUnavailable"
  | Server_fail _ -> "serverFail"
  | Server_partial_fail -> "serverPartialFail"
  | Unknown_method -> "unknownMethod"
  | Invalid_arguments _ -> "invalidArguments"
  | Invalid_result_reference -> "invalidResultReference"
  | Forbidden -> "forbidden"
  | Account_not_found -> "accountNotFound"
  | Account_not_supported_by_method -> "accountNotSupportedByMethod"
  | Account_read_only -> "accountReadOnly"
  | Request_too_large -> "requestTooLarge"
  | State_mismatch -> "stateMismatch"
  | Cannot_calculate_changes -> "cannotCalculateChanges"
  | Anchor_not_found -> "anchorNotFound"
  | Unsupported_sort -> "unsupportedSort"
  | Unsupported_filter -> "unsupportedFilter"
  | Too_many_changes -> "tooManyChanges"
  | From_account_not_found -> "fromAccountNotFound"
  | From_account_not_supported_by_method -> "fromAccountNotSupportedByMethod"

let set_error_type_to_string = function
  | Forbidden -> "forbidden"
  | Over_quota -> "overQuota"
  | Too_large -> "tooLarge"
  | Rate_limit -> "rateLimit"
  | Not_found -> "notFound"
  | Invalid_patch -> "invalidPatch"
  | Will_destroy -> "willDestroy"
  | Invalid_properties -> "invalidProperties"
  | Singleton -> "singleton"
  | Already_exists -> "alreadyExists"
  | Mailbox_has_child -> "mailboxHasChild"
  | Mailbox_has_email -> "mailboxHasEmail"
  | Blob_not_found -> "blobNotFound"
  | Too_many_keywords -> "tooManyKeywords"
  | Too_many_mailboxes -> "tooManyMailboxes"
  | Invalid_email -> "invalidEmail"
  | Too_many_recipients -> "tooManyRecipients"
  | No_recipients -> "noRecipients"
  | Invalid_recipients -> "invalidRecipients"
  | Forbidden_mail_from -> "forbiddenMailFrom"
  | Forbidden_from -> "forbiddenFrom"
  | Forbidden_to_send -> "forbiddenToSend"
  | Cannot_unsend -> "cannotUnsend"

let set_error_type_of_string = function
  | "forbidden" -> Forbidden
  | "overQuota" -> Over_quota
  | "tooLarge" -> Too_large
  | "rateLimit" -> Rate_limit
  | "notFound" -> Not_found
  | "invalidPatch" -> Invalid_patch
  | "willDestroy" -> Will_destroy
  | "invalidProperties" -> Invalid_properties
  | "singleton" -> Singleton
  | "alreadyExists" -> Already_exists
  | "mailboxHasChild" -> Mailbox_has_child
  | "mailboxHasEmail" -> Mailbox_has_email
  | "blobNotFound" -> Blob_not_found
  | "tooManyKeywords" -> Too_many_keywords
  | "tooManyMailboxes" -> Too_many_mailboxes
  | "invalidEmail" -> Invalid_email
  | "tooManyRecipients" -> Too_many_recipients
  | "noRecipients" -> No_recipients
  | "invalidRecipients" -> Invalid_recipients
  | "forbiddenMailFrom" -> Forbidden_mail_from
  | "forbiddenFrom" -> Forbidden_from
  | "forbiddenToSend" -> Forbidden_to_send
  | "cannotUnsend" -> Cannot_unsend
  | s -> raise (Parse_error (Printf.sprintf "Unknown set error type: %s" s))

(** Parse set_error_detail from JSON *)
let parse_set_error_detail json =
  match json with
  | `O fields ->
      let error_type = match List.assoc_opt "type" fields with
        | Some (`String s) -> set_error_type_of_string s
        | Some _ -> raise (Parse_error "SetError type must be a string")
        | None -> raise (Parse_error "SetError requires 'type' field")
      in
      let description = match List.assoc_opt "description" fields with
        | Some (`String s) -> Some s
        | Some `Null | None -> None
        | Some _ -> raise (Parse_error "SetError description must be a string")
      in
      let properties = match List.assoc_opt "properties" fields with
        | Some (`A items) ->
            Some (List.map (function
              | `String s -> s
              | _ -> raise (Parse_error "SetError properties must be strings")
            ) items)
        | Some `Null | None -> None
        | Some _ -> raise (Parse_error "SetError properties must be an array")
      in
      let existing_id = match List.assoc_opt "existingId" fields with
        | Some (`String s) -> Some s
        | Some `Null | None -> None
        | Some _ -> raise (Parse_error "SetError existingId must be a string")
      in
      let not_found = match List.assoc_opt "notFound" fields with
        | Some (`A items) ->
            Some (List.map (function
              | `String s -> s
              | _ -> raise (Parse_error "SetError notFound must be strings")
            ) items)
        | Some `Null | None -> None
        | Some _ -> raise (Parse_error "SetError notFound must be an array")
      in
      let max_recipients = match List.assoc_opt "maxRecipients" fields with
        | Some (`Float f) -> Some (int_of_float f)
        | Some `Null | None -> None
        | Some _ -> raise (Parse_error "SetError maxRecipients must be a number")
      in
      let invalid_recipients = match List.assoc_opt "invalidRecipients" fields with
        | Some (`A items) ->
            Some (List.map (function
              | `String s -> s
              | _ -> raise (Parse_error "SetError invalidRecipients must be strings")
            ) items)
        | Some `Null | None -> None
        | Some _ -> raise (Parse_error "SetError invalidRecipients must be an array")
      in
      { error_type; description; properties; existing_id; not_found;
        max_recipients; invalid_recipients }
  | _ -> raise (Parse_error "SetError must be a JSON object")