share/stringproc/sha1.lisp

   1
   2 #|
   3    This program is free software; you can redistribute it and/or modify
   4    it under the terms of the GNU General Public License as published by
   5    the Free Software Foundation; either version 2 of the License, or
   6    (at your option) any later version.
   7
   8    This program is distributed in the hope that it will be useful,
   9    but WITHOUT ANY WARRANTY; without even the implied warranty of
  10    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11    GNU General Public License for more details.
  12
  13    You should have received a copy of the GNU General Public License
  14    along with this program; if not, write to the Free Software
  15    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
  16    MA 02110-1301, USA.
  17
  18
  19 **** sha1, sha256, mgf1_sha1 ***************************************************
  20
  21    Copyright Volker van Nek, 2014 - 2015
  22
  23    sha1sum returns the sha1 fingerprint of a string, a non-negative integer or
  24    a list of octets.
  25
  26    sha256sum returns the sha256 fingerprint.
  27
  28    The default return value is a string that guarantees 40 (64) hex characters.
  29    An optional argument allows sha1sum and sha256sum to return the corresponding
  30    number or list of octets.
  31
  32    (%i1) ibase: obase: 16.$
  33    (%i2) msg: "foo bar baz"$
  34    (%i3) string: sha1sum(msg);
  35    (%o3)              c7567e8b39e2428e38bf9c9226ac68de4c67dc39
  36    (%i4) integer: sha1sum(msg, 'number);
  37    (%o4)             0c7567e8b39e2428e38bf9c9226ac68de4c67dc39
  38    (%i5) octets: sha1sum(msg, 'list);
  39    (%o5)  [0C7,56,7E,8B,39,0E2,42,8E,38,0BF,9C,92,26,0AC,68,0DE,4C,67,0DC,39]
  40    (%i6) sdowncase( printf(false, "~{~2,'0x~^:~}", octets) );
  41    (%o6)     c7:56:7e:8b:39:e2:42:8e:38:bf:9c:92:26:ac:68:de:4c:67:dc:39
  42
  43    Note that in case the string contains German umlauts or other non-ASCII
  44    characters the fingerprint is platform dependent.
  45
  46    The following code streams the base64 contents of a X509 certificate into a
  47    string, decodes base64 to DER format and returns the SHA1 fingerprint.
  48    The result is checked against openssl in GNU/Linux.
  49
  50    (%i1) ostream : make_string_output_stream();
  51    (%o1)                  #<string-output stream 00f065e8>
  52    (%i2) fos : openr("/home/volker/Deutsche_Telekom_Root_CA_2.crt");
  53    (%o2)        #<input stream /home/volker/Deutsche_Telekom_Root_CA_2.crt>
  54    (%i3) while (z : readline(fos)) # false do
  55    if not cequal(charat(z, 1), "-") then printf(ostream, "~a", z);
  56    (%o3)                                done
  57    (%i4) close(fos);
  58    (%o4)                                true
  59    (%i5) string : get_output_stream_string(ostream);
  60    (%o5) MIIDnzCCAoegAwIBAgIBJjANBgkqhkiG9w0BAQUFADBxMQswCQYDVQQGEwJERTEcMBoGA1UE\
  61    ChMTRGV1dHNjaGUgVGVsZWtvbSBBRzEfMB0GA1UECxMWVC1UZWxlU2VjIFRydXN0IENlbnRlcjEjMC\
  62    EGA1UEAxMaRGV1dHNjaGUgVGVsZWtvbSBSb290IENBIDIwHhcNOTkwNzA5MTIxMTAwWhcNMTkwNzA5\
  63    MjM1OTAwWjBxMQswCQYDVQQGEwJERTEcMBoGA1UEChMTRGV1dHNjaGUgVGVsZWtvbSBBRzEfMB0GA1\
  64    UECxMWVC1UZWxlU2VjIFRydXN0IENlbnRlcjEjMCEGA1UEAxMaRGV1dHNjaGUgVGVsZWtvbSBSb290\
  65    IENBIDIwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCrC6M14IspFLEUha88EOQ5bzVdSq\
  66    7d6mGNlUn0b2SjGmBmpKlAIoTZ1KXleJMOaAGtuU1cOs7TuKhCQN/Po7qCWWqSG6wcmtoIKyUn+Wkj\
  67    R/Hg6yx6m/UTAtB+NHzCnjwAWav12gz1MjwrrFDa1sPeg5TKqAyZMg4ISFZbavva4VhYAUlfckE8FQ\
  68    YBjl2tqriTtM2e66foai1SNNs671x1Udrb8zH57nGYMsRUFUQM+ZtV7a3fGAigo4aKSe5TBY8ZTNXe\
  69    WHmb0mocQqvF1afPaA+W5OFhmHZhyJF81j4A4pFQh+GdCuatl9Idxjp9y7zaAzTVjlsB9WoHtxa2bk\
  70    p/AgMBAAGjQjBAMB0GA1UdDgQWBBQxw3kbuvVT1xfgiXotF2wKsyudMzAPBgNVHRMECDAGAQH/AgEF\
  71    MA4GA1UdDwEB/wQEAwIBBjANBgkqhkiG9w0BAQUFAAOCAQEAlGRZrTlk5ynrE/5aw4sTV8gEJPB0d8\
  72    Bg42f76Ymmg7+Wgnxu1MM9756AbrsptJh6sTtU6zkXR34ajgv8HzFZMQSyzhfzLMdiNlXiItiJVbSY\
  73    SKpk+tYcNthEeFpaIzpXl/V6ME+un2pMSyuOoAPjPuCp1NJ70rOo4nI8rZ7/gFnkm0W09juwzTkZmD\
  74    Ll6iFhkOQxIY40sfcvNUqFENrnijchvllj4PKFiDFT1FQUhXB59C4Gdyd1Lx+4ivn+xbrYNuSD7Odl\
  75    t79jWvNGr4GUN9RBjNYj1h7P9WgbRGOiWrqnNVmh5XAFmw4jV5mUCm26OWMohpLzGITY+9HPBVZkVw\
  76    ==
  77    (%i6) close(ostream);
  78    (%o6)                                true
  79    (%i7) sha1sum(base64_decode(string));
  80    (%o7)              85a408c09c193e5d51587dcdd61330fd8cde37bf
  81    (%i8) system("openssl x509 -fingerprint -noout -in '/home/volker/Deutsche_Telekom_Root_CA_2.crt' > temp ; cat temp");
  82    SHA1 Fingerprint=85:A4:08:C0:9C:19:3E:5D:51:58:7D:CD:D6:13:30:FD:8C:DE:37:BF
  83    (%o8)                                  0
  84
  85
  86    mgf1_sha1(seed, length) resp. mgf1_sha1(seed, length, return_type) returns
  87    a pseudo random number of octet-length length.
  88    The returned value is a number (default) or a list of octets.
  89    See RFC 3447,appendix B.2.1.
  90
  91    (%i1) ibase: obase: 16.$
  92    (%i2) number: mgf1_sha1(0cafe, 8);
  93    (%o2)                          0b097d3c8328001ee
  94    (%i3) octets: mgf1_sha1(0cafe, 8, 'list);
  95    (%o3)                    [0B0,97,0D3,0C8,32,80,1,0EE]
  96
  97 |#
  98
  99 (in-package :maxima)
 100
 101 (eval-when
 102     (:compile-toplevel :execute)
 103   (defvar old-ibase-sha1 *read-base*)
 104   (setq *read-base* 10.) )
 105
 106
 107 (declaim (inline sha-not sha+ sha-left-rotation sha-right-rotation))
 108
 109 (defun sha-not (i32)
 110   (logand (lognot i32) #xffffffff) )
 111
 112 (defun sha+ (&rest args)
 113   (logand (apply #'+ args) #xffffffff) )
 114
 115 (defun sha-left-rotation (i32 k)
 116   (logior (logand (ash i32 k) #xffffffff) (ash i32 (- k 32.))) )
 117
 118 (defun sha-right-rotation (i32 k)
 119   (logior (ash i32 (- k)) (logand (ash i32 (- 32. k)) #xffffffff)) )
 120
 121
 122 (defun sha-update (bytes nr)
 123   (setq bytes (coerce bytes 'vector))
 124   (cond
 125     ((= nr 160.)
 126       (sha1-words bytes)
 127       (sha1-worker) )
 128     ((= nr 256.)
 129       (sha256-words bytes)
 130       (sha256-worker) )))
 131
 132 (defun sha-len64 (bits)
 133   (do ((i 1 (1+ i)) lst) (nil)
 134     (push (logand bits #xff) lst)
 135     (when (= i 8) (return lst))
 136     (setq bits (ash bits -8)) ))
 137
 138 (defun sha-final (bytes off len nr)
 139   (when bytes (setq bytes (append bytes '(#x80)))) ;; don't modify bytes
 140   (when (= 0 off) (setq bytes '(#x80)))
 141   (if (<= off 55.)
 142     (let* ((bits (ash len 3))
 143            (len64 (sha-len64 bits))
 144            (pad (make-list (- 55. off) :initial-element 0)) )
 145       (sha-update (append bytes pad len64) nr) )
 146     (let ((pad (make-list (- 63. off) :initial-element 0)))
 147       (sha-update (append bytes pad) nr)
 148       (sha-final nil -1 len nr) )))
 149
 150
 151 ;; *** SHA1 ***************************************************************** ;;
 152
 153 (defvar *h1* nil)
 154 (defvar *w1* nil)
 155
 156 (defun sha1-worker ()
 157   (multiple-value-bind (a b c d e) (apply #'values *h1*)
 158     (let (f k tmp)
 159       (do ((i 0 (1+ i)))
 160           ((= i 80.))
 161         (cond
 162           ((< i 20.)
 163             (setq f (logior (logand b c) (logand (sha-not b) d))
 164                   k #x5a827999 ))
 165           ((< i 40.)
 166             (setq f (logxor b c d)
 167                   k #x6ed9eba1 ))
 168           ((< i 60.)
 169             (setq f (logior (logand b c) (logand b d) (logand c d))
 170                   k #x8f1bbcdc ))
 171           (t
 172             (setq f (logxor b c d)
 173                   k #xca62c1d6 )))
 174         (setq tmp (sha+ (sha-left-rotation a 5) f e k (svref *w1* i))
 175               e d
 176               d c
 177               c (sha-left-rotation b 30.)
 178               b a
 179               a tmp ) )
 180       (setq *h1* (mapcar #'sha+ (list a b c d e) *h1*)) )))
 181
 182 (defun sha1-words (vec)
 183   (setq *w1* (make-array 80. :element-type 'integer :initial-element 0))
 184   ;; copy 512 bit message into 32 bit big-endian words:
 185   (do ((i 0 (1+ i)) (inc -1))
 186       ((= i 16.))
 187     (setf (svref *w1* i)
 188       (logior (ash (svref vec (incf inc)) 24.)
 189               (ash (svref vec (incf inc)) 16.)
 190               (ash (svref vec (incf inc))  8.)
 191                    (svref vec (incf inc))     )))
 192   ;; expand:
 193   (do ((i 16. (1+ i)))
 194       ((= i 80.))
 195     (setf (svref *w1* i)
 196       (sha-left-rotation
 197         (logxor (svref *w1* (- i 3.))
 198                 (svref *w1* (- i 8.))
 199                 (svref *w1* (- i 14.))
 200                 (svref *w1* (- i 16.)) )
 201         1 ))))
 202
 203 (defmfun $sha1sum (s &optional (rtype '$string))
 204   (let (bytes len)
 205     (cond
 206       ((stringp s)
 207         (setq bytes (string-to-octets s)) )
 208       ((and (integerp s) (>= s 0))
 209         (setq bytes (number-to-octets s)) )
 210       (($listp s)
 211         (setq bytes (cdr s)) )
 212       (t
 213         (gf-merror (intl:gettext
 214           "`sha1sum': Argument must be a string, a non-negative integer or a list of octets." ))))
 215     (setq len (length bytes)
 216           *h1* '(#x67452301 #xefcdab89 #x98badcfe #x10325476 #xc3d2e1f0) )
 217     (do ((off len))
 218         ((< off 64.) (sha-final bytes off len 160.))
 219       (setq off (- off 64.))
 220       (sha-update (butlast bytes off) 160.)
 221       (setq bytes (last bytes off)) )
 222     (cond
 223       ((equal rtype '$list)
 224         (cons '(mlist simp)
 225           (reduce #'nconc (mapcar #'word-to-octets *h1*)) ))
 226       ((equal rtype '$number)
 227         (reduce #'(lambda (x y) (logior (ash x 32.) y)) *h1*) )
 228       ((equal rtype '$string)
 229         (nstring-downcase (format nil "~{~8,'0x~}" *h1*)) )
 230       (t
 231         (gf-merror (intl:gettext
 232           "`sha1sum': Optional argument must be 'list, 'number or 'string." ))))))
 233
 234
 235 ;; *** MGF1_SHA1 ************************************************************ ;;
 236 ;;
 237 ;; Generation of a pseudorandom number according to RFC 3447, appendix B.2.1 .
 238 ;;
 239 (defmfun $mgf1_sha1 (seed len &optional (rtype '$number))
 240   (let ((err-msg (intl:gettext "Unsuitable arguments to `mgf1_sha1': ~m, ~m"))
 241          s s+i res )
 242     (cond
 243       ((and (integerp seed) (>= seed 0)) (setq s (number-to-octets seed)))
 244       (($listp seed) (setq s (cdr seed)))
 245       (t (gf-merror err-msg seed len)) )
 246     (unless (and (integerp len) (> len 0)) (gf-merror err-msg seed len))
 247     (do ((i 0 (1+ i))
 248          (ii (ceiling (/ len 20.0))))
 249         ((= i ii))
 250       (setq s+i (cons '(mlist simp) (append s (word-to-octets i)))
 251             res (nconc res (cdr ($sha1sum s+i '$list))) ))
 252     (setq res (subseq res 0 len))
 253     (cond
 254       ((equal rtype '$number) (octets-to-number res))
 255       ((equal rtype '$list) (cons '(mlist simp) res))
 256       (t (gf-merror (intl:gettext
 257            "`mgf1_sha1': Optional argument must be 'number or 'list." ))))))
 258
 259
 260 ;; *** SHA256 *************************************************************** ;;
 261
 262 (defvar *k2*
 263   (coerce               ;; the first 32 bits of the fractional parts of ..
 264     (mapcar #'(lambda (i) (floor (* (rem (expt (coerce i 'double-float) 1/3) 1.0) #x100000000)))
 265             (subseq *small-primes* 0 64.) ) ;; .. the cube roots of the first 64 primes (2,..,311)
 266     'vector ))
 267
 268 (defvar *h2* nil)
 269 (defvar *w2* nil)
 270
 271 (defun sha256-worker ()
 272   (multiple-value-bind (a b c d e f g h) (apply #'values *h2*)
 273     (let (s1 t1 s2 t2)
 274       (do ((i 0 (1+ i)))
 275           ((= i 64.))
 276         (setq s1 (logxor (sha-right-rotation e 6)
 277                          (sha-right-rotation e 11.)
 278                          (sha-right-rotation e 25.) )
 279               t1 (logxor (logand e f) (logand (sha-not e) g))
 280               t1 (sha+ h s1 t1 (svref *k2* i) (svref *w2* i))
 281               s2 (logxor (sha-right-rotation a 2)
 282                          (sha-right-rotation a 13.)
 283                          (sha-right-rotation a 22.) )
 284               t2 (logxor (logand a b) (logand a c) (logand b c))
 285               t2 (sha+ s2 t2) )
 286         (setq h g
 287               g f
 288               f e
 289               e (sha+ d t1)
 290               d c
 291               c b
 292               b a
 293               a (sha+ t1 t2) ))
 294       (setq *h2* (mapcar #'sha+ (list a b c d e f g h) *h2*)) )))
 295
 296 (defun sha256-words (vec)
 297   (setq *w2* (make-array 64. :element-type 'integer :initial-element 0))
 298   ;; copy 512 bit message into 32 bit big-endian words:
 299   (do ((i 0 (1+ i)) (inc -1))
 300       ((= i 16.))
 301     (setf (svref *w2* i)
 302       (logior (ash (svref vec (incf inc)) 24.)
 303               (ash (svref vec (incf inc)) 16.)
 304               (ash (svref vec (incf inc))  8.)
 305                    (svref vec (incf inc))     )))
 306   ;; expand:
 307   (do ((i 16. (1+ i)) w s0 s1)
 308       ((= i 64.))
 309     (setq w (svref *w2* (- i 15.))
 310           s0 (logxor (sha-right-rotation w 7)
 311                      (sha-right-rotation w 18.)
 312                      (ash w -3) )
 313           w (svref *w2* (- i 2))
 314           s1 (logxor (sha-right-rotation w 17.)
 315                      (sha-right-rotation w 19.)
 316                      (ash w -10.) ))
 317     (setf (svref *w2* i)
 318       (sha+ (svref *w2* (- i 16.)) s0 (svref *w2* (- i 7)) s1) )))
 319
 320 (defmfun $sha256sum (s &optional (rtype '$string))
 321   (let (bytes len)
 322     (cond
 323       ((stringp s)
 324         (setq bytes (string-to-octets s)) )
 325       ((and (integerp s) (>= s 0))
 326         (setq bytes (number-to-octets s)) )
 327       (($listp s)
 328         (setq bytes (cdr s)) )
 329       (t
 330         (gf-merror (intl:gettext
 331           "`sha256sum': Argument must be a string, a non-negative integer or a list of octets." ))))
 332     (setq len (length bytes)
 333           *h2* ;; the first 32 bits of the fractional parts of the square roots of the first 8 primes (2,..,19)
 334             '(#x6a09e667 #xbb67ae85 #x3c6ef372 #xa54ff53a #x510e527f #x9b05688c #x1f83d9ab #x5be0cd19) )
 335     (do ((off len))
 336         ((< off 64.) (sha-final bytes off len 256.))
 337       (setq off (- off 64.))
 338       (sha-update (butlast bytes off) 256.)
 339       (setq bytes (last bytes off)) )
 340     (cond
 341       ((equal rtype '$list)
 342         (cons '(mlist simp)
 343           (reduce #'nconc (mapcar #'word-to-octets *h2*)) ))
 344       ((equal rtype '$number)
 345         (reduce #'(lambda (x y) (logior (ash x 32.) y)) *h2*) )
 346       ((equal rtype '$string)
 347         (nstring-downcase (format nil "~{~8,'0x~}" *h2*)) )
 348       (t
 349         (gf-merror (intl:gettext
 350           "`sha256sum': Optional argument must be 'list, 'number or 'string." ))))))
 351
 352
 353 (eval-when
 354     (:compile-toplevel :execute)
 355   (setq *read-base* old-ibase-sha1) )