
#|
   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., 51 Franklin Street, Fifth Floor, Boston,
   MA 02110-1301, USA.
   
   
**** sha1, sha256 **************************************************************
   
   Copyright Volker van Nek, 2014
   
   sha1sum(string) returns the sha1 fingerprint of string and sha256sum the 
   sha256 fingerprint.
   
   The return value is a string to guarantee 40 (64) hex characters. To parse it 
   into an integer please set the input base to 16 and prefix the string by zero.
   
   (%i2) string : sha1sum("foo bar baz");
   (%o2)              c7567e8b39e2428e38bf9c9226ac68de4c67dc39
   (%i3) ibase : obase : 16.$
   
   (%i4) integer : parse_string(sconcat(0, string));
   (%o4)              0c7567e8b39e2428e38bf9c9226ac68de4c67dc39

   Note that in case the string contains German umlauts or other non-ASCII 
   characters the fingerprint is platform dependend.
   
   The following code streams the base64 contents of a X509 certificate into a 
   string, decodes base64 to DER format and returns the SHA1 fingerprint. 
   The result is checked against openssl in GNU/Linux.
   
   (%i2) ostream : make_string_output_stream();
   (%o2)                  #<string-output stream 00f065e8>
   (%i3) fos : openr("/home/volker/Deutsche_Telekom_Root_CA_2.crt");
   (%o3)        #<input stream /home/volker/Deutsche_Telekom_Root_CA_2.crt>
   (%i4) while (z : readline(fos)) # false do 
   if not cequal(charat(z, 1), "-") then printf(ostream, "~a", z);
   (%o4)                                done
   (%i5) close(fos);
   (%o5)                                true
   (%i6) string : get_output_stream_string(ostream);
   (%o6) MIIDnzCCAoegAwIBAgIBJjANBgkqhkiG9w0BAQUFADBxMQswCQYDVQQGEwJERTEcMBoGA1UE\
   ChMTRGV1dHNjaGUgVGVsZWtvbSBBRzEfMB0GA1UECxMWVC1UZWxlU2VjIFRydXN0IENlbnRlcjEjMC\
   EGA1UEAxMaRGV1dHNjaGUgVGVsZWtvbSBSb290IENBIDIwHhcNOTkwNzA5MTIxMTAwWhcNMTkwNzA5\
   MjM1OTAwWjBxMQswCQYDVQQGEwJERTEcMBoGA1UEChMTRGV1dHNjaGUgVGVsZWtvbSBBRzEfMB0GA1\
   UECxMWVC1UZWxlU2VjIFRydXN0IENlbnRlcjEjMCEGA1UEAxMaRGV1dHNjaGUgVGVsZWtvbSBSb290\
   IENBIDIwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCrC6M14IspFLEUha88EOQ5bzVdSq\
   7d6mGNlUn0b2SjGmBmpKlAIoTZ1KXleJMOaAGtuU1cOs7TuKhCQN/Po7qCWWqSG6wcmtoIKyUn+Wkj\
   R/Hg6yx6m/UTAtB+NHzCnjwAWav12gz1MjwrrFDa1sPeg5TKqAyZMg4ISFZbavva4VhYAUlfckE8FQ\
   YBjl2tqriTtM2e66foai1SNNs671x1Udrb8zH57nGYMsRUFUQM+ZtV7a3fGAigo4aKSe5TBY8ZTNXe\
   WHmb0mocQqvF1afPaA+W5OFhmHZhyJF81j4A4pFQh+GdCuatl9Idxjp9y7zaAzTVjlsB9WoHtxa2bk\
   p/AgMBAAGjQjBAMB0GA1UdDgQWBBQxw3kbuvVT1xfgiXotF2wKsyudMzAPBgNVHRMECDAGAQH/AgEF\
   MA4GA1UdDwEB/wQEAwIBBjANBgkqhkiG9w0BAQUFAAOCAQEAlGRZrTlk5ynrE/5aw4sTV8gEJPB0d8\
   Bg42f76Ymmg7+Wgnxu1MM9756AbrsptJh6sTtU6zkXR34ajgv8HzFZMQSyzhfzLMdiNlXiItiJVbSY\
   SKpk+tYcNthEeFpaIzpXl/V6ME+un2pMSyuOoAPjPuCp1NJ70rOo4nI8rZ7/gFnkm0W09juwzTkZmD\
   Ll6iFhkOQxIY40sfcvNUqFENrnijchvllj4PKFiDFT1FQUhXB59C4Gdyd1Lx+4ivn+xbrYNuSD7Odl\
   t79jWvNGr4GUN9RBjNYj1h7P9WgbRGOiWrqnNVmh5XAFmw4jV5mUCm26OWMohpLzGITY+9HPBVZkVw\
   ==
   (%i7) close(ostream);
   (%o7)                                true
   (%i8) sha1sum(base64_decode(string));
   (%o8)              85a408c09c193e5d51587dcdd61330fd8cde37bf
   (%i9) system("openssl x509 -fingerprint -noout -in '/home/volker/Deutsche_Telekom_Root_CA_2.crt' > temp ; cat temp");
   SHA1 Fingerprint=85:A4:08:C0:9C:19:3E:5D:51:58:7D:CD:D6:13:30:FD:8C:DE:37:BF
   (%o9)                                  0

