Updating to work with CHICKEN 5.

Updated to work with CHICKEN 5. Thanks to Andy Bennett
<andyjpb@ashurst.eu.org> for doing most of the work!

Moved hmac.release-info* uri targz to point at code.thintz.com instead
of github.

hmac.egg

@@ -0,0 +1,11 @@
+; author: Thomas Hintz
+; email: t@thintz.com
+; license: bsd
+
+((license "BSD")
+ (category crypt)
+ (dependencies message-digest)
+ (test-dependencies test sha1 string-utils)
+ (author "Thomas Hintz")
+ (synopsis "HMAC provides a HMAC using the message-digest interface.")
+ (components (extension hmac)))

hmac.meta

@@ -5,9 +5,9 @@
 (
 (license "BSD")
 
-(category cryptography)
+(category crypt)
 
-(needs message-digest srfi-4-utils)
+(needs message-digest)
 
 (test-depends test sha1 string-utils)
 

hmac.release-info

@@ -1,7 +1,10 @@
-(repo git "git://github.com/ThomasHintz/chicken-scheme-{egg-name}.git")   ; optional
-
-(uri targz "https://github.com/ThomasHintz/chicken-scheme-{egg-name}/tarball/{egg-release}")
+(uri targz "https://code.thintz.com/chicken-scheme-{egg-name}/snapshot/chicken-scheme-{egg-name}-{egg-release}.tar.gz")
 (release "1")
 (release "2")
 (release "3")
-(release "4")
+(release "4")
+(release "6")
+(release "7")
+(release "7.0.1")
+(release "7.1.0")
+(release "7.2.0")

hmac.release-info.chicken-5

@@ -0,0 +1,2 @@
+(uri targz "https://code.thintz.com/chicken-scheme-{egg-name}/snapshot/chicken-scheme-{egg-name}-{egg-release}.tar.gz")
+(release "7.2.0")

hmac.scm

@@ -3,20 +3,46 @@
 ; license: bsd
 
 (module hmac
-  (hmac)
+  (hmac hmac-primitive)
 
-(import scheme chicken srfi-4 srfi-13)
-(use srfi-4-utils message-digest-port)
+(import scheme)
 
-; taken from example at http://wiki.call-cc.org/drupal-xml-rpc
-(define (hmac key digest-primitive #!optional (block-size 64))
-  (when (> (string-length key) block-size)
-    (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 (blob->u8vector (string->blob key)))
-  (let ((ipad (blob->string (u8vector->blob (u8vector-map (lambda (v) (bitwise-xor v #x36)) key))))
-        (opad (blob->string (u8vector->blob (u8vector-map (lambda (v) (bitwise-xor v #x5c)) key)))))
-    (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))))
+(cond-expand
 
-)
+  (chicken-4
+    (import chicken srfi-13)
+    (use message-digest-basic message-digest-item message-digest-update-item))
+
+  (chicken-5
+    (import (chicken base) (chicken bitwise) srfi-13)
+    (import message-digest-basic message-digest-item message-digest-update-item)))
+
+
+(define (hmac-primitive key digest-primitive)
+  (let ((block-size (message-digest-primitive-block-length digest-primitive))
+        (key_ key))
+    (when (> (string-length key_) block-size)
+      (set! key_ (message-digest-string digest-primitive key_ 'string)))
+    (set! key_ (string-pad-right key_ block-size (integer->char 0)))
+    (let ((ipad (string-map (lambda (c) (integer->char (bitwise-xor (char->integer c) #x36))) key_))
+          (opad (string-map (lambda (c) (integer->char (bitwise-xor (char->integer c) #x5c))) key_)))
+      (make-message-digest-primitive
+        (lambda ()
+          (initialize-message-digest digest-primitive))
+        (message-digest-primitive-digest-length digest-primitive)
+        (lambda (inner)
+          (message-digest-update-string inner ipad))
+        (lambda (inner blob n)
+          (message-digest-update-object inner blob))
+        (lambda (inner x)
+          (finalize-message-digest!
+            (let ((outer (initialize-message-digest digest-primitive)))
+              (message-digest-update-string outer opad)
+              (message-digest-update-string outer (finalize-message-digest inner 'string))
+              outer)
+            x))))))
+
+(define (hmac key digest-primitive #!optional (result-form 'string))
+  (lambda (message)
+    (message-digest-object (hmac-primitive key digest-primitive) message result-form)))
+)

hmac.setup

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

tests/run.scm

@@ -2,28 +2,41 @@
 ; email: t@thintz.com
 ; license: bsd
 
-(use test)
-(use sha1 string-utils hmac)
+(cond-expand
 
-(test-group "HMAC"
-            (test "Short Key and Message"
-                  "64608bd9aa157cdfbca795bf9a727fc191a50b66"
-                  (string->hex ((hmac "hi" (sha1-primitive) 64) "food is good")))
+  (chicken-4
+    (use test)
+    (use sha1 string-utils hmac))
 
-            (test "Long Key, Short Message"
-                  "511387216297726a7947c6006f5be89711662b1f"
-                  (string->hex ((hmac "hi my name is the big bad wolf" (sha1-primitive) 64) "hi")))
+  (chicken-5
+    (import test)
+    (import sha1 string-hexadecimal hmac)))
 
-            (test "Short Key, Long Message (Longer than blocksize)"
-                  "73dc948bab4e0c65b1e5d18ae3694a39a4788bee"
-                  (string->hex ((hmac "key" (sha1-primitive) 64) "this is a really long message that is going to being run through this hmac test to make sure that it works correctly.")))
 
-            (test "Larger Blocksize"
-                  "3dbf833dc1e13c88f0366efaa2ec7d89399c5c1a"
-                  (string->hex ((hmac "key key key" (sha1-primitive) 256) "hi what is your name?")))
+(test-group "RFC2202 test vectors"
+  (define (testv key msg expected)
+    (test "Vector" expected (string->hex ((hmac key (sha1-primitive)) msg))))
 
-            (test "Smaller Blocksize"
-                  "dd9547893c27d1af459601bb571c6da8941ac00c"
-                  (string->hex ((hmac "key key key" (sha1-primitive) 16) "hi what is your name?"))))
+  (testv (make-string 20 (integer->char #x0b))
+         "Hi There"
+         "b617318655057264e28bc0b6fb378c8ef146be00")
+  (testv "Jefe"
+         "what do ya want for nothing?"
+         "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79")
+  (testv "\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19"
+         (make-string 50 (integer->char #xcd))
+         "4c9007f4026250c6bc8414f9bf50c86c2d7235da")
+  (testv (make-string 20 (integer->char #xaa))
+         (make-string 50 (integer->char #xdd))
+         "125d7342b9ac11cd91a39af48aa17b4f63f175d3")
+  (testv (make-string 20 (integer->char #x0c))
+         "Test With Truncation"
+         "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04")
+  (testv (make-string 80 (integer->char #xaa))
+         "Test Using Larger Than Block-Size Key - Hash Key First"
+         "aa4ae5e15272d00e95705637ce8a3b55ed402112")
+  (testv (make-string 80 (integer->char #xaa))
+         "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
+         "e8e99d0f45237d786d6bbaa7965c7808bbff1a91"))
 
-(test-exit)
+(test-exit)