source: project/release/3/svnwiki-mail/trunk/svnwiki-mail.scm @ 12799

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

Fix typos.

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