From 7d1101657f7a18cefc7dc0f9a5a80bd417474028 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?=
 <dominik.pantucek@trustica.cz>
Date: Tue, 2 Jul 2024 20:50:43 +0200
Subject: [PATCH] Add support for full email addresses.

---
 src/util-mail.scm | 38 ++++++++++++++++++++++++++------------
 1 file changed, 26 insertions(+), 12 deletions(-)

diff --git a/src/util-mail.scm b/src/util-mail.scm
index 8a7e8b5..8e5fb4f 100644
--- a/src/util-mail.scm
+++ b/src/util-mail.scm
@@ -39,6 +39,7 @@
 	 (chicken base)
 	 (chicken keyword)
 	 (chicken string)
+	 (chicken irregex)
 	 util-io
 	 util-utf8
 	 util-string
@@ -61,6 +62,14 @@ sent to the address stored within.")
 		      "?=")
        subj))
 
+ ;; Extracts only usernam@domain from given full RFC email address
+ (define (extract-email-email str)
+   (let* ((irr (irregex "(?:\"?([^\"]*)\"?\\s)?(?:<?(.+@[^>]+)>?)"))
+	  (em (irregex-match irr str))
+	  (name (irregex-match-substring em 1))
+	  (email (irregex-match-substring em 2)))
+     email))
+
  ;; Sends an email using the UNIX mail(1) utility.
  (define*/doc (send-mail body-lines
 			 #:from (from #f)
@@ -83,17 +92,22 @@ Sends email using mail(1) command. The arguments ```#:to``` and
 			tos))
 	  (header-args
 	   (flatten
-	    (map
-	     (lambda (h) (list "-a" h))
-	     headers))))
-     (apply process-send/recv
-	    "mail"
-	    (append (if from
-			(list "-r" from)
-			'())
-		    (list "-s" (encode-subject subject))
-		    real-tos
-		    header-args)
-	    body-lines)))
+	    (append
+	     (if from (list (sprintf "From: ~A" from)) '())
+	     (map
+	      (lambda (h) (list "-a" h))
+	      headers)))))
+     (let ((from-email (if from
+			   (extract-email-email from)
+			   #f)))
+       (apply process-send/recv
+	      "mail"
+	      (append (if from
+			  (list "-r" from-email)
+			  '())
+		      (list "-s" (encode-subject subject))
+		      real-tos
+		      header-args)
+	      body-lines))))
 
  )