CHANGELOG.md

@@ -1,41 +1,14 @@
 ChangeLog
 =========
 
-1.16.2 - released 2024-05-07
+1.15
-----------------------------
+----
-
-* 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 - released 2024-12-06
+1.14
---------------------------
+----
 
 * 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 mailinglist.import.scm
+	dokuwiki.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,8 +59,7 @@ 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	\
@@ -292,7 +291,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 racket-kwargs.import.scm
+	duck.import.scm
 
 util-parser.o: util-parser.import.scm
 util-parser.import.scm: $(UTIL-PARSER-SOURCES)
@@ -333,8 +332,7 @@ 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)
@@ -552,10 +550,3 @@ 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
-		 `((TAG . ,TAG-BRMEMBER)
+		 `((file-name . |1234|)
-		   (file-name . |1234|)
+		   (TAG . ,TAG-BRMEMBER)
 		   (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) #:strip-comments? #f)))
+	 (let ((line (parser-preprocess-line (car lines))))
 	   (if (equal? line "")
 	       (loop (cdr lines)
 		     users)
@@ -74,8 +74,8 @@
    (handle-exceptions
     exn
     (let ()
-      (log-warning "DokuWiki (~A) exception ~A" fname (condition->list exn))
+      (log-warning "DokuWiki: cannot open ~A" fname)
-      (stdout-printf "DokuWiki (~A) exception ~A" fname (condition->list exn))
+      (stdout-printf "DokuWiki: cannot open ~A" fname)
       '())
     (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>CZK: 2500079551/2010<br>EUR:  CZ93 2010 0000 0021 0007 9552</dd>")
+     (print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>2500079551/2010</dd>")
      (print "</dl>")
      (print "</div>")
      (print "<div class=\"bi\">")

src/hackerbase.scm

@@ -50,8 +50,7 @@
 	export-web-static
 	dokuwiki
 	racket-kwargs
-	util-string
+	util-string)
-	mailinglist)
 
 ;; Command-line options and configurable parameters
 (define -needs-bank- (make-parameter #f))
@@ -287,6 +286,32 @@
 	      (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)
@@ -298,7 +323,10 @@
        (let ()
 	 (print-members-base-table MB)
 	 (newline)
-	 (print-mailing-list-checks MB MLS)
+	 (check-mailing-list MLS "internal")
+	 (check-mailing-list MLS "rada"
+			     #:pred? rada-ml-pred?)
+	 (check-mailing-list MLS "rk" #:pred? brmember-revision?)
 	 (print-git-status)))
    (newline))
   ((print-stats)
@@ -396,8 +424,8 @@
    (print-git-status))
   ((summary)
    (if (-send-emails-)
-       (make+send-summary-email MB MLS)
+       (make+send-summary-email MB)
-       (make+print-summary-email MB MLS)))
+       (make+print-summary-email MB)))
   ((list)
    (for-each (lambda (mr)
 	       (print (brmember-nick mr)))

src/mailinglist.scm

@@ -1,78 +0,0 @@
-;;
-;; 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,7 +30,6 @@
  (
   lookup-member-fee
   member-calendar
-  make-member-calendar-entry
   member-calendar-first-month
   member-calendar-last-month
   member-calendar-query
@@ -41,14 +40,12 @@
   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
@@ -85,17 +82,15 @@
        (if (cal-month>? cm last-month)
 	   (reverse cal)
 	   (loop (cal-month-add cm)
-		 (cons (with-current-month
+		 (cons (list cm
-			cm
+			     (with-current-month
-			(make-member-calendar-entry mr))
+			      cm
+			      (brmember-flags mr))
+			     (with-current-month
+			      cm
+			      (brmember-spec-fee 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))
@@ -207,26 +202,5 @@
 		    (+ (cdr acc) (if (brmember-student? mr) 0 1))))
 	    (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,17 +500,7 @@
 			       (null? (cdr dsa)))
 			   #f
 			   (cadr dsa))))
-     (let* ((raw-members
+     (let* ((members ;; Pass 1
-	     (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))
@@ -532,7 +522,15 @@
 			total
 			balance
 			)))
-	      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<?)))
 	    (balances (map (lambda (m)
 			     (list-ref m 6))
 			   members)))
@@ -600,7 +598,19 @@
 		     (map (lambda (member)
 			    (min 0 (list-ref member 5)))
 			  members)))
-       (print (get-expected-income-string MB)))))
+       (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)"))
+       )
+     ))
 
  (define (unpaired-table mb . args)
    (apply

src/notifications.scm

@@ -40,7 +40,6 @@
 	 (chicken format)
 	 (chicken string)
 	 (chicken sort)
-	 (chicken port)
 	 brmember
 	 util-mail
 	 util-bst-ldict
@@ -55,8 +54,7 @@
 	 table
 	 bank-account
 	 logging
-	 srfi-1
+	 srfi-1)
-	 mailinglist)
 
  ;; Prints email to the console
  (define (print-notification-email em)
@@ -144,14 +142,16 @@
      (send-notification-email em)))
 
  ;; Summary email of membership fees payments
