;;; jabber-message-correct.el --- XEP-0308 Last Message Correction  -*- lexical-binding: t; -*-

;; Copyright (C) 2026  Thanos Apollo

;; Maintainer: Thanos Apollo <public@thanosapollo.org>

;; This file is a part of jabber.el.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;;; Commentary:

;; Implements XEP-0308 Last Message Correction.
;;
;; A correction stanza is a normal <message> carrying a
;; <replace id='ORIGINAL-ID' xmlns='urn:xmpp:message-correct:0'/> child.
;; The receiver finds the original message by that id, replaces its body
;; in-place and marks it as edited.
;;
;; Send: `jabber-correct-last-message' (C-c C-e) re-sends your last
;; message with a <replace> child and updates the local buffer entry.

;;; Code:

(require 'jabber-xml)
(require 'jabber-util)
(require 'jabber-chatbuffer)
(require 'jabber-chat)
(require 'jabber-muc)
(require 'jabber-db)
(require 'jabber-disco)
(require 'jabber-message-reply)

(defconst jabber-message-correct-xmlns "urn:xmpp:message-correct:0"
  "XML namespace for XEP-0308 Last Message Correction.")

;;; Parsing

(defun jabber-message-correct--replace-id (xml-data)
  "Return the id from the <replace> child of XML-DATA, or nil."
  (when-let* ((el (jabber-xml-child-with-xmlns xml-data
                                               jabber-message-correct-xmlns))
              (replace-id (jabber-xml-get-attribute el 'id))
              ((not (string= replace-id
                             (or (jabber-xml-get-attribute xml-data 'id)
                                 "")))))
    replace-id))

;;; Sender validation

(defun jabber-message-correct--valid-sender-p
    (original-from new-from muc-p &optional original-occupant-id new-occupant-id)
  "Return non-nil if NEW-FROM may correct a message from ORIGINAL-FROM.
MUC-P non-nil means full-JID comparison unless ORIGINAL-OCCUPANT-ID
and NEW-OCCUPANT-ID are both available."
  (if muc-p
      (if (and original-occupant-id new-occupant-id)
          (string= original-occupant-id new-occupant-id)
        (string= original-from new-from))
    (string= (jabber-jid-user original-from)
             (jabber-jid-user new-from))))

;;; Apply correction

(defun jabber-message-correct--apply
    (replace-id new-body new-from muc-p buffer &optional new-occupant-id)
  "Apply correction REPLACE-ID with NEW-BODY sent by NEW-FROM.
MUC-P non-nil for groupchat.  BUFFER is the chat buffer or nil.
NEW-OCCUPANT-ID is the correction stanza's XEP-0421 occupant-id.
Validates sender against the stored original message (via DB lookup)
before writing.  If the original is not in the DB the correction is
dropped.  Returns non-nil when the correction was accepted."
  (let ((original-from (jabber-db-message-sender-by-stanza-id replace-id))
        (original-occupant-id (and muc-p
                                   (jabber-db-occupant-id-by-stanza-id
                                    replace-id))))
    (cond
     ;; A correction that failed to decrypt must never overwrite the
     ;; original body with the placeholder (issue #134).
     ((jabber--decrypt-failure-body-p new-body)
      (message "XEP-0308: dropped correction %s with undecryptable body"
               replace-id)
      nil)
     ((null original-from)
      (message "XEP-0308: correction for unknown message %s dropped" replace-id)
      nil)
     ((not (jabber-message-correct--valid-sender-p
            original-from new-from muc-p original-occupant-id new-occupant-id))
      (message "XEP-0308: rejected correction from %s for message by %s"
               new-from original-from)
      nil)
     (t
      (jabber-db-correct-message replace-id new-body)
      (when buffer
        (with-current-buffer buffer
          (when-let* ((node (jabber-chat-ewoc-find-by-id replace-id))
                      (data (ewoc-data node))
                      (msg  (cadr data)))
            (setq msg (plist-put msg :body new-body))
            (setq msg (plist-put msg :edited t))
            (setcar (cdr data) msg)
            (jabber-chat-ewoc-invalidate node))))
      t))))

;;; Inhibit DB storage of correction stanzas

(defun jabber-message-correct--inhibit (_jc xml-data)
  "Return non-nil to prevent logging XML-DATA as a new message."
  (not (null (jabber-message-correct--replace-id xml-data))))

(add-to-list 'jabber-history-inhibit-received-message-functions
             #'jabber-message-correct--inhibit)

;;; Disco feature advertisement

(jabber-disco-advertise-feature jabber-message-correct-xmlns)

;;; Find last sent message (pure)

(defun jabber-message-correct--find-last-sent (ewoc)
  "Return (NODE ID BODY MSG) for the last sent message in EWOC, or nil."
  (let (result (node (ewoc-nth ewoc -1)))
    (while (and node (not result))
      (pcase-let ((`(,type ,msg) (ewoc-data node)))
        (when (and (memq type '(:local :muc-local))
                   (listp msg)
                   (plist-get msg :id))
          (setq result (list node
                             (plist-get msg :id)
                             (or (plist-get msg :body) "")
                             msg))))
      (setq node (ewoc-prev ewoc node)))
    result))

;;; Build replace element (pure)

(defun jabber-message-correct--replace-element (stanza-id)
  "Return a <replace> XML element referencing STANZA-ID."
  `(replace ((id . ,stanza-id)
             (xmlns . ,jabber-message-correct-xmlns))))

;;; Update ewoc entry in-place

(defun jabber-message-correct--update-ewoc (ewoc node new-body)
  "Update NODE in EWOC with NEW-BODY and mark as edited."
  (let* ((data (ewoc-data node))
         (msg  (cadr data)))
    (setq msg (plist-put msg :body new-body))
    (setq msg (plist-put msg :edited t))
    (setcar (cdr data) msg)
    (let ((buffer-undo-list t))
      (ewoc-invalidate ewoc node))))

;;; Interactive command

(defun jabber-correct-last-message ()
  "Correct the last sent message in this chat buffer.
Prompts with the existing body pre-filled.  When the corrected
message is a reply, re-attach its <reply> element: per XEP-0308 the
correction replaces the whole message, XEP-0461 linkage included."
  (interactive)
  (pcase (jabber-message-correct--find-last-sent jabber-chat-ewoc)
    ('nil (user-error "No sent message found to correct"))
    (`(,node ,id ,body ,msg)
     (let ((new-body (read-string "Correction: " body)))
       (when (string= new-body body)
         (user-error "No change"))
       (let* ((fb-len (jabber-message-reply--correction-fallback-length
                       msg new-body))
              (reply-els (and-let* ((reply-id (plist-get msg :reply-to-id)))
                           (jabber-message-reply--elements
                            reply-id (plist-get msg :reply-to-jid) fb-len))))
         (plist-put msg :fallback-range (and fb-len (list 0 fb-len)))
         (jabber-message-correct--update-ewoc jabber-chat-ewoc node new-body)
         (jabber-db-correct-message id new-body)
         (let ((extra (cons (jabber-message-correct--replace-element id)
                            reply-els)))
           (if (bound-and-true-p jabber-group)
               (jabber-muc-send jabber-buffer-connection new-body extra)
             (jabber-chat-send jabber-buffer-connection new-body extra))))))))

(provide 'jabber-message-correct)
;;; jabber-message-correct.el ends here
