Mailto override.

This commit is contained in:
Dominik Pantůček 2023-04-11 09:39:07 +02:00
parent 3c9a3fe856
commit 33d2bf9088
2 changed files with 15 additions and 5 deletions

View file

@ -37,7 +37,8 @@
mailman mailman
texts texts
tests tests
reminders) reminders
util-mail)
;; Print banner ;; Print banner
(print "HackerBase 0.9.4 (c) 2023 Brmlab, z.s.") (print "HackerBase 0.9.4 (c) 2023 Brmlab, z.s.")
@ -100,6 +101,8 @@
(-show-destroyed- #t)) (-show-destroyed- #t))
(-sendmail () "Actually send emails" (-sendmail () "Actually send emails"
(-send-emails- #t)) (-send-emails- #t))
(-mailto (email) "Override all outgoing emails destination"
(*mailto-override* email))
"" ""
"Query options:" "Query options:"
(-mi (id) "Specify member by id" (-member-id- (string->number id))) (-mi (id) "Specify member by id" (-member-id- (string->number id)))

View file

@ -28,6 +28,7 @@
(module (module
util-mail util-mail
( (
*mailto-override*
send-mail send-mail
) )
@ -36,6 +37,9 @@
(chicken keyword) (chicken keyword)
util-io) util-io)
;; All emails go to this override
(define *mailto-override* (make-parameter "dominik.pantucek@trustica.cz"))
;; Sends an email using the UNIX mail(1) utility. ;; Sends an email using the UNIX mail(1) utility.
(define (send-mail body-lines . args) (define (send-mail body-lines . args)
(let ((from (get-keyword #:from args)) (let ((from (get-keyword #:from args))
@ -45,16 +49,19 @@
(error 'send-mail "requires #:to argument")) (error 'send-mail "requires #:to argument"))
(when (not subject) (when (not subject)
(error 'send-mail "requires #:subject argument")) (error 'send-mail "requires #:subject argument"))
(let ((tos (if (list? to) (let* ((tos (if (list? to)
to to
(list to)))) (list to)))
(real-tos (if (*mailto-override*)
(list (*mailto-override*))
tos)))
(apply process-send/recv (apply process-send/recv
"mail" "mail"
(append (if from (append (if from
(list "-r" from) (list "-r" from)
'()) '())
(list "-s" subject) (list "-s" subject)
tos) real-tos)
body-lines)))) body-lines))))
) )