Changeset 12576 in project


Ignore:
Timestamp:
11/22/08 22:34:46 (12 years ago)
Author:
azul
Message:

Lots of fixes, too many to list.

Location:
release/3/svnwiki-mail/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/3/svnwiki-mail/trunk/svnwiki-mail.meta

    r12533 r12576  
    66 (synopsis "Functionality for sending email notifications about changes to wiki pages.")
    77 (category web)
    8  (needs svnwiki-extensions  svnwiki-extensions sqlite3 stream-base64 iconv srfi-40 stream-ext svn-post-commit-hooks format-modular html-stream srfi-1 svn-client)
     8 (needs svnwiki-extensions embedded-unittests sqlite3 stream-base64 iconv srfi-40 stream-ext svn-post-commit-hooks format-modular html-stream srfi-1 svn-client)
    99 (license "GPL-3"))
  • release/3/svnwiki-mail/trunk/svnwiki-mail.scm

    r12569 r12576  
    44
    55(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)
     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-unittest)
    77
    88(define (mail-subscribe-link env)
     
    5454  (mail-db-run env "CREATE TABLE addresses ( address varchar, confirmed boolean, password varchar, timestamp integer );")
    5555  (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 );"))
     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 );"))
    5763
    5864(define (get-password-for-address env address)
     
    9197              "Address " address " has already reached the maximum number of subscriptions permited per day.  It was not subscribed.")))))))
    9298
     99(define (svnwiki-mail-path-show path)
     100  (let ((canonical (svnwiki-mail-path-canonical path)))
     101    (if (string=? canonical "")
     102      "/"
     103      canonical)))
     104
     105(unittest (svnwiki-mail-path-show "") "/")
     106(unittest (svnwiki-mail-path-show "/foo/bar/hey/xsvnwiki-discuss/bleh") "foo/bar/hey/bleh")
     107
    93108(define (svnwiki-mail-path-canonical path)
    94109  (if (stream? path)
     
    98113        (svnwiki-discuss->normal path)
    99114        path))))
     115
     116(unittest (svnwiki-mail-path-canonical "") "")
     117(unittest (svnwiki-mail-path-canonical "/foo/bar/hey/xsvnwiki-discuss/bleh") "foo/bar/hey/bleh")
     118(unittest (svnwiki-mail-path-canonical "/foo/bar/hey/bleh") "foo/bar/hey/bleh")
     119(unittest (svnwiki-mail-path-canonical "/foo/bar/../../../../hey/xsvnwiki-discuss/bleh") "hey/bleh")
     120(unittest (svnwiki-mail-path-canonical "/foo/bar/../hey/././quux/xsvnwiki-discuss/bleh") "foo/hey/quux/bleh")
    100121
    101122(define (subscribe-address env address)
     
    145166  (when (> (+ *last-mail-time* *seconds-between-mails*) (current-seconds))
    146167    (sleep 1))
     168  (format (current-error-port) "Sending mail to: ~A~%" to)
    147169  (set! *last-mail-time* (current-seconds))
    148170  (let-from-environment env (path-in path)
     
    203225        (svnwiki-format #t "From: ~A~%" from)
    204226        (svnwiki-format #t "To: ~A~%" address)
    205         (svnwiki-format #t "Subject: ~A: Subscribed~%~%" (svnwiki-mail-path-canonical path))
     227        (svnwiki-format #t "Subject: ~A: Subscribed~%~%" (svnwiki-mail-path-show path))
    206228        (if self-subscribe
    207229          (svnwiki-format #t "You have been subscribed to the following page:~%~%")
     
    209231        (svnwiki-format #t "  ~A~A~%~%" static-url path)
    210232        (let ((list-address (make-mail-gateway-address env)))
    211           (when list-address
     233          (when (and list-address
     234                     (not (directory? (svnwiki-make-pathname path-in path))))
    212235            (svnwiki-format #t "To send messages to this page, write to:~%~%")
    213236            (svnwiki-format #t "  ~A~%~%" list-address)))
     
    219242        (svnwiki-format #t "may speed up the unsubscription process should you decide to do it.~%")))))
    220243
    221 ; TESTED
    222 
    223244(define (send-confirmation-mail env address)
    224245  (let-from-environment env (static-url path path-in)
     
    227248        (svnwiki-format #t "From: ~A~%" from)
    228249        (svnwiki-format #t "To: ~A~%" address)
    229         (svnwiki-format #t "Subject: ~A: Confirmation required~%~%" (svnwiki-mail-path-canonical path))
     250        (svnwiki-format #t "Subject: ~A: Confirmation required~%~%" (svnwiki-mail-path-show path))
    230251        (svnwiki-format #t "We have received a subscription request from ~A~%" (get-subscribe-submitter env))
    231252        (svnwiki-format #t "for this email address for the following page:~%~%")
     
    321342                         (user-input 'target
    322343                                     (string->stream path)))))))
    323       (let loop ((path "/") (components (string-split path "/")))
     344      (let loop ((path "/") (components (string-split (svnwiki-mail-path-canonical path) "/")))
    324345        (stream-delay
    325346          (stream-append
     
    341362          desc
    342363          ((form
    343              action (last (string-split path "/"))
     364             action (svnwiki-url-self path)
    344365             method "post")
    345366           ((input type "hidden" name "action" value "extension"))
     
    386407            (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:")
    387408            ((form
    388                action (last (string-split path "/"))
     409               action (svnwiki-url-self path)
    389410               method "post")
    390411             ((input type "hidden" name "action" value "extension"))
     
    441462             (html-stream
    442463               (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)))
     464               (stream->html-ul (stream-map svnwiki-mail-path-show pages))
    446465               (p "We have sent you a confirmation email message for each.")
    447466               (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."))
     
    461480    (html-stream
    462481      ((form
    463          action (last (string-split path "/"))
     482         action (svnwiki-url-self path)
    464483         method "post")
    465484       ((input type "hidden" name "address" value (user-input 'address stream-null)))
     
    497516        (svnwiki-format #t "From: ~A~%" from)
    498517        (svnwiki-format #t "To: ~A~%" address)
    499         (svnwiki-format #t "Subject: ~A: Unsubscribed~%~%" (svnwiki-mail-path-canonical path))
     518        (svnwiki-format #t "Subject: ~A: Unsubscribed~%~%" (svnwiki-mail-path-show path))
    500519        (svnwiki-format #t "You have been unsubscribed from the following page:~%~%")
    501520        (svnwiki-format #t "  ~A~A~%~%" static-url path)
     
    546565                 (html-stream
    547566                   (p "You are still subscribed to the following pages in this site:")
    548                    (stream->html-ul (stream-map (cut vector-ref <> 0) pages))
     567                   (stream->html-ul (stream-map (compose svnwiki-mail-path-show (cut vector-ref <> 0)) pages))
    549568                   (p "Furthermore, others users of this site can still subscribe you to other pages without requiring your confirmation.")
    550569                   (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."))))
     
    556575    (html-stream
    557576      ((form
    558          action (last (string-split path "/"))
     577         action (svnwiki-url-self path)
    559578         method "post")
    560579       ((input type "hidden" name "address" value address))
     
    615634        (format #t "From: ~A~%" from)
    616635        (format #t "To: ~A~%" address)
    617         (format #t "Subject: Email administration password~%~%" (svnwiki-mail-path-canonical path))
     636        (format #t "Subject: Email administration password~%~%")
    618637        (format #t "We received a request from ~A asking for your~%" (getenv "REMOTE_ADDR"))
    619638        (format #t "administration password to be resent.  Here it is:~%~%")
     
    625644
    626645(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))))
     646  (let-optionals rest ((get-data (lambda (id) (mail-db-run env "SELECT page FROM pages_id WHERE id = ?;" id))))
    628647    (let* ((path-canonical (string->stream (svnwiki-mail-path-canonical path)))
    629648           (base (stream-filter (disjoin char-alphabetic? char-numeric? (cut string-index "-_/" <>))
     
    656675
    657676(define (list-subscribers env path)
    658   (format (current-error-port) "subscribers: ~A~%" path)
    659   (format (current-error-port) "canon: ~A~%" (svnwiki-mail-path-canonical path))
    660677  (mail-db-run
    661678    env
     
    664681
    665682(define (list-subscribers-with-parents env path)
    666   (format (current-error-port) "Meh: ~S~%" path)
    667683  (let loop ((components (string-split path "/")) (base ""))
    668     (format (current-error-port) "Bah: ~S: ~S~%" components base)
    669684    (stream-delay
    670       (if (null? components)
    671         stream-null
    672         (let ((new-base (svnwiki-make-pathname base (car components))))
    673           (stream-append (stream-map (lambda (data)
    674                                        (list (vector-ref data 0)
    675                                              (vector-ref data 1)
    676                                              new-base))
    677                                      (list-subscribers env new-base))
    678                          (loop (cdr components) new-base)))))))
     685      (stream-append
     686        (stream-map (lambda (data)
     687                      (list (vector-ref data 0)
     688                            (vector-ref data 1)
     689                            base))
     690                    (list-subscribers env base))
     691        (if (null? components)
     692          stream-null
     693          (loop (cdr components) (svnwiki-make-pathname base (car components))))))))
    679694
    680695(define (notify-subscribers env)
     
    683698    (unless (or (string=? path "")
    684699                (directory? (svnwiki-make-pathname path-in path)))
    685       (let ((page-data (mail-db-run env "SELECT page, id, last_revision FROM pages WHERE page = ?;" (svnwiki-mail-path-canonical path))))
    686         (when (stream-null? page-data)
    687           (mail-db-run env "INSERT INTO pages VALUES ( ?, ?, 0 );" (svnwiki-mail-path-canonical path) (mail-page->id env path))
    688           (set! page-data (mail-db-run env "SELECT page, id, last_revision FROM pages WHERE page = ?;" (svnwiki-mail-path-canonical path))))
     700      (let ((id (mail-db-run env "SELECT id FROM pages_id WHERE page = ?;" (svnwiki-mail-path-canonical path)))
     701            (last-revision (mail-db-run env "SELECT last_revision FROM pages_revision WHERE page = ?;" path)))
     702        (when (stream-null? id)
     703          (set! id (stream (vector (mail-page->id env path))))
     704          (mail-db-run env "INSERT INTO pages_id VALUES ( ?, ? );" (svnwiki-mail-path-canonical path) (vector-ref (stream-car id) 0)))
     705        (when (stream-null? last-revision)
     706          (set! last-revision (stream (vector 0)))
     707          (mail-db-run env "INSERT INTO pages_revision VALUES ( ?, ? );" path 0))
     708        (format (current-error-port) "Sending email notifications: ~A [id:~A][last-revision:~A]~%" path (stream-car id) (stream-car last-revision))
    689709        (svnwiki-report-progress env (svnwiki-translate env "Sending email notifications: ~A~%") path)
    690710        ((if (svnwiki-is-discuss? path)
     
    692712           notify-subscribers-normal)
    693713         env
    694          (vector-ref (stream-car page-data) 1)
    695          (vector-ref (stream-car page-data) 2))
    696         (mail-db-run env "UPDATE pages SET last_revision = ? WHERE page = ?;"
     714         (vector-ref (stream-car id) 0)
     715         (vector-ref (stream-car last-revision) 0))
     716        (mail-db-run env "UPDATE pages_revision SET last_revision = ? WHERE page = ?;"
    697717                     new-rev
    698                      (svnwiki-mail-path-canonical path))
     718                     path)
    699719        (format (current-error-port) "Notifications sent~%")))))
    700720
     
    727747    (format (current-error-port) "Start notify-generic~%")
    728748    (let-from-environment env (user password path-in path)
    729       (format (current-error-port) "Notify-generic: got data~%")
     749      (format (current-error-port) "Notify-generic: got data: path:~A, last-revision:~A~%" path last-revision)
    730750      (let ((history (get-history user password (svnwiki-make-pathname path-in path) 0 (make-svn-opt-revision-number last-revision) svn-opt-revision-head)))
    731751        (format (current-error-port) "Notify-generic: got history: ~A~%" (stream->list history))
     
    752772                      ; TODO: quoted-printable would be nicer
    753773                      (format #t "Content-Transfer-Encoding: base64~%~%")
    754                       (write-body (environment env ((path (changed-file-path rev)))) address rev)))))
     774                      (write-body (environment env ((path (changed-file-path rev)))) path-subscribed address rev)))))
    755775              (list-subscribers-with-parents env (svnwiki-mail-path-canonical (changed-file-path rev)))))
    756776          (stream-fold-right-delay
     
    758778              (stream-append (parse-revision env rev) rest))
    759779            stream-null
    760             (stream-filter (lambda (rev) (> (second rev) last-revision))
     780            (stream-filter (lambda (rev)
     781                             (format (current-error-port) "chec: [rev:~A][last-revision:~A]~%" (second rev) last-revision)
     782                             (> (second rev) last-revision))
    761783                           history)))))
    762784    (format (current-error-port) "Notify-generic: returning~%")
     
    779801        ; paths in the subversion logs start with a slash.
    780802        (let ((entry (assoc (format #f "/~A" path) (first rev))))
    781           (unless entry
    782             (error "Failed to find" path (first rev)))
    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))))))
     803          (if entry
     804            (stream
     805              (make-changed-file
     806                (svn-change->symbol (cdr entry))
     807                (svnwiki-mail-path-canonical path)
     808                (svnwiki-svn-time->seconds (fourth rev))
     809                (second rev)
     810                (fifth rev)))
     811            stream-null))))
    790812    (cut make-mail-gateway-address <> "xsvnwiki-mail/notifications/")
    791813    (lambda (rev address id gateway-address env original-file)
     
    806828      (format #t "List-ID: ~A~%" (make-mail-list-id env (format "~A.notifications" id)))
    807829      (format #t "List-Post: NO~%"))
    808     (lambda (env address rev)
     830    (lambda (env path-subscribed address rev)
    809831      (let-from-environment env (static-url path)
    810832        (write-stream
     
    823845                (newline)
    824846                (format #t "~%Commited on: ~A~%~%" (seconds->string (changed-file-seconds rev)))
    825                 (mail-footnote env address)))))))))
     847                (mail-footnote (environment env ((path path-subscribed))) address)))))))))
    826848
    827849(define notify-subscribers-discuss
     
    829851    (lambda (env rev)
    830852      (format (current-error-port) "Get list (~S, ~S)~%" env rev)
    831       (let-from-environment env (path)
     853      (let-from-environment env (path base)
    832854        (stream-map
    833855          (lambda (data)
    834856            (make-changed-file
    835857              'add
    836               (car data)
     858              path
    837859              (svnwiki-svn-time->seconds (fourth rev))
    838860              (second rev)
    839861              (fifth rev)))
    840862          (stream-filter
    841             (let ((path-normal (svnwiki-discuss->normal path)))
     863            (let ((path-normal (svnwiki-mail-path-canonical (svnwiki-make-pathname base path))))
    842864              (lambda (data)
    843                 (format (current-error-port) "Checking for path ~S: ~S~%" path-normal data)
    844865                (and (svnwiki-is-discuss? (car data))
    845                      (string=? (svnwiki-discuss->normal (car data)) path-normal)
     866                     (string=? (svnwiki-mail-path-canonical (car data)) path-normal)
    846867                     (char=? #\A (svn-log-changed-path-action (cdr data))))))
    847868            (list->stream (first rev))))))
     
    866887        (svnwiki-format #t "List-ID: ~A~%" (make-mail-list-id env id))
    867888        (svnwiki-format #t "List-Post: ~A~%" gateway-address)))
    868     (lambda (env address rev)
     889    (lambda (env path-subscribed address rev)
    869890      (let-from-environment env (path-in path)
    870891        (with-input-from-file (svnwiki-make-pathname path-in path)
     
    874895                (stream-append (port->stream)
    875896                               (with-output-to-stream
    876                                  (cut mail-footnote env address)))))))))))
     897                                 (cut mail-footnote (environment env ((path path-subscribed))) address)))))))))))
    877898
    878899(define (mail-footnote env address)
Note: See TracChangeset for help on using the changeset viewer.