Rewrite as a message-digest primitive

The block size is an inherent property of the hashing function being
used and should not be manipulated by the user.

hmac.scm

@@ -3,28 +3,36 @@
 ; license: bsd
 
 (module hmac
-  (hmac)
+  (hmac hmac-primitive)
 
-(import scheme chicken srfi-4 srfi-13)
+(import scheme chicken lolevel srfi-13)
-(use message-digest-port)
+(use message-digest-basic message-digest-item message-digest-update-item)
 
-(define (hmac key digest-primitive #!optional (block-size 64))
+(define (hmac-primitive key digest-primitive)
-  (let ((key_ key))
+  (let ((block-size (message-digest-primitive-block-length digest-primitive))
+        (key_ key))
     (when (> (string-length key_) block-size)
-          (set! key_ (call-with-output-digest digest-primitive (cut display key_ <>) 'string)))
+      (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_)))
-      (lambda (message)
+      (make-message-digest-primitive
-        (call-with-output-digest
+        (lambda ()
-         digest-primitive
+          (initialize-message-digest digest-primitive))
-         (cut display
+        (message-digest-primitive-digest-length digest-primitive)
-              (string-append opad
+        (lambda (inner)
-                             (call-with-output-digest
+          (message-digest-update-string inner ipad))
-                              digest-primitive
+        (lambda (inner blob n)
-                              (cut display (string-append ipad message) <>)
+          (message-digest-update-object inner blob))
-                              'string))
+        (lambda (inner x)
-              <>)
+          (finalize-message-digest!
-         'string)))))
+            (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)))
 )