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

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

openssl: Rework digest API

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