source: project/release/3/stream-wiki/trunk/extensions/mail.scm @ 12409

Last change on this file since 12409 was 12409, checked in by azul, 12 years ago

fix

  • Property svn:keywords set to rev
File size: 37.2 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 (mail-subscribe-link env)
34  (let-from-environment env (path-in path)
35    (svnwiki-file-action-link
36      env
37      (format #f "~A~A?action=extension&extension=mail&request=subscribeform"
38              (get-props-parents-first "svnwiki:application-url" path-in path)
39              path)
40      "Subscribe")))
41
42(define (mail-request-handle env)
43  (let-from-environment env (user-input)
44    (let ((result (assoc (stream->symbol (user-input 'request stream-null)) 
45                         *mail-request-handlers*)))
46      (if result
47        ((cadr result) env)
48        (render-template
49          env
50          "Error"
51          (html-stream (p "Invalid request: " (tt request)))
52          'view)))))
53
54(define *mail-db* #f)
55
56(define (mail-db-run query . params)
57  (let-from-environment env (data)
58    (unless *mail-db*
59      (let* ((db-path (svnwiki-make-pathname data "mail" "db"))
60             (existed (file-exists? db-path)))
61        (set! *mail-db* (sqlite3:open db-path))
62        (unless existed
63          (mail-db-create))))
64    (let ((result
65            (iterator->stream
66              (lambda (capture stop)
67                (receive (stmt rest)
68                         (sqlite3:prepare db query)
69                  (sqlite3:for-each-row (compose capture vector) stmt params)
70                  (sqlite3:finalize! stmt))))))
71      (stream-null? result)
72      result)))
73
74(define (mail-db-create)
75  (mail-db-run "CREATE TABLE addresses ( address varchar, confirmed boolean, password varchar, timestamp integer );")
76  (mail-db-run "CREATE TABLE subscriptions ( address varchar, page varchar, timestamp integer, http_address varchar );")
77  (mail-db-run "CREATE TABLE pages ( page varchar, id varchar, last_revision integer );")
78  (mail-db-run "CREATE TABLE configuration ( last_revision integer, version integer );")
79  (mail-db-run "INSERT INTO configuration VALUES ( -1, 1.0 );"))
80
81(define (get-password-for-address address)
82  (let ((data (mail-db-run "SELECT password FROM addresses WHERE address = ~A;" address)))
83    (and (not (stream-null data))
84         (vector-ref (stream-car data) 0))))
85
86;;; Handle subscriptions
87
88(define *random-password-length* 16)
89(define *random-password-chars* "abcdefghijklmnopqrstuvwxyz0123456789")
90
91(define (generate-random-password)
92  (stream->string
93    (stream-tabulate
94      *random-passowrd-length*
95      (lambda (_)
96        (string-ref *random-password-chars*
97                    (random (string-length *random-password-chars*)))))))
98
99(define *max-subscriptions-per-day* 100)
100
101(define (subscribe-address-commit env)
102  (let-from-environment env (user-input)
103    (let ((address (svnwiki-email-parse (user-input 'email stream-null))))
104      (when (svnwiki-email-validate? address)
105        (if (subscribe-address env address)
106          (svnwiki-commit-handler-info
107            (html-stream
108              "Address " address " has been subscribed."))
109          ; Not raising an error is probably better
110          (svnwiki-commit-handler-info
111            (html-stream
112              "Address " address " has already reached the maximum number of subscriptions permited per day.  It was not subscribed.")))))))
113
114(define (subscribe-address env address)
115  (let-from-environment env (user-input path)
116    (let ((http-address (getenv "REMOTE_ADDR")))
117      (and (< (vector-ref (stream-car
118                            (mail-db-run "SELECT count(address) FROM subscriptions WHERE http_address = ~A AND timestamp > ~A;"
119                                         http-address
120                                         (- (current-seconds) (* 24 60 60))))
121                          0)
122              *max-subscriptions-per-day*)
123           (or (not (stream-null? (mail-db-run "SELECT address FROM subscriptions WHERE address = ~A AND page = ~A;" address path)))
124               (let ((confirmed (mail-db-run "SELECT confirmed FROM addresses WHERE address = ~A;")))
125                 (when (stream-null? confirmed)
126                   (mail-db-run "INSERT INTO addresses VALUES ( ~A, false, ~A, ~A );" address (generate-random-password) (current-seconds)))
127                 (mail-db-run "INSERT INTO subscriptions VALUES ( ~A, ~A, ~A, ~A );" address path (current-seconds) http-address)
128                 (if (or (stream-null? confirmed)
129                         (not (vector-ref (stream-car confirmed) 0)))
130                   (send-confirmation-mail env address)
131                   (send-subscribed-mail env address #f))
132                 #t))))))
133
134(define (get-nobody-address env)
135  (let-from-environment env (path-in path)
136    (get-props-parents-first "svnwiki:mail:from-no-reply" path-in path "nobody")))
137
138(define (send-no-reply-mail env to writer)
139  (send-mail env (get-nobody-address env) to writer))
140
141; Some rate limiting: never send more than 1 mail per *seconds-between-mails*
142;
143; TODO: This is way too simplistic.  For pages with lots of subscribers it will
144; create problems.  In that case what we should do is actually wait for the
145; send-mail processes, making sure we never spawn more than N (10?) at a given
146; time.
147
148(define *seconds-between-mails* 1)
149(define *last-mail-time* 0)
150
151(define (sendmail-command file to)
152  (format #f "/usr/sbin/sendmail -i ~A <~A"
153          (svnwiki-path-escape to)
154          (svnwiki-path-escape file)))
155
156(define (send-mail env from to writer)
157  (when (> (+ *last-mail-time* *seconds-between-mails*) (current-time))
158    (sleep 1))
159  (set *last-mail-time* (current-seconds))
160  (let-from-environment env (path-in path)
161    (let ((new-process (process-fork)))
162      (when (zero? new-process)
163        ; Double fork so parent won't be stuck waiting for long; instead, it
164        ; will be able to do the process wait and we'll all be happy (and
165        ; we'll let init take care of doing the waitpid on the actual process
166        ; that sends the email).
167        (when (zero? (process-fork))
168          ; TODO: Don't use a file, use a pipe and fork the mail sending process.
169          (let ((tmp-path (svnwiki-make-pathname *tmp-dir* (format #f "svnwiki-mail-~A" (current-process-id)) "txt")))
170            (with-output-to-file tmp-path (lambda () (writer from)))
171            (system (sendmail-command tmp-path to))
172            (delete-file tmp-path)))
173        (exit 0))
174      (process-wait new-process))))
175
176(define (make-mail-list-id env id)
177  (let-from-environment env (path-in path)
178    (format #f "~A.~A"
179            id
180            (get-props-parents-first
181              "svnwiki:mail:list-id-suffix"
182              path-in
183              path
184              (let ((base (get-props-parents-first "svnwiki:mail:gateway-address" path-in path #f)))
185                (cadr (string-split base #\@)))))))
186
187(define (make-mail-gateway-address env . rest)
188  (let-optionals rest ((prefix ""))
189    (let-from-environment env (path-in path)
190      (and-let* ((base (get-props-parents-first "svnwiki:mail:gateway-address" path-in path #f))
191                 (base-split (string-split base #\@))
192                 (id (mail-page->id path)))
193        (format #f "~A~A~A@~A" (car base-split) prefix id (cadr base-split))))))
194
195(define (get-subscribe-submitter env)
196  (format #f "~A (~A~A)"
197          (iconv (iconv-open "us-ascii" "us-ascii")
198                 (stream->string (get-commit-author env stream-null)))
199          (getenv "REMOTE_ADDR")
200          (if #f ; TODO: authenticate!
201            ""
202            ", unauthenticated")))
203
204(define (send-subscribed-mail env address self-subscribe)
205  (let-from-environment env (static-url path-in path)
206    (send-no-reply-mail env to
207      (lambda (from)
208        (format #t "From: ~A~%" from)
209        (format #t "To: ~A~%" address)
210        (format #t "Subject: ~A: Subscribed~%~%" path)
211        (if self-subscribe
212          (format #t "You have been subscribed to the following page:~%~%")
213          (format #t "You have been subscribed by ~A to the following page:~%~%" (get-subscribe-submitter env)))
214        (format #t "  ~A~A~%~%" static-url path)
215        (let ((list-address (make-mail-gateway-address env)))
216          (when list-address
217            (format #t "To send messages to this page, write to:~%~%")
218            (format #t "  ~A~%~%" list-address)))
219        (format #t "To undo this request and unsubscribe from this page, go to~%~%  ")
220        (write-unsubscribe-url env address)
221        (format #t "and enter your administration password:~%~%")
222        (format #t "  Password: ~A~%~%" (vector-ref (stream-car (mail-db-run "SELECT password FROM addresses WHERE address = ~A;" address)) 0))
223        (format #t "We recommend that you save this message for future reference, as it~%")
224        (format #t "may speed up the unsubscription process should you decide to do it.~%")))))
225
226(define (send-confirmation-mail env address)
227  (let-from-environment env (static-url path)
228    (send-no-reply-mail env address
229      (lambda (from)
230        (format #t "From: ~A~%" from)
231        (format #t "To: ~A~%" address)
232        (format #t "Subject: ~A: Confirmation required~%~%" path)
233        (format #t "We have received a subscription request from ~A~%" (get-subscribe-submitter env))
234        (format #t "for this email address for the following page:~%~%")
235        (format #t "  ~A~A~%~%" static-url path)
236        (format #t "In order to confirm this request and receive notifications about~%")
237        (format #t "modifications to this page and new messages posted to its discussion,~%")
238        (format #t "go to~%")
239        (format #t "  ~A~A?action=extension&extension=mail&request=confirmform&mail=~A~%~%"
240                (get-props-parents-first "svnwiki:application-url" path-in path #f)
241                path
242                address)
243        (format #t "and enter your administration password:~%~%")
244        (let ((password (get-password-for-address address)))
245          (unless password
246            (error "send-confirmation-mail: Unable to load password for address" address))
247          (format #t "  Password: ~A~%~%" password))
248        (format #t "By doing this you will allow others to subscribe you to other pages in~%")
249        (format #t "this site.~%~%")
250        (let ((pages (mail-db-run "SELECT page FROM subscriptions WHERE address = ~A AND page <> ~A;" address path)))
251          (unless (stream-null? pages)
252            (format #t "You will also be confirming your subscription to the following pages:~%~%")
253            (stream-for-each
254              (lambda (p)
255                (format #t "  ~A~A~%" static-url p))
256              pages)
257            (newline)))
258        (format #t "If you don't want to be subscribed, disregard this message: you won't be~%")
259        (format #t "subscribed to any page in this site.~%")))))
260
261(define (mail-request-subscribe-show-list desc s)
262  (stream-if (not (stream-null? s))
263    (html-stream
264      (p desc)
265      (ul (stream-concatenate
266            (stream-map (lambda (address) (html-stream (li address)))
267                        (reverse s)))))))
268
269(define (svnwiki-email-parse email)
270  (stream-reverse (stream-drop-while char-whitespace?
271                                     (stream-reverse (stream-drop-while char-whitespace?
272                                                                        email)))))
273; TODO: max of 50 addresses per HTTP requests?
274
275(define (mail-request-subscribe env)
276  (let-from-environment env (user-input path)
277    (let* ((emails (stream-remove-duplicates
278                     (stream-remove
279                       stream-null?
280                       (stream-map
281                         svnwiki-email-parse
282                         (stream-cons (user-input 'email stream-null)
283                                      (stream-split (user-input 'email-invites stream-null)
284                                                    (cut char=? <> #\,)))))))
285           (invalid stream-null)
286           (successful stream-null)
287           (unsuccessful stream-null)
288           (target (stream->string (user-input 'target (string->stream path))))
289           (new-env (environment env ((path target)))))
290      (stream-for-each
291        (lambda (address)
292          (cond
293            ((not (svnwiki-email-validate? address))
294             (set! invalid (stream-cons address invalid)))
295            ((subscribe-address new-env address)
296             (set! successful (stream-cons address successful)))
297            (else
298             (set! unsuccessful (stream-cons address unsuccessful)))))
299        emails)
300      (render-template
301        env
302        "Subscription results"
303        (html-stream
304          (h2 "Subscription results")
305          (mail-request-subscribe-show-list
306            "The following addresses where successfully subscribed:"
307            successful)
308          (mail-request-subscribe-show-list
309            "The following addresses could not be subscribed because you have already reached the maximum number of subscriptions permited per day:"
310            unsuccessful)
311          (mail-request-subscribe-show-list
312            "The following entries where ignored because a meaningful address could not be extracted from them:"
313            invalid))))))
314
315;;; HTML form for subscribing
316
317; TODO: Make sure this selects the default (the full path).
318
319(define (mail-request-subscribe-form-target env)
320  (let-from-environment env (path user-input)
321    (let ((default (user-input 'target
322                               (stream-cons #\/ (string->stream path)))))
323      (let loop ((path "/") (components (string-split path "/")))
324        (stream-delay
325          (stream-append
326            (if (stream= char=? default (string->stream path))
327              (html-stream ((option value path selected "true") path))
328              (html-stream ((option value path) path)))
329            (stream-if (not (null? components))
330              (loop (svnwiki-make-pathname path (car components))
331                    (cdr components)))))))))
332
333(define (mail-request-subscribe-form env . rest)
334  (let-optionals rest ((title "Subscribe") (desc stream-null))
335    (let-from-environment env (path)
336      (render-template
337        env
338        "Subscribe"
339        (html-stream
340          desc
341          ((form
342             action (last (string-split path "/"))
343             method "post")
344           ((input type "hidden" name "action" value "extension"))
345           ((input type "hidden" name "extension" value "mail"))
346           ((input type "hidden" name "request" value "subscribe"))
347           (svnwiki-form-identity env)
348           (svnwiki-form-email env "Enter your email address (will be subscribed):" #f)
349           (h2 "Subscriptions")
350           (p "Subscribe to:"
351              (br)
352              ((select name "target")
353               (mail-request-subscribe-form-target env)))
354           (p "If you want to also subscribe other people, enter their email addresses (separated by commas)."
355              (br)
356              ((textarea
357                 cols 80
358                 rows 6
359                 name "email-invites"
360                 style "width: 100%")
361               (user-input 'email-invites stream-null)))))
362        'view))))
363
364;;; Handle confirmations
365
366(define (mail-request-invalid env)
367  (let-from-environment env (path user-input)
368    (let ((mail (svnwiki-email-parse (user-input 'mail stream-null))))
369      (render-template
370        env
371        "Invalid address"
372        (html-stream
373          (p "Address " (i mail) " is invalid."))
374        'view))))
375
376(define (mail-request-confirm-form env)
377  (let-from-environment env (path user-input)
378    (let ((mail (svnwiki-email-parse (user-input 'mail stream-null))))
379      (if (svnwiki-email-validate? mail)
380        (render-template
381          env
382          "Confirm subscription"
383          (html-stream
384            (p "To confirm that you want to receive messages from pages in this site that you or other users subscribe you to, enter the email administration password, included in the email you received:")
385            ((form
386               action (last (string-split path "/"))
387               method "post")
388             ((input type "hidden" name "action" "extension"))
389             ((input type "hidden" name "extension" "mail"))
390             ((input type "hidden" name "request" "confirm"))
391             (p "Password: " ((input type "text" name "password")))
392             ((input type "submit" value "Confirm pending subscriptions"))
393             (p "Note that this will allow other users of this site to subscribe your address to any pages in this site that they think you may be interested in.")))
394          'view)
395        (mail-request-invalid env)))))
396
397(define (mail-validate-password address password)
398  (let ((current-password (get-password-from-address address)))
399    (stream=
400      char=?
401      (string->stream current-password)
402      password)))
403
404(define (mail-request-confirm env)
405  (let-from-environment env (path user-input)
406    (let ((address (svnwiki-email-parse (user-input 'mail stream-null)))
407          (password (user-input 'password stream-null)))
408      (cond
409        ((not (svnwiki-email-validate? address))
410         (mail-request-invalid env))
411        ((not (mail-validate-password address password))
412         (unless (get-password-for-address address)
413           (mail-db-run "INSERT INTO addresses VALUES ( ~A, false, ~A, ~A );" address (generate-random-password) (current-seconds)))
414         (when (stream-null? (mail-db-run "SELECT page FROM subscriptions WHERE address = ~A AND page = ~A;" address path))
415           (mail-db-run "INSERT INTO subscriptions VALUES ( ~A, ~A, ~A, ~A );" address path (current-seconds) http-address))
416         (send-confirmation-mail env address)
417         (render-template
418           env
419           "Confirmation failed"
420           (html-stream
421             (p "Your subscription request has failed. This may mean any of the following:")
422             (ul
423               (li "A long time has passed after the request was initiated.")
424               (li "The password you entered is invalid."))
425             (p "A new message has been sent to your email address with instructions on how to subscribe to this page, which should be completed within 14 days."))
426           'view))
427        (else
428         (let ((pages (stream-map (cut vector-ref <> 0) (mail-db-run "SELECT page FROM subscriptions WHERE address = ~A;" address))))
429           (unless (vector-ref (stream-car (mail-db-run "SELECT confirmed FROM addresses WHERE address = ~A;" address)) 0)
430             (mail-db-run "UPDATE addresses SET confirmed = true WHERE address = ~A;" address)
431             (stream-for-each
432               (lambda (p)
433                 (send-subscribed-mail (environment env ((path p))) address #t))
434               pages))
435           (render-template
436             env
437             "Subscription successful"
438             (html-stream
439               (p "Your email address " (i address) " has been subscribed to the following pages:")
440               (ul
441                 (stream-concatenate
442                   (stream-map (lambda (p) (html-stream (li p))) pages)))
443               (p "We have sent you a confirmation email message for each.")
444               (p "Furthermore, any users will now be able to subscribe your address to any pages in this site that they think you could be interested in."))
445             'view)))))))
446
447;;; Unsubscribe
448
449(define (forgot-link-url env)
450  (let-from-environment env (path-in path)
451    (format #f "~A~A?action=extension&extension=mail&request=forgotpassword"
452            (get-props-parents-first "svnwiki:application-url" path-in path)
453            path)))
454
455(define (mail-request-unsubscribe-form-html-form env)
456  (let-from-environment env (path user-input)
457    (html-stream
458      ((form
459         action (last (string-split path "/"))
460         method "post")
461       ((input type "hidden" name "action" "extension"))
462       ((input type "hidden" name "extension" "mail"))
463       ((input type "hidden" name "request" "unsubscribe"))
464       (p "Password: " ((input type "text" name "password")))
465       ((input type "submit" value "Confirm"))))))
466
467(define (mail-request-unsubscribe-form env)
468  (let-from-environment env (path user-input)
469    (let ((address (svnwiki-email-parse (user-input 'mail stream-null))))
470      (if (svnwiki-email-validate? address)
471        (render-template
472          env
473          "Unsubscribe"
474          (html-stream
475            (p "Please enter the email administration password for "
476               (i address)
477               " to confirm that you want to unsubscribe it from "
478               ; TODO: Show the title instead of (or in addition to) the path?
479               (i path)
480               ":")
481            (mail-request-unsubscribe-form-html-form env)
482            (p "The administration password was sent in the message that confirmed your subscription to this page.  If you forgot it, "
483               ((a href (forgot-link-url env)) "follow this link and we will send it to you by mail")
484               ".")
485            (p "Note that this will allow other users of this site to subscribe your address to any pages in this site that they think you may be interested in."))
486          'view)
487        (mail-request-invalid env)))))
488
489(define (send-unsubscribed-mail env address)
490  (let-from-environment env (path user-input static-url)
491    (send-no-reply-mail env address
492      (lambda (from)
493        (format #t "From: ~A~%" from)
494        (format #t "To: ~A~%" address)
495        (format #t "Subject: ~A: Unsubscribed~%~%" path)
496        (format #t "You have been unsubscribed from the following page:~%~%")
497        (format #t "  ~A~A~%~%" static-url path)
498        (format #t "If you want to subscribe in the future, you can do so by visiting~%")
499        (format #t "the following page:~%~%")
500        (format #t "  ~A~A?action=extension&extension=mail&request=subscribeform&target=~A&mail=~A~%"
501                (get-props-parents-first "svnwiki:application-url" path-in path)
502                path
503                path
504                address)))))
505
506(define (mail-request-unsubscribe env)
507  (let-from-environment env (path user-input)
508    (let ((address (svnwiki-email-parse (user-input 'mail stream-null)))
509          (password (user-input 'password stream-null)))
510      (cond
511        ((not (svnwiki-email-validate? address))
512         (mail-request-invalid env))
513        ((not (mail-validate-password address password))
514         (render-template
515           env
516           "Unsubscription failed"
517           (html-stream
518             (p "The email administration password entered is invalid.  It was included in the message that confirmed your subscription to this page.  If you forgot it, "
519                ((a href (forgot-link-url env)) "follow this link and we will send it to you by mail again")
520                ".  Feel free to try again:")
521            (mail-request-unsubscribe-form-html-form env))
522           'view))
523        (else
524         (mail-db-run "DELETE FROM subscriptions WHERE page = ~A AND address = ~A;" path address)
525         (send-unsubscribed-mail env address)
526         (render-template
527           env
528           "Unsubscribed"
529           (html-stream
530             (p "You have been unsubscribed from page "
531                (i path) ".  ["
532                ((a href (format #f "~A~A?action=extension&extension=mail&request=subscribe&mail=~A"
533                                 (get-props-parents-first "svnwiki:application-url" path-in path)
534                                 path))
535                 "Undo") "]")
536             (let ((pages (mail-db-run "SELECT page FROM subscriptions WHERE address = ~A;" address)))
537               (if (stream-null? pages)
538                 (html-stream
539                   (p "Others users of this site can still subscribe you to other pages without requiring your confirmation.")
540                   (p "If you want to prevent other users from subscribing you in the future to any pages on this site that they think you may be interested on, use the following button. Be careful: there is no simple way to undo this operation! You'll have to confirm your subscription again and resubscribe to each page."))
541                 (html-stream
542                   (p "You are still subscribed to the following pages in this site:")
543                   (stream->ul-list pages)
544                   (p "Furthermore, others users of this site can still subscribe you to other pages without requiring your confirmation.")
545                   (p "If you want to unsubscribe from all pages in this wiki and prevent other users from subscribing you in the future to any pages on this site that they think you may be interested on, use the following button. Be careful: there is no simple way to undo this operation! You'll have to confirm your subscription again and resubscribe to each page."))))
546             (mail-unsubscribe-all-form env address password))
547           'view))))))
548
549(define (mail-unsubscribe-all-form env address password)
550  (let-from-environment env (path)
551    (html-stream
552      ((form
553         action (last (string-split path "/"))
554         method "post")
555       ((input type "hidden" name "action" "extension"))
556       ((input type "hidden" name "extension" "mail"))
557       ((input type "hidden" name "mail" address))
558       ((input type "hidden" name "request" "unsubscribeall"))
559       ((input type "hidden" name "password" password))
560       ((input type "submit" value "Unsubscribe from this site"))))))
561
562(define (mail-request-unsubscribe-all env)
563  (let-from-environment env (path user-input)
564    (let ((address (svnwiki-email-parse (user-input 'mail stream-null)))
565          (password (user-input 'password stream-null)))
566      (cond
567        ((not (svnwiki-email-validate? address))
568         (mail-request-invalid env))
569        ((not (mail-validate-password address password))
570         (render-template
571           env
572           "Unsubscription failed"
573           (html-stream
574             (p "The email administration password entered is invalid.  It was included in the message that confirmed your subscription to this page.  If you forgot it, "
575                ((a href (forgot-link-url env)) "follow this link and we will send it to you by mail again") "."))
576           'view))
577        (else
578         (mail-db-run "DELETE FROM subscriptions WHERE address = ~A;" address)
579         (mail-db-run "DELETE FROM addresses WHERE address = ~A;" address)
580         (render-template
581           env
582           "Unsubscribed from all pages"
583           (html-stream
584             (p "You have been unsubscribed from all pages in this wiki and your address has be removed from this site.  Its users won't be able to add you to any pages in the future without your confirmation."))
585           'view))))))
586
587;;; Forgot password
588
589(define (mail-forgot-password env)
590  (let-from-environment env (user-input)
591    (let ((address (svnwiki-email-parse (user-input 'mail stream-null))))
592      (if (svnwiki-email-validate? address)
593        (let ((password (get-password-for-address address)))
594          (unless password
595            (set! password (generate-random-password))
596            (mail-db-run "INSERT INTO addresses VALUES ( ~A, false, ~A, ~A );" address password (current-seconds)))
597          (send-mail-forgot-password env address password)
598          (render-template
599            env
600            "Password sent"
601            (html-stream
602              (p "An email has been sent to " (i address) " with its administration password."))
603            'view))
604        (mail-request-invalid env)))))
605
606(define (send-mail-forgot-password env address password)
607  (let-from-environment env (static-url path-in path)
608    (send-no-reply-mail env address
609      (lambda (from)
610        (format #t "From: ~A~%" from)
611        (format #t "To: ~A~%" address)
612        (format #t "Subject: Email administration password" path)
613        (format #t "We received a request from ~A asking for your~%" (getenv "REMOTE_ADDR"))
614        (format #t "administration password to be resent to you.  Here it is:~%~%")
615        (format #t "  Password: ~A~%" password)))))
616
617;;; Notifications
618
619; Return the id for a given path
620
621(define (mail-page->id path . rest)
622  (let-optionals rest ((get-data (lambda (id) (mail-db-run "SELECT page FROM pages WHERE id = ~A;" id))))
623    (let ((base (stream-filter (disjoin char-alphabetic? char-numeric? (cut string-index "-_/" <>))
624                               (string->stream path))))
625      (let loop ((current #f))
626        (let* ((id (if current (format #f "~A-~A" (stream->string base) current) (stream->string base)))
627               (page (get-data id)))
628          (if (or (stream-null? page)
629                  (string=? (vector-ref (stream-car page) 0) path))
630            id
631            (loop (+ (or current -1) 1))))))))
632
633; Some test cases:
634
635(when (getenv "SVNWIKI_UNITTESTS")
636  (assert (string= (mail-page->id "foo" (constantly stream-null)) "foo"))
637  (assert (string= (mail-page->id "foo/bar hey/there & you" (constantly stream-null)) "foo/barhey/thereyou"))
638  (assert (string= (mail-page->id "foo"
639                                  (lambda (x)
640                                    (assert (string=? x "foo"))
641                                    (stream (vector "foo"))))
642                   "foo"))
643  (assert (string= (mail-page->id "foo"
644                                  (lambda (x)
645                                    (cond
646                                      ((string=? x "foo") (stream (vector "f o o")))
647                                      ((string=? x "foo-0") (stream (vector "f oo")))
648                                      (else stream-null))))
649                   "foo-1")))
650
651(define (list-subscribers path)
652  (stream-map (cut vector-ref <> 0)
653              (mail-db-run "SELECT addresses.address FROM subscriptions, addresses WHERE page = ~A AND addresses.address = subscriptions.address AND confirmed;")))
654
655(define (list-subscribers-with-parents path)
656  (let loop ((components (string-split path "/")) (base ""))
657    (stream-delay
658      (if (null? components)
659        stream-null
660        (let ((new-base (svnwiki-path-join base (car components))))
661          (stream-append (map (lambda (address) (list address new-base))
662                              (list-subscribers new-base))
663                         (loop (cdr components) new-base)))))))
664
665(define (notify-subscribers env)
666  (let-from-environment env (path user-input)
667    (let ((page-data (mail-db-run "SELECT page, id, last_revision FROM pages WHERE page = ~A;" path)))
668      (when (stream-null? page-data)
669        (mail-db-run "INSERT INTO pages VALUES ( ~A, ~A, 0 );" path (mail-page->id path))
670        (set! page-data (mail-db-run "SELECT page, id, last_revision FROM pages WHERE page = ~A;" path)))
671      ((if (svnwiki-is-dicuss? path) notify-subscribers-discuss notify-subscribers-normal)
672       env
673       (vector-ref (stream-car page-data) 2)))))
674
675(define (stream-string-max str len)
676  (assert (stream? str))
677  (if (stream-length>= str (+ len 1))
678    (stream-append
679      (stream-take str (- len 3))
680      (string->stream "..."))
681    str))
682
683(when (getenv "SVNWIKI_UNITTESTS")
684  (let ((test (lambda (input output)
685                (assert (not (stream-length>= (stream-string-max (string->stream input) 10) 11)))
686                (assert (stream= char=? (stream-string-max (string->stream input) 10) (string->stream output))))))
687    (test "" "")
688    (test "foobar" "foobar")
689    (test "012345678" "012345678")
690    (test "0123456789" "0123456789")
691    (test "01234567890" "0123456...")))
692
693; TODO: "A diff for the commit will be included in an attachment."
694
695(define notify-subscribers-normal
696  (notify-subscribers-generic
697    (lambda (last-revision user password path)
698      (get-history user password path 0 last-revision svn-opt-revision-head))
699    identity
700    (cut make-mail-gateway-address <> "xsvnwiki-mail/notifications/")
701    (cut make-mail-gateway-address <> "xsvnwiki-mail/notifications/")
702    (lambda (rev address)
703      (let ((description
704              (string->stream
705                (string-translate
706                  (iconv
707                    (iconv-open "us-ascii" "us-ascii")
708                    (stream->string (fourth rev)))
709                  "\n"
710                  " "))))
711        (format #t "Subject: r~A: ~A~%"
712              (second rev)
713              ; TODO: quoted-printable, instead of iconv above
714              (stream->string (stream-string-max description 60))))
715      (format #t "To: ~A~%" address)
716      (format #t "List-ID: ~A.~A~%" (make-mail-list-id env-new (format "~A.notifications" id)))
717      (format #t "List-Post: NO~%"))
718    (lambda (env address rev)
719      (let-from-environment env (static-url path)
720        (write-stream
721          (base64-encode
722            (with-output-to-stream
723              (lambda ()
724                (format #t "The following page has been modified:~%~%")
725                (format #t "  ~A~A~%~%" static-url path)
726                (format #t "Description of changes:~%~%")
727                (stream-for-each
728                  (lambda (line)
729                    (format #t "> ")
730                    (write-stream line)
731                    (newline))
732                  (stream-lines (string->stream (fourth rev))))
733                (mail-footnote env address)))))))))
734
735(define notify-subscribers-discuss
736  (notify-subscribers-generic
737    (lambda (last-revision user password path)
738      (get-history user password path 1 0 svn-opt-revision-head))
739    (lambda (history)
740      (stream-take history 1))
741    (lambda (env)
742      (let-from-environment env (path-in path)
743        (get-props-parents-first
744          "svnwiki:mail:headers:from" 
745          path-in
746          path
747          (get-nobody-address env))))
748    make-mail-gateway-address
749    (lambda args
750      (write-header-if-available env "Received")
751      (write-header-if-available env "Subject")
752      (format #t "To: ~A~%" gateway-address)
753      (format #t "List-ID: ~A.~A~%" (make-mail-list-id env-new id))
754      (format #t "List-Post: ~A~%" gateway-address))
755    (lambda (env address rev)
756      (let-from-environment env (path-in path)
757        (with-input-from-file (svnwiki-make-pathname path-in path)
758          (lambda ()
759            (write-stream
760              (base64-encode
761                (stream-append (port->stream) (with-output-to-stream (cut mail-footnote env address)))))))))))
762
763(define (notify-subscribers-generic get-history-wrapper filter-revisions get-from get-gateway-address write-headers write-body)
764  (lambda (env last-revision)
765    (let-from-environment env (user password path-in path)
766      (let ((history (get-history-wrapper env user password (svnwiki-make-pathname path-in path))))
767        (unless (and history (not (stream-null? history)))
768          (error "Unable to load history for path" (svnwiki-make-pathname path-in path)))
769        (stream-for-each
770          (lambda (rev)
771            (stream-for-each
772              (lambda (data)
773                (let* ((address (first data))
774                       (path-subscribed (second data))
775                       (env-new (enviroment env (path path-subscribed)))
776                       (gateway-address (get-gateway-address env)))
777                  (send-mail
778                    env-new
779                    (get-from env)
780                    address
781                    (lambda (from)
782                      (format #t "From: ~A~%" from)
783                      (write-headers rev address)
784                      (format #t "MIME-Version: 1.0 (svnwiki mail extension $Rev$)~%")
785                      (format #t "Content-type: text/plain; charset=~A~%" (svnwiki-encoding-for-file env))
786                      ; TODO: quoted-printable would be nicer
787                      (format #t "Content-Transfer-Encoding: base64~%~%")
788                      (write-body env address rev)))))
789              (list-subscribers-with-parents path)))
790          (stream-filter (lambda (rev) (> (second rev) last-revision))
791                         (filter-revisions last-revision history)))))))
792 
793(define (mail-footnote env address)
794  (format #t "--~%")
795  (format #t "To cancel your subscription and stop receiving these messages go to:~%")
796  (write-unsubscribe-url env address))))
797
798(define (write-header-if-available env header)
799  (let-from-environment env (path-in path)
800    (and-let* ((v (get-props-parents-first (format #f "svnwiki:mail:headers:~A" (string-downcase header)) path-in path #f)))
801      (format #t "~A: ~A~%" header v))))
802
803(define (write-unsubscribe-url env address)
804  (let-from-environment env (path-in path)
805    (format #t "~A~A?action=extension&extension=mail&request=unsubscribe&mail=~A~%~%"
806            (get-props-parents-first "svnwiki:application-url" path-in path #f)
807            path
808            address)))
809
810;;; Export everything
811
812(define *mail-request-handlers*
813  `((subscribeform ,mail-request-subscribe-form)
814    (subscribe ,mail-request-subscribe)
815    (unsubscribeform ,mail-request-unsubscribe-form)
816    (unsubscribe ,mail-request-unsubscribe)
817    (unsubscribeall ,mail-request-unsubscribe-all)
818    (forgotpassword ,mail-forgot-password)
819    (confirm ,mail-request-confirm)
820    (confirmform ,mail-request-confirm-form)))
821
822(set! *extensions*
823  `((mail (files-actions-links ,mail-subscribe-link)
824          (commit-handler ,subscribe-address-commit)
825          (update ,notify-subscribers)
826          (dynamic ,mail-request-handle))))
Note: See TracBrowser for help on using the repository browser.