First release with actual content!

hmac.meta

@@ -0,0 +1,15 @@
+; author: Thomas Hintz
+; email: t@thintz.com
+; license: bsd
+
+(
+(license "BSD")
+
+(category cryptography)
+
+(needs message-digest-port srfi-4-utils)
+
+(test-depends test sha1 string-utils)
+
+(author "Thomas Hintz")
+(synopsis "HMAC provides a HMAC using the message-digest interface."))

hmac.release-info

@@ -0,0 +1,4 @@
+(repo git "git://example.com/{egg-name}.git")   ; optional
+
+(uri targz "http://example.com/{egg-name}/releases/{egg-name}-{egg-release}.tar.gz")
+(release "1")

hmac.scm

@@ -1,11 +1,22 @@
-(use sha1 srfi-4 srfi-4-utils)
+; author: Thomas Hintz
+; email: t@thintz.com
+; license: bsd
+
+(module hmac
+  (hmac)
+
+(import scheme chicken srfi-4 srfi-13)
+(use srfi-4-utils message-digest-port)
 
 ; taken from example at http://wiki.call-cc.org/drupal-xml-rpc
-(define (sha1-hmac key)
-  (when (> (string-length key) 64) (set! key (sha1-binary-digest key)))
-  (set! key (string-pad-right key 64 (integer->char 0)))
+(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)
-      (sha1-binary-digest (string-append opad (sha1-binary-digest (string-append ipad 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))))
+
+)

hmac.setup

@@ -0,0 +1,15 @@
+; author: Thomas Hintz
+; email: t@thintz.com
+; license: bsd
+
+(compile -s -O2 -d1 hmac.scm -j hmac)
+(compile -s hmac.import.scm -O2 -d0)
+(compile -c -O2 -d1 hmac.scm -unit hmac -j hmac)
+
+(install-extension
+  'hmac
+  ; Files to install for your extension:
+  '("hmac.o" "hmac.so" "hmac.import.so")
+  ; Assoc list with properties for your extension:
+  '((version 1)
+    (static "hmac.o"))) ;; for static linking

tests/run.scm

@@ -0,0 +1,29 @@
+; author: Thomas Hintz
+; email: t@thintz.com
+; license: bsd
+
+(use test)
+(use sha1 string-utils)
+
+(test-group "HMAC"
+            (test "Short Key and Message"
+                  "64608bd9aa157cdfbca795bf9a727fc191a50b66"
+                  (string->hex ((hmac "hi" (sha1-primitive) 64) "food is good")))
+
+            (test "Long Key, Short Message"
+                  "511387216297726a7947c6006f5be89711662b1f"
+                  (string->hex ((hmac "hi my name is the big bad wolf" (sha1-primitive) 64) "hi")))
+
+            (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 "Smaller Blocksize"
+                  "dd9547893c27d1af459601bb571c6da8941ac00c"
+                  (string->hex ((hmac "key key key" (sha1-primitive) 16) "hi what is your name?"))))
+
+(test-exit)