429c8025 |
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)) |