Release 1.16.2 with -mlsync fix.

CHANGELOG.md

@@ -1,14 +1,41 @@
 ChangeLog
 =========
 
-1.15
-----
+1.16.2 - released 2024-05-07
+----------------------------
+
+* fix rada-ml-pred? in -mlsync
+
+1.16.1 - released 2024-04-02
+----------------------------
+
+* add EUR account for paying membership fees to member's page
+
+1.16 - released 2024-02-09
+--------------------------
+
+* handle # character at weird positions in DokuWiki users.auth.php
+* unify -mlsync and -mlcheck handling of member predicates
+* handle unicode characters with 3-byte UTF-8 representation correctly
+* calculate expected income with respect to discounts granted
+* report soon-expiring members in the summary emails
+* report mailing lists check status in summary emails
+
+1.15.1 - released 2024-01-02
+----------------------------
+
+* fix calculating historical membership fee (was erroneously based on
+  current date)
+* fix showing basic information without MLs loaded
+
+1.15 - released 2024-12-24
+--------------------------
 
 * increase membership fees starting 2024-01 (specification.rkt)
 * add support for explicit fee amounts for specified period
 
-1.14
-----
+1.14 - released 2024-12-06
+--------------------------
 
 * add support for dynamic terminal size
 * use table cell formatting instead of paragraph formatting everywhere

src/Makefile

@@ -42,7 +42,7 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm			\
 	tests.import.scm notifications.import.scm logging.import.scm	\
 	progress.import.scm cal-period.import.scm			\
 	util-stdout.import.scm export-web-static.import.scm		\
-	dokuwiki.import.scm
+	dokuwiki.import.scm mailinglist.import.scm
 
 HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
 	 cal-period.o ansi.o util-bst-ldict.o command-line.o mbase.o	\
@@ -59,7 +59,8 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
 	 template-list-expander.o box-drawing.o export-web-static.o	\
 	 util-dir.o dokuwiki.o racket-kwargs.o duck.o util-bst.o	\
 	 util-bst-bdict.o util-bst-ldict.o util-bst-lset.o mailman2.o	\
-	 mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o
+	 mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o	\
+	 mailinglist.o
 
 GENDOC-SOURCES=gendoc.scm duck-extract.import.scm			\
 	util-time.import.scm util-csv.import.scm util-git.import.scm	\
@@ -291,7 +292,7 @@ util-io.o: util-io.import.scm
 util-io.import.scm: $(UTIL-IO-SOURCES)
 
 UTIL-PARSER-SOURCES=util-parser.scm testing.import.scm	\
-	duck.import.scm
+	duck.import.scm racket-kwargs.import.scm
 
 util-parser.o: util-parser.import.scm
 util-parser.import.scm: $(UTIL-PARSER-SOURCES)
@@ -332,7 +333,8 @@ NOTIFICATIONS-SOURCES=notifications.scm brmember.import.scm		\
 	brmember-format.import.scm configuration.import.scm		\
 	util-time.import.scm members-fees.import.scm mbase.import.scm	\
 	members-print.import.scm table.import.scm			\
-	bank-account.import.scm logging.import.scm
+	bank-account.import.scm logging.import.scm			\
+	mailinglist.import.scm
 
 notifications.o: notifications.import.scm
 notifications.import.scm: $(NOTIFICATIONS-SOURCES)
@@ -550,3 +552,10 @@ TIOCGWINSZ-SOURCES=tiocgwinsz.scm duck.import.scm
 
 tiocgwinsz.o: tiocgwinsz.import.scm
 tiocgwinsz.import.scm: $(TIOCGWINSZ-SOURCES)
+
+MAILINGLIST-SOURCES=mailinglist.scm racket-kwargs.import.scm		\
+	mailman.import.scm mbase.import.scm util-string.import.scm	\
+	brmember.import.scm
+
+mailinglist.o: mailinglist.import.scm
+mailinglist.import.scm: $(MAILINGLIST-SOURCES)

src/brmember.scm

@@ -499,8 +499,8 @@
 	       (ldict-equal?
 		(make-brmember '|1234| "members/1234" '(|member|))
 		(make-ldict
-		 `((file-name . |1234|)
-		   (TAG . ,TAG-BRMEMBER)
+		 `((TAG . ,TAG-BRMEMBER)
+		   (file-name . |1234|)
 		   (file-path . "members/1234")
 		   (symlinks |member|)
 		   (id . 1234)))))

src/dokuwiki.scm

