Common Lisp CFFI interface

contrib/kana-hash/README.org

@@ -0,0 +1,53 @@
+* kana-hash
+Common Lisp kana hashes using CFFI.
+
+We export one function, ~make-hash~, that takes the ~string~ we want
+to hash, and optionally the ~algorithm~, ~salt-type~ and ~salt~ to use.
+
+** Installation
+- =git clone= the repo
+- =$ make && sudo make install=
+- Add kana-hash to your quicklisp local-projects with something like
+  =$ ln -sf `pwd`/contrib/kana-hash/
+  $home/quicklisp/local-projects/kana-hash=
+- Then in your Lisp do:
+#+BEGIN_SRC lisp
+(ql:register-local-projects)
+(ql:quickload :kana-hash)
+#+END_SRC
+** Usage
+#+BEGIN_SRC lisp
+;; Just hashing the string
+(kana-hash:make-hash "uguu~")
+
+;; Using a different algorithm
+(kana-hash:make-hash "uguu~" :algo +algo-sha256+)
+
+;; Using a salt
+;; salt-type is implicitly set to +salt-specific+
+(kana-hash:make-hash "uguu~" :salt "am I cute?")
+
+;; Using a different algorithm and salt-type
+(kana-hash:make-hash "uguu~"
+                     :algo +algo-crc32+
+                     :salt-type +salt-random+)
+#+END_SRC
+** Algorithms
+We define lisp constants for the algorithms used. Input is ~uguu~~
+using the default salt.
+| Algorithm               | Output                                                           |
+| =+algo-sha256+=         | おシソまツアでぅせヅモァだゅノぴヲろヂォセづマふげぁユねハァがゅ |
+| =+algo-crc32+=          | わほヂァ                                                         |
+| =+algo-crc64+=          | づやワえほぢレご                                                 |
+| =+algo-sha256-truncated+= | おシソまツアでぅ                                                 |
+** Salt types
+We also define constants for salt types. Input is ~uguu~~ using the
+default algorithm.
+| Salt Type       | Output           |
+| =+salt-none+=   | らニにすわムねぅ |
+| =+salt-default+= | おシソまツアでぅ |
+| =+salt-specific+= | ぱペみぇサべツュ |
+| =+salt-random+= | リヨみがゆヲえに |
+Calling ~+salt-specific+~ without a ~salt~ it will use the salt
+~NIL~. Using a ~salt~ will implicitly set ~salt-type~ to
+~+salt-specific+~.

contrib/kana-hash/constants.lisp

@@ -0,0 +1,28 @@
+(in-package :kana-hash-ffi)
+#.`(progn
+     ,@(loop for (name . code) in
+             '((KHASH_SUCCESS               . 0)
+               (KHASH_ERROR_IO              . 1)
+               (KHASH_ERROR_FORMAT          . 2)
+               (KHASH_ERROR_LENGTH          . 3)
+               (KHASH_ERROR_RNG             . 4)
+               (KHASH_ERROR_UNKNOWN         . -1))
+             collect `(defconstant ,name ,code)
+             collect `(export (quote ,name))))
+
+
+(in-package :kana-hash)
+#.`(progn
+     ,@(loop for (name . code) in
+             '((+algo-default+          . 0)
+               (+algo-crc32+            . 1)
+               (+algo-crc64+            . 2)
+               (+algo-sha256+           . 3)
+               (+algo-sha256-truncated+ . 4)
+               
+               (+salt-none+     . 0)
+               (+salt-default+  . 1)
+               (+salt-specific+ . 2)
+               (+salt-random+   . 3))
+             collect `(defconstant ,name ,code)
+             collect `(export (quote ,name))))

contrib/kana-hash/ffi.lisp

