;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2023 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;;
;;; This file is based on haunt/builder/blog.scm,
;;; haunt/reader/commonmark.scm and tests/post.scm and from Haunt
;;; 2.6.0.
;;;
;;; This file 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.
;;;
;;; Haunt 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 Haunt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (website builders replicant-blog)
  #:use-module (commonmark)
  #:use-module (haunt artifact)
  #:use-module (haunt builder assets)
  #:use-module (haunt html)
  #:use-module (haunt post)
  #:use-module (haunt site)
  #:use-module (haunt utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:export (theme-collection-template)
  #:export (make-theme)
  #:export (render-collection)
  #:export (replicant-blog-website)
  #:export (replicant-layout)
  #:export (replicant-theme)
  #:export (theme)
  #:export (theme-layout)
  #:export (theme-name)
  #:export (theme-post-template)
  #:export (theme?))

(fluid-set! %default-port-encoding "UTF-8")

(define-record-type <theme>
  (make-theme name layout post-template collection-template)
  theme?
  (name theme-name)
  (layout theme-layout)
  (post-template theme-post-template)
  (collection-template theme-collection-template))

(define (replicant-layout site title body)
  `((doctype "html")
    (head
     (meta (@ (charset "utf-8")))
     (link
      (@ (rel "stylesheet")
	 (href "static/twentyeleven-style-20231107.css")))
     (title ,(string-append title " - " (site-title site))))
    (body
     (header
      (img (@ (id "banner")
	      (src "static/replicant_banner_white.png")
	      (alt "Replicant banner")))
      (nav
       (@ (id "access"))
	   (ul
	    (li (a (@ (href "https://www.replicant.us"))
		   "Home"))
	    (li (a (@ (href "https://blog.replicant.us"))
		   "Blog"))
	    (li (a (@ (href "https://redmine.replicant.us/projects/replicant/wiki"))
		   "Wiki"))
	    (li (a (@ (href "https://redmine.replicant.us/projects/replicant/issues"))
		   "Tracker"))
	    (li (a (@ (href "https://redmine.replicant.us/projects/replicant/boards"))
		   "Forums"))
	    (li (a (@ (href "https://test.blog.replicant.us/search.html"))
		   "Blog: Search")))))
     ,body)))

(define (replicant-default-post-template post)
  `((h1 (@ (id "title")) ,(post-ref post 'title))
    ;; Metadata
    (p (string-append
	"Posted"
	,(if
	  (post-ref post 'authors)
	  (string-append " by " (post-ref post 'authors))
	  "")
	,(if
	  (post-ref post 'date)
	  (string-append
	   " on the "
	   (date->string (post-ref post 'date) "~d ~B ~Y at ~kh~M"))
	  "")
	,(if (post-ref post 'licenses)
	     (string-append
	      " under the "
	      (post-ref post 'licenses) " license(s)")
	     "")
	"."))
    (div (@ (id "post-content")) ,(post-sxml post))))

(define (sort-posts-by-most-recent-first a b)
  (time>?
   (date->time-utc (post-ref a 'date))
   (date->time-utc (post-ref b 'date))))

(define (replicant-default-collection-template site title posts prefix)
  (define (post-uri post)
    (string-append (or prefix "") "/"
                   (site-post-slug site post) ".html"))

  `((h3 ,title)
    (ul
     ,@(map (lambda (post)
              `(li
                (a (@ (href ,(post-uri post)))
                   ,(post-ref post 'title))))
            (sort posts sort-posts-by-most-recent-first)))))

(define* (theme #:key
                (name "Replicant")
                (layout replicant-layout)
                (post-template replicant-default-post-template)
                (collection-template replicant-default-collection-template))
  (make-theme name layout post-template collection-template))

(define (with-layout theme site title body)
  ((theme-layout theme) site title body))

(define (render-post theme site post)
  (let ((title (post-ref post 'title))
        (body ((theme-post-template theme) post)))
    (with-layout theme site title body)))

(define (render-collection theme site title posts prefix)
  (let ((body ((theme-collection-template theme) site title posts prefix)))
    (with-layout theme site title body)))

(define (date->string* date)
  "Convert DATE to human readable string."
  (date->string date "~a ~d ~B ~Y"))

(define replicant-theme
  (theme #:name "Replicant"
         #:layout replicant-layout
         #:post-template replicant-default-post-template
         #:collection-template replicant-default-collection-template))

(define* (replicant-blog-website #:key (theme replicant-theme) prefix
               (collections
                `(("" "index.html" ,posts/reverse-chronological))))
  "Return a procedure that transforms a list of posts into pages
decorated by THEME, whose URLs start with PREFIX."
  (define (make-file-name base-name)
    (if prefix
        (string-append prefix "/" base-name)
        base-name))

  (lambda (site posts)
    (define (post->page post)
      (let ((base-name (string-append (site-post-slug site post)
                                      ".html")))
        (serialized-artifact (make-file-name base-name)
                             (render-post theme site post)
                             sxml->html)))

    (define collection->page
      (match-lambda
       ((title file-name filter)
        (serialized-artifact (make-file-name file-name)
                             (render-collection theme site title (filter posts) prefix)
                             sxml->html))))

    (append (map post->page posts)
            (map collection->page collections))))