@@ -54,7 +54,7 @@
 	      (users '()))
      (if (null? lines)
 	 users
-	 (let ((line (parser-preprocess-line (car lines))))
+	 (let ((line (parser-preprocess-line (car lines) #:strip-comments? #f)))
 	   (if (equal? line "")
 	       (loop (cdr lines)
 		     users)
@@ -74,8 +74,8 @@
    (handle-exceptions
     exn
     (let ()
-      (log-warning "DokuWiki: cannot open ~A" fname)
-      (stdout-printf "DokuWiki: cannot open ~A" fname)
+      (log-warning "DokuWiki (~A) exception ~A" fname (condition->list exn))
+      (stdout-printf "DokuWiki (~A) exception ~A" fname (condition->list exn))
       '())
     (with-input-from-file fname
       parse-dokuwiki-users-auth)))

src/export-web-static.scm

@@ -101,7 +101,7 @@
      (print "<dt>Member ID, Variable Symbol for Payments<br>(Členské číslo, variabilní symbol plateb)</dt><dd>"
 	    (brmember-id mr) "</dd>")
      (print "<dt>Balance in CZK<br>(Zůstatek v Kč)</dt><dd>" (caar (reverse bhs)) "</dd>")
-     (print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>2500079551/2010</dd>")
+     (print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>CZK: 2500079551/2010<br>EUR:  CZ93 2010 0000 0021 0007 9552</dd>")
      (print "</dl>")
      (print "</div>")
      (print "<div class=\"bi\">")

src/hackerbase.scm

@@ -50,7 +50,8 @@
 	export-web-static
 	dokuwiki
 	racket-kwargs
-	util-string)
+	util-string
+	mailinglist)
 
 ;; Command-line options and configurable parameters
 (define -needs-bank- (make-parameter #f))
@@ -286,32 +287,6 @@
 	      (print "  " (car keys) ": " (length (ldict-ref status (car keys)))))
 	    (loop (cdr keys)))))))
 
-(define* (check-mailing-list mls name #:pred? (pred? #f))
-  (define ml (find-mailman-list mls name))
-  (when ml
-    (let-values (((missing surplus)
-		  (mailman-compare-members ml
-					   (mbase-active-emails MB
-								#:suspended #t
-								#:pred? pred?
-								))))
-      (if (null? (cdr ml))
-	  (print "Skipping ML check - not loaded")
-	  (if (and (null? missing)
-		   (null? surplus))
-	      (print (format "~a mailing list membership in sync." (string-capitalize name)))
-	      (let ()
-		(print (format "~a mailing list:" (string-capitalize name)))
-		(when (not (null? missing))
-		  (print "  Missing: " missing))
-		(when (not (null? surplus))
-		  (print "  Outsiders: " surplus))))))))
-
-(define (rada-ml-pred? mr)
-  (or (brmember-council? mr)
-      (brmember-chair? mr)
-      (brmember-revision? mr)))
-
 ;; Perform requested action
 (case (-action-)
   ((print-info)
@@ -323,10 +298,7 @@
        (let ()
 	 (print-members-base-table MB)
 	 (newline)
-	 (check-mailing-list MLS "internal")
-	 (check-mailing-list MLS "rada"
-			     #:pred? rada-ml-pred?)
-	 (check-mailing-list MLS "rk" #:pred? brmember-revision?)
+	 (print-mailing-list-checks MB MLS)
 	 (print-git-status)))
    (newline))
   ((print-stats)
@@ -424,8 +396,8 @@
    (print-git-status))
   ((summary)
    (if (-send-emails-)
-       (make+send-summary-email MB)
-       (make+print-summary-email MB)))
+       (make+send-summary-email MB MLS)
+       (make+print-summary-email MB MLS)))
   ((list)
    (for-each (lambda (mr)
 	       (print (brmember-nick mr)))

src/mailinglist.scm

@@ -0,0 +1,78 @@
+;;
+;; mailinglist.scm
+;;
+;; Common high-level mailinglist management procedures.
+;;
+;; ISC License
+;;
+;; Copyright 2023 Brmlab, z.s.
+;; Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(declare (unit mailinglist))
+
+(module
+ mailinglist
+ (
+  check-mailing-list
+  print-mailing-list-checks
+
+  rada-ml-pred?
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken format)
+	 racket-kwargs
+	 mailman
+	 mbase
+	 util-string
+	 brmember)
+
+ (define* (check-mailing-list MB mls name #:pred? (pred? #f) #:suspended (suspended #f))
+   (define ml (find-mailman-list mls name))
+   (when ml
+     (let-values (((missing surplus)
+		   (mailman-compare-members ml
+					    (mbase-active-emails MB
+								 #:suspended suspended
+								 #:pred? pred?
+								 ))))
+       (if (null? (cdr ml))
+	   (print "Skipping ML check - not loaded")
+	   (if (and (null? missing)
+		    (null? surplus))
+	       (print (format "~a mailing list membership in sync." (string-capitalize name)))
+	       (let ()
+		 (print (format "~a mailing list:" (string-capitalize name)))
+		 (when (not (null? missing))
+		   (print "  Missing: " missing))
+		 (when (not (null? surplus))
+		   (print "  Outsiders: " surplus))))))))
+
+ (define (print-mailing-list-checks MB MLS)
+   (check-mailing-list MB MLS "internal" #:suspended #t)
+   (check-mailing-list MB MLS "rada"
+		       #:pred? rada-ml-pred?)
+   (check-mailing-list MB MLS "rk" #:pred? brmember-revision?))
+
+ (define (rada-ml-pred? mr)
+   (or (brmember-council? mr)
+       (brmember-chair? mr)
+       (brmember-revision? mr)))
+
+ )

src/members-fees.scm

@@ -30,6 +30,7 @@
  (
   lookup-member-fee
   member-calendar
+  make-member-calendar-entry
   member-calendar-first-month
   member-calendar-last-month
   member-calendar-query
@@ -40,12 +41,14 @@
   member-calendar->table
   members-summary
   member-calendar-entry->fee
+  get-expected-income-string
   )
 
  (import scheme
 	 (chicken base)
 	 (chicken format)
 	 (chicken sort)
+	 (chicken string)
 	 srfi-1
 	 configuration
 	 brmember
@@ -82,15 +85,17 @@
        (if (cal-month>? cm last-month)
 	   (reverse cal)
 	   (loop (cal-month-add cm)
-		 (cons (list cm
-			     (with-current-month
-			      cm
-			      (brmember-flags mr))
-			     (with-current-month
-			      cm
-			      (brmember-spec-fee mr)))
+		 (cons (with-current-month
+			cm
+			(make-member-calendar-entry mr))
 		       cal))))))
 
+ ;; Assumes current-month is specified correctly
+ (define (make-member-calendar-entry mr)
+   (list (*current-month*)
+	 (brmember-flags mr)
+	 (brmember-spec-fee mr)))
+
  ;; Returns the first month of the calendar
  (define (member-calendar-first-month mc)
    (caar mc))
@@ -203,4 +208,25 @@
 	    (cons 0 0)
 	    members)))
 
+ (define (get-expected-income-string mb)
+   (let* ((flst
+	   (map (compose member-calendar-entry->fee make-member-calendar-entry)
+		(find-members-by-predicate mb brmember-active?)))
+	  (amts (sort (delete-duplicates flst) <))
+	  (sums
+	   (map
+	    (lambda (amt)
+	      (cons amt
+		    (length (filter (lambda (v) (= v amt)) flst))))
+	    amts)))
+     (string-append
+      "Expected income: "
+      (string-intersperse (map
+			   (lambda (p)
+			     (format "~A*~A" (cdr p) (car p)))
+			   sums)
+			  " + ")
+      " = "
+      (number->string (foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums))))))
+ 
  )

src/members-print.scm

@@ -500,7 +500,17 @@
 			       (null? (cdr dsa)))
 			   #f
 			   (cadr dsa))))
-     (let* ((members ;; Pass 1
+     (let* ((raw-members
+	     (sort
+	      (if destroyed?
+		  (find-members-by-predicate MB (lambda x #t))
+		  (if only-active?
+		      (find-members-by-predicate MB (lambda (mr)
+						      (brmember-active? mr)))
+		      (find-members-by-predicate MB (lambda (mr)
+						      (not (brmember-destroyed? mr))))))
+	      brmember<?))
+	    (members ;; Pass 1
 	     (map
 	      (lambda (mr)
 		(let* ((balance (member-balance mr))
@@ -522,15 +532,7 @@
 			total
 			balance
 			)))
-	      (sort
-	       (if destroyed?
-		   (find-members-by-predicate MB (lambda x #t))
-		   (if only-active?
-		       (find-members-by-predicate MB (lambda (mr)
-						       (brmember-active? mr)))
-		       (find-members-by-predicate MB (lambda (mr)
-						       (not (brmember-destroyed? mr))))))
-	       brmember<?)))
+	      raw-members))
 	    (balances (map (lambda (m)
 			     (list-ref m 6))
 			   members)))
@@ -598,19 +600,7 @@
 		     (map (lambda (member)
 			    (min 0 (list-ref member 5)))
 			  members)))
-       (let* ((ns (foldl (lambda (acc member)
-			   (cons (+ (car acc) (if (eq? 'student (cadr member)) 1 0))
-				 (+ (cdr acc) (if (eq? 'active (cadr member)) 1 0))))
-			 (cons 0 0)
-			 members))
-	      (students (car ns))
-	      (full (cdr ns)))
-	 (print "Expected income: "
-		(+ (* (lookup-member-fee 'normal) full)
-		   (* (lookup-member-fee 'student) students))
-		" (" full " full members + " students " students)"))
-       )
-     ))
+       (print (get-expected-income-string MB)))))
 
  (define (unpaired-table mb . args)
    (apply

src/notifications.scm

@@ -40,6 +40,7 @@
 	 (chicken format)
 	 (chicken string)
 	 (chicken sort)
+	 (chicken port)
 	 brmember
 	 util-mail
 	 util-bst-ldict
@@ -54,7 +55,8 @@
 	 table
 	 bank-account
 	 logging
-	 srfi-1)
+	 srfi-1
+	 mailinglist)
 
  ;; Prints email to the console
  (define (print-notification-email em)
@@ -142,16 +144,14 @@
      (send-notification-email em)))
 
  ;; Summary email of membership fees payments
- (define (summary-email-body mb)
+ (define (summary-email-body mb mls)
    (let* ((mbs (members-summary mb))
 	  (students (car mbs))
 	  (full (cdr mbs))
 	  (income (+ (* (lookup-member-fee 'normal) full)
 		     (* (lookup-member-fee 'student) students)))
 	  (income-lst
-	   (list (format "Expected income: ~A CZK" income)
-		 (format "  ~A full members" full)
-		 (format "  ~A students" students)))
+	   (list (get-expected-income-string mb)))
 	  (unpaired (mbase-unpaired mb))
 	  (unpaired-lst
 	   (if (null? unpaired)
@@ -160,6 +160,30 @@
 		(list ""
 		      "Unpaired transactions:")
 		(unpaired-table mb #:border-style 'ascii))))
+	  (soonexps (sort
+		     (find-members-by-predicate
+		      mb
+		      (brmember-suspended-for 21 24))
+		     brmember<?))
+	  (soonexps-lst
+	   (if (null? soonexps)
+	       #f
+	       (list ""
+		     (format "Expiring members (~A): ~A"
+			     (length soonexps)
+			     (string-intersperse
+			      (map
+			       (lambda (mr)
+				 (brmember-format "~N (~S)" mr))
+			       soonexps)
+			      ",")))))
+	  (mlcheck-lst
+	   (cons ""
+		 (string-split
+		  (with-output-to-string
+		    (lambda ()
+		      (print-mailing-list-checks mb mls)))
+		  "\n")))
 	  (debtors (sort
 		    (members-to-notify mb 1)
 		    brmember<?))
@@ -256,6 +280,8 @@
 		       ", "))))))
      (append income-lst
 	     unpaired-lst
+	     soonexps-lst
+	     mlcheck-lst
 	     debtors-lst
 	     boring-lst
 	     dw-lst
@@ -266,21 +292,21 @@
 		   ))))
 
  ;; Creates the summary email structure
- (define (make-summary-email mb)
+ (define (make-summary-email mb mls)
    (make-ldict
     `((to . ,(*summary-mailto*))
       (subject . ,(format "Členské příspěvky ~A"
 			  (today/iso)))
-      (body . ,(summary-email-body mb)))))
+      (body . ,(summary-email-body mb mls)))))
 
  ;; Just print to standard output
- (define (make+print-summary-email mb)
-   (let ((em (make-summary-email mb)))
+ (define (make+print-summary-email mb mls)
+   (let ((em (make-summary-email mb mls)))
      (print-notification-email em)))
 
  ;; Actually send emails
- (define (make+send-summary-email mr)
-   (let ((em (make-summary-email mr)))
+ (define (make+send-summary-email mr mls)
+   (let ((em (make-summary-email mr mls)))
      (send-notification-email em)))
 
  )

src/texts.scm

@@ -39,7 +39,7 @@
 	 (chicken format))
 
  ;; Short banner
- (define banner-line "HackerBase 1.15.1 (c) 2023 Brmlab, z.s.")
+ (define banner-line "HackerBase 1.16.2 (c) 2023-2024 Brmlab, z.s.")
 
  ;; Banner source with numbers for ANSI CSI SGR
  (define banner-source "

src/util-bst.scm

@@ -286,10 +286,12 @@
        (call/cc
 	(lambda (cc)
 	  (set! break cc)
-	  (if resume
-	      (resume '())
-	      (bst-iter-kv bst yield))
-	  #f)))))
+	  (cond (resume
+		 (resume '())
+		 (break #f))
+		(else
+		 (bst-iter-kv bst yield)
+		 (break #f))))))))
 
  (define/doc (bst-keys bst)
    ("Returns all the keys contained in given dictionary.")

src/util-parser.scm

@@ -39,11 +39,12 @@ member file parsers. All functions are UTF-8 aware.")
  
  (import scheme
 	 (chicken base)
+	 racket-kwargs
 	 testing)
 
  ;; Pass 0: Removes any comments and removes any leading and trailing
  ;; whitespace.
- (define/doc (parser-preprocess-line line)
+ (define*/doc (parser-preprocess-line line #:strip-comments? (strip-comments? #t))
    ("* ```line``` - a string with contents of one source line
 
 If the input ```line``` contains the ```#``` character, the rest of
@@ -62,7 +63,9 @@ Returns a string representing the preprocessed line.")
 		      (ploop (add1 pidx)))))
 	  (hpos (let hloop ((hidx ppos))
 		  (if (or (= hidx llen)
-			  (eq? (string-ref line hidx) #\#))
+			  (and (or strip-comments?
+				   (= hidx 0))
+			       (eq? (string-ref line hidx) #\#)))
 		      hidx
 		      (hloop (add1 hidx)))))
 	  (spos (let sloop ((sidx (sub1 hpos)))

src/util-utf8.scm

@@ -120,13 +120,13 @@ of the string and a list of remaining bytes (as integers).")
  (define/doc (utf8-bytes->lists chars)
    ("The same as above but accepts a list of bytes (as integers).")
    (let loop ((bytes chars)
-	      (rpending '())
+	      (rpending chars)
 	      (pending 0)
 	      (expected #f)
 	      (res '()))
      (if (null? bytes)
 	 (values (reverse res)
-		 (reverse rpending))
+		 rpending)
 	 (let ((byte (car bytes)))
 	   (cond (expected
 		  ;; Decode UTF-8 sequence
@@ -135,14 +135,14 @@ of the string and a list of remaining bytes (as integers).")
 			 (let ((char (integer->char (bitwise-ior pending
 								 (bitwise-and byte #b111111)))))
 			   (loop (cdr bytes)
-				 '()
+				 (cdr bytes)
 				 0
 				 #f
 				 (cons char res))))
 			(else
 			 ;; Intermediate bytes
 			 (loop (cdr bytes)
-			       (cons byte rpending)
+			       rpending
 			       (arithmetic-shift (bitwise-ior pending
 							      (bitwise-and byte #b111111)) 6)
 			       (sub1 expected)
@@ -152,7 +152,7 @@ of the string and a list of remaining bytes (as integers).")
 		  (cond ((= (bitwise-and byte #b10000000) 0)
 			 ;; ASCII
 			 (loop (cdr bytes)
-			       '()
+			       (cdr bytes)
 			       0
 			       #f
 			       (cons (integer->char byte) res)))
@@ -160,20 +160,20 @@ of the string and a list of remaining bytes (as integers).")
 			 ;; First byte of UTF-8 sequence
 			 (let-values
 			     (((first-byte char-bytes)
-			       (cond ((= (bitwise-and byte #b11000000) #b11000000)
+			       (cond ((= (bitwise-and byte #b11100000) #b11000000)
 				      (values (bitwise-and byte #b11111)
 					      2))
-				     ((= (bitwise-and byte #b11100000) #b11100000)
+				     ((= (bitwise-and byte #b11110000) #b11100000)
 				      (values (bitwise-and byte #b1111)
 					      3))
-				     ((= (bitwise-and byte #b11110000) #b11110000)
+				     ((= (bitwise-and byte #b11111000) #b11110000)
 				      (values (bitwise-and byte #b111)
 					      4))
 				     (else
 				      ;; Should not happen
 				      (values 0 0)))))
 			   (loop (cdr bytes)
-				 (list byte)
+				 bytes
 				 (arithmetic-shift first-byte 6)
 				 (sub1 char-bytes)
 				 res))))))))))