Improve mailman analysis.

src/bbstool.scm

@@ -140,6 +140,8 @@ CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  (-unpaired () "Show latest unpaired bank transactions"
 	    (-needs-bank- #t)
 	    (-action- 'unpaired))
+ (-mlcheck () "Check internal ML"
+	   (-action- 'mlcheck))
  (-mlsync () "Synchronize internal ML"
 	  (-action- 'mlsync))
  )
@@ -282,6 +284,19 @@ CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
    (if (-normal-month-)
        (mailman-sync-members internal-ml (members-base-active-emails MB))
        (print "Mailman synchronization disabled with manually specified current month.")))
+  ((mlcheck)
+   (define-values (missing surplus)
+     (mailman-compare-members internal-ml
+			      (membars-base-active-emails MB)))
+   (if (and (null? missing)
+	    (null? surplus))
+       (print "Internal mailing list membership in sync.")
+       (let ()
+	 (print "Internal mailing list:")
+	 (when (not (null? missing))
+	   (print "  Missing: " missing))
+	 (when (not (null? surplus))
+	   (print "  Outsiders: " surplus)))))
   (else
    (print "Nothing to do."))
   

src/mailman.scm

@@ -29,13 +29,27 @@
  mailman
  (
   *mailman-bin*
+
   list-mailman-lists
   list-mailman-list-members
   load-mailman-list
   load-mailman-lists
+  
   find-mailman-list
+  
   mailman-list-name
   mailman-list-members
+  
+  email-in-mailman-list?
+  
+  add-email-to-mailman-list
+  remove-email-from-mailman-list
+  
+  mailman-ensure-member
+  mailman-ensure-not-member
+  
+  mailman-compare-members
+  
   mailman-sync-members
   )
 
@@ -153,20 +167,24 @@
    (when (email-in-mailman-list? ml email)
      (remove-email-from-mailman-list (mailman-list-name ml) email)))
 
+ ;; Returns two values - missing members and surplus list members
+ (define (mailman-compare-members ml emails)
+   (let* ((mlemails (list->lset (mailman-list-members ml)))
+	  (emails (list->lset emails))
+	  (surplus (lset-subtract mlemails emails))
+	  (missing (lset-subtract emails mlemails)))
+     (values missing surplus)))
+
  ;; Ensures given ML subscribers are exactly what is in emails list
  (define (mailman-sync-members ml emails)
-   ;; Ensure all emails in ml
-   (let loop ((emails emails))
-     (when (not (null? emails))
-       (let ((email (car emails)))
-	 (mailman-ensure-member ml email)
-	 (loop (cdr emails)))))
-   ;; Go through all emails in ml and remove all not in emails list
-   (let loop ((ml-emails (mailman-list-members ml)))
-     (when (not (null? ml-emails))
-       (let ((email (car ml-emails)))
-	 (when (not (member email emails))
-	   (mailman-ensure-not-member ml email))
-	 (loop (cdr ml-emails))))))
+   (define-values (missing surplus)
+     (mailman-compare-members ml emails))
+   (define listname (mailman-list-name ml))
+   (let loop ((emails missing))
+     (add-emails-to-mailman-list listname (car emails))
+     (loop (cdr emails)))
+   (let loop ((emails surplus))
+     (remove-email-from-mailman-list listname (car emails))
+     (loop (cdr loop))))
 
  )