|#

(eval-when
  #+gcl (compile eval)
  #-gcl (:compile-toplevel :execute)
    (defvar old-ibase *read-base*)
    (setq *read-base* 10.) )


(declaim (inline sha-not sha+ sha-left-rotation sha-right-rotation))

(defun sha-not (i32)
  (logand (lognot i32) #xffffffff) )

(defun sha+ (&rest args)
  (logand (apply #'+ args) #xffffffff) )

(defun sha-left-rotation (i32 k)
  (logior (logand (ash i32 k) #xffffffff) (ash i32 (- k 32.))) )

(defun sha-right-rotation (i32 k)
  (logior (ash i32 (- k)) (logand (ash i32 (- 32. k)) #xffffffff)) )


(defun sha-update (bytes nr)
  (setq bytes (coerce bytes 'vector))
  (cond
    ((= nr 160.)
      (sha1-words bytes)
      (sha1-worker) )
    ((= nr 256.)
      (sha256-words bytes)
      (sha256-worker) )))

(defun sha-len64 (bits)
  (do ((i 1 (1+ i)) lst) (nil)
    (push (logand bits #xff) lst)
    (when (= i 8) (return lst))
    (setq bits (ash bits -8)) ))

(defun sha-final (bytes off len nr)
  (when bytes (rplacd (last bytes) '(#x80)))
  (when (= 0 off) (setq bytes '(#x80)))
  (if (<= off 55.)
    (let* ((bits (ash len 3))
           (len64 (sha-len64 bits))
           (pad (make-list (- 55. off) :initial-element 0)) )
      (sha-update (append bytes pad len64) nr) )
    (let ((pad (make-list (- 63. off) :initial-element 0)))
      (sha-update (append bytes pad) nr)
      (sha-final nil -1 len nr) )))


;; *** SHA1 ***************************************************************** ;;

(defvar *h1* nil)
(defvar *w1* nil)

(defun sha1-worker ()
  (multiple-value-bind (a b c d e) (apply #'values *h1*)
    (let (f k tmp)
      (do ((i 0 (1+ i)))
          ((= i 80.))
        (cond
          ((< i 20.)
            (setq f (logior (logand b c) (logand (sha-not b) d))
                  k #x5a827999 ))
          ((< i 40.)
            (setq f (logxor b c d)
                  k #x6ed9eba1 ))
          ((< i 60.)
            (setq f (logior (logand b c) (logand b d) (logand c d))
                  k #x8f1bbcdc ))
          (t
            (setq f (logxor b c d)
                  k #xca62c1d6 )))
        (setq tmp (sha+ (sha-left-rotation a 5) f e k (svref *w1* i))
              e d
              d c
              c (sha-left-rotation b 30.)
              b a
              a tmp ) )
      (setq *h1* (mapcar #'sha+ (list a b c d e) *h1*)) )))

(defun sha1-words (vec)
  (setq *w1* (make-array 80. :element-type 'integer :initial-element 0))
  ;; copy 512 bit message into 32 bit big-endian words:
  (do ((i 0 (1+ i)) (inc -1))
      ((= i 16.))
    (setf (svref *w1* i) 
      (logior (ash (svref vec (incf inc)) 24.)
              (ash (svref vec (incf inc)) 16.)
              (ash (svref vec (incf inc))  8.)
                   (svref vec (incf inc))     )))
  ;; expand:
  (do ((i 16. (1+ i)))
      ((= i 80.))
    (setf (svref *w1* i) 
      (sha-left-rotation 
        (logxor (svref *w1* (- i 3.))
                (svref *w1* (- i 8.))
                (svref *w1* (- i 14.))
                (svref *w1* (- i 16.)) )
        1 ))))

(defmfun $sha1sum (s)
  (unless (stringp s)
    (merror "`sha1sum': Argument must be a string.") )
  (let* ((bytes (mapcar #'char-code (coerce s 'list)))
         (len (length bytes)) )
    (setq *h1* '(#x67452301 #xefcdab89 #x98badcfe #x10325476 #xc3d2e1f0))
    (do ((off len)) 
        ((< off 64.) (sha-final bytes off len 160.))
      (setq off (- off 64.))
      (sha-update (butlast bytes off) 160.)
      (setq bytes (last bytes off)) )
    (nstring-downcase (format nil "~{~8,'0x~}" *h1*)) ))


;; *** SHA256 *************************************************************** ;;

(defvar *k2* 
  (coerce               ;; the first 32 bits of the fractional parts of ..
    (mapcar #'(lambda (i) (floor (* (rem (expt (coerce i 'real) 1/3) 1.0) #x100000000))) 
            (subseq *small-primes* 0 64.) ) ;; .. the cube roots of the first 64 primes (2,..,311)
    'vector ))

(defvar *h2* nil)
(defvar *w2* nil)

(defun sha256-worker ()
  (multiple-value-bind (a b c d e f g h) (apply #'values *h2*)
    (let (s1 t1 s2 t2)
      (do ((i 0 (1+ i)))
          ((= i 64.))
        (setq s1 (logxor (sha-right-rotation e 6)
                         (sha-right-rotation e 11.)
                         (sha-right-rotation e 25.) )
              t1 (logxor (logand e f) (logand (sha-not e) g))
              t1 (sha+ h s1 t1 (svref *k2* i) (svref *w2* i))
              s2 (logxor (sha-right-rotation a 2)
                         (sha-right-rotation a 13.)
                         (sha-right-rotation a 22.) )
              t2 (logxor (logand a b) (logand a c) (logand b c))
              t2 (sha+ s2 t2) )
        (setq h g
              g f
              f e
              e (sha+ d t1)
              d c
              c b
              b a
              a (sha+ t1 t2) ))
      (setq *h2* (mapcar #'sha+ (list a b c d e f g h) *h2*)) )))

(defun sha256-words (vec)
  (setq *w2* (make-array 64. :element-type 'integer :initial-element 0))
  ;; copy 512 bit message into 32 bit big-endian words:
  (do ((i 0 (1+ i)) (inc -1))
      ((= i 16.))
    (setf (svref *w2* i) 
      (logior (ash (svref vec (incf inc)) 24.)
              (ash (svref vec (incf inc)) 16.)
              (ash (svref vec (incf inc))  8.)
                   (svref vec (incf inc))     )))
  ;; expand:
  (do ((i 16. (1+ i)) w s0 s1)
      ((= i 64.))
    (setq w (svref *w2* (- i 15.))
          s0 (logxor (sha-right-rotation w 7)
                     (sha-right-rotation w 18.)
                     (ash w -3) )
          w (svref *w2* (- i 2))
          s1 (logxor (sha-right-rotation w 17.)
                     (sha-right-rotation w 19.)
                     (ash w -10.) ))
    (setf (svref *w2* i) 
      (sha+ (svref *w2* (- i 16.)) s0 (svref *w2* (- i 7)) s1) )))

(defmfun $sha256sum (s)
  (unless (stringp s)
    (merror "`sha256sum': Argument must be a string.") )
  (let* ((bytes (mapcar #'char-code (coerce s 'list)))
         (len (length bytes)) )
    (setq *h2* ;; the first 32 bits of the fractional parts of the square roots of the first 8 primes (2,..,19)
      '(#x6a09e667 #xbb67ae85 #x3c6ef372 #xa54ff53a #x510e527f #x9b05688c #x1f83d9ab #x5be0cd19) )
    (do ((off len)) 
        ((< off 64.) (sha-final bytes off len 256.))
      (setq off (- off 64.))
      (sha-update (butlast bytes off) 256.)
      (setq bytes (last bytes off)) )
    (nstring-downcase (format nil "~{~8,'0x~}" *h2*)) ))


(eval-when
  #+gcl (compile eval)
  #-gcl (:compile-toplevel :execute)
    (setq *read-base* old-ibase) )
