1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
|
;; Tekuti
;; Copyright (C) 2008, 2010, 2011 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;;; Commentary:
;;
;; Posts -- pulling them out of git, and, later, putting them in.
;;
;;; Code:
(define-module (tekuti post)
#:use-module (srfi srfi-1)
#:use-module (tekuti match-bind)
#:use-module (tekuti util)
#:use-module (tekuti url)
#:use-module (tekuti comment)
#:use-module (tekuti config)
#:use-module (tekuti git)
#:use-module (tekuti filters)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:export (post-from-tree post-from-key
post-tags post-timestamp post-key post-published?
post-comments-open? post-comments
post-sxml-content post-readable-date post-n-comments
post-raw-content
post-title
make-new-post modify-post delete-post
all-published-posts
reindex-posts))
;;;
;;; pulling posts out of git
;;;
(define *post-spec*
`((timestamp . ,string->number)
(tags . ,(lambda (v) (string-split/trimming v #\,)))
(title . ,identity)))
(define (post-from-tree encoded-name sha1)
(append `((key . ,encoded-name)
(sha1 . ,sha1))
(match-lines
(git "show" (string-append sha1 ":metadata"))
"^([^: ]+): +(.*)$" (_ k v)
(let* ((k (string->symbol k))
(parse (or (assq-ref *post-spec* k)
identity)))
(cons k (parse v))))))
(define (post-from-key master key . allow-unpublished)
(false-if-git-error
(let ((pairs (git-ls-subdirs master key)))
(and (= (length pairs) 1)
(let ((post (post-from-tree key (cdar pairs))))
(if (or (post-published? post)
(and (pair? allow-unpublished) (car allow-unpublished)))
post
#f))))))
;;;
;;; accessors
;;;
(define (post-published? post-alist)
(equal? (assq-ref post-alist 'status) "publish"))
(define (post-timestamp post-alist)
(assq-ref post-alist 'timestamp))
(define (post-tags post-alist)
(or (assq-ref post-alist 'tags) '()))
(define (post-key post)
(assq-ref post 'key))
(define (post-title post)
(assq-ref post 'title))
(define (post-comments-open? post)
(equal? (assq-ref post 'comment_status) "open"))
(define (post-raw-content post)
(git "show" (string-append (assq-ref post 'sha1) ":content")))
(define (post-sxml-content post)
(let ((format (or (assq-ref post 'format) 'wordpress))
(raw (post-raw-content post)))
(catch #t
(lambda ()
(case format
((wordpress) (wordpress->sxml raw))
(else `(pre ,raw))))
(lambda args
`(pre ,(bad-user-submitted-xhtml? raw))))))
(define (post-readable-date post)
(let ((date (time-utc->date
(make-time time-utc 0 (post-timestamp post)))))
(date->string date "~e ~B ~Y ~l:~M ~p")))
(define (post-comments post)
(dsu-sort
(map (lambda (pair)
(blob->comment (car pair) (cadr pair)))
(git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f))
comment-timestamp
<))
(define (post-n-comments post)
(length (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f)))
(define (munge-post old-key parsed)
(let ((metadata (with-output-to-blob
(for-each
(lambda (k)
(format #t "~a: ~a\n" k (assq-ref parsed k)))
'(timestamp tags status title name comment_status))))
(content (with-output-to-blob (display (assq-ref parsed 'body))))
(key (assq-ref parsed 'key))
(message (format #f "~a: \"~a\""
(if old-key "post modified" "new post")
(assq-ref parsed 'title))))
(define (maybe-rename ops)
(if (and old-key (not (equal? old-key key)))
(cons `(rename () (,old-key ,key)) ops)
ops))
(define (maybe-clear ops)
(if old-key
(append `((delete (,key) ("content"))
(delete (,key) ("metadata")))
ops)
ops))
(let ((ops (maybe-rename
(maybe-clear
`((create (,key) ("metadata" ,metadata blob))
(create (,key) ("content" ,content blob)))))))
(post-from-key
(git-update-ref "refs/heads/master"
(lambda (master)
(git-commit-tree (munge-tree master ops)
master message #f))
5)
key #t))))
(define space-to-dash (s///g " " "-"))
(define remove-extraneous (s///g "[^a-z-]+" ""))
(define collapse (s///g "-+" "-"))
(define (title->name title)
(collapse (remove-extraneous (space-to-dash (string-downcase title)))))
;; some verification necessary...
(define (parse-post-data post-data)
(let ((title (assoc-ref post-data "title"))
(body (assoc-ref post-data "body"))
(tags (assoc-ref post-data "tags"))
(status (assoc-ref post-data "status"))
(comments-open? (assoc-ref post-data "comments"))
(date-str (assoc-ref post-data "date")))
(let ((timestamp (if (string-null? date-str)
(time-second (current-time))
(rfc822-date->timestamp date-str)))
(name (title->name title)))
`((title . ,title)
(body . ,body)
(tags . ,tags)
(status . ,status)
(comment_status . ,(if comments-open? "open" "closed"))
(timestamp . ,timestamp)
(name . ,name)
(key . ,(url:encode
(string-append (date->string (timestamp->date timestamp)
"~Y/~m/~d/")
(url:encode name))))))))
(define (make-new-post post-data)
(munge-post #f (parse-post-data post-data)))
(define (modify-post old-key post-data)
(munge-post old-key (parse-post-data post-data)))
(define (delete-post key)
(let* ((post (post-from-key "refs/heads/master" key))
(message (format #f "~a: \"~a\"" "post deleted" (post-title post))))
(git-update-ref "refs/heads/master"
(lambda (master)
(git-commit-tree (munge-tree1 master 'delete '() `(,key))
master message #f))
5)))
(define (all-posts master)
(map (lambda (pair)
(post-from-tree (car pair) (cdr pair)))
(git-ls-subdirs master #f)))
(define (all-published-posts master)
(dsu-sort
(filter post-published? (all-posts master))
post-timestamp
>))
(define (hash-fill proc list)
(let ((table (make-hash-table)))
(for-each (lambda (x) (proc x table))
list)
table))
(define (reindex-posts oldindex newindex)
(let ((old (hash-fill (lambda (post h)
(hash-set! h (assq-ref post 'sha1) post))
(or (assq-ref oldindex 'posts) '()))))
(dsu-sort (map (lambda (dent)
(or (hash-ref old (cadr dent))
(begin (pk 'updated dent)
(post-from-tree (car dent) (cadr dent)))))
(git-ls-tree (assq-ref newindex 'master) #f))
post-timestamp
>)))
|
