[armedbear-cvs] r14196 - trunk/abcl/src/org/armedbear/lisp

[mevenson at common-lisp.net]

Author: mevenson
Date: Sun Oct 14 03:54:05 2012
New Revision: 14196

Log:
SYS:SHA256 efficiently computes cryptographic hashs on pathnames.

Added:
   trunk/abcl/src/org/armedbear/lisp/digest.lisp
Modified:
   trunk/abcl/src/org/armedbear/lisp/compile-system.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp	Sat Oct 13 08:19:20 2012	(r14195)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp	Sun Oct 14 03:54:05 2012	(r14196)
@@ -325,6 +325,7 @@
                            "copy-seq.lisp"
                            "copy-symbol.lisp"
                            "count.lisp"
+                           "digest.lisp"
                            "debug.lisp"
                            "define-modify-macro.lisp"
                            "define-symbol-macro.lisp"

Added: trunk/abcl/src/org/armedbear/lisp/digest.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/abcl/src/org/armedbear/lisp/digest.lisp	Sun Oct 14 03:54:05 2012	(r14196)
@@ -0,0 +1,103 @@
+;;; require.lisp
+;;; 
+;;; Copyright (C) 2012 Mark Evenson
+;;; $Id$
+
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+;;;
+;;; As a special exception, the copyright holders of this library give you
+;;; permission to link this library with independent modules to produce an
+;;; executable, regardless of the license terms of these independent
+;;; modules, and to copy and distribute the resulting executable under
+;;; terms of your choice, provided that you also meet, for each linked
+;;; independent module, the terms and conditions of the license of that
+;;; module.  An independent module is a module which is not derived from
+;;; or based on this library.  If you modify this library, you may extend
+;;; this exception to your version of the library, but you are not
+;;; obligated to do so.  If you do not wish to do so, delete this
+;;; exception statement from your version.
+
+(require :java)
+(in-package :system)
+
+(defun ascii-digest (digest)
+  (format nil "~{~X~}"
+          (mapcar (lambda (b) (if (< b 0) (+ 256 b) b))
+                  (java::list-from-jarray digest))))
+(export 'sha256 :system)
+(defun sha256 (&rest paths-or-strings)
+  (format *debug-io* "~&Args: ~S~&" paths-or-strings)
+  (cond 
+    ((= 1 (length paths-or-strings))
+     (typecase paths-or-strings
+       (pathname
+        (ascii-digest (digest (first paths) 'nio)))
+       (string 
+        
+    ((consp paths)
+     (concatenate 'string
+                  (append
+                   (mapcar #'ascii-digest
+                           (mapcar (lambda (p)
+                                     (funcall #'digest p 'nio))
+                                   paths)))))
+    ((null paths)
+     nil)))
+                                      
+           
+(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"))
+  "Normalization of cryptographic digest naming.")
+
+;;; Implementation
+(defconstant +byte-buffer-rewind+ 
+  (java:jmethod "java.nio.ByteBuffer" "rewind"))
+(defconstant +byte-buffer-get+ 
+  (java:jmethod "java.nio.ByteBuffer" "get" "[B" "int" "int"))
+(defconstant +digest-update+ 
+  (java:jmethod "java.security.MessageDigest" "update" "[B" "int" "int"))
+
+(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.
+
+*DIGEST-TYPES* controls the allowable digest types."
+
+ (let* ((digest-type (cdr (assoc digest *digest-types*)))
+        (digest (java:jstatic "getInstance" "java.security.MessageDigest" digest-type))
+        (namestring (if (pathnamep url) (namestring url) url))
+        (file-input-stream (java:jnew "java.io.FileInputStream" namestring))
+        (channel (java:jcall "getChannel" file-input-stream))
+        (length 8192)
+        (buffer (java:jstatic "allocateDirect" "java.nio.ByteBuffer" length))
+        (array (java:jnew-array "byte" length)))
+   (do ((read (java:jcall "read" channel buffer)
+              (java:jcall "read" channel buffer)))
+       ((not (> read 0)))
+     (java:jcall +byte-buffer-rewind+ buffer)
+     (java:jcall +byte-buffer-get+ buffer array 0 read)
+     (java:jcall +byte-buffer-rewind+ buffer)
+     (java:jcall +digest-update+ digest array 0 read))
+   (java:jcall "digest" digest)))
+
+;;(defmethod digest ((s string) (algorithim (eql 'nio)) &optional (digest 'sha-256))
+;;  (warn "Unimplemented."))
+;;  (let ((input-stream (