126 lines
5.8 KiB
Racket
126 lines
5.8 KiB
Racket
#lang syndicate
|
|
|
|
(provide (struct-out/defaults [make-smtp-account-config smtp-account-config])
|
|
(rename-out [smtp-account-config <smtp-account-config>])
|
|
(struct-out smtp-account)
|
|
(struct-out smtp-delivery)
|
|
(struct-out smtp-delivery-complete)
|
|
|
|
spawn-smtp-driver
|
|
smtp-deliver!)
|
|
|
|
(define-logger syndicate/drivers/smtp)
|
|
|
|
(require racket/exn)
|
|
(require racket/tcp)
|
|
(require (only-in racket/list flatten))
|
|
(require net/head)
|
|
(require net/smtp)
|
|
(require openssl)
|
|
(require struct-defaults)
|
|
|
|
;; An SSLMode is one of
|
|
;; - #f: Use unencrypted SMTP, by default at port 587
|
|
;; - 'ssl: Use TLS-tunneled SMTP, by default at port 465 (!)
|
|
;; - 'starttls: Use STARTTLS SMTP upgrade to TLS encryption, by default at port 587
|
|
|
|
;; (smtp-account-config Symbol String Number (Option String) (Option String) SSLMode)
|
|
(struct smtp-account-config (id host port user password ssl-mode) #:prefab) ;; ASSERTION
|
|
|
|
;; (smtp-account Any)
|
|
(struct smtp-account (id) #:prefab) ;; ASSERTION
|
|
|
|
(struct smtp-delivery (account-id ;; Any
|
|
delivery-id ;; Any
|
|
from ;; String -- *envelope* FROM
|
|
to ;; (Listof String) -- *envelope* RCPT
|
|
header ;; (Listof (Cons Symbol String))
|
|
lines ;; (Listof (U String Bytes))
|
|
) #:prefab) ;; MESSAGE
|
|
|
|
;; (smtp-delivery-complete Any Boolean)
|
|
(struct smtp-delivery-complete (delivery-id ok?) #:prefab) ;; MESSAGE
|
|
|
|
;; On SMTP ports.
|
|
;;
|
|
;; 25: MTA-to-MTA; message transfer
|
|
;; 465: Legacy SSL SMTP, prefer not to use
|
|
;; 587: MUA-to-MTA; message submission; STARTTLS for upgrade to TLS
|
|
|
|
(begin-for-declarations
|
|
(define-struct-defaults make-smtp-account-config smtp-account-config
|
|
(#:ssl-mode [smtp-account-config-ssl-mode 'starttls]
|
|
#:port [smtp-account-config-port (case smtp-account-config-ssl-mode
|
|
[(#f starttls) 587]
|
|
[(ssl) 465]
|
|
[else (error 'smtp-account-config
|
|
"Invalid smtp-account-config-ssl-mode ~v"
|
|
smtp-account-config-ssl-mode)])]
|
|
#:user [smtp-account-config-user #f]
|
|
#:password [smtp-account-config-password #f])))
|
|
|
|
(define (spawn-smtp-driver)
|
|
(spawn #:name 'smtp-account-driver
|
|
(during/spawn (smtp-account-config $id $host $port $user $password $ssl-mode)
|
|
#:name (list 'smtp-account id)
|
|
(on-start
|
|
(log-syndicate/drivers/smtp-info "~v starting: ~a:~a ~s ~s" id host port user ssl-mode))
|
|
(on-stop
|
|
(log-syndicate/drivers/smtp-info "~v stopping: ~a:~a ~s ~s" id host port user ssl-mode))
|
|
(assert (smtp-account id))
|
|
(on (message (smtp-delivery id $delivery-id $from $to $header $lines))
|
|
(with-handlers [(exn:fail?
|
|
(lambda (e)
|
|
(log-syndicate/drivers/smtp-error "smtp-delivery ~a ~a: ~a"
|
|
id
|
|
delivery-id
|
|
(exn->string e))
|
|
(send-ground-message
|
|
(smtp-delivery-complete delivery-id #f))))]
|
|
(parameterize ((smtp-sending-end-of-message
|
|
(lambda ()
|
|
(send-ground-message
|
|
(smtp-delivery-complete delivery-id #t)))))
|
|
(log-syndicate/drivers/smtp-info "account ~a delivery ~a: ~s -> ~s"
|
|
id
|
|
delivery-id
|
|
from
|
|
to)
|
|
(smtp-send-message host
|
|
from
|
|
to
|
|
(construct-header header)
|
|
lines
|
|
#:port-no port
|
|
#:auth-user user
|
|
#:auth-passwd password
|
|
#:tcp-connect (case ssl-mode
|
|
[(ssl) ssl-connect]
|
|
[else tcp-connect])
|
|
#:tls-encode (case ssl-mode
|
|
[(starttls) ports->ssl-ports]
|
|
[else #f]))))))
|
|
(during/spawn (smtp-account-config _ _ _ _ _ _)
|
|
;; By *conditionally* paying attention to inbound messages
|
|
;; from ground, we ensure that we don't unnecessarily hold
|
|
;; up ground termination.
|
|
(on (message (inbound (smtp-delivery-complete $delivery-id $ok?)))
|
|
(send! (smtp-delivery-complete delivery-id ok?))))))
|
|
|
|
(define (construct-header hs)
|
|
(for/fold [(acc empty-header)] [(h (reverse hs))]
|
|
(match-define (cons key val) h)
|
|
(insert-field (symbol->string key) val acc)))
|
|
|
|
(define (smtp-deliver! account-id from to header lines)
|
|
(define delivery-id (gensym 'smtp-delivery))
|
|
(react/suspend (k)
|
|
(on (asserted (smtp-account account-id))
|
|
(send! (smtp-delivery account-id delivery-id from to header lines)))
|
|
(stop-when (message (smtp-delivery-complete delivery-id $status))
|
|
(k status))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(spawn-smtp-driver)
|