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