hans/audio-library-manager
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

opus conversie

Browse Source
This commit is contained in:
Hans Dijkema
2026-06-09 08:41:01 +02:00
parent 92c8e40518
commit ce5c4d6de5
18 changed files with 1202 additions and 86 deletions
Download Patch File Download Diff File Expand all files Collapse all files
private/mail.rkt
+131 -15
View File
@@ -1,12 +1,121 @@
#lang racket/base
(require smtp
(require racket/list
racket/string
racket/tcp
net/base64
"config.rkt"
"report.rkt")
(provide maybe-send-report-mail)
(provide maybe-send-report-mail
mail-address->envelope-address
strict-send-smtp-mail)
(define (maybe-send-report-mail config summary errors)
(define (smtp-proc name)
(dynamic-require 'smtp name))
(define (non-empty-string? v)
(and (string? v) (not (string=? (string-trim v) ""))))
(define (base64-line s)
(bytes->string/utf-8 (base64-encode (string->bytes/utf-8 (or s "")) #"")))
(define (trim-envelope-address s)
(define t (string-replace s "\"" ""))
(regexp-replace* #rx"^[<> \t\r\n]+|[<> \t\r\n]+$" t ""))
(define (mail-address->envelope-address v)
(define s (string-trim (format "~a" v)))
(define m (regexp-match #px"<([^<>]+)>" s))
(define addr (if m (cadr m) s))
(trim-envelope-address addr))
(define (clean-address-list xs)
(filter non-empty-string?
(for/list ([x (in-list xs)])
(mail-address->envelope-address x))))
(define (write-smtp-command out command)
(display (string-append (string-trim command) "\r\n") out)
(flush-output out))
(define (read-smtp-response in expected host)
(let loop ([lines '()])
(define line (read-line in 'any))
(when (eof-object? line)
(error 'strict-send-smtp-mail "smtp server ~a: unexpected EOF" host))
(define lines* (cons line lines))
(define ok-code?
(and (>= (string-length line) 3)
(equal? (substring line 0 3) (number->string expected))))
(unless ok-code?
(error 'strict-send-smtp-mail "smtp server ~a:\n ~a" host (string-join (reverse lines*) "\n ")))
(if (and (> (string-length line) 3) (char=? (string-ref line 3) #\-))
(loop lines*)
(reverse lines*))))
(define (strict-send-smtp-mail mail
#:host host
#:port port
#:tls-encode [tls-encode #f]
#:username [username ""]
#:password [password ""])
;; The smtp package writes commands as "MAIL FROM: <addr>" and
;; "RCPT TO: <addr>". Some servers reject the whitespace before the path.
;; This sender keeps using smtp's mail struct and MIME header generation,
;; but sends the SMTP envelope as "MAIL FROM:<addr>" / "RCPT TO:<addr>".
(when tls-encode
(error 'strict-send-smtp-mail "TLS/STARTTLS is not supported by the strict sender yet"))
(define mail-sender (smtp-proc 'mail-sender))
(define mail-recipients (smtp-proc 'mail-recipients))
(define mail-cc-recipients (smtp-proc 'mail-cc-recipients))
(define mail-bcc-recipients (smtp-proc 'mail-bcc-recipients))
(define mail-header (smtp-proc 'mail-header))
(define sender (mail-address->envelope-address (mail-sender mail)))
(define recipients (append (clean-address-list (mail-recipients mail))
(clean-address-list (mail-cc-recipients mail))
(clean-address-list (mail-bcc-recipients mail))))
(unless (non-empty-string? host)
(error 'strict-send-smtp-mail "missing SMTP host"))
(unless (non-empty-string? sender)
(error 'strict-send-smtp-mail "missing SMTP sender"))
(when (null? recipients)
(error 'strict-send-smtp-mail "missing SMTP recipient"))
(define-values (in out) (tcp-connect host port))
(dynamic-wind
void
(lambda ()
(read-smtp-response in 220 host)
(write-smtp-command out "EHLO localhost.localdomain")
(read-smtp-response in 250 host)
(when (non-empty-string? username)
(write-smtp-command out "AUTH LOGIN")
(read-smtp-response in 334 host)
(write-smtp-command out (base64-line username))
(read-smtp-response in 334 host)
(write-smtp-command out (base64-line password))
(read-smtp-response in 235 host))
(write-smtp-command out (format "MAIL FROM:<~a>" sender))
(read-smtp-response in 250 host)
(for ([r (in-list recipients)])
(write-smtp-command out (format "RCPT TO:<~a>" r))
(read-smtp-response in 250 host))
(write-smtp-command out "DATA")
(read-smtp-response in 354 host)
(display (mail-header mail) out)
(display "\r\n.\r\n" out)
(flush-output out)
(read-smtp-response in 250 host)
(write-smtp-command out "QUIT")
(read-smtp-response in 221 host))
(lambda ()
(close-input-port in)
(close-output-port out))))
(define (maybe-send-report-mail config summary errors
#:manager-name [manager-name "FLAC 48 kHz manager"]
#:result-label [result-label "converted"])
(define has-errors? (positive? (summary-ref summary 'errors 0)))
(define should-send?
(and (manager-config-mail-enabled? config)
@@ -14,20 +123,27 @@
(or (and has-errors? (manager-config-mail-send-on-error? config))
(and (not has-errors?) (manager-config-mail-send-on-success? config)))))
(when should-send?
(define subject (format "~a FLAC 48 kHz manager: ~a error(s), ~a converted"
(define from (mail-address->envelope-address (manager-config-mail-from config)))
(define to (clean-address-list (manager-config-mail-to config)))
(define cc (clean-address-list (manager-config-mail-cc config)))
(define bcc (clean-address-list (manager-config-mail-bcc config)))
(define subject (format "~a ~a: ~a error(s), ~a ~a"
(manager-config-mail-subject-prefix config)
manager-name
(summary-ref summary 'errors 0)
(summary-ref summary 'converted 0)))
(summary-ref summary 'converted 0)
result-label))
(define body (html-report subject summary errors))
(define make-mail (smtp-proc 'make-mail))
(define mail (make-mail subject body
#:from (manager-config-mail-from config)
#:to (manager-config-mail-to config)
#:cc (manager-config-mail-cc config)
#:bcc (manager-config-mail-bcc config)
#:from from
#:to to
#:cc cc
#:bcc bcc
#:body-content-type "text/html"))
(send-smtp-mail mail
#:host (manager-config-mail-host config)
#:port (manager-config-mail-port config)
#:tls-encode (manager-config-mail-tls? config)
#:username (manager-config-mail-username config)
#:password (manager-config-mail-password config))))
(strict-send-smtp-mail mail
#:host (string-trim (manager-config-mail-host config))
#:port (manager-config-mail-port config)
#:tls-encode (manager-config-mail-tls? config)
#:username (string-trim (manager-config-mail-username config))
#:password (manager-config-mail-password config))))