removed dependency on srfi-4-utils as it was gpl and not compatible with bsd

master 6
t@thintz.com 13 years ago
parent ce8e7b6d79
commit 3b221a88ce

@ -7,7 +7,7 @@
(category crypt) (category crypt)
(needs message-digest srfi-4-utils) (needs message-digest)
(test-depends test sha1 string-utils) (test-depends test sha1 string-utils)

@ -5,4 +5,5 @@
(release "2") (release "2")
(release "3") (release "3")
(release "4") (release "4")
(release "5") (release "5")
(release "6")

@ -6,16 +6,15 @@
(hmac) (hmac)
(import scheme chicken srfi-4 srfi-13) (import scheme chicken srfi-4 srfi-13)
(use srfi-4-utils message-digest-port) (use message-digest-port)
; taken from example at http://wiki.call-cc.org/drupal-xml-rpc ; taken from example at http://wiki.call-cc.org/drupal-xml-rpc
(define (hmac key digest-primitive #!optional (block-size 64)) (define (hmac key digest-primitive #!optional (block-size 64))
(when (> (string-length key) block-size) (when (> (string-length key) block-size)
(set! key (call-with-output-digest digest-primitive (cut display key <>) 'string))) (set! key (call-with-output-digest digest-primitive (cut display key <>) 'string)))
(set! key (string-pad-right key block-size (integer->char 0))) (set! key (string-pad-right key block-size (integer->char 0)))
(set! key (blob->u8vector (string->blob key))) (let ((ipad (string-map (lambda (c) (integer->char (bitwise-xor (char->integer c) #x36))) key))
(let ((ipad (blob->string (u8vector->blob (u8vector-map (lambda (v) (bitwise-xor v #x36)) key)))) (opad (string-map (lambda (c) (integer->char (bitwise-xor (char->integer c) #x5c))) key)))
(opad (blob->string (u8vector->blob (u8vector-map (lambda (v) (bitwise-xor v #x5c)) key)))))
(lambda (message) (lambda (message)
(call-with-output-digest digest-primitive (cut display (string-append opad (call-with-output-digest digest-primitive (cut display (string-append ipad message) <>) 'string)) <>) 'string)))) (call-with-output-digest digest-primitive (cut display (string-append opad (call-with-output-digest digest-primitive (cut display (string-append ipad message) <>) 'string)) <>) 'string))))

@ -11,5 +11,5 @@
; Files to install for your extension: ; Files to install for your extension:
'("hmac.o" "hmac.so" "hmac.import.so") '("hmac.o" "hmac.so" "hmac.import.so")
; Assoc list with properties for your extension: ; Assoc list with properties for your extension:
'((version 5) '((version 6)
(static "hmac.o"))) ;; for static linking (static "hmac.o"))) ;; for static linking
Loading…
Cancel
Save