Commit6bf97abdRecorded30 Mar 2026Repositorysigil-ses
Initial sigil-ses library implementation
Message
SES v2 API client with AWS SigV4 signing, email sending, suppression list management, account info, identity verification, and SNS bounce/complaint notification parsing.
- (ses auth): Full SigV4 implementation verified against AWS test vectors - (ses): Client with send-email, send-bulk-email, suppression CRUD, get-account, get-identity - (ses notify): Stateless SNS notification parser with typed records - 24 unit tests passing, integration tested against live SES API
Changed
.gitignore | 1 +
README.md | 103 +++++++++++++++++++++++++++++++++++++++++++++++++++
dev-redirects.sgl | 6 +++
examples/integration-test.sgl | 40 ++++++++++++++++++++
package.sgl | 41 ++++++++++++++++++++
src/ses.sgl | 331 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/ses/auth.sgl | 235 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/ses/notify.sgl | 115 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/ses-test.sgl | 298 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
9 files changed, 1170 insertions(+)Diff
.gitignoreadded
@@ -0,0 +1 @@
+1
build/README.mdadded
@@ -0,0 +1,103 @@
+1
# sigil-ses+2
+3
A Sigil library for the [Amazon SES v2](https://docs.aws.amazon.com/ses/latest/APIReference-V2/) API. Send email, manage suppression lists, and parse bounce/complaint notifications.+4
+5
## Features+6
+7
- **Send email** -- simple text/HTML emails with To/Cc/Bcc/Reply-To support+8
- **Bulk email** -- send to multiple recipients with template substitution+9
- **Suppression list** -- add, remove, query, and list suppressed addresses+10
- **Account info** -- sending quota, daily usage, enforcement status+11
- **Identity verification** -- check domain/email DKIM and MAIL FROM status+12
- **Bounce/complaint parsing** -- stateless SNS notification parsing with typed records+13
- **AWS SigV4 signing** -- full implementation of AWS Signature Version 4+14
+15
## Usage+16
+17
```scheme+18
(import (ses))+19
+20
;; Create a client (defaults to us-east-2 region)+21
(define client (ses-client access-key-id: "AKIA..."+22
secret-access-key: "wJalr..."))+23
+24
;; Send a simple email+25
(ses-send-email client+26
"[email protected]"+27
"[email protected]"+28
"Hello from Sigil"+29
"This is the plain text body."+30
html: "<h1>Hello from Sigil</h1><p>HTML body here.</p>"+31
reply-to: "[email protected]")+32
+33
;; Send to multiple recipients+34
(ses-send-email client+35
"[email protected]"+36
'("[email protected]" "[email protected]")+37
"Newsletter #42"+38
"Plain text content."+39
html: "<p>Newsletter content.</p>"+40
bcc: '("[email protected]"))+41
+42
;; Check account quota+43
(let ((acct (ses-get-account client)))+44
(display (ses-account-send-quota acct))+45
(display (ses-account-sent-last-24h acct)))+46
+47
;; Manage suppression list+48
(ses-put-suppressed client "[email protected]" "BOUNCE")+49
(ses-list-suppressed client)+50
(ses-delete-suppressed client "[email protected]")+51
+52
;; Check domain identity+53
(let ((id (ses-get-identity client "systemcrafters.net")))+54
(ses-identity-verified? id)+55
(ses-identity-dkim-status id))+56
```+57
+58
## Bounce/Complaint Notifications+59
+60
Parse SNS notifications from SES:+61
+62
```scheme+63
(import (ses notify))+64
+65
;; In your webhook handler, parse the SNS JSON body:+66
(let ((notif (parse-ses-notification json-body)))+67
(when notif+68
(cond+69
((ses-hard-bounce? notif)+70
;; Remove permanently bounced addresses+71
(for-each remove-subscriber (ses-notification-addresses notif)))+72
((ses-complaint? notif)+73
;; Unsubscribe complainers+74
(for-each unsubscribe (ses-notification-addresses notif))))))+75
```+76
+77
## Configuration+78
+79
SES requires AWS credentials with `ses:SendEmail` and related IAM permissions.+80
+81
Environment variables (load with your preferred method):+82
- `AWS_ACCESS_KEY_ID`+83
- `AWS_SECRET_ACCESS_KEY`+84
- `AWS_REGION` (optional, defaults to us-east-2)+85
+86
## Dependencies+87
+88
- sigil-stdlib+89
- sigil-tls+90
- sigil-http+91
- sigil-json+92
- sigil-crypto+93
+94
## Building+95
+96
```+97
sigil build --redirects dev-redirects.sgl+98
sigil test+99
```+100
+101
## License+102
+103
BSD-3-Clausedev-redirects.sgladded
@@ -0,0 +1,6 @@
+1
;; Development redirects — point dependencies at local checkouts+2
(redirects+3
repos: (list+4
(for-repo+5
url: "codeberg:sigil/sigil"+6
use: (from-path dir: "../sigil"))))examples/integration-test.sgladded
@@ -0,0 +1,40 @@
+1
;;; Integration test — sends a real email via SES+2
;;; Requires: AWS_ACCESS_KEY_ID, AWS_SECRET_ACCESS_KEY, AWS_REGION env vars+3
;;; Run: SIGIL_REDIRECTS=dev-redirects.sgl sigil eval -f examples/integration-test.sgl+4
+5
(import (sigil core)+6
(only (sigil process) getenv)+7
(ses))+8
+9
(define client+10
(ses-client access-key-id: (getenv "AWS_ACCESS_KEY_ID")+11
secret-access-key: (getenv "AWS_SECRET_ACCESS_KEY")+12
region: (or (getenv "AWS_REGION") "us-east-2")))+13
+14
;; Test 1: Get account info+15
(display "=== Account Info ===\n")+16
(let ((acct (ses-get-account client)))+17
(display "Send quota: ") (display (ses-account-send-quota acct)) (newline)+18
(display "Send rate: ") (display (ses-account-send-rate acct)) (newline)+19
(display "Sent last 24h: ") (display (ses-account-sent-last-24h acct)) (newline)+20
(display "Status: ") (display (ses-account-enforcement-status acct)) (newline))+21
+22
;; Test 2: Check identity+23
(display "\n=== Identity Check ===\n")+24
(let ((id (ses-get-identity client "systemcrafters.net")))+25
(display "Domain: ") (display (ses-identity-name id)) (newline)+26
(display "Verified: ") (display (ses-identity-verified? id)) (newline)+27
(display "DKIM: ") (display (ses-identity-dkim-status id)) (newline)+28
(display "MAIL FROM: ") (display (ses-identity-mail-from-status id)) (newline))+29
+30
;; Test 3: Send a test email+31
(display "\n=== Sending Test Email ===\n")+32
(let ((result (ses-send-email client+33
"[email protected]"+34
"[email protected]"+35
"sigil-ses integration test"+36
"This email was sent by the sigil-ses library integration test."+37
html: "<h2>sigil-ses Integration Test</h2><p>This email was sent by the <code>sigil-ses</code> library.</p>")))+38
(display "Message ID: ") (display (ses-email-result-message-id result)) (newline))+39
+40
(display "\nDone!\n")package.sgladded
@@ -0,0 +1,41 @@
+1
;;; sigil-ses - Amazon SES v2 API client library for Sigil+2
;;;+3
;;; Provides functions for sending email, managing suppression lists,+4
;;; and parsing bounce/complaint notifications via Amazon SES.+5
+6
(define sigil-repo "codeberg:sigil/sigil#v0.8.0")+7
+8
(package+9
name: "sigil-ses"+10
version: "0.1.0"+11
description: "Amazon SES v2 API client library for Sigil"+12
url: "https://codeberg.org/sigil/sigil-ses"+13
license: "BSD-3-Clause"+14
authors: (list "David Wilson <[email protected]>")+15
+16
configs: (list+17
(config+18
name: 'dev+19
output-dir: "build/dev"+20
debug?: #t+21
optimize: 0)+22
(config+23
name: 'release+24
output-dir: "build/release"+25
debug?: #f+26
optimize: 2))+27
+28
dependencies: (list+29
(from-git url: sigil-repo package: "sigil-stdlib")+30
(from-git url: sigil-repo package: "sigil-tls")+31
(from-git url: sigil-repo package: "sigil-http")+32
(from-git url: sigil-repo package: "sigil-json")+33
(from-git url: sigil-repo package: "sigil-crypto"))+34
+35
tasks: (list+36
(task+37
name: 'build+38
description: "Compile sigil-ses modules"+39
steps: (list+40
(compile-sigil-modules sources: "src/**/*.sgl"+41
output-dir: (config-output-subdir "lib"))))))src/ses.sgladded
@@ -0,0 +1,331 @@
+1
;;; (ses) - Amazon SES v2 API client library.+2
;;;+3
;;; Provides functions for sending email, managing suppression lists,+4
;;; checking account quotas, and verifying domain identities via the+5
;;; Amazon SES v2 REST API.+6
+7
(define-library (ses)+8
(import (sigil core)+9
(sigil dict)+10
(sigil string)+11
(sigil struct)+12
(sigil json)+13
(only (sigil array) array-map)+14
(only (sigil http) url-encode-value)+15
(sigil http client)+16
(ses auth))+17
+18
(export ;; Client+19
ses-client+20
ses-client?+21
ses-client-access-key-id+22
ses-client-secret-access-key+23
ses-client-region+24
+25
;; Records+26
ses-email-result+27
ses-email-result?+28
ses-email-result-message-id+29
+30
ses-account+31
ses-account?+32
ses-account-send-quota+33
ses-account-send-rate+34
ses-account-sent-last-24h+35
ses-account-enforcement-status+36
+37
ses-suppressed-address+38
ses-suppressed-address?+39
ses-suppressed-address-email+40
ses-suppressed-address-reason+41
ses-suppressed-address-last-update+42
+43
ses-identity+44
ses-identity?+45
ses-identity-name+46
ses-identity-verified?+47
ses-identity-dkim-status+48
ses-identity-mail-from-status+49
+50
;; API functions+51
ses-send-email+52
ses-send-bulk-email+53
ses-get-account+54
ses-list-suppressed+55
ses-get-suppressed+56
ses-put-suppressed+57
ses-delete-suppressed+58
ses-get-identity+59
+60
;; Parsing (exported for testing)+61
parse-account+62
parse-suppressed-address+63
parse-identity)+64
+65
(begin+66
+67
;; ---------------------------------------------------------------+68
;; Client record+69
;; ---------------------------------------------------------------+70
+71
(define-struct ses-client+72
(access-key-id)+73
(secret-access-key)+74
(region default: "us-east-2"))+75
+76
;; ---------------------------------------------------------------+77
;; Response records+78
;; ---------------------------------------------------------------+79
+80
(define-struct ses-email-result+81
(message-id))+82
+83
(define-struct ses-account+84
(send-quota)+85
(send-rate)+86
(sent-last-24h)+87
(enforcement-status))+88
+89
(define-struct ses-suppressed-address+90
(email)+91
(reason)+92
(last-update))+93
+94
(define-struct ses-identity+95
(name)+96
(verified?)+97
(dkim-status)+98
(mail-from-status))+99
+100
;; ---------------------------------------------------------------+101
;; Internal helpers+102
;; ---------------------------------------------------------------+103
+104
;;; Build the SES v2 API host for the client's region.+105
(define (ses-host client)+106
(string-append "email." (ses-client-region client) ".amazonaws.com"))+107
+108
;;; Response checker for SES API errors.+109
(define check-ses-response+110
(make-response-checker+111
name: "SES API"+112
handlers: (list+113
(cons 400 "Bad request. Check request parameters.")+114
(cons 403 "Access denied. Check IAM permissions and credentials.")+115
(cons 404 "Resource not found.")+116
(cons 429 "Sending rate exceeded. Retry after a delay.")+117
(cons 503 "Service unavailable. Retry after a delay."))))+118
+119
;;; Make a signed request to the SES v2 API.+120
;;; Returns parsed JSON response, or #t for empty responses.+121
(define (ses-request client method path payload-dict . rest)+122
(let* ((query (if (null? rest) "" (car rest)))+123
(host (ses-host client))+124
(body (if payload-dict (json-encode payload-dict) ""))+125
(extra-headers (if payload-dict+126
#{ content-type: "application/json" }+127
#{}))+128
(signed-headers (sigv4-sign-request+129
(ses-client-access-key-id client)+130
(ses-client-secret-access-key client)+131
(ses-client-region client)+132
"ses"+133
method host path query+134
extra-headers body))+135
(url (string-append "https://" host path+136
(if (string=? query "") ""+137
(string-append "?" query)))))+138
(check-ses-response+139
(cond+140
((string=? method "POST")+141
(http-post url body headers: signed-headers))+142
((string=? method "GET")+143
(http-get url headers: signed-headers))+144
((string=? method "PUT")+145
(http-put url body headers: signed-headers))+146
((string=? method "DELETE")+147
(http-delete url headers: signed-headers))+148
(else (error "ses-request: unsupported method" method))))))+149
+150
;; ---------------------------------------------------------------+151
;; Response parsing+152
;; ---------------------------------------------------------------+153
+154
;;; Parse the account info response.+155
(define (parse-account data)+156
(let ((quota (dict-ref data SendQuota: #{})))+157
(ses-account+158
send-quota: (dict-ref quota Max24HourSend: 0)+159
send-rate: (dict-ref quota MaxSendRate: 0)+160
sent-last-24h: (dict-ref quota SentLast24Hours: 0)+161
enforcement-status: (dict-ref data EnforcementStatus: ""))))+162
+163
;;; Parse a suppressed address entry.+164
(define (parse-suppressed-address data)+165
(ses-suppressed-address+166
email: (dict-ref data EmailAddress: "")+167
reason: (dict-ref data Reason: "")+168
last-update: (dict-ref data LastUpdateTime: "")))+169
+170
;;; Parse an identity (domain/email) info response.+171
(define (parse-identity name data)+172
(let ((dkim (dict-ref data DkimAttributes: #{}))+173
(mail-from (dict-ref data MailFromAttributes: #{})))+174
(ses-identity+175
name: name+176
verified?: (dict-ref data VerifiedForSendingStatus: #f)+177
dkim-status: (dict-ref dkim Status: "")+178
mail-from-status: (dict-ref mail-from MailFromDomainStatus: ""))))+179
+180
;; ---------------------------------------------------------------+181
;; Email sending+182
;; ---------------------------------------------------------------+183
+184
;;; Send a simple email via SES v2.+185
;;;+186
;;; Parameters:+187
;;; client: ses-client record+188
;;; from: sender email address (string)+189
;;; to: recipient(s) — string or list of strings+190
;;; subject: email subject line (string)+191
;;; body: plain text body (string)+192
;;;+193
;;; Keyword arguments:+194
;;; html: HTML body (string or #f)+195
;;; cc: CC recipients — string or list of strings+196
;;; bcc: BCC recipients — string or list of strings+197
;;; reply-to: reply-to addresses — string or list of strings+198
;;; list-unsubscribe: List-Unsubscribe header URL (string or #f)+199
;;;+200
;;; Returns an ses-email-result record with the message ID.+201
(define (ses-send-email client from to subject body . args)+202
(let* ((kw-args (cdr (split-keyword-args args)))+203
(html (keyword-ref kw-args html: #f))+204
(cc (keyword-ref kw-args cc: '()))+205
(bcc (keyword-ref kw-args bcc: '()))+206
(reply-to (keyword-ref kw-args reply-to: '()))+207
(list-unsub (keyword-ref kw-args list-unsubscribe: #f)))+208
(let* ((to-list (ensure-list to))+209
(cc-list (ensure-list cc))+210
(bcc-list (ensure-list bcc))+211
(reply-list (ensure-list reply-to))+212
(body-dict (let ((d #{ Text: #{ Data: body Charset: "UTF-8" } }))+213
(if html+214
(dict-set d Html: #{ Data: html Charset: "UTF-8" })+215
d)))+216
(payload #{ FromEmailAddress: from+217
Destination: #{ ToAddresses: (list->array to-list)+218
CcAddresses: (list->array cc-list)+219
BccAddresses: (list->array bcc-list) }+220
Content: #{ Simple: #{ Subject: #{ Data: subject+221
Charset: "UTF-8" }+222
Body: body-dict } } })+223
(payload (if (null? reply-list)+224
payload+225
(dict-set payload+226
ReplyToAddresses: (list->array reply-list))))+227
(payload (if list-unsub+228
(dict-set payload+229
ListManagementOptions:+230
#{ ContactListName: list-unsub })+231
payload))+232
(result (ses-request client "POST"+233
"/v2/email/outbound-emails" payload)))+234
(ses-email-result+235
message-id: (dict-ref result MessageId: "")))))+236
+237
;;; Ensure a value is a list. Strings become single-element lists.+238
(define (ensure-list v)+239
(cond+240
((list? v) v)+241
((string? v) (list v))+242
(else '())))+243
+244
;;; Send bulk email via SES v2.+245
;;;+246
;;; Parameters:+247
;;; client: ses-client record+248
;;; from: sender email address+249
;;; subject: default subject line+250
;;; html-template: HTML template with {{var}} placeholders+251
;;; text-template: plain text template with {{var}} placeholders+252
;;; entries: list of dicts, each with Destination: and+253
;;; ReplacementEmailContent: fields+254
;;;+255
;;; Returns the raw API response dict.+256
(define (ses-send-bulk-email client from subject+257
html-template text-template entries)+258
(let ((payload+259
#{ FromEmailAddress: from+260
DefaultContent:+261
#{ Template:+262
#{ TemplateName: "inline"+263
TemplateContent:+264
#{ Subject: subject+265
Html: html-template+266
Text: text-template } } }+267
BulkEmailEntries: (list->array entries) }))+268
(ses-request client "POST"+269
"/v2/email/outbound-bulk-emails" payload)))+270
+271
;; ---------------------------------------------------------------+272
;; Account info+273
;; ---------------------------------------------------------------+274
+275
;;; Get SES account sending quota and usage info.+276
;;; Returns an ses-account record.+277
(define (ses-get-account client)+278
(let ((data (ses-request client "GET" "/v2/email/account" #f)))+279
(parse-account data)))+280
+281
;; ---------------------------------------------------------------+282
;; Suppression list management+283
;; ---------------------------------------------------------------+284
+285
;;; List suppressed email addresses.+286
;;; Returns a list of ses-suppressed-address records.+287
(define (ses-list-suppressed client)+288
(let ((data (ses-request client "GET"+289
"/v2/email/suppression/addresses" #f)))+290
(let ((items (dict-ref data SuppressedDestinationSummaries: #[])))+291
(if (array? items)+292
(array->list+293
(array-map parse-suppressed-address items))+294
'()))))+295
+296
;;; Get details for a specific suppressed address.+297
;;; Returns an ses-suppressed-address record.+298
(define (ses-get-suppressed client email)+299
(let ((data (ses-request client "GET"+300
(string-append "/v2/email/suppression/addresses/"+301
(url-encode-value email))+302
#f)))+303
(let ((dest (dict-ref data SuppressedDestination: data)))+304
(parse-suppressed-address dest))))+305
+306
;;; Add an email address to the suppression list.+307
;;; reason: "BOUNCE" or "COMPLAINT"+308
(define (ses-put-suppressed client email reason)+309
(ses-request client "PUT" "/v2/email/suppression/addresses"+310
#{ EmailAddress: email+311
Reason: reason }))+312
+313
;;; Remove an email address from the suppression list.+314
(define (ses-delete-suppressed client email)+315
(ses-request client "DELETE"+316
(string-append "/v2/email/suppression/addresses/"+317
(url-encode-value email))+318
#f))+319
+320
;; ---------------------------------------------------------------+321
;; Identity verification+322
;; ---------------------------------------------------------------+323
+324
;;; Get identity (domain or email) verification status.+325
;;; Returns an ses-identity record.+326
(define (ses-get-identity client identity)+327
(let ((data (ses-request client "GET"+328
(string-append "/v2/email/identities/"+329
(url-encode-value identity))+330
#f)))+331
(parse-identity identity data)))))src/ses/auth.sgladded
@@ -0,0 +1,235 @@
+1
;;; (ses auth) - AWS Signature Version 4 signing for SES requests.+2
;;;+3
;;; Implements the SigV4 signing algorithm used to authenticate all+4
;;; AWS API requests. Reference:+5
;;; https://docs.aws.amazon.com/IAM/latest/UserGuide/reference_sigv4-signer.html+6
+7
(define-library (ses auth)+8
(import (sigil core)+9
(sigil string)+10
(sigil dict)+11
(sigil list)+12
(sigil math)+13
(sigil crypto)+14
(only (sigil http) url-encode-value)+15
(only (sigil time) current-second time->list))+16
+17
(export sigv4-sign-request+18
;; Exported for testing+19
derive-signing-key+20
canonical-headers-pair+21
canonical-request+22
string-to-sign+23
format-amz-date+24
format-date-stamp+25
hex->bytevector)+26
+27
(begin+28
+29
;; ---------------------------------------------------------------+30
;; Hex/byte conversion helpers+31
;; ---------------------------------------------------------------+32
+33
;;; Convert a hex string to a bytevector.+34
;;; Used to chain HMAC operations where the output of one step+35
;;; becomes the key of the next step.+36
(define (hex->bytevector hex-str)+37
(let* ((len (string-length hex-str))+38
(bv (make-bytevector (/ len 2))))+39
(let loop ((i 0))+40
(if (>= i len)+41
bv+42
(begin+43
(bytevector-u8-set! bv (/ i 2)+44
(string->number (substring hex-str i (+ i 2)) 16))+45
(loop (+ i 2)))))))+46
+47
;; ---------------------------------------------------------------+48
;; Date formatting+49
;; ---------------------------------------------------------------+50
+51
;;; Zero-pad a number to the given width.+52
(define (zero-pad n width)+53
(let ((s (number->string n)))+54
(string-append (make-string (max 0 (- width (string-length s))) #\0)+55
s)))+56
+57
;;; Format a time list as YYYYMMDDTHHMMSSZ (ISO 8601 basic format).+58
;;; Time list format: (second minute hour day month year weekday yearday dst)+59
(define (format-amz-date time-list)+60
(let ((sec (list-ref time-list 0))+61
(min (list-ref time-list 1))+62
(hour (list-ref time-list 2))+63
(day (list-ref time-list 3))+64
(month (list-ref time-list 4))+65
(year (list-ref time-list 5)))+66
(string-append (zero-pad year 4)+67
(zero-pad month 2)+68
(zero-pad day 2)+69
"T"+70
(zero-pad hour 2)+71
(zero-pad min 2)+72
(zero-pad sec 2)+73
"Z")))+74
+75
;;; Format a time list as YYYYMMDD (date stamp for credential scope).+76
;;; Time list format: (second minute hour day month year weekday yearday dst)+77
(define (format-date-stamp time-list)+78
(let ((day (list-ref time-list 3))+79
(month (list-ref time-list 4))+80
(year (list-ref time-list 5)))+81
(string-append (zero-pad year 4)+82
(zero-pad month 2)+83
(zero-pad day 2))))+84
+85
;; ---------------------------------------------------------------+86
;; Canonical request building+87
;; ---------------------------------------------------------------+88
+89
;;; Sort and format headers for the canonical request.+90
;;; Returns (signed-headers-string . canonical-headers-string).+91
(define (canonical-headers-pair headers)+92
(let* ((entries (dict->alist headers))+93
(lower (map (lambda (entry)+94
(cons (string-downcase (symbol->string (car entry)))+95
(string-trim (cdr entry))))+96
entries))+97
(sorted (list-sort (lambda (a b)+98
(string<? (car a) (car b)))+99
lower)))+100
(cons+101
;; signed headers: semicolon-separated lowercase names+102
(string-join (map car sorted) ";")+103
;; canonical headers: name:value\n for each+104
(apply string-append+105
(map (lambda (entry)+106
(string-append (car entry) ":" (cdr entry) "\n"))+107
sorted)))))+108
+109
;;; Sort and format query string parameters.+110
;;; Input: query string without leading "?", or empty string.+111
;;; Returns the canonical query string (sorted by param name).+112
(define (canonical-query-string query-str)+113
(if (or (not query-str) (string=? query-str ""))+114
""+115
(let* ((pairs (map (lambda (p)+116
(let ((eq-pos (string-index p #\=)))+117
(if eq-pos+118
(cons (substring p 0 eq-pos)+119
(substring p (+ eq-pos 1)+120
(string-length p)))+121
(cons p ""))))+122
(string-split query-str #\&)))+123
(sorted (list-sort (lambda (a b)+124
(string<? (car a) (car b)))+125
pairs)))+126
(string-join (map (lambda (p)+127
(string-append (car p) "=" (cdr p)))+128
sorted)+129
"&"))))+130
+131
;;; Build the canonical request string from pre-computed header pair.+132
;;; headers-pair: result of canonical-headers-pair (signed-headers . canonical-headers)+133
(define (canonical-request method path query headers-pair payload-hash)+134
(string-append method "\n"+135
path "\n"+136
(canonical-query-string query) "\n"+137
(cdr headers-pair) "\n"+138
(car headers-pair) "\n"+139
payload-hash))+140
+141
;; ---------------------------------------------------------------+142
;; String to sign+143
;; ---------------------------------------------------------------+144
+145
;;; Build the string to sign for SigV4.+146
;;; amz-date: YYYYMMDDTHHMMSSZ format+147
;;; scope: date/region/service/aws4_request+148
;;; canonical-request-hash: SHA-256 hex hash of the canonical request+149
(define (string-to-sign amz-date scope canonical-request-hash)+150
(string-append "AWS4-HMAC-SHA256\n"+151
amz-date "\n"+152
scope "\n"+153
canonical-request-hash))+154
+155
;; ---------------------------------------------------------------+156
;; Signing key derivation+157
;; ---------------------------------------------------------------+158
+159
;;; Derive the SigV4 signing key.+160
;;; secret-key: AWS secret access key+161
;;; date-stamp: YYYYMMDD format+162
;;; region: AWS region (e.g., "us-east-2")+163
;;; service: AWS service (e.g., "ses")+164
(define (derive-signing-key secret-key date-stamp region service)+165
(let* ((k-date (hex->bytevector+166
(hmac-sha256 (string-append "AWS4" secret-key)+167
date-stamp)))+168
(k-region (hex->bytevector+169
(hmac-sha256 k-date region)))+170
(k-service (hex->bytevector+171
(hmac-sha256 k-region service)))+172
(k-signing (hex->bytevector+173
(hmac-sha256 k-service "aws4_request"))))+174
k-signing))+175
+176
;; ---------------------------------------------------------------+177
;; Request signing+178
;; ---------------------------------------------------------------+179
+180
;;; Sign an HTTP request using AWS SigV4.+181
;;; Returns a dict of headers with Authorization, X-Amz-Date, and Host added.+182
;;;+183
;;; Parameters:+184
;;; access-key-id: AWS access key ID+185
;;; secret-access-key: AWS secret access key+186
;;; region: AWS region+187
;;; service: AWS service name (e.g., "ses")+188
;;; method: HTTP method (e.g., "POST")+189
;;; host: hostname (e.g., "email.us-east-2.amazonaws.com")+190
;;; path: URL path (e.g., "/v2/email/outbound-emails")+191
;;; query: query string without leading "?" (or "")+192
;;; extra-headers: additional headers dict (content-type, etc.)+193
;;; payload: request body string (or "" for empty)+194
;;; time-list: optional time list override (for testing)+195
(define (sigv4-sign-request access-key-id secret-access-key+196
region service+197
method host path query+198
extra-headers payload+199
. rest)+200
(let* ((time-list (if (null? rest)+201
(time->list (current-second) #t) ; UTC+202
(car rest)))+203
(amz-date (format-amz-date time-list))+204
(date-stamp (format-date-stamp time-list))+205
(payload-hash (sha256 payload))+206
;; Build headers to sign (host + x-amz-date + extras)+207
(headers-to-sign (dict-merge+208
extra-headers+209
#{ host: host+210
x-amz-date: amz-date }))+211
;; Compute header pair once (used for both canonical request and auth header)+212
(headers-pair (canonical-headers-pair headers-to-sign))+213
;; Build canonical request+214
(creq (canonical-request method path query+215
headers-pair payload-hash))+216
(creq-hash (sha256 creq))+217
;; Build scope and string to sign+218
(scope (string-append date-stamp "/"+219
region "/"+220
service "/aws4_request"))+221
(sts (string-to-sign amz-date scope creq-hash))+222
;; Derive signing key and compute signature+223
(signing-key (derive-signing-key secret-access-key+224
date-stamp region service))+225
(signature (hmac-sha256 signing-key sts))+226
;; Build authorization header+227
(auth-header (string-append+228
"AWS4-HMAC-SHA256 "+229
"Credential=" access-key-id "/" scope ", "+230
"SignedHeaders=" (car headers-pair) ", "+231
"Signature=" signature)))+232
;; Return all headers needed for the request+233
(dict-merge headers-to-sign+234
#{ authorization: auth-header+235
x-amz-date: amz-date })))))src/ses/notify.sgladded
@@ -0,0 +1,115 @@
+1
;;; (ses notify) - SNS notification parsing for SES bounce/complaint events.+2
;;;+3
;;; SES sends bounce and complaint notifications via SNS as JSON POST+4
;;; requests to a webhook URL. This module provides stateless parsers+5
;;; that extract notification type, affected email addresses, and metadata.+6
+7
(define-library (ses notify)+8
(import (sigil core)+9
(sigil dict)+10
(sigil string)+11
(sigil struct)+12
(sigil json)+13
(only (sigil array) array-map))+14
+15
(export ;; Records+16
ses-notification+17
ses-notification?+18
ses-notification-type+19
ses-notification-addresses+20
ses-notification-bounce-type+21
ses-notification-bounce-sub-type+22
ses-notification-complaint-type+23
ses-notification-timestamp+24
ses-notification-feedback-id+25
ses-notification-raw+26
+27
;; Parsing+28
parse-ses-notification+29
+30
;; Predicates+31
ses-bounce?+32
ses-hard-bounce?+33
ses-complaint?)+34
+35
(begin+36
+37
;; ---------------------------------------------------------------+38
;; Notification record+39
;; ---------------------------------------------------------------+40
+41
(define-struct ses-notification+42
(type) ; "Bounce" or "Complaint"+43
(addresses) ; list of affected email addresses+44
(bounce-type) ; "Permanent", "Transient", etc. (bounces only)+45
(bounce-sub-type) ; "General", "NoEmail", etc. (bounces only)+46
(complaint-type) ; "abuse", "not-spam", etc. (complaints only)+47
(timestamp) ; ISO 8601 timestamp+48
(feedback-id) ; SES feedback ID for tracking+49
(raw)) ; original parsed dict for full access+50
+51
;; ---------------------------------------------------------------+52
;; Parsing+53
;; ---------------------------------------------------------------+54
+55
;;; Extract email addresses from a recipient array in a notification dict.+56
(define (extract-addresses dict key)+57
(let ((recipients (dict-ref dict key #[])))+58
(if (array? recipients)+59
(array->list+60
(array-map (lambda (r) (dict-ref r emailAddress: ""))+61
recipients))+62
'())))+63
+64
;;; Parse an SNS notification JSON dict into an ses-notification record.+65
;;; Accepts either a pre-parsed dict or a JSON string.+66
;;; Returns an ses-notification record, or #f if the notification type+67
;;; is not recognized (e.g., "Delivery" notifications).+68
(define (parse-ses-notification data)+69
(let ((parsed (if (string? data) (json-decode data) data)))+70
(let ((notif-type (dict-ref parsed notificationType: #f)))+71
(cond+72
((string=? notif-type "Bounce")+73
(let ((bounce (dict-ref parsed bounce: #{})))+74
(ses-notification+75
type: "Bounce"+76
addresses: (extract-addresses bounce bouncedRecipients:)+77
bounce-type: (dict-ref bounce bounceType: "")+78
bounce-sub-type: (dict-ref bounce bounceSubType: "")+79
complaint-type: #f+80
timestamp: (dict-ref bounce timestamp:+81
(dict-ref parsed timestamp: ""))+82
feedback-id: (dict-ref bounce feedbackId: "")+83
raw: parsed)))+84
((string=? notif-type "Complaint")+85
(let ((complaint (dict-ref parsed complaint: #{})))+86
(ses-notification+87
type: "Complaint"+88
addresses: (extract-addresses complaint complainedRecipients:)+89
bounce-type: #f+90
bounce-sub-type: #f+91
complaint-type: (dict-ref complaint complaintFeedbackType: "")+92
timestamp: (dict-ref complaint timestamp:+93
(dict-ref parsed timestamp: ""))+94
feedback-id: (dict-ref complaint feedbackId: "")+95
raw: parsed)))+96
(else #f)))))+97
+98
;; ---------------------------------------------------------------+99
;; Convenience predicates+100
;; ---------------------------------------------------------------+101
+102
;;; True if the notification is a bounce.+103
(define (ses-bounce? notif)+104
(and (ses-notification? notif)+105
(string=? (ses-notification-type notif) "Bounce")))+106
+107
;;; True if the notification is a permanent (hard) bounce.+108
(define (ses-hard-bounce? notif)+109
(and (ses-bounce? notif)+110
(string=? (ses-notification-bounce-type notif) "Permanent")))+111
+112
;;; True if the notification is a complaint.+113
(define (ses-complaint? notif)+114
(and (ses-notification? notif)+115
(string=? (ses-notification-type notif) "Complaint")))))test/ses-test.sgladded
@@ -0,0 +1,298 @@
+1
;;; Tests for sigil-ses+2
+3
(import (sigil core)+4
(sigil dict)+5
(sigil string)+6
(sigil struct)+7
(sigil json)+8
(sigil test)+9
(sigil crypto)+10
(ses)+11
(ses auth)+12
(ses notify))+13
+14
;; ---------------------------------------------------------------+15
;; SigV4 signing tests+16
;; ---------------------------------------------------------------+17
+18
;; AWS test vector values+19
;; Reference: https://docs.aws.amazon.com/general/latest/gr/sigv4-calculate-signature.html+20
(define test-access-key "AKIDEXAMPLE")+21
(define test-secret-key "wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY")+22
(define test-region "us-east-1")+23
(define test-service "iam")+24
;; 2015-08-30T12:36:00Z as a time list: (sec min hour day month year weekday yearday dst)+25
(define test-time-list '(0 36 12 30 8 2015 0 0 0))+26
+27
(test-group "date formatting"+28
+29
(test "format-amz-date"+30
(assert-equal "20150830T123600Z"+31
(format-amz-date test-time-list)))+32
+33
(test "format-date-stamp"+34
(assert-equal "20150830"+35
(format-date-stamp test-time-list))))+36
+37
(test-group "hex conversion"+38
+39
(test "hex->bytevector basic"+40
(let ((bv (hex->bytevector "deadbeef")))+41
(assert-equal 4 (bytevector-length bv))+42
(assert-equal #xde (bytevector-u8-ref bv 0))+43
(assert-equal #xad (bytevector-u8-ref bv 1))+44
(assert-equal #xbe (bytevector-u8-ref bv 2))+45
(assert-equal #xef (bytevector-u8-ref bv 3))))+46
+47
(test "hex->bytevector empty"+48
(let ((bv (hex->bytevector "")))+49
(assert-equal 0 (bytevector-length bv)))))+50
+51
(test-group "signing key derivation"+52
+53
(test "derive-signing-key matches AWS test vector"+54
;; Expected signing key for the AWS test vector:+55
;; Secret: wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY+56
;; Date: 20150830, Region: us-east-1, Service: iam+57
(let* ((key (derive-signing-key test-secret-key "20150830"+58
test-region test-service))+59
;; Convert to hex for comparison+60
(key-hex (apply string-append+61
(map (lambda (i)+62
(let ((b (bytevector-u8-ref key i)))+63
(string-append+64
(if (< b 16) "0" "")+65
(number->string b 16))))+66
(iota (bytevector-length key))))))+67
(assert-equal "c4afb1cc5771d871763a393e44b703571b55cc28424d1a5e86da6ed3c154a4b9"+68
key-hex))))+69
+70
(test-group "canonical request"+71
+72
(test "canonical request with headers"+73
(let* ((headers #{ host: "iam.amazonaws.com"+74
content-type: "application/x-www-form-urlencoded; charset=utf-8"+75
x-amz-date: "20150830T123600Z" })+76
(hp (canonical-headers-pair headers))+77
(creq (canonical-request "GET" "/" "" hp (sha256 ""))))+78
;; Verify it starts with GET and contains sorted headers+79
(assert-true (string-contains? creq "GET"))+80
(assert-true (string-contains? creq "content-type:application/x-www-form-urlencoded; charset=utf-8"))+81
(assert-true (string-contains? creq "host:iam.amazonaws.com"))+82
(assert-true (string-contains? creq "x-amz-date:20150830T123600Z")))))+83
+84
(test-group "full sigv4 signing"+85
+86
(test "sigv4-sign-request produces authorization header"+87
(let ((headers (sigv4-sign-request+88
test-access-key test-secret-key+89
test-region test-service+90
"GET" "iam.amazonaws.com" "/" ""+91
#{ content-type: "application/x-www-form-urlencoded; charset=utf-8" }+92
""+93
test-time-list)))+94
;; Check authorization header exists and has correct format+95
(let ((auth (dict-ref headers authorization:)))+96
(assert-true (string-starts-with? auth "AWS4-HMAC-SHA256 "))+97
(assert-true (string-contains? auth "Credential=AKIDEXAMPLE/20150830/us-east-1/iam/aws4_request"))+98
(assert-true (string-contains? auth "SignedHeaders="))+99
(assert-true (string-contains? auth "Signature=")))))+100
+101
(test "sigv4-sign-request includes x-amz-date"+102
(let ((headers (sigv4-sign-request+103
test-access-key test-secret-key+104
test-region "ses"+105
"POST" "email.us-east-2.amazonaws.com"+106
"/v2/email/outbound-emails" ""+107
#{ content-type: "application/json" }+108
"{\"test\": true}"+109
test-time-list)))+110
(assert-equal "20150830T123600Z"+111
(dict-ref headers x-amz-date:)))))+112
+113
;; ---------------------------------------------------------------+114
;; Client construction tests+115
;; ---------------------------------------------------------------+116
+117
(test-group "client construction"+118
+119
(test "default region"+120
(let ((c (ses-client access-key-id: "AK"+121
secret-access-key: "SK")))+122
(assert-true (ses-client? c))+123
(assert-equal "AK" (ses-client-access-key-id c))+124
(assert-equal "SK" (ses-client-secret-access-key c))+125
(assert-equal "us-east-2" (ses-client-region c))))+126
+127
(test "custom region"+128
(let ((c (ses-client access-key-id: "AK"+129
secret-access-key: "SK"+130
region: "eu-west-1")))+131
(assert-equal "eu-west-1" (ses-client-region c)))))+132
+133
;; ---------------------------------------------------------------+134
;; Response parsing tests+135
;; ---------------------------------------------------------------+136
+137
(test-group "account parsing"+138
+139
(test "parse account info"+140
(let ((data #{ SendQuota: #{ Max24HourSend: 50000+141
MaxSendRate: 14+142
SentLast24Hours: 127 }+143
EnforcementStatus: "HEALTHY" }))+144
(let ((acct (parse-account data)))+145
(assert-true (ses-account? acct))+146
(assert-equal 50000 (ses-account-send-quota acct))+147
(assert-equal 14 (ses-account-send-rate acct))+148
(assert-equal 127 (ses-account-sent-last-24h acct))+149
(assert-equal "HEALTHY" (ses-account-enforcement-status acct))))))+150
+151
(test-group "suppressed address parsing"+152
+153
(test "parse suppressed address"+154
(let ((data #{ EmailAddress: "[email protected]"+155
Reason: "BOUNCE"+156
LastUpdateTime: "2026-03-15T10:00:00Z" }))+157
(let ((addr (parse-suppressed-address data)))+158
(assert-true (ses-suppressed-address? addr))+159
(assert-equal "[email protected]" (ses-suppressed-address-email addr))+160
(assert-equal "BOUNCE" (ses-suppressed-address-reason addr))+161
(assert-equal "2026-03-15T10:00:00Z"+162
(ses-suppressed-address-last-update addr))))))+163
+164
(test-group "identity parsing"+165
+166
(test "parse verified identity"+167
(let ((data #{ VerifiedForSendingStatus: #t+168
DkimAttributes: #{ Status: "SUCCESS" }+169
MailFromAttributes: #{ MailFromDomainStatus: "SUCCESS" } }))+170
(let ((id (parse-identity "systemcrafters.net" data)))+171
(assert-true (ses-identity? id))+172
(assert-equal "systemcrafters.net" (ses-identity-name id))+173
(assert-true (ses-identity-verified? id))+174
(assert-equal "SUCCESS" (ses-identity-dkim-status id))+175
(assert-equal "SUCCESS" (ses-identity-mail-from-status id))))))+176
+177
;; ---------------------------------------------------------------+178
;; SNS notification parsing tests+179
;; ---------------------------------------------------------------+180
+181
(define bounce-json+182
(json-decode+183
(string-append+184
"{\"notificationType\": \"Bounce\","+185
" \"bounce\": {"+186
" \"bounceType\": \"Permanent\","+187
" \"bounceSubType\": \"General\","+188
" \"bouncedRecipients\": ["+189
" {\"emailAddress\": \"[email protected]\"},"+190
" {\"emailAddress\": \"[email protected]\"}"+191
" ],"+192
" \"timestamp\": \"2026-03-15T10:30:00Z\","+193
" \"feedbackId\": \"feedback-123\""+194
" }}")))+195
+196
(define complaint-json+197
(json-decode+198
(string-append+199
"{\"notificationType\": \"Complaint\","+200
" \"complaint\": {"+201
" \"complainedRecipients\": ["+202
" {\"emailAddress\": \"[email protected]\"}"+203
" ],"+204
" \"complaintFeedbackType\": \"abuse\","+205
" \"timestamp\": \"2026-03-16T14:00:00Z\","+206
" \"feedbackId\": \"feedback-456\""+207
" }}")))+208
+209
(define delivery-json+210
(json-decode "{\"notificationType\": \"Delivery\"}"))+211
+212
(test-group "bounce notification parsing"+213
+214
(test "parse bounce notification"+215
(let ((n (parse-ses-notification bounce-json)))+216
(assert-true (ses-notification? n))+217
(assert-equal "Bounce" (ses-notification-type n))+218
(assert-equal "Permanent" (ses-notification-bounce-type n))+219
(assert-equal "General" (ses-notification-bounce-sub-type n))+220
(assert-equal #f (ses-notification-complaint-type n))+221
(assert-equal "2026-03-15T10:30:00Z" (ses-notification-timestamp n))+222
(assert-equal "feedback-123" (ses-notification-feedback-id n))))+223
+224
(test "bounce addresses extracted"+225
(let ((n (parse-ses-notification bounce-json)))+226
(let ((addrs (ses-notification-addresses n)))+227
(assert-equal 2 (length addrs))+228
(assert-equal "[email protected]" (car addrs))+229
(assert-equal "[email protected]" (cadr addrs)))))+230
+231
(test "ses-bounce? predicate"+232
(let ((n (parse-ses-notification bounce-json)))+233
(assert-true (ses-bounce? n))+234
(assert-false (ses-complaint? n))))+235
+236
(test "ses-hard-bounce? predicate"+237
(let ((n (parse-ses-notification bounce-json)))+238
(assert-true (ses-hard-bounce? n)))))+239
+240
(test-group "complaint notification parsing"+241
+242
(test "parse complaint notification"+243
(let ((n (parse-ses-notification complaint-json)))+244
(assert-true (ses-notification? n))+245
(assert-equal "Complaint" (ses-notification-type n))+246
(assert-equal "abuse" (ses-notification-complaint-type n))+247
(assert-equal #f (ses-notification-bounce-type n))+248
(assert-equal "2026-03-16T14:00:00Z" (ses-notification-timestamp n))+249
(assert-equal "feedback-456" (ses-notification-feedback-id n))))+250
+251
(test "complaint addresses extracted"+252
(let ((n (parse-ses-notification complaint-json)))+253
(let ((addrs (ses-notification-addresses n)))+254
(assert-equal 1 (length addrs))+255
(assert-equal "[email protected]" (car addrs)))))+256
+257
(test "ses-complaint? predicate"+258
(let ((n (parse-ses-notification complaint-json)))+259
(assert-true (ses-complaint? n))+260
(assert-false (ses-bounce? n)))))+261
+262
(test-group "other notification types"+263
+264
(test "delivery notification returns #f"+265
(let ((n (parse-ses-notification delivery-json)))+266
(assert-false n))))+267
+268
;; ---------------------------------------------------------------+269
;; Record construction tests+270
;; ---------------------------------------------------------------+271
+272
(test-group "record construction"+273
+274
(test "ses-email-result fields"+275
(let ((r (ses-email-result message-id: "msg-123")))+276
(assert-true (ses-email-result? r))+277
(assert-equal "msg-123" (ses-email-result-message-id r))))+278
+279
(test "ses-account fields"+280
(let ((a (ses-account send-quota: 50000 send-rate: 14+281
sent-last-24h: 0 enforcement-status: "HEALTHY")))+282
(assert-equal 50000 (ses-account-send-quota a))+283
(assert-equal "HEALTHY" (ses-account-enforcement-status a))))+284
+285
(test "ses-notification fields"+286
(let ((n (ses-notification type: "Bounce"+287
addresses: '("[email protected]")+288
bounce-type: "Permanent"+289
bounce-sub-type: "General"+290
complaint-type: #f+291
timestamp: "2026-01-01T00:00:00Z"+292
feedback-id: "fb-1"+293
raw: #{})))+294
(assert-true (ses-notification? n))+295
(assert-equal "Bounce" (ses-notification-type n))+296
(assert-equal '("[email protected]") (ses-notification-addresses n)))))+297
+298
(run-tests)