[armedbear-cvs] r13330 - trunk/abcl/tools

[mevenson at common-lisp.net]

Author: mevenson
Date: Wed Jun 15 02:26:03 2011
New Revision: 13330

Log:
Create API for message digests via generic function DIGEST.

DIGEST-PATH will return the ascii encoding of the SHA-256
cryptographic hash of the resource at PATH as fast as possible.

Added:
   trunk/abcl/tools/abcl-tools.asd
Modified:
   trunk/abcl/tools/digest.lisp

Added: trunk/abcl/tools/abcl-tools.asd
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/abcl/tools/abcl-tools.asd	Wed Jun 15 02:26:03 2011	(r13330)
@@ -0,0 +1,9 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP -*-
+(require 'asdf)
+(in-package :asdf)
+
+(defsystem :abcl-tools :version "0.1.0" :components 
+           ((:module src :pathname "" :components
+                     ((:file "digest")
+                      (:file "code-grapher")))))
+                     
\ No newline at end of file

Modified: trunk/abcl/tools/digest.lisp
==============================================================================
--- trunk/abcl/tools/digest.lisp	Tue Jun 14 23:26:32 2011	(r13329)
+++ trunk/abcl/tools/digest.lisp	Wed Jun 15 02:26:03 2011	(r13330)
@@ -1,8 +1,22 @@
+;;;; Cryptographic  message digest calculation with ABCL with different implementations.
+;;;;
+;;;; Mark <evenson.not.org at gmail.com>
+;;;;
+
+(in-package :cl-user)
+
+;;; API
+(defgeneric digest (url algorithim  &optional (digest 'sha-256))
+  (:documentation "Digest byte based resource at URL with ALGORITHIM."))
+(defun digest-path (path) (ascii-digest (digest path 'nio 'sha-256)))
+
 (defvar *digest-types* 
-  '((:sha-1 . "SHA-1")
-    (:sha-256 . "SHA-256")
-    (:sha-512 . "SHA-512")))
+  '((sha-1 . "SHA-1")
+    (sha-256 . "SHA-256")
+    (sha-512 . "SHA-512"))
+  "Normalization of cryptographic digest naming.")
 
+;;; Implementation
 (defconstant +byte-buffer-rewind+ 
   (jmethod "java.nio.ByteBuffer" "rewind"))
 (defconstant +byte-buffer-get+ 
@@ -10,24 +24,15 @@
 (defconstant +digest-update+ 
   (jmethod "java.security.MessageDigest" "update" "[B" "int" "int"))
 
-;;;  needs ABCL svn > r13328 and is probably not faster than the NIO version
+(defmethod digest ((url t) (algorithim (eql 'nio)) &optional (digest 'sha-256))
+  "Calculate digest with default of :SHA-256 pathname specified by URL.
+Returns an array of JVM primitive signed 8-bit bytes.
 
-(defun digest-file-1 (path &key (digest :sha-256))
- (let* ((digest-type (cdr (assoc digest *digest-types*)))
-        (digest (jstatic "getInstance" "java.security.MessageDigest" digest-type))
-        (buffer (make-array 8192 :element-type '(unsigned-byte 8))))
-   (with-open-file (input path :element-type '(unsigned-byte 8))
-     (loop :for bytes = (read-sequence buffer input)
-        :while (plusp bytes)
-        :do 
-        (jcall-raw "update" digest 
-                   (jnew-array-from-array "byte" buffer) 0 bytes))
-     (jcall "digest" digest))))
+*DIGEST-TYPES* controls the allowable digest types."
 
-(defun digest-file (path &key (digest :sha-256))
  (let* ((digest-type (cdr (assoc digest *digest-types*)))
         (digest (jstatic "getInstance" "java.security.MessageDigest" digest-type))
-        (namestring (if (pathnamep path) (namestring path) path))
+        (namestring (if (pathnamep url) (namestring url) url))
         (file-input-stream (jnew "java.io.FileInputStream" namestring))
         (channel (jcall "getChannel" file-input-stream))
         (length 8192)
@@ -42,27 +47,55 @@
      (jcall +digest-update+ digest array 0 read))
    (jcall "digest" digest)))
 
+(defmethod digest ((url pathname) (algorithim (eql 'lisp)) &optional (digest 'sha-256))
+  "Compute digest of URL in Lisp where possible.
+
+Currently much slower that using 'nio.
+
+Needs ABCL svn > r13328."
+
+ (let* ((digest-type (cdr (assoc digest *digest-types*)))
+        (digest (jstatic "getInstance" "java.security.MessageDigest" digest-type))
+        (buffer (make-array 8192 :element-type '(unsigned-byte 8))))
+   (with-open-file (input url :element-type '(unsigned-byte 8))
+     (loop 
+        :for  
+            bytes = (read-sequence buffer input)
+        :while 
+           (plusp bytes)
+        :do 
+           (jcall-raw "update" digest 
+                      (jnew-array-from-array "byte" buffer) 0 bytes))
+     (jcall "digest" digest))))
+
 (defun ascii-digest (digest)
   (format nil "~{~X~}"
           (mapcar (lambda (b) (if (< b 0) (+ 256 b) b))
                   (java::list-from-jarray digest))))
 
 (defun benchmark (directory)
-    (let (results start-1 end-1 start-2 end-2)
+  "For a given DIRECTORY containing a wildcard of files, run the benchmark tests."
+  (let (results)
+    (flet ((benchmark (task)
+             (let (start end result)
+               (psetf start (get-internal-run-time)
+                      result (push (funcall task) result)
+                      end (get-internal-run-time))
+               (nconc result (list start (- end start))))))
       (dolist (entry (directory directory))
-        (setf start-1 (get-internal-run-time))
-        (digest-file-1 entry)
-        (setf end-1 (get-internal-run-time))
-        (setf start-2 (get-internal-run-time))
-        (digest-file entry)
-        (setf end-2 (get-internal-run-time))
-        (let ((result (list entry (- end-1 start-1) (- end-2 start-2))))
-          (format t "~&~A" result)
-          (push result results)))
-      results))
-    
-        
-
-
-    
-
+        (let ((result 
+               (list 
+                (list 'nio (benchmark (lambda () (digest entry 'nio))))
+                (list 'lisp (benchmark (lambda () (digest entry 'lisp)))))))
+          (format t "~&~{~A~&~A~}" result)
+          (push result results))))))
+
+;;; Deprecated
+(setf (symbol-function 'digest-file-1) #'digest)
+
+;;; Test
+
+#|
+(benchmark "/usr/local/bin/*") ;; unix
+(benchmark "c:/*")             ;; win32
+|#