@@ -0,0 +1,118 @@
+(in-package :kana-hash-ffi)
+
+(define-foreign-library libkhash
+  (:unix (:or "libkhash.so" "libkhash" "./libkhash.so" "/usr/lib/libkhash.so" "/usr/local/lib/libkhash.so"))
+  (t (:default "libkhash")))
+
+(use-foreign-library libkhash)
+
+(defcstruct khash-salt
+  (salt_type :char)
+  (size :int)
+  (body :pointer))
+
+(defcstruct khash-ctx
+  (algo :char)
+  (flags :long)
+  (khash_salt (:struct khash-salt)))
+
+(defcfun "khash_max_length" :int
+  (algo :char)
+  (input-length :long)
+  (digest-length :pointer))
+
+(defcfun "khash_new_context" :int
+  (algo :char)
+  (salt_type :char)
+  (data :pointer)
+  (size :long)
+  (output :pointer))
+
+(defcfun "khash_free_context" :int
+  (ctx :pointer))
+
+(defcfun "khash_clone_context" :int
+  (src :pointer)
+  (dest :pointer))
+
+(defcfun "khash_length" :int
+  (context :pointer)
+  (data :pointer)
+  (size :long)
+  (length :pointer))
+
+(defcfun "khash_do" :int
+  (context :pointer)
+  (data :pointer)
+  (size :long)
+  (string :pointer)
+  (strlen :long))
+
+(defmacro with-khash-context (ctx &body body)
+  `(with-foreign-object (,ctx '(:struct khash-ctx))
+     ,@body))
+
+(defmacro initialise-khash-context (context ctx &body body)
+  `(with-foreign-object (,context '(:struct khash-ctx))
+     (setf (mem-aref ,context '(:struct khash-ctx)) ,ctx)
+     ,@body))
+
+(defun get-length (string)
+  (foreign-funcall "strlen" :pointer string :int))
+
+(defmacro initialise-foreign-string (data _data &body body)
+  `(with-foreign-string (data _data)
+     (let ((len (get-length ,data)))
+       ,@body)))
+
+(defun ffi-khash-max-length (algo input-length)
+  (with-foreign-object (digest-length :long)
+    (values 
+     (khash-max-length algo input-length digest-length)
+     (mem-ref digest-length :long))))
+
+(defun ffi-khash-new-context (algo salt-type _data)
+  (with-khash-context output
+    (with-foreign-string (data _data)
+      (let ((len (get-length data)))
+        (values
+         (khash-new-context algo salt-type data len output)
+         (mem-ref output '(:struct khash-ctx)))))))
+
+(defun ffi-khash-free-context (ctx)
+  (initialise-khash-context context ctx
+    (khash-free-context context)))
+
+(defun ffi-khash-clone-context (src)
+  (with-khash-context destination
+    (initialise-khash-context context src
+      (khash-clone-context context destination)
+      (mem-ref destination '(:struct khash-ctx)))))
+
+(defun ffi-khash-length (ctx _data)
+  (initialise-khash-context context ctx
+    (with-foreign-string (data _data)
+      (let ((len (get-length data)))
+        (with-foreign-object (output-length :long)          
+          (values (khash-length context data len output-length)
+                  (mem-aref output-length :long)))))))
+
+(defun ffi-khash-do (ctx _data length)
+  (initialise-khash-context context ctx
+    (with-foreign-string (data _data)
+      (let ((len (get-length data)))
+        (with-foreign-pointer (string (1+ length))
+          (foreign-funcall "memset" :pointer string
+                                    :int 0 
+                                    :long (1+ length)
+                                    :pointer)
+          (values 
+           (khash-do context data len string length)
+           (foreign-string-to-lisp string)))))))
+
+(export '(ffi-khash-do
+          ffi-khash-length
+          ffi-khash-clone-context
+          ffi-khash-free-context
+          ffi-khash-new-context
+          ffi-khash-max-length))

contrib/kana-hash/kana-hash.asd

@@ -0,0 +1,11 @@
+(asdf:defsystem :kana-hash
+  :description "Kana Hashes"
+  :author "Plum (boku@plum.moe)"
+  :license "GPLv3"
+  :version "1.0.0"
+  :serial t
+  :depends-on (:cffi)
+  :Components ((:file "package")
+               (:file "constants")
+               (:file "ffi")
+               (:file "kana-hash")))

contrib/kana-hash/kana-hash.lisp

@@ -0,0 +1,47 @@
+(in-package :kana-hash)
+
+(define-condition kana-hash-error (error)
+  ((msg :initarg :msg
+        :reader messig))
+  (:report (lambda (condition stream)
+             (format stream "~a" (messig condition)))))
+
+(defun handle-kana-hash-error (error-code)
+  (error 'kana-hash-error :msg
+         (cond
+           ((= error-code KHASH_ERROR_IO) "IO Error")
+           ((= error-code KHASH_ERROR_FORMAT) "Format Error")
+           ((= error-code KHASH_ERROR_LENGTH) "Length Error")
+           ((= error-code KHASH_ERROR_RNG) "RNG Error")
+           ((= error-code KHASH_ERROR_UNKNOWN) "Unknown Error"))))
+
+(defmacro with-success (thing function &body body)
+  `(multiple-value-bind (return-code ,thing) ,function
+     (if (= KHASH_SUCCESS return-code)
+         (progn ,@body)
+         (error 'kana-hash-error (handle-kana-hash-error return-code)))))
+
+
+(defmacro with-context ((ctx algo salt-type salt) &body body)
+  `(multiple-value-bind (return-code ,ctx) (ffi-khash-new-context ,algo ,salt-type ,salt)
+     (unwind-protect          
+          (progn
+            (unless (= KHASH_SUCCESS return-code)
+              (error 'kana-hash-error (handle-kana-hash-error return-code)))
+            ,@body)
+       (when ,ctx
+         (ffi-khash-free-context ,ctx)))))
+
+(defun make-hash (string &key (algo +algo-default+) (salt-type +salt-default+) salt
+                  &aux (salt (or salt nil)))
+  (when salt
+    (setf salt-type +salt-specific+))
+  (unless salt
+    (setf salt (format nil "~a" salt)))
+  (with-context (ctx algo salt-type salt)
+    (with-success hash-length (ffi-khash-length ctx string)
+      (with-success kana-hash (ffi-khash-do ctx string hash-length)
+        (setf ctx nil)
+        kana-hash))))
+
+(export 'make-hash)

contrib/kana-hash/package.lisp

@@ -0,0 +1,5 @@
+(defpackage :kana-hash-ffi
+  (:use :cl :cffi))
+
+(defpackage :kana-hash
+  (:use :cl :kana-hash-ffi))