#!/bin/sh
exec guile -s $0 "$@" # -*- scheme -*-
!#
;;; Copyright (C) 1999-2012 Thien-Thi Nguyen
;;; This program is provided under the terms of the GNU GPL, version 3.
;;; See http://www.fsf.org/copyleft/gpl.html for details.

(use-modules
 ((gnuvola common))                     ; for side effect (setenv)
 ((gnuvola ct-sw) #:select (make-A
                            make-M))
 ((ttn-do zzz personally) #:select (FE fs))
 ((ttn-do zzz publishing) #:select (copyright-since
                                    flatten-to
                                    smhdwy
                                    :NULL
                                    css-tree))
 (ttn-do zzz xhtml-tree)
 ((ttn-do mogrify) #:select (find-file
                             editing-buffer))
 ((www http) #:select (http:message-status-ok?
                       http:message-headers
                       http:head))
 ((www url) #:select (url:parse))
 ((srfi srfi-13) #:select (string-prefix?))
 ((scripts read-text-outline) #:select (read-text-outline-silently))
 ((ttn-do zzz publishing) #:select (update-all-html-data-pages!))
 ((ttn-do cron-walk) #:select (cron!)))

(define *a* #f)                         ; ugh

(define (setup!)
  (set! *a* (make-A)))

(define (shutdown!)
  (*a* #:finish)
  #t)

(define-macro (lol-map formals lol . body)
  (let ((--x (gensym)))
    `(map (lambda (,--x)
            (apply (lambda ,formals ,@body) ,--x))
          ,lol)))

(define (~ulol ls)
  (lol-map (text url) ls
    (list " (" (~a 'href url text) ") ")))

(define all-projects
  (let ((ans #f))

    (define (dig)
      (let* ((w (make-M))
             (alist (w #:tuples-result->alists
                       (w #:select
                          '(name url mon
                                 (bool "ext?" (= 1 (strpos url "http:")))
                                 (text "file" (|| url mon))
                                 orig
                                 utim)
                          #:where 'v
                          #:order-by '((> utim))))))
        (w #:finish)
        alist))

    (define (tiny-hash string)
      (fs "x~A" (number->string (hash string 821497) 16)))

    (define (proj<- alist)
      (let ((alist `((#:enc . ,(tiny-hash (assq-ref alist 'name)))
                     ,@(map cons (map symbol->keyword (map car alist))
                            (map cdr alist)))))
        ;; rv
        (lambda (key)
          (assq-ref alist key))))

    ;; rv
    (lambda ()
      (cond (ans)
            (else
             (set! ans (map proj<- (dig)))
             ans)))))

(define (~maintained proj)
  (let ((name (proj #:name))
        (url (proj #:url))
        (enc (proj #:enc))
        (ext? (proj #:ext?))
        (orig (proj #:orig)))
    (define (link skip)
      (~a 'href url
          'id enc
          'name enc
          (substring name skip)))
    (~tr (~td 'class "L"
              (if (string-prefix? "GNU" name)
                  (list (~a 'href "http://www.gnu.org/" "GNU")
                        " "
                        (link 4))
                  (link 0))
              (cond ((string-null? orig)
                     :NULL)
                    ((string=? "GNU" orig)
                     (~ulol `((,orig "http://www.gnu.org/"))))
                    (else
                     (~ulol `((,orig (,url "HISTORY" ,(if ext?
                                                          ".txt"
                                                          :NULL))))))))
         (~td 'class "R"
              (~a 'href (proj #:file)
                  (strftime "%Y-%m-%d" (gmtime (proj #:utim))))))))

(define (outline<- port)
  (define (cleaned s)
    (editing-buffer s
      (goto-char (point-min))
      (FE '("&"     "<"    ">")
          '("&amp;" "&lt;" "&gt;")
          (lambda (bef aft)
            (goto-char (point-min))
            (while (search-forward bef #f #t)
              (replace-match aft #t #t))))
      (buffer-string)))
  (define (listify x)
    (if (pair? x)
        (list (car x) (~ul (map ~li (map listify (cdr x)))))
        (cleaned x)))
  (listify (car (read-text-outline-silently port))))

(define (atomsexp<- proj)

  (define (title+categories name)
    `((title ,name)
      ,@(map (lambda (attr)
               `(category (@ (term ,attr))))
             (cdar (*a* #:tuples-result->object-alist
                        (*a* #:select 'attr #:where `(= name ,name)))))))

  (define (action proj)
    (let* ((file (proj #:file))
           (ustr (if (file-exists? file)
                     (strftime "updated %F %T"
                               (gmtime (stat:mtime (stat file))))
                     "updated")))
      (or (and (member (proj #:mon) '("NEWS" "NOTIZIE"))
               (not (proj #:ext?))
               (editing-buffer (find-file file)
                 (toggle-read-only 0)
                 (goto-char (point-min))
                 (and (re-search-forward "^- ([^ ]+) [|] (.*)$" (point-max) #t)
                      (let* ((b (1- (match-beginning 0)))
                             (status (match-string 2)))
                        (replace-match
                         (fs "- version ~A ~A ~A"
                             (match-string 1)
                             (if (char-numeric? (string-ref status 0))
                                 "released"
                                 (fs "~A, but" ustr))
                             status))
                        (re-search-forward "^-" #f 1)
                        (delete-region (1- (point)) (point-max))
                        (goto-char b)
                        (outline<- (buffer-port))))))
          ustr)))

  (let* ((here "software/")
         (i+frag (fs "~A#~A" here (proj #:enc)))
         (news (action proj)))
    `(entry
      (id ,(fs "http://www.gnuvola.org/~A" i+frag))
      ,@(title+categories (proj #:name))
      (updated ,(proj #:utim))
      (link (@ (rel "alternate") (href ,i+frag)))
      ,(if (string? news)
           `(summary ,news)
           `(content
             (@ (type "xhtml"))
             ,(flatten-to #f (~div 'xmlns "http://www.w3.org/1999/xhtml"
                                   news)))))))

(define (write-NEWS.atom-partial!)
  (let ((filename "NEWS.atom-partial"))
    (or (and (file-exists? filename)
             (> (stat:mtime (stat filename))))
        (call-with-output-file filename
          (lambda (port)
            (define (pr x)
              (write x port)
              (newline port))
            (pr '((category (@ (term "ttn software")))
                  (author (name "Thien-Thi Nguyen")
                          (email "ttn@gnuvola.org"))
                  ;; Add other shared elements here.
                  ))
            (FE (map atomsexp<- (all-projects)) pr)
            #t)))))

(define (update-html)
  (update-all-html-data-pages! '("funding.html"
                                 "index.html")))

(define (update-everything!)
  (setup!)
  (let ((rv (and (update-html) (write-NEWS.atom-partial!))))
    (shutdown!)
    rv))

(cron! ((now hourly) (update-everything!)))

;;; .cron ends here