231 lines
6.3 KiB
Scheme
231 lines
6.3 KiB
Scheme
;;
|
|
;; notifications.scm
|
|
;;
|
|
;; Email notifications and reminders.
|
|
;;
|
|
;; 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 notifications))
|
|
|
|
(module
|
|
notifications
|
|
(
|
|
make+print-reminder-email
|
|
make+send-reminder-email
|
|
|
|
make+print-summary-email
|
|
make+send-summary-email
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken format)
|
|
(chicken string)
|
|
brmember
|
|
util-mail
|
|
util-dict-list
|
|
members-payments
|
|
util-format
|
|
brmember-format
|
|
configuration
|
|
util-time
|
|
members-fees
|
|
mbase
|
|
members-print
|
|
table
|
|
bank-account
|
|
logging)
|
|
|
|
;; Prints email to the console
|
|
(define (print-notification-email em)
|
|
(print "### From: " (ldict-ref em 'from (*email-from*)))
|
|
(print "### To: " (ldict-ref em 'to))
|
|
(print "### Subject: " (ldict-ref em 'subject))
|
|
(let loop ((lines (ldict-ref em 'body)))
|
|
(when (not (null? lines))
|
|
(print (car lines))
|
|
(loop (cdr lines)))))
|
|
|
|
;; Sends notification email - the dictionary representation
|
|
(define (send-notification-email em)
|
|
(log-info "Sending ~A to ~A~A"
|
|
(ldict-ref em 'subject)
|
|
(ldict-ref em 'to)
|
|
(if (*mailto-override*)
|
|
(format " (overriden to ~A)" (*mailto-override*))
|
|
""))
|
|
(send-mail (ldict-ref em 'body)
|
|
#:from (*email-from*)
|
|
#:to (ldict-ref em 'to)
|
|
#:subject (ldict-ref em 'subject)))
|
|
|
|
;; Creates reminder email body
|
|
(define (reminder-email-body mr)
|
|
(let ((C identity)
|
|
(M (lambda (s)
|
|
(brmember-format s mr)))
|
|
(F format)
|
|
(absdebt (format-amount (- (member-total-balance mr))))
|
|
(macc "2500079551/2010"))
|
|
(list
|
|
(M "Ahoj ~N,")
|
|
(C "podle evidence členů a bankovního účtu to vypadá, že máš nedoplatek")
|
|
(F "ve výši ~A Kč." absdebt)
|
|
(C "Zkontroluj, prosím, zda tvé platby členských příspěvků")
|
|
(M "s variabilním symbolem ~I byly zaslány na")
|
|
(F "správný účet ~A." macc)
|
|
""
|
|
""
|
|
(M "Dear ~N,")
|
|
(C "according to the members database and bank account statements, it appears")
|
|
(F "your payment of ~A CZK is missing." absdebt)
|
|
(C "Please, check whether your membership fees were transfered")
|
|
(M "correctly with the variable symbol (identification) ~I to")
|
|
(F "the correct bank account ~A." macc)
|
|
""
|
|
"--"
|
|
"Brmlab Hackerspace Members Database"
|
|
)))
|
|
|
|
;; Creates reminder email dictionary
|
|
(define (make-reminder-email mr)
|
|
(make-ldict
|
|
`((to . ,(brmember-info mr 'mail))
|
|
(subject . "Připomínka členských příspěvků / Membership fees reminder")
|
|
(body . ,(reminder-email-body mr)))))
|
|
|
|
;; Creates and prints reminder email for given member record
|
|
(define (make+print-reminder-email mr)
|
|
(print-notification-email
|
|
(make-reminder-email mr)))
|
|
|
|
;; Actually send emails
|
|
(define (make+send-reminder-email mr)
|
|
(let ((em (make-reminder-email mr)))
|
|
(send-notification-email em)))
|
|
|
|
;; Summary email of membership fees payments
|
|
(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 (format "Expected income: ~A CZK" income)
|
|
(format " ~A full members" full)
|
|
(format " ~A students" students)))
|
|
(unpaired (mbase-unpaired mb))
|
|
(unpaired-lst
|
|
(if (null? unpaired)
|
|
'()
|
|
(append
|
|
(list ""
|
|
"Unpaired transactions:")
|
|
(unpaired-table mb #:border-style 'ascii))))
|
|
(debtors (members-to-notify mb 1))
|
|
(debtors-lst
|
|
(if (null? debtors)
|
|
'()
|
|
(append
|
|
(list ""
|
|
"Active debtors:")
|
|
(table->list
|
|
(cons (list "Id" "Member" "Type" "Balance" "Last payment")
|
|
(map (lambda (mr)
|
|
(list (brmember-id mr)
|
|
(brmember-nick mr)
|
|
(if (brmember-student? mr)
|
|
'student
|
|
'normal)
|
|
(format "\t~A" (member-total-balance mr))
|
|
(let* ((payments (brmember-payments mr))
|
|
(tr (if (null? payments)
|
|
#f
|
|
(car (reverse payments)))))
|
|
(if tr
|
|
(bank-transaction-date tr)
|
|
"-"))
|
|
))
|
|
debtors))
|
|
#:border-style 'ascii
|
|
#:col-border #t
|
|
#:row0-border #t))))
|
|
(boring (find-members-by-predicate
|
|
mb
|
|
(lambda (mr)
|
|
(and (brmember-active? mr)
|
|
(not (member-to-notify? mr))))))
|
|
(boring-lst
|
|
(if (null? boring)
|
|
'()
|
|
(append
|
|
(list ""
|
|
"Other active members:")
|
|
(table->list
|
|
(cons (list "Id" "Member" "Type" "Balance" "Last payment")
|
|
(map (lambda (mr)
|
|
(list (brmember-id mr)
|
|
(brmember-nick mr)
|
|
(if (brmember-student? mr)
|
|
'student
|
|
'normal)
|
|
(format "\t~A" (member-total-balance mr))
|
|
(let* ((payments (brmember-payments mr))
|
|
(tr (if (null? payments)
|
|
#f
|
|
(car (reverse payments)))))
|
|
(if tr
|
|
(bank-transaction-date tr)
|
|
"-"))
|
|
))
|
|
boring))
|
|
#:border-style 'ascii
|
|
#:col-border #t
|
|
#:row0-border #t)))))
|
|
(append income-lst
|
|
unpaired-lst
|
|
debtors-lst
|
|
boring-lst
|
|
(list ""
|
|
"--"
|
|
"Brmlab Hackerspace Members Database"
|
|
))))
|
|
|
|
;; Creates the summary email structure
|
|
(define (make-summary-email mb)
|
|
(make-ldict
|
|
`((to . ,(*summary-mailto*))
|
|
(subject . ,(format "Členské příspěvky ~A"
|
|
(today/iso)))
|
|
(body . ,(summary-email-body mb)))))
|
|
|
|
;; Just print to standard output
|
|
(define (make+print-summary-email mb)
|
|
(let ((em (make-summary-email mb)))
|
|
(print-notification-email em)))
|
|
|
|
;; Actually send emails
|
|
(define (make+send-summary-email mr)
|
|
(let ((em (make-summary-email mr)))
|
|
(send-notification-email em)))
|
|
|
|
)
|