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