- (define (summary-email-body mb mls)
+ (define (summary-email-body mb)
    (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 (get-expected-income-string mb)))
+	   (list (format "Expected income: ~A CZK" income)
+		 (format "  ~A full members" full)
+		 (format "  ~A students" students)))
 	  (unpaired (mbase-unpaired mb))
 	  (unpaired-lst
 	   (if (null? unpaired)
@@ -160,30 +160,6 @@
 		(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<?))
@@ -280,8 +256,6 @@
 		       ", "))))))
      (append income-lst
 	     unpaired-lst
-	     soonexps-lst
-	     mlcheck-lst
 	     debtors-lst
 	     boring-lst
 	     dw-lst
@@ -292,21 +266,21 @@
 		   ))))
 
  ;; Creates the summary email structure
- (define (make-summary-email mb mls)
+ (define (make-summary-email mb)
    (make-ldict
     `((to . ,(*summary-mailto*))
       (subject . ,(format "Členské příspěvky ~A"
 			  (today/iso)))
-      (body . ,(summary-email-body mb mls)))))
+      (body . ,(summary-email-body mb)))))
 
  ;; Just print to standard output
- (define (make+print-summary-email mb mls)
+ (define (make+print-summary-email mb)
-   (let ((em (make-summary-email mb mls)))
+   (let ((em (make-summary-email mb)))
      (print-notification-email em)))
 
  ;; Actually send emails
- (define (make+send-summary-email mr mls)
+ (define (make+send-summary-email mr)
-   (let ((em (make-summary-email mr mls)))
+   (let ((em (make-summary-email mr)))
      (send-notification-email em)))
 
  )

src/texts.scm

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

src/util-bst.scm

@@ -286,12 +286,10 @@
        (call/cc
 	(lambda (cc)
 	  (set! break cc)
-	  (cond (resume
+	  (if resume
-		 (resume '())
+	      (resume '())
-		 (break #f))
+	      (bst-iter-kv bst yield))
-		(else
+	  #f)))))
-		 (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,12 +39,11 @@ 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 #:strip-comments? (strip-comments? #t))
+ (define/doc (parser-preprocess-line line)
    ("* ```line``` - a string with contents of one source line
 
 If the input ```line``` contains the ```#``` character, the rest of
@@ -63,9 +62,7 @@ Returns a string representing the preprocessed line.")
 		      (ploop (add1 pidx)))))
 	  (hpos (let hloop ((hidx ppos))
 		  (if (or (= hidx llen)
-			  (and (or strip-comments?
+			  (eq? (string-ref line hidx) #\#))
-				   (= 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 chars)
+	      (rpending '())
 	      (pending 0)
 	      (expected #f)
 	      (res '()))
      (if (null? bytes)
 	 (values (reverse res)
-		 rpending)
+		 (reverse 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)
-			       rpending
+			       (cons byte 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 #b11100000) #b11000000)
+			       (cond ((= (bitwise-and byte #b11000000) #b11000000)
 				      (values (bitwise-and byte #b11111)
 					      2))
-				     ((= (bitwise-and byte #b11110000) #b11100000)
+				     ((= (bitwise-and byte #b11100000) #b11100000)
 				      (values (bitwise-and byte #b1111)
 					      3))
-				     ((= (bitwise-and byte #b11111000) #b11110000)
+				     ((= (bitwise-and byte #b11110000) #b11110000)
 				      (values (bitwise-and byte #b111)
 					      4))
 				     (else
 				      ;; Should not happen
 				      (values 0 0)))))
 			   (loop (cdr bytes)
-				 bytes
+				 (list byte)
 				 (arithmetic-shift first-byte 6)
 				 (sub1 char-bytes)
 				 res))))))))))