source: project/release/5/openssl/trunk/openssl.cipher.scm @ 40254

Last change on this file since 40254 was 40254, checked in by Vasilij Schneidermann, 3 months ago

openssl: Reorder port arguments for consistency

File size: 16.4 KB
Line 
1(module (openssl cipher)
2  (
3   cipher-list
4   cipher-by-name
5   cipher-key-length
6   cipher-iv-length
7   cipher-block-size
8   cipher-name
9   max-key-length
10   max-iv-length
11   max-block-length
12   cipher-context-allocate!
13   cipher-context-free!
14   cipher-context-reset!
15   cipher-context-init!
16   cipher-context-update!
17   cipher-context-final!
18   cipher-context-get-tag
19   string-cipher
20   string-encrypt-and-digest
21   string-decrypt-and-verify
22   file-cipher
23   open-cipher-port
24   )
25
26(import scheme)
27(import (chicken base))
28(import (chicken bitwise))
29(import (chicken blob))
30(import (chicken condition))
31(import (chicken file posix))
32(import (chicken foreign))
33(import (chicken format))
34(import (chicken gc))
35(import (chicken memory))
36(import (chicken port))
37
38#>
39#include <openssl/err.h>
40#include <openssl/evp.h>
41<#
42
43(define ERR_clear_error (foreign-lambda void "ERR_clear_error"))
44(define ERR_get_error (foreign-lambda unsigned-long "ERR_get_error"))
45(define ERR_lib_error_string (foreign-lambda c-string "ERR_lib_error_string" unsigned-long))
46(define ERR_func_error_string (foreign-lambda c-string "ERR_func_error_string" unsigned-long))
47(define ERR_reason_error_string (foreign-lambda c-string "ERR_reason_error_string" unsigned-long))
48
49(define OBJ_NAME_ALIAS (foreign-value "OBJ_NAME_ALIAS" int))
50(define EVP_CIPH_FLAG_AEAD_CIPHER (foreign-value "EVP_CIPH_FLAG_AEAD_CIPHER" int))
51(define EVP_CIPH_CCM_MODE (foreign-value "EVP_CIPH_CCM_MODE" int))
52(define EVP_CTRL_AEAD_SET_IVLEN (foreign-value "EVP_CTRL_AEAD_SET_IVLEN" int))
53(define EVP_CTRL_AEAD_SET_TAG (foreign-value "EVP_CTRL_AEAD_SET_TAG" int))
54(define EVP_CTRL_AEAD_GET_TAG (foreign-value "EVP_CTRL_AEAD_GET_TAG" int))
55(define EVP_CTRL_CCM_SET_MSGLEN (foreign-value "EVP_CTRL_CCM_SET_MSGLEN" int))
56
57(define-foreign-type OBJ_NAME* (const (c-pointer (struct "obj_name_st"))))
58(define-foreign-type EVP_CIPHER* (const c-pointer))
59(define-foreign-type EVP_CIPHER_CTX* c-pointer)
60(define-foreign-type int* (c-pointer int))
61
62(define evp-ciphers '())
63(define-external (EVP_CipherList_callback (OBJ_NAME* obj) (c-pointer _arg)) c-pointer
64  (let ((name ((foreign-lambda* c-string ((OBJ_NAME* obj)) "C_return(obj->name);") obj))
65        (alias ((foreign-lambda* int ((OBJ_NAME* obj)) "C_return(obj->alias);") obj)))
66    (when (not (= alias OBJ_NAME_ALIAS))
67      (set! evp-ciphers (cons name evp-ciphers)))
68    #f))
69
70(define EVP_CIPHER_CTX_new (foreign-lambda EVP_CIPHER_CTX* "EVP_CIPHER_CTX_new"))
71(define EVP_CIPHER_CTX_free (foreign-lambda void "EVP_CIPHER_CTX_free" EVP_CIPHER_CTX*))
72(define EVP_CIPHER_CTX_reset (foreign-lambda bool "EVP_CIPHER_CTX_reset" EVP_CIPHER_CTX*))
73(define EVP_CIPHER_CTX_set_padding (foreign-lambda bool "EVP_CIPHER_CTX_set_padding" EVP_CIPHER_CTX* bool))
74(define EVP_CIPHER_CTX_key_length (foreign-lambda int "EVP_CIPHER_CTX_key_length" EVP_CIPHER_CTX*))
75(define EVP_CIPHER_CTX_set_key_length (foreign-lambda bool "EVP_CIPHER_CTX_set_key_length" EVP_CIPHER_CTX* int))
76(define EVP_CIPHER_CTX_iv_length (foreign-lambda int "EVP_CIPHER_CTX_iv_length" EVP_CIPHER_CTX*))
77(define EVP_CIPHER_CTX_ctrl (foreign-lambda int "EVP_CIPHER_CTX_ctrl" EVP_CIPHER_CTX* int int blob))
78(define EVP_CIPHER_CTX_flags (foreign-lambda int "EVP_CIPHER_CTX_flags" EVP_CIPHER_CTX*))
79(define EVP_CIPHER_CTX_cipher (foreign-lambda EVP_CIPHER* "EVP_CIPHER_CTX_cipher" EVP_CIPHER_CTX*))
80
81(define EVP_CipherInit_ex (foreign-lambda bool "EVP_CipherInit_ex" EVP_CIPHER_CTX* EVP_CIPHER* c-pointer blob blob int))
82(define EVP_CipherUpdate (foreign-lambda bool "EVP_CipherUpdate" EVP_CIPHER_CTX* blob int* (const blob) int))
83(define EVP_CipherFinal_ex (foreign-lambda bool "EVP_CipherFinal_ex" EVP_CIPHER_CTX* blob int*))
84
85(define EVP_get_cipherbyname (foreign-lambda EVP_CIPHER* "EVP_get_cipherbyname" (const c-string)))
86(define EVP_CIPHER_key_length (foreign-lambda int "EVP_CIPHER_key_length" EVP_CIPHER*))
87(define EVP_CIPHER_iv_length (foreign-lambda int "EVP_CIPHER_iv_length" EVP_CIPHER*))
88(define EVP_CIPHER_block_size (foreign-lambda int "EVP_CIPHER_block_size" EVP_CIPHER*))
89(define EVP_CIPHER_name (foreign-lambda c-string "EVP_CIPHER_name" EVP_CIPHER*))
90
91(define EVP_MAX_KEY_LENGTH (foreign-value "EVP_MAX_KEY_LENGTH" int))
92(define EVP_MAX_IV_LENGTH (foreign-value "EVP_MAX_IV_LENGTH" int))
93(define EVP_MAX_BLOCK_LENGTH (foreign-value "EVP_MAX_BLOCK_LENGTH" int))
94
95(define (openssl-type-error loc expected #!rest args)
96  (abort
97   (condition `(exn message ,(format "expected ~a, got" expected)
98                    location ,loc
99                    arguments ,args)
100              '(type))))
101
102(define (openssl-error loc #!rest args)
103  (let* ((err (ERR_get_error))
104         (message (format "error: library=~a, function=~a, reason=~a"
105                          (or (ERR_lib_error_string err) "<unknown>")
106                          (or (ERR_func_error_string err) "<unknown>")
107                          (or (ERR_reason_error_string err) "<unknown>"))))
108    (abort
109     (condition `(exn message ,message location ,loc arguments ,args)
110                '(i/o)
111                `(openssl status #f)))))
112
113(define (cipher-list)
114  ;; HACK: without this, the cipher list is empty
115  (foreign-code "OPENSSL_init_crypto(OPENSSL_INIT_ADD_ALL_CIPHERS, NULL);")
116  (set! evp-ciphers '())
117  ((foreign-safe-lambda* void ()
118     "OBJ_NAME_do_all_sorted(OBJ_NAME_TYPE_CIPHER_METH, (void(*)(const OBJ_NAME*,void*))EVP_CipherList_callback, NULL);"))
119  (reverse evp-ciphers))
120
121(define (cipher-by-name name)
122  (EVP_get_cipherbyname name))
123
124(define (cipher-key-length cipher)
125  (EVP_CIPHER_key_length cipher))
126
127(define (cipher-iv-length cipher)
128  (EVP_CIPHER_iv_length cipher))
129
130(define (cipher-block-size cipher)
131  (EVP_CIPHER_block_size cipher))
132
133(define (cipher-name cipher)
134  (EVP_CIPHER_name cipher))
135
136(define max-key-length EVP_MAX_KEY_LENGTH)
137(define max-iv-length EVP_MAX_IV_LENGTH)
138(define max-block-length EVP_MAX_BLOCK_LENGTH)
139
140(define-record cipher-context ptr mode tag-length)
141
142(define (cipher-context-free! context)
143  (and-let* ((ctx (cipher-context-ptr context)))
144    (EVP_CIPHER_CTX_free ctx)
145    (cipher-context-mode-set! context #f)
146    (cipher-context-ptr-set! context #f)))
147
148(define (cipher-context-allocate!)
149  (ERR_clear_error)
150  (let ((ctx (EVP_CIPHER_CTX_new)))
151    (when (not ctx)
152      (openssl-error 'cipher-context-allocate!))
153    (set-finalizer! (make-cipher-context ctx #f #f) cipher-context-free!)))
154
155(define (cipher-context-unwrap! context)
156  (let ((ctx (cipher-context-ptr context)))
157    (when (not ctx)
158      (openssl-type-error 'cipher-context-unwrap! "valid context pointer" #f))
159    ctx))
160
161(define (cipher-context-reset! context)
162  (let ((ctx (cipher-context-unwrap! context)))
163    (ERR_clear_error)
164    (when (not (EVP_CIPHER_CTX_reset ctx))
165      (openssl-error 'cipher-context-reset!))
166    (cipher-context-tag-length-set! context #f)
167    (void)))
168
169(define (aead-cipher? ctx)
170  (bitwise-and (EVP_CIPHER_CTX_flags ctx) EVP_CIPH_FLAG_AEAD_CIPHER))
171
172(define (remove-known-key-args known-keys args)
173  (let loop ((args args)
174             (unknown-args '()))
175    (if (null? args)
176        (reverse unknown-args)
177        (let ((arg (car args)))
178          (if (memv arg known-keys)
179              (if (pair? (cdr args))
180                  (loop (cddr args) unknown-args)
181                  (loop (cdr args) unknown-args))
182              (loop (cdr args) (cons arg unknown-args)))))))
183
184(define (check-unknown-key-args known-keys args)
185  (let ((unknown-args (remove-known-key-args known-keys args)))
186    (when (pair? unknown-args)
187      (fprintf (current-error-port) "warning: unknown rest arguments: ~s\n" unknown-args))))
188
189(define (cipher-context-init! context cipher key iv
190                              #!rest args
191                              #!key
192                              (mode 'encrypt)
193                              (padding #t)
194                              (effective-key-length #f)
195                              (auth-data #f)
196                              (tag-length #f)
197                              (expected-tag #f)
198                              (effective-iv-length #f)
199                              (message-length #f))
200  (define (mode->flag mode)
201    (case mode
202      ((encrypt) 1)
203      ((decrypt) 0)
204      (else (openssl-type-error 'cipher-context-init! "mode symbol" (list mode)))))
205  (define (ccm-cipher? ctx)
206    (bitwise-and (EVP_CIPHER_CTX_flags ctx) EVP_CIPH_CCM_MODE))
207  (check-unknown-key-args '(#:mode #:padding #:effective-key-length #:auth-data
208                            #:tag-length #:expected-tag #:effective-iv-length
209                            #:message-length) args)
210  (let ((ctx (cipher-context-unwrap! context))
211        (key-length (or effective-key-length (blob-size key)))
212        (iv-length (and iv (blob-size iv))))
213    (ERR_clear_error)
214    (when (not (EVP_CipherInit_ex ctx cipher #f #f #f (mode->flag mode)))
215      (openssl-error 'cipher-context-init! (list cipher mode)))
216    (cipher-context-mode-set! context mode)
217    (when (> key-length (blob-size key))
218      (openssl-type-error "effective key length <= key size" key-length (blob-size key)))
219    (when (not (EVP_CIPHER_CTX_set_key_length ctx key-length))
220      (openssl-error 'cipher-context-init! (list key-length effective-key-length)))
221    (when (and iv-length (not (<= (EVP_CIPHER_CTX_iv_length ctx) iv-length)))
222      (openssl-type-error 'cipher-context-init! "sufficient iv length" iv-length))
223    (when effective-iv-length
224      (when (not (aead-cipher? ctx))
225        (openssl-type-error 'cipher-context-init! "AEAD cipher" (cipher-name cipher)))
226      (when (> effective-iv-length max-iv-length)
227        (openssl-type-error 'cipher-context-init! "integer <= 16" effective-iv-length))
228      (when (not (EVP_CIPHER_CTX_ctrl ctx EVP_CTRL_AEAD_SET_IVLEN effective-iv-length #f))
229        (openssl-error 'cipher-context-init! (list effective-iv-length))))
230    (when (and expected-tag tag-length)
231      (when (not (aead-cipher? ctx))
232        (openssl-type-error 'cipher-context-init! "AEAD cipher" (cipher-name cipher)))
233      (when (not (eqv? mode 'decrypt))
234        (openssl-type-error 'cipher-context-init! "decrypt mode" mode))
235      (when (not tag-length)
236        (openssl-type-error 'cipher-context-init! "tag length" #f))
237      (when (> tag-length (blob-size expected-tag))
238        (openssl-type-error 'cipher-context-init! "tag shorter than tag length" tag-length (blob-size expected-tag)))
239      (when (not (EVP_CIPHER_CTX_ctrl ctx EVP_CTRL_AEAD_SET_TAG tag-length expected-tag))
240        (openssl-error 'cipher-context-init! (list expected-tag tag-length))))
241    (when (and (not expected-tag) tag-length)
242      (when (not (aead-cipher? ctx))
243        (openssl-type-error 'cipher-context-init! "AEAD cipher" (cipher-name cipher)))
244      (when (not (eqv? mode 'encrypt))
245        (openssl-type-error 'cipher-context-init! "encrypt mode" mode))
246      (when (> tag-length max-iv-length)
247        (openssl-type-error 'cipher-context-init! "integer <= 16" tag-length))
248      (when (not (EVP_CIPHER_CTX_ctrl ctx EVP_CTRL_AEAD_SET_TAG tag-length #f))
249        (openssl-error 'cipher-context-init! (list tag-length)))
250      (cipher-context-tag-length-set! context tag-length))
251    (when (not (EVP_CipherInit_ex ctx #f #f key iv -1))
252      (openssl-error 'cipher-context-init! (list cipher key iv)))
253    (when message-length
254      (when (not (ccm-cipher? ctx))
255        (openssl-type-error 'cipher-context-init! "CCM cipher mode" (cipher-name cipher)))
256      ;; https://github.com/pyca/cryptography/blob/0034926f2cca02258f50e9faccb90ec344790159/src/cryptography/hazmat/backends/openssl/aead.py#L108
257      ;; https://github.com/pyca/cryptography/blob/0034926f2cca02258f50e9faccb90ec344790159/src/cryptography/hazmat/backends/openssl/aead.py#L77
258      (let-location ((_length int))
259        (when (not (EVP_CipherUpdate ctx #f (location _length) #f message-length))
260          (openssl-error 'cipher-context-init! (list message-length)))))
261    (when auth-data
262      (when (not (aead-cipher? ctx))
263        (openssl-type-error 'cipher-context-init! "AEAD cipher" (cipher-name cipher)))
264      (let-location ((_length int))
265        (when (not (EVP_CipherUpdate ctx #f (location _length) auth-data (blob-size auth-data)))
266          (openssl-error 'cipher-context-init! (list auth-data (blob-size auth-data))))))
267    (EVP_CIPHER_CTX_set_padding ctx padding)
268    (void)))
269
270(define (cipher-context-update! context blob)
271  (let ((ctx (cipher-context-unwrap! context))
272        (buf (make-blob (+ (blob-size blob) max-block-length))))
273    (ERR_clear_error)
274    (let-location ((buf-length int))
275      (when (not (EVP_CipherUpdate ctx buf (location buf-length) blob (blob-size blob)))
276        (openssl-error 'cipher-context-update! (list blob (blob-size blob))))
277      (let ((ret (make-blob buf-length)))
278        (move-memory! buf ret buf-length)
279        ret))))
280
281(define (cipher-context-final! context)
282  (let ((ctx (cipher-context-unwrap! context))
283        (buf (make-blob max-block-length)))
284    (ERR_clear_error)
285    (let-location ((buf-length int))
286      (when (not (EVP_CipherFinal_ex ctx buf (location buf-length)))
287        (openssl-error 'cipher-context-final!))
288      (let ((ret (make-blob buf-length)))
289        (move-memory! buf ret buf-length)
290        ret))))
291
292(define (cipher-context-get-tag context)
293  (let ((ctx (cipher-context-unwrap! context)))
294    (ERR_clear_error)
295    (when (not (aead-cipher? ctx))
296      (openssl-type-error 'cipher-context-get-tag "AEAD cipher" (cipher-name (EVP_CIPHER_CTX_cipher ctx))))
297    (let ((mode (cipher-context-mode context))
298          (tag-length (cipher-context-tag-length context)))
299      (when (not mode)
300        (openssl-type-error 'cipher-context-get-tag "initialized context" #f))
301      (when (not (eqv? mode 'encrypt))
302        (openssl-type-error 'cipher-context-get-tag "encrypt mode" mode))
303      (when (not tag-length)
304        (openssl-type-error 'cipher-context-get-tag "tag length to be set" #f))
305      (let ((buf (make-blob tag-length)))
306        (when (not (EVP_CIPHER_CTX_ctrl ctx EVP_CTRL_AEAD_GET_TAG tag-length buf))
307          (openssl-error 'cipher-context-get-tag tag-length))
308        buf))))
309
310(define (string-cipher cipher str key iv #!rest options)
311  (let ((context (cipher-context-allocate!)))
312    (apply cipher-context-init! context cipher key iv options)
313    (let* ((output (cipher-context-update! context (string->blob str)))
314           (final (cipher-context-final! context))
315           (output (string-append (blob->string output) (blob->string final))))
316      (cipher-context-free! context)
317      output)))
318
319(define (string-encrypt-and-digest cipher str key iv #!rest options)
320  (let ((context (cipher-context-allocate!)))
321    (apply cipher-context-init! context cipher key iv mode: 'encrypt options)
322    (let* ((output (cipher-context-update! context (string->blob str)))
323           (final (cipher-context-final! context))
324           (output (string-append (blob->string output) (blob->string final)))
325           (tag (blob->string (cipher-context-get-tag context))))
326      (cipher-context-free! context)
327      (values output tag))))
328
329(define (string-decrypt-and-verify cipher str tag key iv #!rest options)
330  (let ((context (cipher-context-allocate!)))
331    (apply cipher-context-init! context cipher key iv
332           mode: 'decrypt
333           tag-length: (string-length tag)
334           expected-tag: (string->blob tag)
335           options)
336    (let* ((output (cipher-context-update! context (string->blob str)))
337           (final (cipher-context-final! context))
338           (output (string-append (blob->string output) (blob->string final))))
339      (cipher-context-free! context)
340      output)))
341
342(define (file-cipher cipher in-path out-path key iv #!rest options)
343  (let* ((buf-size 4096)
344         (buf (make-blob buf-size))
345         (context (cipher-context-allocate!))
346         (in (file-open in-path open/rdonly))
347         (out (file-open out-path
348                         (+ open/wronly open/creat open/trunc)
349                         (+ perm/irusr perm/iwusr))))
350    (apply cipher-context-init! context cipher key iv options)
351    (let loop ()
352      (let ((count (cadr (file-read in buf-size buf))))
353        (when (positive? count)
354          (file-write out (cipher-context-update! context buf))
355          (loop))))
356    (file-write out (cipher-context-final! context))
357    (file-close in)
358    (file-close out)
359    (cipher-context-free! context)))
360
361(define (open-cipher-port cipher out key iv #!rest options)
362  (let ((context (cipher-context-allocate!)))
363    (apply cipher-context-init! context cipher key iv options)
364    (make-output-port
365     (lambda (str)
366       (display (blob->string (cipher-context-update! context (string->blob str))) out))
367     (lambda ()
368       (display (blob->string (cipher-context-final! context)) out))
369     (lambda ()
370       (flush-output out)))))
371
372)
Note: See TracBrowser for help on using the repository browser.