src/amazon/ses.sgl — sigil-ses

1;;; (amazon 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.

7(define-library (amazon 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 (amazon ses auth))

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

25 ;; Records

26 ses-email-result

27 ses-email-result?

28 ses-email-result-message-id

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

37 ses-suppressed-address

38 ses-suppressed-address?

39 ses-suppressed-address-email

40 ses-suppressed-address-reason

41 ses-suppressed-address-last-update

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

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

60 ;; Parsing (exported for testing)

61 parse-account

62 parse-suppressed-address

63 parse-identity)

65 (begin

67 ;; ---------------------------------------------------------------

68 ;; Client record

69 ;; ---------------------------------------------------------------

71 (define-struct ses-client

72 (access-key-id)

73 (secret-access-key)

74 (region default: "us-east-2"))

76 ;; ---------------------------------------------------------------

77 ;; Response records

78 ;; ---------------------------------------------------------------

80 (define-struct ses-email-result

81 (message-id))

83 (define-struct ses-account

84 (send-quota)

85 (send-rate)

86 (sent-last-24h)

87 (enforcement-status))

89 (define-struct ses-suppressed-address

90 (email)

91 (reason)

92 (last-update))

94 (define-struct ses-identity

95 (name)

96 (verified?)

97 (dkim-status)

98 (mail-from-status))

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)))))