update the update script to use git

[clinton/website/site-support.git] / rss.lisp

(if (not (find-package :swank))
    (asdf:oos 'asdf:load-op :swank))

(mapc (lambda (system) (asdf:oos 'asdf:load-op system))
      '(:cxml :cxml-stp :arnesi :cl-ppcre 
	:xml-emitter :local-time :cl-fad :split-sequence))

(defpackage :org.unknownlamer.rss-feed
  (:nicknames :ul-rss)
  (:use :cl :xml-emitter)
  (:import-from :arnesi :if-bind :when-bind :escape-as-uri :curry :compose)
  (:import-from :split-sequence :split-sequence)
  (:export :darcs->feed :run))

(in-package :org.unknownlamer.rss-feed)

(defparameter *repo-path*
  (make-pathname
   :directory "afs/hcoop.net/user/c/cl/clinton/darcs/unknownlamer.org"))

(defparameter *rss-path*
  (make-pathname
   :directory "afs/hcoop.net/user/c/cl/clinton/feeds/rss"
   :name "site-updates"))

(defparameter *muse-file-scanner*
    (ppcre:create-scanner "(.+)\\.muse"))

(defparameter *special-files*
  '(("book-list.lisp" . "Book List")))

;;; Parse darcs xml changelog

;;; structure
;; (changelog
;;  (patch
;;   :author :date :local_date
;;   (name PATCH-NAME)
;;   (comment PATCH-COMMENT)
;;   (summary
;;    (add_file FILE-NAME)
;;    (modify_file FILE-NAME
;; 		(removed_lines :num)
;; 		(added_lines :num)))))

(defun darcs-changes->stp (stream)
  (cxml:parse-stream
   stream
   (cxml:make-whitespace-normalizer (stp:make-builder))))

(defun find-child-named (child-name parent-node)
  (stp:find-child-if (lambda (node)
		       (and (typep node 'stp:element)
			    (string= (stp:local-name node) child-name)))
		     parent-node))

(defun filter-children-by-name (child-name parent-node)
  (stp:filter-children (lambda (node)
			 (and (typep node 'stp:element)
			      (string= (stp:local-name node) child-name)))
		       parent-node))

(defun darcs-stp->parsed-list (document)
  ;; What must be done: load darcs changes xml, iterate over patches,
  ;; generate a simpler structure storing (NAME ID DATE COMMENT CHANGES)
  ;; where COMMENT may be nil and CHANGES is another list of sublists
  ;; ((ADDED ...) (CHANGED ...)). Deletions may be ignored for now.
  (map 'list
       (lambda (patch)
	 (list (stp:string-value (find-child-named "name" patch))
	       (stp:attribute-value patch "date")
	       (stp:attribute-value patch "hash")
	       (when-bind comment (find-child-named "comment" patch)
		 (stp:string-value comment))
	       (let ((summary (find-child-named "summary" patch)))
		 (list
		  (cons :added
			(map 'list
			     (compose (curry #'string-trim
							   '(#\space #\newline))
					     #'stp:string-value)
			     (filter-children-by-name "add_file" summary)))
		  (cons :changed
			(map 'list
			     (compose (curry #'string-trim
							   '(#\space #\newline))
					     #'stp:string-value)
			     (filter-children-by-name "modify_file" summary)))))))
       (filter-children-by-name "patch"
			      (stp:first-child document))))

;;; Parsed changelog accessors

(defun patch-name (patch)
  (first patch))

(defun patch-date (patch)
  (second patch))

(defun patch-hash (patch)
  (third patch))

(defun patch-comment (patch)
  (fourth patch))

(defun patch-added-files (patch)
  (cdr (first (fifth patch))))

(defun patch-changed-files (patch)
  (cdr (second (fifth patch))))

;;; Feed generation

(defun muse-path->html-url (potential-muse-path)
  ;; When generating the RSS only *.muse files should have links and
  ;; these should be translated to the corresponding html
  (when-bind basename (or (ppcre:register-groups-bind (basename)
			      (*muse-file-scanner* potential-muse-path)
			    basename)
			  (cdar (member potential-muse-path *special-files*
				       :key #'car :test #'string=)))
    (format nil "http://unknownlamer.org/muse/~A.html"
	    (escape-as-uri basename))))

(defun darcs-time->local-time (timestring)
  ;; YYYYMMDDHHMMSS UTC
  (local-time:universal-to-timestamp 
   (encode-universal-time (parse-integer timestring :start 12 :end 14)
			  (parse-integer timestring :start 10 :end 12)
			  (parse-integer timestring :start 8 :end 10)
			  (parse-integer timestring :start 6 :end 8)
			  (parse-integer timestring :start 4 :end 6)
			  (parse-integer timestring :start 0 :end 4)
			  0)))

(defun darcs-time->pubdate (darcs-time)
  ;; this seems to be correct but at least liferea is taking my time
  ;; and substracting the tz offset from it ... what the fuck
  (let ((local-time (darcs-time->local-time darcs-time)))
    (local-time:format-timestring
     nil local-time
     :format '(:short-weekday ", "
	       (:day 2) #\space :short-month #\space (:year 4) #\space
	       (:hour 2) #\: (:min 2) #\: (:sec 2) #\space :timezone))))

(defun darcs-hash->guid (hash)
  (format
   nil
   "http://unknownlamer.org/darcsweb/browse?r=unknownlamer.org;a=commit;h=~A"
   hash))

(defun file-link (file)
  (with-tag ("li")
    (with-tag ("p")
      (if-bind muse-url (muse-path->html-url file)
	(simple-tag "a" file `(("href" ,muse-url)))
	(xml-out file)))))

(defun generate-entry-html (patch)
  (with-output-to-string (string-stream)
    ;; EVIL, but ... I don't feel like modifying the xml-emitter lib
    (let ((xml-emitter::*xml-output-stream* string-stream))
      (when-bind comment (patch-comment patch)
	(with-tag ("p")
	  (xml-out comment)))
      (when-bind added-files (patch-added-files patch)
	(simple-tag "h2" "New Files")
	(with-tag ("ul")
	  (dolist (file added-files)
	    (file-link file))))
      (when-bind changed-files (patch-changed-files patch)
	(simple-tag "h2" "Modified Files")
	(with-tag ("ul")
	  (dolist (file changed-files)
	    (file-link file)))))))

(defun generate-feed (entries stream)
  (with-rss2 (stream :encoding "UTF-8")
    (rss-channel-header "The Home of Your Friendly Neighborhood Terrorist"
			"http://unknownlamer.org"
			:description "Updates to Clinton Ebadi's personal website")
    (dolist (entry entries)
      (rss-item (patch-name entry)
		:description (generate-entry-html entry)
		:guid (darcs-hash->guid (patch-hash entry)) ; fix guid
		:pubdate (darcs-time->pubdate (patch-date entry))))))

;;; Call darcs

(defun darcs-changelog-stream ()
  (let ((files (append
		(let ((dirlist (fad:list-directory
				*repo-path*))
		      (wild-path (make-pathname :type "muse")))
		  (mapcan (lambda (path)
			    (if (pathname-match-p path wild-path)
				(list path)))
			  dirlist))
		(mapcar (lambda (file)
			  ;; note: assumes only one . in the filename
			  ;; (this is true ... for now)
			  (let ((split-file (split-sequence #\. (car file))))
			    (merge-pathnames 
			     (make-pathname :name (first split-file)
					    :type (second split-file))
			     *repo-path*)))
			*special-files*))))
    (sb-ext:process-output
     (sb-ext:run-program "darcs"
			 `("changes" "--xml" "--summary"
				     ,(format nil "--repodir=~A" *repo-path*)
				     "--only-to-files" ,@(mapcar
							  #'namestring files))
			 :search t
			 :output :stream
			 :wait t))))


;;; Public Interface

(defun firstn (n list)
  ;; yeah yeah really shitty whatever
  (loop for i from 0 to n collect (nth i list)))

(defun stream->feed (input-stream output-stream)
  (generate-feed
   (firstn 15
	   (darcs-stp->parsed-list (darcs-changes->stp input-stream)))
   output-stream))

(defun darcs->feed ()
  (with-open-file (rss-out *rss-path*
			   :direction :output
			   :if-exists :supersede
			   :if-does-not-exist :create)
    (stream->feed (darcs-changelog-stream) rss-out)))

(defun run ()
  (darcs->feed)
  (sb-ext:quit))