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

Last change on this file since 17159 was 17159, checked in by azul, 10 years ago

improve descriptions.

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