;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;;
;;; 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 3 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, see
;;; <http://www.gnu.org/licenses/>.

(define-module (jakob builder atom)
  #:use-module (haunt artifact)
  #:use-module (haunt html)
  #:use-module (haunt post)
  #:use-module (haunt site)
  #:use-module (haunt utils)
  #:use-module (ice-9 match)
  #:use-module (jakob builder blog)
  #:use-module (jakob utils)
  #:use-module (jakob utils sxml)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (web uri)
  #:export (atom-feed))

;; Slight hack to use relative URLs in the Atom feed for Tor and i2p mirrors.
(define %disable-compliance (make-parameter (getenv "DISABLE_ATOM_COMPLIANCE")))

(define (format-date date)
  "Format DATE into a date-time production as defined in RFC 3339"
  (let* ((formatted       (date->string date "~4"))
         (up-to-tz-minute (string-drop-right formatted 2))
         (tz-minute       (string-take-right formatted 2)))
    (string-concatenate `(,up-to-tz-minute ":" ,tz-minute))))

(define (format-relative-path site path)
  "Return an absolute URI for PATH"
  (if (%disable-compliance)
      path
      (let ((path (if (not (string-prefix? "/" path))
                      (format #f "/~a" path)
                      path)))
        (uri->string
         (build-uri 'https ;; (site-scheme site)
                    #:host (site-domain site)
                    #:path path)))))

(define* (post->atom-entry site post #:key (blog-prefix ""))
  "Convert POST into an Atom <entry> XML node."
  (let ((uri (or (post-ref post 'crosspost)
                 (post-uri post))))
    `(entry
      (title ,(post-ref post 'title))
      (id ,(format-relative-path site uri))
      (author
       (name ,(post-ref post 'author))
       ,(let ((email (post-ref post 'email)))
          (if email `(email ,email) '())))
      (updated ,(format-date (post-date post)))
      (link (@ (href ,uri) (rel "alternate")))
      (summary (@ (type "html"))
               ,(sxml->html-string
                 (append (first-paragraph post)
                         (if (post-ref post 'crosspost)
                             `((p "...")
                               (p "This is a crosspost. Click "
                                  ,(hyperlink (post-ref post 'crosspost) "here")
                                  " to read the rest of the article."))
                             '()))))
      ,@(map (lambda (enclosure)
               `(link (@ (rel "enclosure")
                         (title ,(enclosure-title enclosure))
                         (href ,(enclosure-url enclosure))
                         (type ,(enclosure-mime-type enclosure))
                         ,@(map (match-lambda
                                  ((key . value)
                                   (list key value)))
                                (enclosure-extra enclosure)))))
             (post-ref-all post 'enclosure)))))

(define* (atom-feed #:key
                    (file-name "feed.xml")
                    (subtitle "Recent Posts")
                    (filter posts/reverse-chronological)
                    (max-entries 20)
                    (blog-prefix ""))
  "Minor modification to the 'atom-feed' builder in '(haunt builder atom)' to
add support for cross-posts. See the docstring in that manual for details on the
use of this function."
  (lambda (site posts)
    (serialized-artifact file-name
                         `(feed (@ (xmlns "http://www.w3.org/2005/Atom"))
                                (title ,(site-title site))
                                (id ,(format-relative-path site file-name))
                                (subtitle ,subtitle)
                                (updated ,(format-date (current-date)))
                                (link (@ (href ,(format-relative-path site file-name))
                                         (rel "self")))
                                (link (@ (href ,(format-relative-path site ""))))
                                ,@(map (cut post->atom-entry site <>
                                            #:blog-prefix blog-prefix)
                                       (take-up-to max-entries (filter posts))))
                         (@@ (haunt builder atom) sxml->xml*))))