/
sendmail.scm
144 lines (127 loc) · 5.9 KB
/
sendmail.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
;; -*- indent-tabs-mode:nil; coding: utf-8 -*-
;; Copyright (C) 2013,2014
;; "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
;; Artanis is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; Artanis is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(define-module (artanis sendmail)
#:use-module (artanis utils)
#:use-module (artanis config)
#:use-module (artanis mime)
#:use-module (artanis crypto base64)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 popen))
(module-export-all! (current-module))
;; TODO: customize the printer in case too much info printed when debugging
(define-record-type <sendmail>
(%make-sendmail sender from to subject message headers attachements)
sendmail?
(sender sendmail-sender sendmail-sender!) ; sendmail compatible MTA
(from sendmail-from sendmail-from!)
(to sendmail-to sendmail-to!)
(subject sendmail-subject sendmail-subject!)
(message sendmail-message sendmail-message!)
(headers sendmail-headers sendmail-headers!)
(attachements sendmail-attachements sendmail-attachements!))
(set-record-type-printer! <sendmail>
(lambda (sm port)
(display "\n#<sendmail\n" port)
(format port " sender: ~a~%" (sendmail-sender sm))
(format port " from: ~a~%" (sendmail-from sm))
(format port " to: ~a~%" (sendmail-to sm))
(format port " subject: ~a~%" (sendmail-subject sm))
(format port " message: <the message>...~%")
(format port " headers: ~a~%" (sendmail-headers sm))
(format port " attachements: <the data>...~%")
(display " >\n" port)))
(define-syntax-rule (add-header sm new-header)
(let ((header (sendmail-header sm)))
(sendmail-header! sm (cons new-header header))))
(define-syntax-rule (add-attachment sm file-with-path)
(if (not (file-exists? file-with-path))
(throw 'artanis-err 500 "can't find attachment file" file-with-path)
(let* ((file (basename file-with-path))
(bv (bv-cat file #f))
(al (sendmail-attachements sm)))
(sendmail-attachements! sm (cons (cons file bv) al)))))
;; ENHANCE: do we need a customizable transfer encoding?
(define (dump-all-attachments port boundry sm)
(define bdr (string-append "--" boundry "\n"))
(define bdr-end (string-append "--" boundry "--\n"))
(for-each (lambda (att)
(let* ((filename (car att))
(mime (guess-mime filename))
(content (cdr att)))
(display bdr port)
(display (string-append "Content-Type: application; name=\""
filename "\"\n") port)
(display "Content-Transfer-Encoding: base64\n" port)
(display (string-append "Content-Disposition: attachmet; filename=\""
filename "\"\n") port)
(display (base64-encode content) port)(newline port)))
(sendmail-attachements sm))
(display bdr-end port))
;; TODO: don't dump the header which exists in customed headers list
(define (dump-headers port sm)
(for-each (lambda (p)
(format port "~a: ~a~%" (car p) (cdr p)))
(sendmail-headers sm)))
(define (generate-boundary)
(string-append "boundry-"(get-random-from-dev)))
(define (dump-as-attachments-mail sm)
(define boundry (generate-boundary))
(define bdr (string-append "--" boundry "\n"))
(call-with-output-string
(lambda (port)
(format port "From: ~a~%To: ~a~%Subject: ~a~%"
(sendmail-from sm) (sendmail-to sm) (sendmail-subject sm))
(display "MIME-Version: 1.0\n" port)
(dump-headers port sm)
(display (string-append "Content-Type: multipart/mixed; boundary=\""
boundry "\"\n\n") port)
(display bdr port)
(display "Content-Type: text/html\n" port)
(display "Content-Disposition: inline\n" port)
(display (sendmail-message sm) port)(newline port)
(dump-all-attachments port boundry sm))))
(define (dump-as-normal-mail sm)
(call-with-output-string
(lambda (port)
(format port
"From: ~a~%To: ~a~%Subject: ~a~%~%~a~%"
(sendmail-from sm) (sendmail-to sm) (sendmail-subject sm)
(sendmail-message sm)))))
(define (%send-the-mail sm t)
(let* ((sender (sendmail-sender sm))
(port (open-pipe* OPEN_WRITE sender "-i" "-t")))
(display t port)
(unless (zero? (status:exit-val (close-pipe port)))
(throw 'artanis-err 500 "mail command failed" sm))))
(define-syntax-rule (no-attachments? sm)
(null? (sendmail-attachements sm)))
(define (send-the-mail sm)
(and (not (sendmail? sm)) (throw 'artanis-err 500 "invalid <sendmail> object" sm))
(let ((t (if (no-attachments? sm)
(dump-as-normal-mail sm)
(dump-as-attachments-mail sm))))
(%send-the-mail sm t)))
;; TODO: maybe delay to send calling sender
(define* (make-simple-mail-sender from to #:key (sender (current-mail-sender)))
(let ((sm (%make-sendmail sender from to "no subject" #f '() '())))
(lambda* (message #:key (attachements #f) (header #f) (subject #f))
(if (string? message)
(sendmail-message! sm message)
(throw 'artanis-err 500 "invalid message format, must be string!" message))
(and attachements (sendmail-attachements! sm attachements))
(and subject (sendmail-subject! sm subject))
(and header (sendmail-headers! sm header))
sm)))
;;(send-the-mail sm))))