source: project/release/5/openssl/trunk/openssl.digest.scm @ 40223

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

openssl: Clear errors only for non-free'd contexts

File size: 6.4 KB
Line 
1(module (openssl digest)
2  (
3   digest-list
4   digest-by-name
5   digest-size
6   digest-block-size
7   digest-name
8   max-digest-size
9   digest-context-allocate!
10   digest-context-free!
11   digest-context-reset!
12   digest-context-init!
13   digest-context-update!
14   digest-context-final!
15   string-digest
16   file-digest
17   )
18
19(import scheme)
20(import (chicken base))
21(import (chicken blob))
22(import (chicken condition))
23(import (chicken file posix))
24(import (chicken foreign))
25(import (chicken format))
26(import (chicken gc))
27(import (chicken io))
28(import (chicken memory))
29(import (chicken port))
30
31#>
32#include <openssl/err.h>
33#include <openssl/evp.h>
34<#
35
36(define ERR_clear_error (foreign-lambda void "ERR_clear_error"))
37(define ERR_get_error (foreign-lambda unsigned-long "ERR_get_error"))
38(define ERR_lib_error_string (foreign-lambda c-string "ERR_lib_error_string" unsigned-long))
39(define ERR_func_error_string (foreign-lambda c-string "ERR_func_error_string" unsigned-long))
40(define ERR_reason_error_string (foreign-lambda c-string "ERR_reason_error_string" unsigned-long))
41
42(define OBJ_NAME_ALIAS (foreign-value "OBJ_NAME_ALIAS" int))
43(define-foreign-type OBJ_NAME* (const (c-pointer (struct "obj_name_st"))))
44(define-foreign-type EVP_MD* (const c-pointer))
45(define-foreign-type EVP_MD_CTX* c-pointer)
46(define-foreign-type unsigned-int* (c-pointer unsigned-int))
47
48(define evp-digests '())
49(define-external (EVP_DigestList_callback (OBJ_NAME* obj) (c-pointer _arg)) c-pointer
50  (let ((name ((foreign-lambda* c-string ((OBJ_NAME* obj)) "C_return(obj->name);") obj))
51        (alias ((foreign-lambda* int ((OBJ_NAME* obj)) "C_return(obj->alias);") obj)))
52    (when (not (= alias OBJ_NAME_ALIAS))
53      (set! evp-digests (cons name evp-digests)))
54    #f))
55
56(define EVP_MD_CTX_new (foreign-lambda EVP_MD_CTX* "EVP_MD_CTX_new"))
57(define EVP_MD_CTX_free (foreign-lambda void "EVP_MD_CTX_free" EVP_MD_CTX*))
58(define EVP_MD_CTX_reset (foreign-lambda int "EVP_MD_CTX_reset" EVP_MD_CTX*))
59(define EVP_MD_CTX_set_flags (foreign-lambda void "EVP_MD_CTX_set_flags" EVP_MD_CTX* int))
60
61(define EVP_DigestInit_ex (foreign-lambda bool "EVP_DigestInit_ex" EVP_MD_CTX* EVP_MD* c-pointer))
62(define EVP_DigestUpdate (foreign-lambda bool "EVP_DigestUpdate" EVP_MD_CTX* (const blob) size_t))
63(define EVP_DigestFinal_ex (foreign-lambda bool "EVP_DigestFinal_ex" EVP_MD_CTX* blob unsigned-int*))
64
65(define EVP_get_digestbyname (foreign-lambda EVP_MD* "EVP_get_digestbyname" c-string))
66(define EVP_MD_size (foreign-lambda int "EVP_MD_size" EVP_MD*))
67(define EVP_MD_block_size (foreign-lambda int "EVP_MD_block_size" EVP_MD*))
68(define EVP_MD_name (foreign-lambda c-string "EVP_MD_name" EVP_MD*))
69
70(define EVP_MAX_MD_SIZE (foreign-value "EVP_MAX_MD_SIZE" int))
71(define EVP_MD_CTX_FLAG_ONESHOT (foreign-value "EVP_MD_CTX_FLAG_ONESHOT" int))
72
73(define (openssl-type-error loc expected #!rest args)
74  (abort
75   (condition `(exn message ,(format "expected ~a, got" expected)
76                    location ,loc
77                    arguments ,args)
78              '(type))))
79
80(define (openssl-error loc #!rest args)
81  (let* ((err (ERR_get_error))
82         (message (format "error: library=~a, function=~a, reason=~a"
83                          (or (ERR_lib_error_string err) "<unknown>")
84                          (or (ERR_func_error_string err) "<unknown>")
85                          (or (ERR_reason_error_string err) "<unknown>"))))
86    (abort
87     (condition `(exn message ,message location ,loc arguments ,args)
88                '(i/o)
89                `(openssl status #f)))))
90
91(define (digest-list)
92  ;; HACK: without this, the digest list is empty
93  (foreign-code "OPENSSL_init_crypto(OPENSSL_INIT_ADD_ALL_DIGESTS, NULL);")
94  (set! evp-digests '())
95  ((foreign-safe-lambda* void ()
96     "OBJ_NAME_do_all_sorted(OBJ_NAME_TYPE_MD_METH, (void(*)(const OBJ_NAME*,void*))EVP_DigestList_callback, NULL);"))
97  (reverse evp-digests))
98
99(define (digest-by-name name)
100  (EVP_get_digestbyname name))
101
102(define (digest-size digest)
103  (EVP_MD_size digest))
104
105(define (digest-block-size digest)
106  (EVP_MD_block_size digest))
107
108(define (digest-name digest)
109  (EVP_MD_name digest))
110
111(define max-digest-size EVP_MAX_MD_SIZE)
112
113(define-record digest-context ptr)
114
115(define (digest-context-free! context)
116  (and-let* ((ctx (digest-context-ptr context)))
117    (EVP_MD_CTX_free ctx)
118    (digest-context-ptr-set! context #f)))
119
120(define (digest-context-allocate!)
121  (ERR_clear_error)
122  (let ((ctx (EVP_MD_CTX_new)))
123    (when (not ctx)
124      (openssl-error 'digest-context-allocate!))
125    (set-finalizer! (make-digest-context ctx) digest-context-free!)))
126
127(define (digest-context-reset! context)
128  (and-let* ((ctx (digest-context-ptr context)))
129    (ERR_clear_error)
130    (when (not (EVP_MD_CTX_reset ctx))
131      (openssl-error 'digest-context-reset!))
132    (void)))
133
134(define (digest-context-init! context digest #!key (oneshot #f))
135  (and-let* ((ctx (digest-context-ptr context)))
136    (ERR_clear_error)
137    (when (not (EVP_DigestInit_ex ctx digest #f))
138      (openssl-error 'digest-context-init! (list digest)))
139    (when oneshot
140      (EVP_MD_CTX_set_flags ctx EVP_MD_CTX_FLAG_ONESHOT))
141    (void)))
142
143(define (digest-context-update! context blob)
144  (and-let* ((ctx (digest-context-ptr context))
145             (size (blob-size blob)))
146    (ERR_clear_error)
147    (when (not (EVP_DigestUpdate ctx blob size))
148      (openssl-error 'digest-context-update (list blob size)))
149    (void)))
150
151(define (digest-context-final! context)
152  (and-let* ((ctx (digest-context-ptr context))
153             (blob (make-blob max-digest-size)))
154    (ERR_clear_error)
155    (let-location ((size int))
156      (when (not (EVP_DigestFinal_ex (digest-context-ptr context) blob (location size)))
157        (openssl-error 'digest-context-final!))
158      (let ((str (make-string size)))
159        (move-memory! blob str size)
160        str))))
161
162(define (string-digest digest str)
163  (let ((context (digest-context-allocate!)))
164    (digest-context-init! context digest oneshot: #t)
165    (digest-context-update! context (string->blob str))
166    (digest-context-final! context)))
167
168(define (file-digest digest path)
169  (let* ((buf-size 4096)
170         (buf (make-blob buf-size))
171         (context (digest-context-allocate!))
172         (in (file-open path open/rdonly)))
173    (digest-context-init! context digest)
174    (let loop ()
175      (let ((count (cadr (file-read in buf-size buf))))
176        (when (positive? count)
177          (digest-context-update! context buf)
178          (loop))))
179    (file-close in)
180    (digest-context-final! context)))
181
182)
Note: See TracBrowser for help on using the repository browser.