AtlatestRepositorysigil-ses
1
;;; (amazon ses auth) - AWS Signature Version 4 signing for SES requests.2
;;;3
;;; Implements the SigV4 signing algorithm used to authenticate all4
;;; AWS API requests. Reference:5
;;; https://docs.aws.amazon.com/IAM/latest/UserGuide/reference_sigv4-signer.html7
(define-library (amazon 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))17
(export sigv4-sign-request18
;; Exported for testing19
derive-signing-key20
canonical-headers-pair21
canonical-request22
string-to-sign23
format-amz-date24
format-date-stamp25
hex->bytevector)27
(begin29
;; ---------------------------------------------------------------30
;; Hex/byte conversion helpers31
;; ---------------------------------------------------------------33
;;; Convert a hex string to a bytevector.34
;;; Used to chain HMAC operations where the output of one step35
;;; 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
bv42
(begin43
(bytevector-u8-set! bv (/ i 2)44
(string->number (substring hex-str i (+ i 2)) 16))45
(loop (+ i 2)))))))47
;; ---------------------------------------------------------------48
;; Date formatting49
;; ---------------------------------------------------------------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)))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")))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))))85
;; ---------------------------------------------------------------86
;; Canonical request building87
;; ---------------------------------------------------------------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
(cons101
;; signed headers: semicolon-separated lowercase names102
(string-join (map car sorted) ";")103
;; canonical headers: name:value\n for each104
(apply string-append105
(map (lambda (entry)106
(string-append (car entry) ":" (cdr entry) "\n"))107
sorted)))))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-pos118
(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
"&"))))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))141
;; ---------------------------------------------------------------142
;; String to sign143
;; ---------------------------------------------------------------145
;;; Build the string to sign for SigV4.146
;;; amz-date: YYYYMMDDTHHMMSSZ format147
;;; scope: date/region/service/aws4_request148
;;; canonical-request-hash: SHA-256 hex hash of the canonical request149
(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))155
;; ---------------------------------------------------------------156
;; Signing key derivation157
;; ---------------------------------------------------------------159
;;; Derive the SigV4 signing key.160
;;; secret-key: AWS secret access key161
;;; date-stamp: YYYYMMDD format162
;;; 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->bytevector166
(hmac-sha256 (string-append "AWS4" secret-key)167
date-stamp)))168
(k-region (hex->bytevector169
(hmac-sha256 k-date region)))170
(k-service (hex->bytevector171
(hmac-sha256 k-region service)))172
(k-signing (hex->bytevector173
(hmac-sha256 k-service "aws4_request"))))174
k-signing))176
;; ---------------------------------------------------------------177
;; Request signing178
;; ---------------------------------------------------------------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 ID185
;;; secret-access-key: AWS secret access key186
;;; region: AWS region187
;;; 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-key196
region service197
method host path query198
extra-headers payload199
. rest)200
(let* ((time-list (if (null? rest)201
(time->list (current-second) #t) ; UTC202
(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-merge208
extra-headers209
#{ host: host210
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 request214
(creq (canonical-request method path query215
headers-pair payload-hash))216
(creq-hash (sha256 creq))217
;; Build scope and string to sign218
(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 signature223
(signing-key (derive-signing-key secret-access-key224
date-stamp region service))225
(signature (hmac-sha256 signing-key sts))226
;; Build authorization header227
(auth-header (string-append228
"AWS4-HMAC-SHA256 "229
"Credential=" access-key-id "/" scope ", "230
"SignedHeaders=" (car headers-pair) ", "231
"Signature=" signature)))232
;; Return all headers needed for the request233
(dict-merge headers-to-sign234
#{ authorization: auth-header235
x-amz-date: amz-date })))))