source: project/release/3/svnwiki-weblog/trunk/svnwiki-weblog.scm @ 12533

Last change on this file since 12533 was 12533, checked in by azul, 11 years ago

Importing svnwiki extensions.

  • Property svn:keywords set to id
File size: 11.8 KB
Line 
1; $id$
2;
3; License: GPL-3
4
5(declare (export))
6(use svnwiki-extensions-support srfi-40 svn-post-commit-hooks orders format-modular html-stream srfi-1 stream-ext svn-client)
7
8(define (weblog-update env)
9  (let-from-environment env (path path-out)
10    (svnwiki-report-progress env "Weblog update start: ~A~%" path)
11    (let ((weblog-index (get-weblog-index env)))
12      (stream-for-each
13        (lambda (language)
14          (let* ((path-out-real (svnwiki-make-pathname path weblog-index (and language (stream->string language))))
15                 (new-env (environment env ((path path-out-real) (path-out-real path-out-real)))))
16            (write-file-with-tmp path-out-real "text/html" path-out
17              (render-template new-env "" (weblog-content new-env) 'view))))
18        (stream-delete-duplicates
19          (stream-map svnwiki-file-language 
20                      (stream-map car (list-all-posts env)))
21          (lambda (a b)
22            (or (and (not a) (not b))
23                (and (stream? a)
24                     (stream? b)
25                     (stream= char=? a b)))))))))
26
27(define (weblog-dir-path env)
28  (let-from-environment env (path-in path)
29    (if (directory? (svnwiki-make-pathname path-in path))
30      path
31      (svnwiki-make-pathname (butlast (string-split path "/"))))))
32
33(define (list-all-posts env)
34  (let-from-environment env (path-in base user password)
35    (let ((dir-path (weblog-dir-path env)))
36      (list->stream
37        (sort
38          (let ((path-real (svnwiki-make-pathname path-in dir-path)))
39            (remove
40              (lambda (post)
41                (weblog-entry-ignore? path-real post))
42              (hash-table->alist
43                (entry-subs
44                  (post-commit-changed-files path-real (string-append base "/" dir-path) user password)))))
45          (key>
46            (lambda (x)
47              (post-seconds path-in (svnwiki-make-pathname dir-path (car x)) x))))))))
48
49(define (post-seconds path-in path post)
50  (post-seconds-default-time
51    path-in
52    path
53    (change-seconds (last (entry-changes (cdr post))))))
54
55(define (post-seconds-default-time path-in path default-time)
56  (or
57    (and-let* ((creation-date
58                 (get-props-parents-first "svnblog:creation-date" path-in path #f)))
59      (string->number creation-date))
60    (and-let* ((creation-date
61                 (get-props-parents-first "svnwiki:creation-date" path-in path #f)))
62      (string->number creation-date))
63    default-time))
64
65(define (get-post-title post path-in path-post)
66  (or (and-let* ((title (svn-propget "svnwiki:title" (svnwiki-make-pathname path-in path-post) "" "" '()))
67                 ((not (null? title))))
68        (cadar title))
69      post))
70
71(define (render-post env post)
72  (let-from-environment env (path path-out-real path-in)
73    (svnwiki-report-progress env "Render for weblog [~A]: post [~A]~%" path (car post))
74    (let ((path-post (svnwiki-make-pathname (weblog-dir-path env) (car post))))
75      (html-stream
76      ((h2 class "post-title")
77       ((a href (car post))
78        (get-post-title (car post) path-in path-post)))
79      ((p class "post-date") (seconds->string (post-seconds path-in path-post post)))
80      (render-file-contents (environment env ((path path-post))) path-out-real 3)))))
81
82(define (weblog-content env)
83  (let-from-environment env (path-in path path-out-real)
84    (if (file-exists? (svnwiki-make-pathname path-in path))
85      (render-file-contents env path-out-real 2)
86      (weblog-content-posts env))))
87
88(define (weblog-add-separators env posts)
89  (let-from-environment env (path path-in path-out-real)
90    (or (and-let* ((separator-file (get-props-parents-first "svnblog:separator" path-in path #f))
91                   ((file-exists? (svnwiki-make-pathname path-in separator-file)))
92                   (separator-code (render-file-contents (environment env ((path separator-file))) path-out-real 3)))
93          (stream-intersperse posts separator-code))
94        posts)))
95
96(define (weblog-content-posts env)
97  (let-from-environment env (path-out-real)
98    (let ((language (svnwiki-file-language path-out-real)))
99      (stream-concatenate
100        (weblog-add-separators
101          env
102          (stream-map
103            (lambda (post)
104              (render-post env post))
105            (stream-take-safe
106              (stream-filter
107                (compose
108                  (if language
109                    (lambda (lang)
110                      (and lang (stream= char=? language lang)))
111                    not)
112                  svnwiki-file-language
113                  car)
114                (list-all-posts env))
115              (get-posts-number env))))))))
116
117(define (get-posts-number env)
118  (let-from-environment env (path-in path)
119    (string->number (get-props-parents-first "svnblog:count" path-in path "10"))))
120
121(define (weblog-entry-ignore? path entry)
122  (or (null? (entry-changes (cdr entry)))
123      (svnwiki-is-special? #f (car entry))
124      (directory? (svnwiki-make-pathname path (car entry)))
125      (char=? #\D (svn-log-changed-path-action (change-data (first (entry-changes (cdr entry))))))
126      (get-props-parents-first "svnblog:ignore" path (car entry) #f)))
127
128(define (get-weblog-index env)
129  (let-from-environment env (path-in path)
130    (get-props-parents-first "svnblog:index" path-in path "index")))
131
132(define (weblog-about env)
133  (let-from-environment env (path-out-real path-in user password)
134    (let ((author (get-props-parents-first "svnblog:author" path-in path-out-real #f))
135          (index (get-weblog-index env))
136          (file (last (string-split path-out-real "/")))
137          (path (svnwiki-make-pathname (butlast (string-split path-out-real "/")))))
138      (cond
139        ((not (file-exists? (svnwiki-make-pathname path-in path-out-real)))
140         (html-stream
141           (p "You are creating the file "
142              (b path-out-real)
143              (if author
144                (html-stream
145                  " as part of "
146                  ((a href index)
147                   "the weblog of " (b author)))
148                (html-stream
149                  ".  You can go to "
150                  ((a href "..")
151                   "this weblog's main page"))))))
152        ((svnwiki-is-discuss? path-out-real)
153         (html-stream
154           (p "You are reading the discussion for the post "
155              (b ((a href (format #f "../~A" file))
156                  (get-post-title file path-in path-out-real)))
157              (if author
158                (html-stream
159                  ", which is part of "
160                  ((a href "..")
161                   "the weblog of " (b author)))
162                (html-stream
163                  ".  You can go to "
164                  ((a href "..")
165                   "this weblog's main page")))
166              ".")))
167        ((svnwiki-is-special? "xsvnwiki-archive" path-out-real)
168         (html-stream
169           (p "This file contains all the posts made in "
170              (b (list->string (take-while (complement (cut char=? <> #\.)) (string->list file))))
171              " to "
172              ((a href "..")
173               (if author
174                 (html-stream "the weblog of " (b author))
175                 "this weblog"))
176              "."
177              (rss-link env))))
178        ((svnwiki-is-special? #f path-out-real)
179         stream-null)
180        ((not (stream= char=? (svnwiki-file-without-language file) (->stream-char index)))
181         (html-stream
182           (p "You are reading the post "
183            (b (get-post-title file path-in path-out-real))
184            (if author
185              (html-stream
186                ", which is part of "
187                ((a href index)
188                 "the weblog of " (b author)))
189              (html-stream
190                ".  You can go to "
191                ((a href index)
192                 "this weblog's main page")))
193            (let ((history (get-history user password (svnwiki-make-pathname path-in path-out-real))))
194              (if (stream-null? history)
195                stream-null
196                (let ((publish
197                        (strftime "%Y-%m-%d"
198                                  (post-seconds-default-time
199                                    path-in
200                                    path-out-real
201                                    (/ (svn-time-from-cstring (fourth (stream-last history))) 1000000))))
202                      (last-change
203                        (strftime "%Y-%m-%d"
204                                  (/ (svn-time-from-cstring (fourth (stream-car history))) 1000000))))
205                  (html-stream
206                    ". This post was published on "
207                    (b publish)
208                    (if (string=? publish last-change)
209                      stream-null
210                      (html-stream
211                        " and last modified on "
212                        (b last-change)))
213                    ".")))))
214           (let loop ((posts (stream-map car (list-all-posts (environment-capture env (path)))))
215                      (next #f))
216             ; I used to think posts would not be null the first time (in which
217             ; case the following check would not be needed), but this
218             ; assumption is false: it could be null if the weblogs' directory
219             ; only has files that list-all-posts ignores.
220             (if (stream-null? posts)
221               stream-null
222               (if (string=? (stream-car posts) file)
223                 (html-stream
224                   (if (stream-null? (stream-cdr posts))
225                     stream-null
226                     (html-stream
227                       (p "The previous post in this weblog is "
228                          ((a href (stream-cadr posts))
229                           (b (get-post-title
230                                (stream-cadr posts)
231                                path-in
232                                (svnwiki-make-pathname path (stream-cadr posts)))))
233                          ".")))
234                   (if next
235                     (html-stream
236                       (p "The next post in this weblog is "
237                          ((a href next)
238                           (b (get-post-title
239                                next
240                                path-in
241                                (svnwiki-make-pathname path next))))
242                          "."))
243                     stream-null))
244                 (loop (stream-cdr posts) (stream-car posts)))))))
245        (author
246          (let ((posts-count (stream-length (list-all-posts (environment-capture env (path)))))
247                (number (get-posts-number env)))
248            (html-stream
249              (p "You are reading the weblog of " (b author) ". "
250                 (cond
251                   ((zero? posts-count)
252                    "This weblog has no posts right now.")
253                   ((= posts-count 1)
254                    "This file contains the one and only post in this weblog.")
255                   ((< posts-count number)
256                    (html-stream
257                      "This file contains all " posts-count " posts in this weblog."))
258                   (else
259                     (html-stream
260                       "This file contains the " number " most recent posts.")))
261                 (rss-link env)))))
262        (else
263          stream-null)))))
264
265(define (rss-link env)
266  (let-from-environment env (path-out path-out-real)
267    (let* ((link (svnwiki-make-pathname "xsvnwiki-atom" "xsvnwiki-dir"))
268           (file (svnwiki-make-pathname
269                   (cons path-out
270                         (butlast (string-split path-out-real "/")))
271                   link
272                   "xml")))
273      (if (file-exists? file)
274        (html-stream
275          " Subscribe to the "
276          ((a href link) "RSS")
277          " to be notified when new posts are made.")
278        stream-null))))
279   
280(svnwiki-extension-define 'update-notify 'weblog weblog-update)
281(svnwiki-extension-define 'code-break 'weblogabout weblog-about)
282(svnwiki-extension-define 'code-break 'weblogcontent weblog-content-posts)
Note: See TracBrowser for help on using the repository browser.