;;; nnatom.el --- Atom backend for Gnus -*- lexical-binding: t -*-

;; Copyright (C) 2023 Free Software Foundation, Inc.
;; Author: Daniel Semyonov <daniel@dsemy.com>

;; This file is part of GNU Emacs.

;; nnatom 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 3 of the License, or
;; (at your option) any later version.

;; nnatom 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 nnatom.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Gnus backend for HTTP or local feeds following the
;; Atom Syndication Format <https://www.ietf.org/rfc/rfc4287>.
;; Other types of feeds may be supported by providing custom parsing
;; functions.

;;; Code:

(eval-when-compile
  (require 'cl-lib)
  (require 'subr-x))

(require 'gnus)
(require 'nnheader)
(require 'nnoo)
(require 'gnus-group)
(require 'mm-url)
(require 'dom)

(defgroup nnatom nil
  "Atom backend for Gnus."
  :group 'gnus)

(nnoo-declare nnatom)

(defvoo nnatom-backend 'nnatom
  "Symbol which identifies this backend.")

(defvoo nnatom-status-string nil
  "Last status message reported by this backend.")

;;;; Atom feed parser:

(defun nnatom--read-feed (feed _)
  "Return a list structure representing FEED, or nil."
  (if (string-match-p "\\`https?://" feed)
      (nnheader-report
       nnatom-backend
       "Address shouldn't start with \"http://\" or \"https://\"")
    (with-temp-buffer
      (condition-case e
          (if (file-name-absolute-p feed)
              (insert-file-contents feed)
            (mm-url-insert-file-contents (concat "https://" feed)))
        (file-error (nnheader-report nnatom-backend (cdr e)))
        (:success (when-let ((data (if (libxml-available-p)
                                       (libxml-parse-xml-region
                                        (point-min) (point-max))
                                     (car (xml-parse-region
                                           (point-min) (point-max)))))
                             (auth (list 'authors)))
                    (when (eq (car data) 'top)
                      (setq data (assq 'feed data)))
                    (dom-add-child-before data auth)
                    (catch :stop ; Collect feed authors, stop at first entry.
                      (dolist (child (cdddr data))
                        (let ((tag (car-safe child)))
                          (if (eq tag 'entry)
                              (throw :stop data)
                            (and (or (eq tag 'author)
                                     (eq tag 'contributor))
                                 (dom-add-child-before auth child)))))
                      data)))))))

(defun nnatom--read-group (data)
  "Return the next group and the remaining DATA in a cons cell, or nil."
  `(,data))

(defun nnatom--read-article (data _)
  "Return the next article and the remaining DATA in a cons cell, or nil."
  (when (eq (car data) 'feed) (setq data (cddr data)))
  (while (and data (not (eq (car-safe (car data)) 'entry))) (pop data))
  (when-let ((article (car data))
             (auths (list 'authors)) (links (list 'links)))
    (dom-add-child-before article links)
    (dom-add-child-before article auths)
    (dolist (child (cddddr article) `(,article . ,(cdr data)))
      (pcase (car-safe child)                ; Authors and links can appear
        ((or 'author 'contributor)           ; anywhere in the entry so we
         (dom-add-child-before auths child)  ; collect them all here to
         (dom-add-child-before links child)) ; avoid looping over the
        ((or 'link                           ; entry multiple times later.
             (and 'content (guard (assq 'src (dom-attributes child)))))
         (dom-add-child-before links child))))))

(defun nnatom--read-title (group)
  "Return the title of GROUP, or nil."
  (dom-text (dom-child-by-tag group 'title)))

(defun nnatom--read-description (group)
  "Return the description of GROUP, or nil."
  (dom-text (dom-child-by-tag group 'subtitle)))

(defun nnatom--read-article-or-group-authors (article-or-group)
  "Return the authors of ARTICLE-OR-GROUP, or nil."
  (when-let
      ((a (string-trim-right
           (mapconcat (lambda (author)
                        (let* ((name
                                (dom-text (dom-child-by-tag author 'name)))
                               (name (unless (string-blank-p name) name))
                               (email
                                (dom-text (dom-child-by-tag author 'email)))
                               (email (unless (string-blank-p email) email)))
                          (concat
                           (or (and name email (format "%s <%s>" name email))
                               name email)
                           ", ")))
                      (dom-children
                       (dom-child-by-tag article-or-group 'authors)))
           ", "))
       ((not (string-blank-p a))))
    a))

(defun nnatom--read-subject (article)
  "Return the subject of ARTICLE, or nil."
  (dom-text (dom-child-by-tag article 'title)))

(defun nnatom--read-id (article)
  "Return the ID of ARTICLE.
If the ARTICLE doesn't contain an ID but it does contain a subject,
return the subject.  Otherwise, return nil."
  (or (dom-text (dom-child-by-tag article 'id))
      (nnatom--read-subject article)))

(defun nnatom--read-publish (article)
  "Return the date and time ARTICLE was published, or nil."
  (when-let (d (dom-child-by-tag article 'published))
    (date-to-time (dom-text d))))

(defun nnatom--read-update (article)
  "Return the date and time of the last update to ARTICLE, or nil."
  (when-let (d (dom-child-by-tag article 'updated))
    (date-to-time (dom-text d))))

(defun nnatom--read-links (article)
  "Return all links contained in ARTICLE, or nil."
  (let ((alt 0) (rel 0) (sel 0) (enc 0) (via 0) (aut 0))
    (mapcan
     (lambda (link)
       (when-let ((l (car-safe link)))
         (or
          (when-let (((eq l 'content))
                     (src (dom-attr link 'src))
                     (label (concat "Link"
                                    (and (< 1 (cl-incf alt))
                                         (format " %s" alt)))))
            `(((("text/plain") . ,(format "%s: %s\n" label src))
               (("text/html") . ,(format "<a href=\"%s\">[%s]</a> "
                                         src label)))))
          (when-let (((or (eq l 'author) (eq l 'contributor)))
                     (name (dom-text (dom-child-by-tag link 'name)))
                     (name (if (string-blank-p name)
                               (concat "Author"
                                       (and (< 1 (cl-incf aut))
                                            (format " %s" aut)))
                             name))
                     (uri (dom-text (dom-child-by-tag link 'uri)))
                     ((not (string-blank-p uri))))
            `(((("text/plain") . ,(format "%s: %s\n" name uri))
               (("text/html") . ,(format "<a href=\"%s\">[%s]</a> "
                                         uri name)))))
          (when-let (((eq l 'link))
                     (attrs (dom-attributes link))
                     (label (or (cdr (assq 'title attrs))
                                (pcase (cdr (assq 'rel attrs))
                                  ("related"
                                   (concat "Related"
                                           (and (< 1 (cl-incf rel))
                                                (format " %s" rel))))
                                  ("self"
                                   (concat "More"
                                           (and (< 1 (cl-incf sel))
                                                (format " %s" sel))))
                                  ("enclosure"
                                   (concat "Enclosure"
                                           (and (< 1 (cl-incf enc))
                                                (format " %s" enc))))
                                  ("via"
                                   (concat "Source"
                                           (and (< 1 (cl-incf via))
                                                (format " %s" via))))
                                  (_ (if-let
                                         ((lang (cdr (assq 'hreflang link))))
                                         (format "Link (%s)" lang)
                                       (concat
                                        "Link"
                                        (and (< 1 (cl-incf alt))
                                             (format " %s" alt))))))))
                     (link (cdr (assq 'href attrs))))
            `(((("text/plain") . ,(format "%s: %s\n" label link))
               (("text/html") . ,(format "<a href=\"%s\">[%s]</a> "
                                         link label))))))))
     (dom-children (dom-child-by-tag article 'links)))))

(defun nnatom--read-part (part type)
  (let* ((atypes '("html" "plain"))
         (mtypes '(("xhtml" . "text/html") ("text" . "text/plain")))
         (xsuff (concat "[+/]xml\\(-\\(dtd\\|external-parsed-entity\\)\\)?\\'"
                        "\\|^text"))
         (part (if (string= type "xhtml")
                   (with-temp-buffer
                     (dom-print (dom-child-by-tag part 'div) nil t)
                     (buffer-substring-no-properties
                      (point-min) (point-max)))
                 (dom-text part)))
         (type (if (member type atypes) (concat "text/" type) type))
         (type (or (cdr (assoc type mtypes)) type)))
    (unless (string-blank-p part)
      `(,part (Content-Type . ,(or type (setq type "text/plain")))
              ,(and (not (string-match-p xsuff type))
                    '(Content-Transfer-Encoding . "base64"))))))

(defun nnatom--read-parts (article)
  "Return all parts contained in ARTICLE, or an empty HTML part with links."
  (let* ((summary (dom-child-by-tag article 'summary))
         (stype (cdr (assq 'type (dom-attributes summary))))
         (summary (nnatom--read-part summary stype))
         (content (dom-child-by-tag article 'content))
         (ctype (cdr (assq 'type (dom-attributes content))))
         (content (nnatom--read-part content ctype))
         (st (string= stype ctype))
         parts)
    (cond ((and summary content)
           (and st (push summary parts))
           (push (append content '(links)) parts)
           (or st (push summary parts))
           parts)
          ((setq parts (or summary content))
           `(,(append (or summary content) '(links))))
          (t '((nil (Content-Type . "text/html") links))))))

;;;; Feed I/O:

(defvoo nnatom-read-feed-function #'nnatom--read-feed
  "Function returning a Lisp object representing a feed (or part of it).
It should accept two arguments, the address of a feed and the name of
a group (or nil).
If a group name is supplied, it should return a representation of only
the group (as if it was extracted from the feed with
`nnatom-read-group-function').")

(defvoo nnatom-read-group-function #'nnatom--read-group
  "Function returning a cons cell of a group and remaining data from a feed.")

(defvoo nnatom-read-article-function #'nnatom--read-article
  "Function returning a cons cell of an article and remaining data from a group.
It should accept a two arguments, a Lisp object representing a feed,
and a flag indicating whether the last article was stale (not new or updated).")

(defvoo nnatom-read-title-function #'nnatom--read-title
  "Function returning the title of a group (a string).
It should accept a single argument, a Lisp object representing a group.")

(defvoo nnatom-read-description-function #'nnatom--read-description
  "Function returning the description of a group (a string).
It should accept a single argument, a Lisp object representing a group.")

(defvoo nnatom-read-group-author-function
    #'nnatom--read-article-or-group-authors
  "Function returning the author of a group (a string).
It should accept a single argument, a Lisp object representing a group.")

(defvoo nnatom-read-id-function #'nnatom--read-id
  "Function returning the ID of an article.
It should accept a single argument, a Lisp object representing an article.")

(defvoo nnatom-read-subject-function #'nnatom--read-subject
  "Function returning the subject of an article (a string).
It should accept a single argument, a Lisp object representing an article.")

(defvoo nnatom-read-publish-date-function #'nnatom--read-publish
  "Function returning the publish date of an article (a time value).
It should accept a single argument, a Lisp object representing an article.")

(defvoo nnatom-read-update-date-function #'nnatom--read-update
  "Function returning the update date of an article (a time value).
It should accept a single argument, a Lisp object representing an article.")

(defvoo nnatom-read-author-function #'nnatom--read-article-or-group-authors
  "Function returning the author of an article (a string).
It should accept a single argument, a Lisp object representing an article.")

(defvoo nnatom-read-headers-function #'ignore
  "Function returning an alist of article-wide MIME headers.
Each element of this alist maps a MIME header (a symbol,
i.e. `Content-Type') to its value.  As a special case, `:boundary'
maps to a string which will serve as the boundary between article
parts.  This must be supplied if a custom boundary is used in a
multipart content type header.  The default boundary is \"-_nnatom_-\",
and is automatically modified to match the name of the back end.
It should accept a single argument, a Lisp object representing an article.")

(defvoo nnatom-read-links-function #'nnatom--read-links
  "Function returning all links contained in an article.
For the default `nnatom-print-content-function', it should return a
list of links, where each link is an alist mapping MIME content types
to links formatted for display in a part of that type.  Each content
type may also be a list of content types.
Otherwise, it could return any Lisp object.
It should accept a single argument, a Lisp object representing an article.")

(defvoo nnatom-read-parts-function #'nnatom--read-parts
  "Function returning an alist associating parts of an article to their headers.
For the default `nnatom-print-content-function', each part should be a
string.  Otherwise, it can be any Lisp object.  The \"headers\" of
each part should be a list where each element is either a cons of a
MIME header (a symbol, i.e. `Content-Type') and its value (a string),
or any other Lisp object.  MIME headers will be printed, the rest will
be passed on to `nnatom-print-content-function', which recognizes the
following extra data by default:
- `links', if present, will cause links to be printed in the part.
It should accept a single argument, a Lisp object representing an article.")

(defvoo nnatom-servers (make-hash-table :test 'equal)
  "Hash table mapping known servers to their groups.

Each value in this table should itself be a hash table mapping known
group names to their data, which should be a vector of the form
[GROUP IDS ARTICLES MAX MIN DESCRIPTION], where:
- GROUP is the \"real\" group name (the name known to the server).
- IDS is a hash table mapping article IDs to their numbers.
- ARTICLES is a hash table mapping article numbers to articles and
  their attributes (see `nnatom-group-articles').
- MAX is the maximum article number.
- MIN is the minimum article number.
- DESCRIPTION is the group description.")

(defvoo nnatom-group-names (make-hash-table :test 'equal)
  "Hash table mapping real group names to their custom name.")

(defun nnatom--server-file (server)
  "Return the file containing data for SERVER."
  (expand-file-name (format "%s/%s.eld"
                            (string-trim (symbol-name nnatom-backend)
                                         "nn")
                            (gnus-newsgroup-savable-name server))
                    gnus-directory))

(defun nnatom--read-server (server)
  "Read SERVER's information from `nnatom-directory'."
  (if-let ((f (nnatom--server-file server))
           ((file-readable-p f)))
      (with-temp-buffer
        (insert-file-contents f)
        (goto-char (point-min))
        (puthash server (read (current-buffer)) nnatom-servers))
    (nnheader-report nnatom-backend "Can't read %s" server)))

(defun nnatom--write-server (server)
  "Write SERVER's information to `nnatom-directory'."
  (if-let ((f (nnatom--server-file server))
           ((file-writable-p f)))
      (if-let ((s (gethash server nnatom-servers))
               ((hash-table-p s)))
          (with-temp-file f
            (insert ";;;; -*- mode: lisp-data -*- DO NOT EDIT\n")
            (prin1 s (current-buffer))
            (insert "\n")
            t)
        t)
    (nnheader-report nnatom-backend "Can't write %s" f)))

(defun nnatom--server-address (server)
  (if (string-suffix-p "-ephemeral" server)
      (setq server (or (cadr (assq (nnoo-symbol nnatom-backend 'address)
                                   (cddr (gnus-server-to-method
                                          (concat
                                           (symbol-name nnatom-backend) ":"
                                           server)))))
                       server))
    server))

(defun nnatom--parse-feed (feed &optional group)
  "Parse FEED into a new or existing server.
Optionally, only parse GROUP."
  (let* ((feed (nnatom--server-address feed))
         (s (or (gethash feed nnatom-servers) (nnatom--read-server feed)))
         (g (or (and (hash-table-p s) (gethash group s)) `[,group]))
         (name group) ; (Maybe) fake name
         (group (or (aref g 0) name)) ; Real name
         data)
    (when (setq data (funcall nnatom-read-feed-function feed group)
                s (or (gethash feed nnatom-servers)
                      (make-hash-table :test 'equal)))
      (while-let ((cg (or (and name `(,data))
                          (funcall nnatom-read-group-function data)))
                  (cg (prog1 (car cg) (setq data (cdr cg)))))
        (let* ((name (funcall nnatom-read-title-function cg)) ; Real name
               (group (gethash name nnatom-group-names name)) ; (Maybe) fake name
               (info (gnus-get-info
                      (concat (symbol-name nnatom-backend) "+" feed ":" group)))
               (g (or (gethash group s)
                      `[ ,name ,(make-hash-table :test 'equal)
                         ,(make-hash-table :test 'eql) nil 1 ""]))
               (desc (funcall nnatom-read-description-function cg))
               (ids (aref g 1))
               (articles (aref g 2))
               (max (aref g 3))
               (max (if max max
                      (setq max 0) ; Find max article number
                      (dolist      ; remembered by Gnus.
                          ( r (cons (gnus-info-read info)
                                    (gnus-info-marks info))
                            max)
                        (mapc (lambda (x)
                                (let ((x (if (consp x)
                                             (if (< (car x) (cdr x))
                                                 (cdr x) (car x))
                                           x)))
                                  (when (< max x) (setq max x))))
                              (if (symbolp (car r)) (cdr r) r)))))
               (group-author (funcall nnatom-read-group-author-function cg))
               stale)
          (and desc (aset g 5 desc))
          (while-let ((article (funcall nnatom-read-article-function cg stale))
                      (article (prog1 (car article) (setq cg (cdr article)))))
            (when-let ((id (funcall nnatom-read-id-function article))
                       (id (format "<%s@%s.%s>" id name nnatom-backend)))
              (let* ((num (gethash id ids))
                     (update (funcall nnatom-read-update-date-function article))
                     (prev-update (aref (gethash num articles
                                                 '[nil nil nil nil nil])
                                        4)))
                (if (or (null num) ; New article ID.
                        (and (null prev-update) update)
                        (and prev-update update
                             (time-less-p prev-update update)))
                    (let* ((num (or num (aset g 3 (cl-incf max))))
                           (publish (funcall nnatom-read-publish-date-function
                                             article)))
                      (setf
                       (gethash id (aref g 1)) num
                       (gethash num (aref g 2))
                       `[ ,id
                          ,(or (funcall nnatom-read-author-function article)
                               group-author group)
                          ,(or (funcall nnatom-read-subject-function article)
                               "no subject")
                          ,(or publish update '(0 0)) ; published
                          ,(or update publish '(0 0)) ; updated
                          ,(funcall nnatom-read-links-function article)
                          ,(funcall nnatom-read-parts-function article)
                          ,(funcall nnatom-read-headers-function article)]
                       stale nil))
                  (setq stale t)))))
          (puthash group g s)))
      (puthash feed s nnatom-servers))))

;;;; Gnus backend functions:

(defvoo nnatom-group nil
  "Name of the current group.")

(defvoo nnatom-group-article-ids (make-hash-table :test 'equal)
  "Hash table mapping article IDs to their article number.")

(defvoo nnatom-group-articles (make-hash-table :test 'eql)
  "Hash table mapping article numbers to articles and their attributes.

Each value in this table should be a vector of the form
[ID FROM SUBJECT DATE UPDATED LINKS PARTS HEADERS], where:
- ID is the ID of the article.
- FROM is the author of the article or group.
- SUBJECT is the subject of the article.
- DATE is the date the article was published, or last updated (time value).
- UPDATE is the date the article was last updated, or published (time value).
- LINKS is a collection of links (any Lisp object).
- PARTS is an alist associating the content of each part of the
  article to its headers.
- HEADERS is an alist associating article-wide MIME headers to their value.")

(defvoo nnatom-group-article-max-num 0
  "Maximum article number for the current group.")

(defvoo nnatom-group-article-min-num 1
  "Minimum article number for the current group.")

(defvar nnatom-date-format "%F %X"
  "Format of displayed dates.")

(nnoo-define-basics nnatom)

(defun nnatom--current-server-no-prefix ()
  (string-remove-prefix (concat (symbol-name nnatom-backend) "+")
                        (nnoo-current-server nnatom-backend)))

(defun nnatom--group-data (group &optional server)
  (let ((s (gethash server nnatom-servers)) c)
    (or (and (hash-table-p s) (gethash group s))
        (and (setq c (nnatom--current-server-no-prefix))
             (setq s (gethash c nnatom-servers))
             (hash-table-p s) (gethash group s))
        (catch :stop (maphash (lambda (n s)
                                (or (string= n server)
                                    (string= n c)
                                    (when-let (((hash-table-p s))
                                               (g (gethash group s)))
                                      (throw :stop g))))
                              nnatom-servers)))))

(defun nnatom-retrieve-article (article group)
  (if-let ((a (gethash article (aref group 2))))
      (insert (format "221 %s Article retrieved.
From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n"
                      article
                      (aref a 1)
                      (aref a 2)
                      (format-time-string nnatom-date-format (aref a 3))
                      (aref a 0)))
    (insert "404 Article not found.\n.\n")))

(deffoo nnatom-retrieve-headers (articles &optional group server _fetch-old)
  (if-let ((server (or server (nnatom--current-server-no-prefix)))
           (g (or (nnatom--group-data group server)
                  `[ nil ,nnatom-group-article-ids ,nnatom-group-articles
                     nil nil nil])))
      (with-current-buffer nntp-server-buffer
        (erase-buffer)
        (or (and (stringp (car articles))
                 (mapc (lambda (a)
                         (nnatom-retrieve-article
                          (gethash a (aref g 2)) g))
                       articles))
            (and (numberp (car articles))
                 (range-map (lambda (a) (nnatom-retrieve-article a g))
                            articles)))
        'headers)
    (nnheader-report nnatom-backend "Group %s not found" (or group ""))))

(deffoo nnatom-open-server (server &optional defs backend)
  (let ((backend (or backend 'nnatom))
        (a (nnatom--server-address server))
        s)
    (nnoo-change-server backend server defs)
    (when (setq s (or (gethash server nnatom-servers)
                      (nnatom--read-server a)))
      (maphash (lambda (group g)
                 (setq g (aref g 0))
                 (unless (string= group g)
                   (puthash group g nnatom-group-names)))
               s))
    (or s (file-writable-p (nnatom--server-file a))
        (and (nnoo-close-server nnatom-backend server)
             (nnheader-report
              nnatom-backend "Server file %s not readable or writable"
              server)))))

(deffoo nnatom-request-close ()
  (maphash (lambda (server _)
             (nnatom--write-server
              (nnatom--server-address server)))
           nnatom-servers)
  (setq nnatom-servers (make-hash-table :test 'equal)
        nnatom-status-string nil)
  t)

(defun nnatom--print-content (content attributes links)
  "Return CONTENT formatted according to ATTRIBUTES, possibly with LINKS added."
  (let ((links (and (memq 'links attributes) links)))
    (when (or content links)
      (concat
       (and content (format "%s\n\n" content))
       (mapconcat (lambda (link)
                    (cdr (assoc (cdr (assq 'Content-Type attributes)) link
                                (lambda (types type)
                                  (if (stringp types) (string= types type)
                                    (member type types))))))
                  links)))))

(defvoo nnatom-print-content-function #'nnatom--print-content
  "Function returning a single piece of content (a string).
It should accept three arguments, a part and its attributes (as returned
by `nnatom-read-parts-function'), and links.")

(defun nnatom--print-part (content headers mime links)
  (concat
   (mapconcat (lambda (header)
                (when-let ((m (car-safe header))
                           ((member m mime)))
                  (format "%s: %s\n" m (cdr header))))
              headers)
   "\n"
   (funcall nnatom-print-content-function content headers links)))

(deffoo nnatom-request-article (article &optional group server to-buffer)
  (if-let ((server (or server (nnatom--current-server-no-prefix)))
           (g (or (nnatom--group-data group server)
                  (and (setq group nnatom-group)
                       `[ nil ,nnatom-group-article-ids
                          ,nnatom-group-articles
                          ,nnatom-group-article-max-num
                          ,nnatom-group-article-min-num nil])))
           (num (or (and (stringp article)
                         (gethash article (aref g 1)))
                    (and (numberp article) article)))
           ((and (<= num (aref g 3))
                 (>= num (aref g 4))))
           (a (gethash num (aref g 2))))
      (with-current-buffer (or to-buffer nntp-server-buffer)
        (erase-buffer)
        (let* ((links (aref a 5))
               (parts (aref a 6))
               (headers (aref a 7))
               (boundary (or (cdr (assq :boundary headers))
                             (format "-_%s_-" nnatom-backend)))
               (multi (length> parts 1))
               (mime '( Content-Type Content-Disposition
                        Content-Transfer-Encoding)))
          (insert (format
                   "Subject: %s\nFrom: %s\nDate: %s\nMessage-ID: %s\n"
                   (aref a 2) (aref a 1)
                   (format-time-string
                    nnatom-date-format (or (aref a 3) '(0 0)))
                   (aref a 0))
                  (if (assq 'MIME-Version headers) "" "MIME-Version: 1.0\n")
                  (mapconcat (lambda (header)
                               (unless (keywordp (car header))
                                 (format "%s: %s\n" (car header) (cdr header))))
                             headers)
                  (if multi
                      (if (assq 'Content-Type headers) ""
                        (format
                         "Content-Type: multipart/alternative; boundary=%s\n"
                         boundary))
                    (prog1 (nnatom--print-part
                            (caar parts) (cdar parts) mime links)
                      (setq parts nil)))
                  (mapconcat (lambda (part)
                               (format "--%s\n%s\n" boundary
                                       (nnatom--print-part
                                        (car part) (cdr part) mime links)))
                             parts)
                  (if multi (format "--%s--" boundary) "\n")))
        `(,group . ,num))
    (nnheader-report nnatom-backend "No such article")))

(deffoo nnatom-request-group (group &optional server fast _info)
  (with-current-buffer nntp-server-buffer
    (erase-buffer)
    (if-let ((server (or server (nnatom--current-server-no-prefix)))
             (g (or (if fast (nnatom--group-data group server)
                      (setq server (nnatom--parse-feed server group))
                      (and (hash-table-p server) (gethash group server)))
                    `[ ,group ,(make-hash-table :test 'equal)
                       ,(make-hash-table :test 'eql) 0 1 ""])))
        (progn
          (setq nnatom-group group
                nnatom-group-article-ids (aref g 1)
                nnatom-group-articles (aref g 2)
                nnatom-group-article-max-num (aref g 3)
                nnatom-group-article-min-num (aref g 4))
          (insert (format "211 %s %s %s \"%s\""
                          (hash-table-count nnatom-group-article-ids)
                          nnatom-group-article-min-num
                          nnatom-group-article-max-num group))
          t)
      (insert "404 group not found")
      (nnheader-report nnatom-backend "Group %s not found" group))))

(deffoo nnatom-close-group (group &optional server)
  (and (string= group nnatom-group)
       (setq nnatom-group nil
             nnatom-group-article-ids (make-hash-table :test 'equal)
             nnatom-group-articles (make-hash-table :test 'eql)
             nnatom-group-article-max-num 0
             nnatom-group-article-min-num 1))
  (setq server (or server (nnatom--current-server-no-prefix)))
  (nnatom--write-server server))

(deffoo nnatom-request-list (&optional server)
  (with-current-buffer nntp-server-buffer
    (erase-buffer)
    (when-let ((p (point))
               (s (nnatom--parse-feed
                   (or server (nnatom--current-server-no-prefix))))
               ((hash-table-p s)))
      (maphash (lambda (group g)
                 (insert (format "\"%s\" %s %s y\n"
                                 group (aref g 3) (aref g 4))))
               s)
      (not (= (point) p)))))

(deffoo nnatom-request-post (&optional _server)
  (nnheader-report nnatom-backend "%s is a read only backend" nnatom-backend))

;;;; Optional back end functions:

(deffoo nnatom-retrieve-groups (_groups &optional server)
  (nnatom-request-list (or server (nnatom--current-server-no-prefix)))
  'active)

(deffoo nnatom-request-type (_group &optional _article)
  'unknown)

(deffoo nnatom-request-group-description (group &optional server)
  (when-let ((server (or server (nnatom--current-server-no-prefix)))
             (g (nnatom--group-data group server)))
    (with-current-buffer nntp-server-buffer
      (erase-buffer)
      (insert group "	" (aref g 5) "\n"))))

(deffoo nnatom-request-list-newsgroups (&optional server)
  (when-let ((server (or server (nnatom--current-server-no-prefix)))
             (s (gethash server nnatom-servers))
             ((hash-table-p s)))
    (with-current-buffer nntp-server-buffer
      (erase-buffer)
      (maphash (lambda (group g)
                 (insert group "	" (aref g 5) "\n"))
               s))))

(deffoo nnatom-request-rename-group (group new-name &optional server)
  (when-let ((server (or server (nnatom--current-server-no-prefix)))
             (s (or (gethash server nnatom-servers)
                    (and ; Open the server to add it to `nnatom-servers'
                     (save-match-data
                       (nnatom-open-server
                        server
                        (cdr ; Get defs and backend.
                         (assoc server (cdr (assq 'nnatom nnoo-state-alist))
                                (lambda (car key)
                                  (and (stringp car)
                                       (string-match
                                        (concat
                                         "\\(\\(nn[[:alpha:]]+\\)\\+\\)?"
                                         "\\(" (regexp-quote key) "\\)")
                                        car)
                                       (setq server car)))))
                        (prog1 (if (stringp (match-string 1 server))
                                   (intern (match-string 2 server))
                                 'nnatom)
                          (setq server (match-string 3 server))))
                       (gethash server nnatom-servers)))))
             (g (or (nnatom--group-data group server)
                    `[ ,group ,(make-hash-table :test 'equal)
                       ,(make-hash-table :test 'eql) nil 1 ""])))
    (puthash new-name g s)
    (puthash group new-name nnatom-group-names)
    (remhash group s)
    (and (string= group nnatom-group)
         (setq nnatom-group new-name))
    t))

(gnus-declare-backend (symbol-name nnatom-backend) 'address)

;;;; Utilities:

(defmacro nnatom-define-basic-backend-interface (backend)
  "Define a basic set of functions and variables for BACKEND."
  `(progn
     (defvoo ,(nnoo-symbol backend 'backend) ',backend nil nnatom-backend)
     (defvoo ,(nnoo-symbol backend 'status-string)
         nil nil nnatom-status-string)
     (defvoo ,(nnoo-symbol backend 'group) nil nil nnatom-group)
     (defvoo ,(nnoo-symbol backend 'servers)
         (make-hash-table :test 'equal) nil nnatom-servers)
     (defvoo ,(nnoo-symbol backend 'group-article-ids)
         (make-hash-table :test 'equal) nil nnatom-group-article-ids)
     (defvoo ,(nnoo-symbol backend 'group-articles)
         (make-hash-table :test 'eql) nil nnatom-group-articles)
     (defvoo ,(nnoo-symbol backend 'group-article-max-num) 0 nil
             nnatom-group-article-max-num)
     (defvoo ,(nnoo-symbol backend 'group-article-mix-num) 1 nil
             nnatom-group-article-min-num)
     ,@(mapcar (lambda (fun)
                 `(deffoo ,(nnoo-symbol backend fun) (&optional server)
	            (,(nnoo-symbol 'nnoo fun) ',backend server)))
	       '(server-opened status-message))
     (deffoo ,(nnoo-symbol backend 'open-server) (server &optional defs)
       (nnatom-open-server server defs ',backend))
     (nnoo-import ,backend (nnatom))))

(provide 'nnatom)

;;; nnatom.el ends here