crypto.lisp

   1 ;;;;
   2 ;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
   3 ;;;;
   4 ;;;; Redistribution and use in source and binary forms, with or without
   5 ;;;; modification, are permitted provided that the following conditions
   6 ;;;; are met:
   7 ;;;;
   8 ;;;;   * Redistributions of source code must retain the above copyright
   9 ;;;;     notice, this list of conditions and the following disclaimer.
  10 ;;;;
  11 ;;;;   * Redistributions in binary form must reproduce the above
  12 ;;;;     copyright notice, this list of conditions and the following
  13 ;;;;     disclaimer in the documentation and/or other materials
  14 ;;;;     provided with the distribution.
  15 ;;;;
  16 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  17 ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18 ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  19 ;;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  20 ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  21 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  22 ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  23 ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  25 ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  26 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27 ;;;;
  28 ;;;; crypto.lisp
  29
  30 (in-package #:zs3)
  31
  32 (defclass digester ()
  33   ((hmac
  34     :initarg :hmac
  35     :accessor hmac)
  36    (newline
  37     :initarg :newline
  38     :accessor newline
  39     :allocation :class)
  40    (signed-stream
  41     :initarg :signed-stream
  42     :accessor signed-stream))
  43   (:default-initargs
  44    :signed-stream (make-string-output-stream)
  45    :newline (make-array 1 :element-type '(unsigned-byte 8)
  46                         :initial-element 10)))
  47
  48 (defun make-digester (key)
  49   (let ((hmac (ironclad:make-hmac (string-octets key) :sha1)))
  50     (make-instance 'digester
  51                    :hmac hmac)))
  52
  53 (defgeneric add-string (string digester)
  54   (:method (string digester)
  55     (write-string string (signed-stream digester))
  56     (ironclad:update-hmac (hmac digester) (string-octets string))))
  57
  58 (defgeneric add-newline (digester)
  59   (:method (digester)
  60     (terpri (signed-stream digester))
  61     (ironclad:update-hmac (hmac digester) (newline digester))))
  62
  63 (defgeneric add-line (string digester)
  64   (:method (string digester)
  65     (add-string string digester)
  66     (add-newline digester)))
  67
  68 (defgeneric digest64 (digester)
  69   (:method (digester)
  70     (base64:usb8-array-to-base64-string
  71      (ironclad:hmac-digest (hmac digester)))))
  72
  73 (defun file-md5 (file)
  74    (ironclad:digest-file :md5 file))
  75
  76 (defun file-md5/b64 (file)
  77   (base64:usb8-array-to-base64-string (file-md5 file)))
  78
  79 (defun file-md5/hex (file)
  80   (ironclad:byte-array-to-hex-string (file-md5 file)))
  81
  82 (defun vector-md5/b64 (vector)
  83   (base64:usb8-array-to-base64-string
  84    (ironclad:digest-sequence :md5 vector)))
  85
  86 (defun file-etag (file)
  87   (format nil "\"~A\"" (file-md5/hex file)))
  88
  89 (defun sign-string (key string)
  90   (let ((digester (make-digester key)))
  91     (add-string string digester)
  92     (digest64 digester)))