| 1 | (if (not (find-package :swank)) |
| 2 | (asdf:oos 'asdf:load-op :swank)) |
| 3 | |
| 4 | (mapc (lambda (system) (asdf:oos 'asdf:load-op system)) |
| 5 | '(:cxml :cxml-stp :arnesi :cl-ppcre |
| 6 | :xml-emitter :local-time :cl-fad :split-sequence)) |
| 7 | |
| 8 | (defpackage :org.unknownlamer.rss-feed |
| 9 | (:nicknames :ul-rss) |
| 10 | (:use :cl :xml-emitter) |
| 11 | (:import-from :arnesi :if-bind :when-bind :escape-as-uri :curry :compose) |
| 12 | (:import-from :split-sequence :split-sequence) |
| 13 | (:export :darcs->feed :run)) |
| 14 | |
| 15 | (in-package :org.unknownlamer.rss-feed) |
| 16 | |
| 17 | (defparameter *repo-path* |
| 18 | (make-pathname |
| 19 | :directory "afs/hcoop.net/user/c/cl/clinton/darcs/unknownlamer.org")) |
| 20 | |
| 21 | (defparameter *rss-path* |
| 22 | (make-pathname |
| 23 | :directory "afs/hcoop.net/user/c/cl/clinton/feeds/rss" |
| 24 | :name "site-updates")) |
| 25 | |
| 26 | (defparameter *muse-file-scanner* |
| 27 | (ppcre:create-scanner "(.+)\\.muse")) |
| 28 | |
| 29 | (defparameter *special-files* |
| 30 | '(("book-list.lisp" . "Book List"))) |
| 31 | |
| 32 | ;;; Parse darcs xml changelog |
| 33 | |
| 34 | ;;; structure |
| 35 | ;; (changelog |
| 36 | ;; (patch |
| 37 | ;; :author :date :local_date |
| 38 | ;; (name PATCH-NAME) |
| 39 | ;; (comment PATCH-COMMENT) |
| 40 | ;; (summary |
| 41 | ;; (add_file FILE-NAME) |
| 42 | ;; (modify_file FILE-NAME |
| 43 | ;; (removed_lines :num) |
| 44 | ;; (added_lines :num))))) |
| 45 | |
| 46 | (defun darcs-changes->stp (stream) |
| 47 | (cxml:parse-stream |
| 48 | stream |
| 49 | (cxml:make-whitespace-normalizer (stp:make-builder)))) |
| 50 | |
| 51 | (defun find-child-named (child-name parent-node) |
| 52 | (stp:find-child-if (lambda (node) |
| 53 | (and (typep node 'stp:element) |
| 54 | (string= (stp:local-name node) child-name))) |
| 55 | parent-node)) |
| 56 | |
| 57 | (defun filter-children-by-name (child-name parent-node) |
| 58 | (stp:filter-children (lambda (node) |
| 59 | (and (typep node 'stp:element) |
| 60 | (string= (stp:local-name node) child-name))) |
| 61 | parent-node)) |
| 62 | |
| 63 | (defun darcs-stp->parsed-list (document) |
| 64 | ;; What must be done: load darcs changes xml, iterate over patches, |
| 65 | ;; generate a simpler structure storing (NAME ID DATE COMMENT CHANGES) |
| 66 | ;; where COMMENT may be nil and CHANGES is another list of sublists |
| 67 | ;; ((ADDED ...) (CHANGED ...)). Deletions may be ignored for now. |
| 68 | (map 'list |
| 69 | (lambda (patch) |
| 70 | (list (stp:string-value (find-child-named "name" patch)) |
| 71 | (stp:attribute-value patch "date") |
| 72 | (stp:attribute-value patch "hash") |
| 73 | (when-bind comment (find-child-named "comment" patch) |
| 74 | (stp:string-value comment)) |
| 75 | (let ((summary (find-child-named "summary" patch))) |
| 76 | (list |
| 77 | (cons :added |
| 78 | (map 'list |
| 79 | (compose (curry #'string-trim |
| 80 | '(#\space #\newline)) |
| 81 | #'stp:string-value) |
| 82 | (filter-children-by-name "add_file" summary))) |
| 83 | (cons :changed |
| 84 | (map 'list |
| 85 | (compose (curry #'string-trim |
| 86 | '(#\space #\newline)) |
| 87 | #'stp:string-value) |
| 88 | (filter-children-by-name "modify_file" summary))))))) |
| 89 | (filter-children-by-name "patch" |
| 90 | (stp:first-child document)))) |
| 91 | |
| 92 | ;;; Parsed changelog accessors |
| 93 | |
| 94 | (defun patch-name (patch) |
| 95 | (first patch)) |
| 96 | |
| 97 | (defun patch-date (patch) |
| 98 | (second patch)) |
| 99 | |
| 100 | (defun patch-hash (patch) |
| 101 | (third patch)) |
| 102 | |
| 103 | (defun patch-comment (patch) |
| 104 | (fourth patch)) |
| 105 | |
| 106 | (defun patch-added-files (patch) |
| 107 | (cdr (first (fifth patch)))) |
| 108 | |
| 109 | (defun patch-changed-files (patch) |
| 110 | (cdr (second (fifth patch)))) |
| 111 | |
| 112 | ;;; Feed generation |
| 113 | |
| 114 | (defun muse-path->html-url (potential-muse-path) |
| 115 | ;; When generating the RSS only *.muse files should have links and |
| 116 | ;; these should be translated to the corresponding html |
| 117 | (when-bind basename (or (ppcre:register-groups-bind (basename) |
| 118 | (*muse-file-scanner* potential-muse-path) |
| 119 | basename) |
| 120 | (cdar (member potential-muse-path *special-files* |
| 121 | :key #'car :test #'string=))) |
| 122 | (format nil "http://unknownlamer.org/muse/~A.html" |
| 123 | (escape-as-uri basename)))) |
| 124 | |
| 125 | (defun darcs-time->local-time (timestring) |
| 126 | ;; YYYYMMDDHHMMSS UTC |
| 127 | (local-time:universal-to-timestamp |
| 128 | (encode-universal-time (parse-integer timestring :start 12 :end 14) |
| 129 | (parse-integer timestring :start 10 :end 12) |
| 130 | (parse-integer timestring :start 8 :end 10) |
| 131 | (parse-integer timestring :start 6 :end 8) |
| 132 | (parse-integer timestring :start 4 :end 6) |
| 133 | (parse-integer timestring :start 0 :end 4) |
| 134 | 0))) |
| 135 | |
| 136 | (defun darcs-time->pubdate (darcs-time) |
| 137 | ;; this seems to be correct but at least liferea is taking my time |
| 138 | ;; and substracting the tz offset from it ... what the fuck |
| 139 | (let ((local-time (darcs-time->local-time darcs-time))) |
| 140 | (local-time:format-timestring |
| 141 | nil local-time |
| 142 | :format '(:short-weekday ", " |
| 143 | (:day 2) #\space :short-month #\space (:year 4) #\space |
| 144 | (:hour 2) #\: (:min 2) #\: (:sec 2) #\space :timezone)))) |
| 145 | |
| 146 | (defun darcs-hash->guid (hash) |
| 147 | (format |
| 148 | nil |
| 149 | "http://unknownlamer.org/darcsweb/browse?r=unknownlamer.org;a=commit;h=~A" |
| 150 | hash)) |
| 151 | |
| 152 | (defun file-link (file) |
| 153 | (with-tag ("li") |
| 154 | (with-tag ("p") |
| 155 | (if-bind muse-url (muse-path->html-url file) |
| 156 | (simple-tag "a" file `(("href" ,muse-url))) |
| 157 | (xml-out file))))) |
| 158 | |
| 159 | (defun generate-entry-html (patch) |
| 160 | (with-output-to-string (string-stream) |
| 161 | ;; EVIL, but ... I don't feel like modifying the xml-emitter lib |
| 162 | (let ((xml-emitter::*xml-output-stream* string-stream)) |
| 163 | (when-bind comment (patch-comment patch) |
| 164 | (with-tag ("p") |
| 165 | (xml-out comment))) |
| 166 | (when-bind added-files (patch-added-files patch) |
| 167 | (simple-tag "h2" "New Files") |
| 168 | (with-tag ("ul") |
| 169 | (dolist (file added-files) |
| 170 | (file-link file)))) |
| 171 | (when-bind changed-files (patch-changed-files patch) |
| 172 | (simple-tag "h2" "Modified Files") |
| 173 | (with-tag ("ul") |
| 174 | (dolist (file changed-files) |
| 175 | (file-link file))))))) |
| 176 | |
| 177 | (defun generate-feed (entries stream) |
| 178 | (with-rss2 (stream :encoding "UTF-8") |
| 179 | (rss-channel-header "The Home of Your Friendly Neighborhood Terrorist" |
| 180 | "http://unknownlamer.org" |
| 181 | :description "Updates to Clinton Ebadi's personal website") |
| 182 | (dolist (entry entries) |
| 183 | (rss-item (patch-name entry) |
| 184 | :description (generate-entry-html entry) |
| 185 | :guid (darcs-hash->guid (patch-hash entry)) ; fix guid |
| 186 | :pubdate (darcs-time->pubdate (patch-date entry)))))) |
| 187 | |
| 188 | ;;; Call darcs |
| 189 | |
| 190 | (defun darcs-changelog-stream () |
| 191 | (let ((files (append |
| 192 | (let ((dirlist (fad:list-directory |
| 193 | *repo-path*)) |
| 194 | (wild-path (make-pathname :type "muse"))) |
| 195 | (mapcan (lambda (path) |
| 196 | (if (pathname-match-p path wild-path) |
| 197 | (list path))) |
| 198 | dirlist)) |
| 199 | (mapcar (lambda (file) |
| 200 | ;; note: assumes only one . in the filename |
| 201 | ;; (this is true ... for now) |
| 202 | (let ((split-file (split-sequence #\. (car file)))) |
| 203 | (merge-pathnames |
| 204 | (make-pathname :name (first split-file) |
| 205 | :type (second split-file)) |
| 206 | *repo-path*))) |
| 207 | *special-files*)))) |
| 208 | (sb-ext:process-output |
| 209 | (sb-ext:run-program "darcs" |
| 210 | `("changes" "--xml" "--summary" |
| 211 | ,(format nil "--repodir=~A" *repo-path*) |
| 212 | "--only-to-files" ,@(mapcar |
| 213 | #'namestring files)) |
| 214 | :search t |
| 215 | :output :stream |
| 216 | :wait t)))) |
| 217 | |
| 218 | |
| 219 | ;;; Public Interface |
| 220 | |
| 221 | (defun firstn (n list) |
| 222 | ;; yeah yeah really shitty whatever |
| 223 | (loop for i from 0 to n collect (nth i list))) |
| 224 | |
| 225 | (defun stream->feed (input-stream output-stream) |
| 226 | (generate-feed |
| 227 | (firstn 15 |
| 228 | (darcs-stp->parsed-list (darcs-changes->stp input-stream))) |
| 229 | output-stream)) |
| 230 | |
| 231 | (defun darcs->feed () |
| 232 | (with-open-file (rss-out *rss-path* |
| 233 | :direction :output |
| 234 | :if-exists :supersede |
| 235 | :if-does-not-exist :create) |
| 236 | (stream->feed (darcs-changelog-stream) rss-out))) |
| 237 | |
| 238 | (defun run () |
| 239 | (darcs->feed) |
| 240 | (sb-ext:quit)) |