From 2fdf52cda17f4bf237b8ac47cc5a422eb5fae9c5 Mon Sep 17 00:00:00 2001 From: patrick Date: Mon, 14 Apr 2025 13:43:32 +0200 Subject: [PATCH 1/5] Improves implementation of hash-table->alist --- rosetta-test/interpreter-tests.json | 4 +++- rosetta-test/stdlib.scm | 8 +++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/rosetta-test/interpreter-tests.json b/rosetta-test/interpreter-tests.json index a52d36d..01549df 100644 --- a/rosetta-test/interpreter-tests.json +++ b/rosetta-test/interpreter-tests.json @@ -113,5 +113,7 @@ {"input": "(hash-table-exists? ht 'b)", "expected": true}, {"input": "(hash-table-map ht (lambda (key value) key))", "expected": ["b"]}, {"input": "(hash-table-walk ht (lambda (key value) key))", "expected": null}, - {"input": "(begin (hash-table-ref! ht 'c 3) (hash-table-ref ht 'c))", "expected": 3} + {"input": "(begin (hash-table-ref! ht 'c 3) (hash-table-ref ht 'c))", "expected": 3}, + {"input": "(hash-table->alist ht)", "expected": [["b", 2], ["c", 3]]}, + {"input": "(hash-table->alist (make-hash-table))", "expected": []} ] \ No newline at end of file diff --git a/rosetta-test/stdlib.scm b/rosetta-test/stdlib.scm index fa4513a..ea0dbeb 100644 --- a/rosetta-test/stdlib.scm +++ b/rosetta-test/stdlib.scm @@ -223,12 +223,10 @@ ht) (define (hash-table->alist ht) - (define alist '()) - (for-each + (map (lambda (key) - (set! alist (cons (list key (hash-table-ref ht key)) alist))) - (hash-table-keys ht)) - alist) + (list key (hash-table-ref ht key))) + (hash-table-keys ht))) ; Aliases (define hash-ref hash-table-ref) From 80e4fd7939be62a5ad054f95305ceebdd3cf7080 Mon Sep 17 00:00:00 2001 From: patrick Date: Mon, 14 Apr 2025 15:19:08 +0200 Subject: [PATCH 2/5] Adds tests on setting headers in sendmail suite --- rosetta-test-py/sendmail-python-emails.py | 15 ++-- rosetta-test-py/sendmail-redmail.py | 12 ++- rosetta-test-suites/sendmail.ros | 105 +++++++++++++++++++--- 3 files changed, 112 insertions(+), 20 deletions(-) diff --git a/rosetta-test-py/sendmail-python-emails.py b/rosetta-test-py/sendmail-python-emails.py index 0f7ab75..3b0421c 100644 --- a/rosetta-test-py/sendmail-python-emails.py +++ b/rosetta-test-py/sendmail-python-emails.py @@ -120,13 +120,16 @@ def sendmail_connected(env, backend): # Send Message # -@sendmail_suite.placeholder("sendmail-send-message-with-options") -def sendmail_send_message(env, sender:SMTPBackend, message, sender_address, recipient_addresses, message_options, recipients_options): +@sendmail_suite.placeholder("sendmail-send-message-full") +def sendmail_send_message(env, sender:SMTPBackend, message, sender_address, recipient_addresses, cc_addresses, bcc_addresses, custom_headers, message_options, recipients_options): try: message = emails.Message(text=message, subject="Test", mail_to=recipient_addresses, - mail_from=sender_address) + mail_from=sender_address, + cc=cc_addresses, + bcc=bcc_addresses, + headers=custom_headers,) return [message.send(smtp=sender,smtp_mail_options=message_options, smtp_rcpt_options=recipients_options)] except Exception as e: return [e] @@ -154,7 +157,8 @@ def sendmail_error(env, result: SMTPResponse): exclude_capabilities=( "root.connection.lazy-connection", # TODO: python-emails does not handle failed auth correctly "root.connection.eager-connection", - "root.crlf-injection-detection.detection", + "root.general-crlf-injection.detection", + "root.headers.crlf-injection.mitigation", "root.unicode-messages.8bitmime.automatic-detection", "root.internationalized-email-addresses.smtputf8.explicit-options"), expected_failures=( @@ -165,4 +169,5 @@ def sendmail_error(env, result: SMTPResponse): # The library should problably automatically detect whether smtputf8 is required "test_international_sender_mailbox_in_send-message_with_SMTPUTF8_support", "test_international_recipient_mailbox_in_send-message_with_SMTPUTF8_support", - "test_Send_a_message_with_empty_recipient",)) \ No newline at end of file + "test_Send_a_message_with_empty_recipient", + "test_set_header_with_unicode_value")) # Encoding of unicode in header value seems wrong (underscore instead of space) \ No newline at end of file diff --git a/rosetta-test-py/sendmail-redmail.py b/rosetta-test-py/sendmail-redmail.py index f95dc63..38917da 100644 --- a/rosetta-test-py/sendmail-redmail.py +++ b/rosetta-test-py/sendmail-redmail.py @@ -130,11 +130,14 @@ def sendmail_connected(env, sender: EmailSender): # Send Message # -@sendmail_suite.placeholder("sendmail-send-message-with-options") -def sendmail_send_message(env, sender: EmailSender, message, sender_address, recipient_addresses, message_options, recipients_options): +@sendmail_suite.placeholder("sendmail-send-message-full") +def sendmail_send_message(env, sender: EmailSender, message, sender_address, recipient_addresses, cc_addresses, bcc_addresses, custom_headers, message_options, recipients_options): try: sender.send(sender=sender_address, receivers=recipient_addresses, + cc=cc_addresses, + bcc=bcc_addresses, + headers=custom_headers, subject="test", text=message) except Exception as e: @@ -161,13 +164,14 @@ def sendmail_error(env, result): sendmail_suite.run( exclude=( - "test_CRLF_detection_in_send-message_recipient", + "test_CRLF_detection_in_send-message_recipient", "test_CRLF_mitigation_in_send-message_sender", "test_Connect_with_invalid_credentials"), # TODO redmail leaks sockets when credentials are invalid exclude_capabilities=( "root.unicode-messages.8bitmime.automatic-detection", "root.unicode-messages.8bitmime.mandatory-options", - "root.internationalized-email-addresses.smtputf8.explicit-options",), + "root.internationalized-email-addresses.smtputf8.explicit-options", + "root.headers.crlf-injection.mitigation",), # redmail does detects CRLF injections in header values expected_failures=( "test_Handle_421_during_data_command", "test_Handle_421_at_start_of_data_command", diff --git a/rosetta-test-suites/sendmail.ros b/rosetta-test-suites/sendmail.ros index fb1b368..71a66f6 100644 --- a/rosetta-test-suites/sendmail.ros +++ b/rosetta-test-suites/sendmail.ros @@ -28,9 +28,14 @@ (placeholder '(sendmail-connected? connection) "Should return true if the connection is still open") ; Send Mail - (placeholder '(sendmail-send-message-with-options connection message-content from to-list message-options to-list-options) "Send a message to the server. The message-options and the to-list-options are optional. The to-list-options is a list of option tuple lists, one for each receiver. The function should return a list corresponding to the responses from the server for each recipient in the to-list. If there is only a single response, a list with a single response should be returned.") + (placeholder '(sendmail-send-message-full connection message-content from to-list cc-list bcc-list headers message-options to-list-options) "Send a message to the server. The cc-list and bcc-list are optional. The headers hash is optional. The message-options and the to-list-options are optional. The to-list-options is a list of option tuple lists, one for each receiver. The function should return a list corresponding to the responses from the server for each recipient in the to-list. If there is only a single response, a list with a single response should be returned.") + + (define (sendmail-send-message-with-options connection message-content from to-list message-options to-list-options) + (sendmail-send-message-full connection message-content from to-list '() '() (make-hash-table) message-options to-list-options)) (define (sendmail-send-message connection content from to-list) (sendmail-send-message-with-options connection content from to-list '() '())) + (define (sendmail-send-message-with-headers connection content from to-list headers-hash-map) + (sendmail-send-message-full connection content from to-list '() '() headers-hash-map '() '())) ; Response accessors (placeholder '(send-success? response) "Return whether the sending was successful.") @@ -59,6 +64,8 @@ (define (compile-options-string options) (string-join (compile-options-strings options) " ")) + (define (server-message-contains? content) + (string-contains? (server-message-data server) content)) (setup (lambda () (set! server '()))) @@ -142,8 +149,7 @@ (setup (lambda () (set! server (start-mock-server)) - (connect-smtp-server) - )) + (connect-smtp-server))) (tearDown (lambda () (sendmail-disconnect smtp-connection) @@ -170,6 +176,8 @@ (server-requests-with-command server "MAIL")) (string-append "Expected client to send empty sender: " (server-requests-with-command server "MAIL")))))) + ; TODO: CC and BCC + ; TODO ;(test "Send message with a valid and an invalid recipient" (lambda () ; (let @@ -229,7 +237,85 @@ )) - (capability 'crlf-injection-detection (list + (capability 'headers (list + + (define smtp-connection '()) + (define (connect-smtp-server) + (set! smtp-connection (sendmail-connect "localhost" (server-port server)))) + + (setup (lambda () + (set! server (start-mock-server)) + (connect-smtp-server))) + + (tearDown (lambda () + (sendmail-disconnect smtp-connection) + (set! smtp-connection '()))) + + (test "set basic header" (lambda () + (sendmail-send-message-with-headers smtp-connection "message content" "sender@sender.to" '("user@recipient.to") (alist->hash-table '(("x-my-header" "some value")))) + (assert (server-message-contains? "x-my-header: some value") (string-append "Expected x-my-header to be present, but instead got " (server-message-data server))))) + + (test "set header with unicode value" (lambda () + (sendmail-send-message-with-headers smtp-connection "message content" "sender@sender.to" '("user@recipient.to") (alist->hash-table '(("x-my-header" "¡some value")))) + (assert + (or + (server-message-contains? "x-my-header: =?utf-8?q?=C2=A1some?= value") + (server-message-contains? "x-my-header: =?utf-8?b?wqFzb21lIHZhbHVl?=") + (server-message-contains? "x-my-header: =?UTF-8?Q?=C2=A1some?= value") + (server-message-contains? "x-my-header: =?UTF-8?B?wqFzb21lIHZhbHVl?=")) + (string-append "Expected x-my-header to contain encoded ¡, but instead got " (server-message-data server))) + (assert + (server-message-contains? "message content") + (string-append "Expected message content to be unaltered by unicode header value, but instead got" (server-message-data server))))) + + (test "set override standard header" (lambda () + (sendmail-send-message-with-headers smtp-connection "message content" "sender@sender.to" '("user@recipient.to") (alist->hash-table '(("To" "another-user@recipient.to")))) + (assert (server-message-contains? "To: another-user@recipient.to") (string-append "Expected To header field to include another-user..., but instead got " (server-message-data server))))) + + (capability 'crlf-injection (list + + (capability 'detection (list + + (data-test "CRLF detection in basic header value" + '(("1some\rvalue") ("2some\nvalue") ("3some\r\nvalue")) + (lambda (header-value) + (let + ((responses (sendmail-send-message-with-headers smtp-connection "message content" "sender@sender.to" '("user@recipient.to") (alist->hash-table (list (list "x-my-header" header-value)))))) + (assert (all? send-error? responses) (string-append "The header value: " header-value " should have resulted in error but did not:" responses))))) + + (data-test "CRLF detection in unicode header value" + '(("1¡some\rvalue") ("2¡some\nvalue") ("3¡some\r\nvalue")) + (lambda (header-value) + (let + ((responses (sendmail-send-message-with-headers smtp-connection "message content" "sender@sender.to" '("user@recipient.to") (alist->hash-table (list (list "x-my-header" header-value)))))) + (assert (all? send-error? responses) (string-append "The header value: " header-value " should have resulted in error but did not:" responses))))) + + )) + + (capability 'mitigation (list + + (data-test "CRLF mitigation in basic header value" + '(("1some\rvalue") ("2some\nvalue") ("3some\r\nvalue")) + (lambda (header-value) + (let + ((responses (sendmail-send-message-with-headers smtp-connection "message content" "sender@sender.to" '("user@recipient.to") (alist->hash-table (list (list "x-my-header" header-value)))))) + (assert (all? send-success? responses) (string-append "Message was not sent successfully, instead got: " responses)) + (assert (not (server-message-contains? header-value)) (string-append "The header value: " header-value " should have been stripped of CRLF but did not:" (server-message-data server)))))) + + (data-test "CRLF mitigation in unicode header value" + '(("1¡some \rvalue" "\rvalue") ("2¡some \nvalue" "\nvalue") ("3¡some \r\nvalue" "\r\nvalue")) + (lambda (header-value fragment) + (let + ((responses (sendmail-send-message-with-headers smtp-connection "message content" "sender@sender.to" '("user@recipient.to") (alist->hash-table (list (list "x-my-header" header-value)))))) + (assert (all? send-success? responses) (string-append "Message was not sent successfully, instead got: " responses)) + (assert (not (server-message-contains? fragment)) (string-append "The header value: " header-value " should have been stripped of CRLF but did not: " (server-message-data server)))))) + + )) + )) + + )) + + (capability 'general-crlf-injection (list (define smtp-connection '()) (define (connect-smtp-server) @@ -320,9 +406,6 @@ (sendmail-disconnect smtp-connection) (set! smtp-connection '()))) - (define (server-message-data-contains content) - (string-contains? content (server-message-data server))) - (capability '8bitmime (list (define (activate-8bitmime server) @@ -346,7 +429,7 @@ smtp-connection "¡a test message containing unicode!" "sender@sender.com" '("user@recipient.com") '() '()))) (assert (all? send-success? send-message-responses)) (assert - (not (server-message-data-contains "¡a test message containing unicode!"))) + (not (server-message-contains? "¡a test message containing unicode!"))) (string-append "Expected server to receive message with unicode content encoded, but received: " (server-message-data server))))) @@ -358,7 +441,7 @@ (assert (all? send-success? send-message-responses)) (assert-any-request server "MAIL FROM: BODY=8BITMIME") (assert - (server-message-contains "¡a test message containing unicode!") + (server-message-contains? "¡a test message containing unicode!") (string-append "Expected server to receive message with unicode content directly, but received: " (server-message-data server)))))) @@ -373,7 +456,7 @@ smtp-connection "¡a test message containing unicode!" "sender@sender.com" '("user@recipient.com") '() '()))) (assert-any-request server "MAIL FROM:") (assert - (not (server-message-contains "¡a test message containing unicode!")) + (not (server-message-contains? "¡a test message containing unicode!")) (string-append "Expected server to receive message with unicode content directly, but received: " (server-message-data server)))))) @@ -385,7 +468,7 @@ (assert (all? send-success? send-message-responses)) (assert-any-request server "MAIL FROM: BODY=8BITMIME") (assert - (server-message-contains "¡a test message containing unicode!") + (server-message-contains? "¡a test message containing unicode!") (string-append "Expected server to receive message with unicode content directly, but received: " (server-message-data server)))))) From ff06fbb121ea51eba933f751ab8171790ea585ec Mon Sep 17 00:00:00 2001 From: patrick Date: Mon, 14 Apr 2025 15:19:42 +0200 Subject: [PATCH 3/5] Fixes a defect in alist->hash-table --- rosetta-test/interpreter-tests.json | 3 ++- rosetta-test/stdlib.scm | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/rosetta-test/interpreter-tests.json b/rosetta-test/interpreter-tests.json index 01549df..0daa483 100644 --- a/rosetta-test/interpreter-tests.json +++ b/rosetta-test/interpreter-tests.json @@ -115,5 +115,6 @@ {"input": "(hash-table-walk ht (lambda (key value) key))", "expected": null}, {"input": "(begin (hash-table-ref! ht 'c 3) (hash-table-ref ht 'c))", "expected": 3}, {"input": "(hash-table->alist ht)", "expected": [["b", 2], ["c", 3]]}, - {"input": "(hash-table->alist (make-hash-table))", "expected": []} + {"input": "(hash-table->alist (make-hash-table))", "expected": []}, + {"input": "(hash-table-ref (alist->hash-table '((a 10) (b 20))) 'b)", "expected": 20} ] \ No newline at end of file diff --git a/rosetta-test/stdlib.scm b/rosetta-test/stdlib.scm index ea0dbeb..924eef1 100644 --- a/rosetta-test/stdlib.scm +++ b/rosetta-test/stdlib.scm @@ -218,7 +218,7 @@ (define ht (make-hash-table)) (for-each (lambda (pair) - (hash-table-set! ht (car pair) (cdr pair))) + (hash-table-set! ht (car pair) (car (cdr pair)))) alist) ht) From b63195cb0c27c700ba96d2a9face4a0b24937320 Mon Sep 17 00:00:00 2001 From: patrick Date: Mon, 14 Apr 2025 15:21:07 +0200 Subject: [PATCH 4/5] Removes some superfluous begins in sendmail suite --- rosetta-test-suites/sendmail.ros | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/rosetta-test-suites/sendmail.ros b/rosetta-test-suites/sendmail.ros index 71a66f6..1c692a1 100644 --- a/rosetta-test-suites/sendmail.ros +++ b/rosetta-test-suites/sendmail.ros @@ -188,12 +188,12 @@ ("502 SYNTAX ERROR") ("530 AUTH ERROR") ("520 FATAL ERROR")) - (lambda (response-code) (begin + (lambda (response-code) (server-set-response-code! server response-code) (let ((responses (sendmail-send-message smtp-connection "failure content" "sender@sender.to" '("user@recipient.to")))) - (assert (all? send-error? responses) (string-append "Expected client to fail when server responds with error:" response-code)))))) + (assert (all? send-error? responses) (string-append "Expected client to fail when server responds with error:" response-code))))) (capability 'handle-421 (list ; As send-message handles multiple commands and responses, it also needs to deal with responses that @@ -348,18 +348,18 @@ (data-test "CRLF detection in send-message sender" '(("foo\r\nbar@email.com") ("foo\nbar@email.com") ("foo\rbar@email.com")) - (lambda (sender-string) (begin + (lambda (sender-string) (let ((responses (sendmail-send-message smtp-connection "message content" sender-string '("user@recipient.to")))) (display responses) - (assert (all? send-error? responses) (string-append "Expected client to fail when CR or LF is in sender of send-message: " sender-string)))))) + (assert (all? send-error? responses) (string-append "Expected client to fail when CR or LF is in sender of send-message: " sender-string))))) (data-test "CRLF detection in send-message recipient" '(("foo\r\nbar@email.com") ("foo\nbar@email.com") ("foo\rbar@email.com")) - (lambda (recipient-string) (begin + (lambda (recipient-string) (let ((responses (sendmail-send-message smtp-connection "message content" "sender@email.com" (list recipient-string)))) - (assert (all? send-error? responses) (string-append "Expected client to fail when CR or LF is in recipient of send-message: " recipient-string)))))) + (assert (all? send-error? responses) (string-append "Expected client to fail when CR or LF is in recipient of send-message: " recipient-string))))) )) @@ -367,7 +367,7 @@ (data-test "CRLF mitigation in send-message sender" '(("foo\r\nbar@email.com" "\r\n") ("foo\nbar@email.com" "\n") ("foo\rbar@email.com" "\r")) - (lambda (sender-string injection) (begin + (lambda (sender-string injection) (let ((responses (sendmail-send-message smtp-connection "message content" sender-string '("user@recipient.to")))) (assert (all? send-success? responses)) @@ -375,11 +375,11 @@ (all? (lambda (c) (not (string-index c injection))) (server-requests-with-command server "MAIL")) - (string-append "Expected client to remove CR or LF or both from sender of send-message: " sender-string)))))) + (string-append "Expected client to remove CR or LF or both from sender of send-message: " sender-string))))) (data-test "CRLF mitigation in send-message recipient" '(("foo\r\nbar@email.com" "\r\n") ("foo\nbar@email.com" "\n") ("foo\rbar@email.com" "\r")) - (lambda (recipient-string injection) (begin + (lambda (recipient-string injection) (let ((responses (sendmail-send-message smtp-connection "message content" "sender@email.com" (list recipient-string)))) (assert (all? send-success? responses)) @@ -387,7 +387,7 @@ (all? (lambda (c) (not (string-index c injection))) (server-requests-with-command server "RCPT")) - (string-append "Expected client to remove CR or LF or both from recipients of send-message: " recipient-string)))))) + (string-append "Expected client to remove CR or LF or both from recipients of send-message: " recipient-string))))) )) )) From c14ea6631b512191540a541778646aaf843c51de Mon Sep 17 00:00:00 2001 From: patrick Date: Mon, 14 Apr 2025 15:40:49 +0200 Subject: [PATCH 5/5] Adds tests for sending message to cc and bcc recipients --- rosetta-test-suites/sendmail.ros | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/rosetta-test-suites/sendmail.ros b/rosetta-test-suites/sendmail.ros index 1c692a1..dfe39b1 100644 --- a/rosetta-test-suites/sendmail.ros +++ b/rosetta-test-suites/sendmail.ros @@ -176,7 +176,29 @@ (server-requests-with-command server "MAIL")) (string-append "Expected client to send empty sender: " (server-requests-with-command server "MAIL")))))) - ; TODO: CC and BCC + (test "Send a message to cc recipients" (lambda () + (let + ((responses (sendmail-send-message-full smtp-connection "message content" "sender@sender.to" '() '("user1@recipient.to") '() (make-hash-table) '() '()))) + (assert (all? send-success? responses)) + (assert (server-message-contains? "user1@recipient.to")) + (assert + (any? + (lambda (request) + (string-prefix-ci? "TO:" (first (request-arguments request)))) + (server-requests-with-command server "RCPT")) + (string-append "Expected client to send RCPT command for cc recipients: " (server-requests-with-command server "RCPT")))))) + + (test "Send a message to bcc recipients" (lambda () + (let + ((responses (sendmail-send-message-full smtp-connection "message content" "sender@sender.to" '() '() '("user1@recipient.to") (make-hash-table) '() '()))) + (assert (all? send-success? responses)) + (assert (not (server-message-contains? "user1@recipient.to"))) + (assert + (any? + (lambda (request) + (string-prefix-ci? "TO:" (first (request-arguments request)))) + (server-requests-with-command server "RCPT")) + (string-append "Expected client to send RCPT command for bcc recipients: " (server-requests-with-command server "RCPT")))))) ; TODO ;(test "Send message with a valid and an invalid recipient" (lambda ()