source: project/stream-wiki/trunk/extensions/weblog.scm @ 2902

Last change on this file since 2902 was 2902, checked in by azul, 14 years ago

Fix for the message shown for creating a file.

File size: 8.8 KB
Line 
1(require-extension syntax-case svn-post-commit-hooks orders format-modular html-stream)
2
3(define-syntax environment
4  (syntax-rules ()
5    ((environment original ((name expr) ...))
6     (lambda (op)
7       (case op
8         ((name) expr)
9         ...
10         (else (original op)))))
11    ((environment ((name expr) ...))
12     (environment (lambda (op)
13                    (warning "unbound variable (dynamic environment)" op)
14                    (if #f #f))
15                  ((name expr) ...)))))
16
17(define-syntax environment-get
18  (syntax-rules ()
19    ((environment-get env sym) (env 'sym))))
20
21(define-syntax let-from-environment
22  (syntax-rules ()
23    ((let-from-environment env (sym ...) body ...)
24     (let ((sym (environment-get env sym)) ...) body ...))))
25
26(define-syntax environment-capture
27  (syntax-rules ()
28    ((environment-capture env (sym ...))
29     (environment env ((sym sym) ...)))
30    ((environment-capture (sym ...))
31     (environment ((sym sym) ...)))))
32
33(define (weblog-update env)
34  (let-from-environment env (path path-out)
35    (format (current-error-port) "Weblog update start: ~A~%" path)
36    (let* ((path-out-real (svnwiki-make-pathname path "index"))
37           (new-env (environment-capture env (path-out-real))))
38      (write-file-with-tmp path-out-real "text/html" path-out
39        (render-template
40          (environment new-env ((path path-out-real)))
41          ""
42          (weblog-content new-env)
43          'view)))))
44
45(define (list-all-posts env)
46  (let-from-environment env (path-in path base user password)
47    (list->stream
48      (sort
49        (let ((path-real (svnwiki-make-pathname path-in path)))
50          (format (current-error-port) "path: ~A, base: ~A, path-real: ~A~%" path base path-real)
51          (remove
52            (lambda (post)
53              (entry-ignore? path-real post))
54            (hash-table->alist
55              (entry-subs
56                (post-commit-changed-files path-real (svnwiki-make-pathname base path) user password)))))
57        (key>
58          (lambda (x)
59            (post-seconds path-in (svnwiki-make-pathname path (car x)) x)))))))
60
61(define (post-seconds path-in path post)
62  (post-seconds-default-time
63    path-in
64    path
65    (change-seconds (last (entry-changes (cdr post))))))
66
67(define (post-seconds-default-time path-in path default-time)
68  (or
69    (and-let* ((creation-date
70                 (get-props-parents-first "svnblog:creation-date" path-in path #f)))
71      (string->number creation-date))
72    (and-let* ((creation-date
73                 (get-props-parents-first "svnwiki:creation-date" path-in path #f)))
74      (string->number creation-date))
75    default-time))
76
77(define (get-post-title post path-in path-post)
78  (or (and-let* ((title (svn-propget "svnwiki:title" (svnwiki-make-pathname path-in path-post) "" "" '()))
79                 ((not (null? title))))
80        (cadar title))
81      post))
82
83(define (render-post env post)
84  (let-from-environment env (path path-out-real path-in)
85    (let ((path-post (svnwiki-make-pathname path (car post))))
86      (html-stream
87      ((h2 class "post-title")
88       ((a href (car post))
89        (get-post-title (car post) path-in path-post)))
90      ((p class "post-date") (seconds->string (post-seconds path-in path-post post)))
91      (render-file-contents (environment env ((path path-post))) path-out-real 3)))))
92
93(define (weblog-content env)
94  (let-from-environment env (path-in path)
95    (stream-concatenate
96      (stream-map
97        (lambda (post)
98          (render-post env post))
99        (stream-take-safe
100          (list-all-posts env)
101          (get-posts-number env))))))
102
103(define (get-posts-number env)
104  (let-from-environment env (path-in path)
105    (string->number (get-props-parents-first "svnblog:count" path-in path "10"))))
106
107(define (entry-ignore? path entry)
108  (or (null? (entry-changes (cdr entry)))
109      (is-discuss? (car entry))
110      (directory? (svnwiki-make-pathname path (car entry)))
111      (char=? #\D (svn-log-changed-path-action (change-data (first (entry-changes (cdr entry))))))
112      (get-props-parents-first "svnblog:ignore" path (car entry) #f)))
113
114(define (weblog-about env)
115  (let-from-environment env (path-out-real path-in user password)
116    (let ((author (get-props-parents-first "svnblog:author" path-in path-out-real #f))
117          (file (last (string-split path-out-real "/")))
118          (path (svnwiki-make-pathname (butlast (string-split path-out-real "/")))))
119      (cond
120        ((not (file-exists? (svnwiki-make-pathname path-in path-out-real)))
121         (html-stream
122           (p "You are creating the file "
123              (b path-out-real)
124              (if author
125                (html-stream
126                  " as part of "
127                  ((a href "..")
128                   "the weblog of " (b author)))
129                (html-stream
130                  ".  You can go to "
131                  ((a href "..")
132                   "this weblog's main page"))))))
133        ((svnwiki-is-discuss? path-out-real)
134         (html-stream
135           (p "You are reading the discussion for the post "
136              (b ((a href (format #f "../~A" file))
137                  (get-post-title file path-in path-out-real)))
138              (if author
139                (html-stream
140                  ", which is part of "
141                  ((a href "..")
142                   "the weblog of " (b author)))
143                (html-stream
144                  ".  You can go to "
145                  ((a href "..")
146                   "this weblog's main page")))
147              ".")))
148        ((svnwiki-is-special? "xsvnwiki-archive" path-out-real)
149         (html-stream
150           (p "This file contains all the posts made in "
151              (b (list->string (take-while (complement (cut char=? <> #\.)) (string->list file))))
152              " to "
153              ((a href "..")
154               (if author
155                 (html-stream "the weblog of " (b author))
156                 "this weblog"))
157              ".")))
158        ((svnwiki-is-special? #f path-out-real)
159         stream-null)
160        ((not (string=? file "index"))
161         (html-stream
162           (p "You are reading the post "
163            (b (get-post-title file path-in path-out-real))
164            (if author
165              (html-stream
166                ", which is part of "
167                ((a href "index")
168                 "the weblog of " (b author)))
169              (html-stream
170                ".  You can go to "
171                ((a href "index")
172                 "this weblog's main page")))
173            (let ((history (get-history user password (svnwiki-make-pathname path-in path-out-real))))
174              (if (stream-null? history)
175                stream-null
176                (let ((publish
177                        (strftime "%Y-%m-%d"
178                                  (post-seconds-default-time
179                                    path-in
180                                    path-out-real
181                                    (/ (svn-time-from-cstring (fourth (stream-last history))) 1000000))))
182                      (last-change
183                        (strftime "%Y-%m-%d"
184                                  (/ (svn-time-from-cstring (fourth (stream-car history))) 1000000))))
185                  (html-stream
186                    ".  This post was published on "
187                    (b publish)
188                    (if (string=? publish last-change)
189                      stream-null
190                      (html-stream
191                        " and last modified on "
192                        (b last-change)))))))
193            ".")
194           (let loop ((posts (stream-map car (list-all-posts (environment-capture env (path)))))
195                      (next #f))
196             (if (string=? (stream-car posts) file)
197               (html-stream
198                 (if (stream-null? (stream-cdr posts))
199                   stream-null
200                   (html-stream
201                     (p "The previous post in this weblog is "
202                        ((a href (stream-cadr posts))
203                         (b (get-post-title
204                              (stream-cadr posts)
205                              path-in
206                              (svnwiki-make-pathname path (stream-cadr posts)))))
207                        ".")))
208                 (if next
209                   (html-stream
210                     (p "The next post in this weblog is "
211                        ((a href next)
212                         (b (get-post-title
213                              next
214                              path-in
215                              (svnwiki-make-pathname path next))))
216                        "."))
217                   stream-null))
218               (loop (stream-cdr posts) (stream-car posts))))))
219        (author
220          (html-stream
221            (p "You are reading the weblog of " (b author) ". "
222               "This file contains the " (get-posts-number env)
223               " most recent posts.")))
224        (else
225          stream-null)))))
226
227(define *extensions*
228  `((weblog (update ,weblog-update))
229    (weblogabout (code-break ,weblog-about))))
Note: See TracBrowser for help on using the repository browser.