share/stringproc/md5.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 **** md5sum ********************************************************************
  20
  21    Copyright Volker van Nek, 2013 - 2015
  22
  23    md5sum returns the md5 checksum of a string, a non-negative integer or
  24    a list of octets.
  25
  26    The default return value is a string that guarantees 32 hex characters.
  27    An optional argument allows md5sum to return the corresponding number or
  28    list of octets.
  29
  30    (%i1) ibase: obase: 16.$
  31    (%i2) msg: "foo bar baz"$
  32    (%i3) string: md5sum(msg);
  33    (%o3)                  ab07acbb1e496801937adfa772424bf7
  34    (%i4) integer: md5sum(msg, 'number);
  35    (%o4)                 0ab07acbb1e496801937adfa772424bf7
  36    (%i5) octets: md5sum(msg, 'list);
  37    (%o5)        [0AB,7,0AC,0BB,1E,49,68,1,93,7A,0DF,0A7,72,42,4B,0F7]
  38    (%i6) sdowncase( printf(false, "~{~2,'0x~^:~}", octets) );
  39    (%o6)           ab:07:ac:bb:1e:49:68:01:93:7a:df:a7:72:42:4b:f7
  40
  41    Note that in case the string contains German umlauts or other non-ASCII
  42    characters the md5 checksum is platform dependent.
  43
  44    To check the md5sum of a *small* file the file can be streamed into a string.
  45
  46    (%i1) ostream : make_string_output_stream();
  47    (%o1)                  #<string-output stream 00f06ae8>
  48    (%i2) fos : openr("/home/volker/pub_key_temp.pem");
  49    (%o2)            #<input stream /home/volker/pub_key_temp.pem>
  50    (%i3) while (c : readchar(fos)) # false do printf(ostream, "~a", c);
  51    (%o3)                                done
  52    (%i4) close(fos);
  53    (%o4)                                true
  54    (%i5) string : get_output_stream_string(ostream);
  55    (%o5) -----BEGIN PUBLIC KEY-----
  56    MIIBCgKCAQEA7CCxZOFAoZ7khi0TiwIxU8cHEZJnIQb96ONrPbSqq/s3CVwU1eLH
  57    9QEaZb8viFhe6/Db66DjR6RqCO3uIfx2siAb8SaTo0PYZz8JQ5IenjBDJAGA56gE
  58    6OX8JadgPCLEZTdJ2Q0axqPHwoWsZkn56Pt4UlJfUcW7cNPNIihgy2DwE1PpbHCY
  59    IdhYcT/iYA6C+TiYdYNcAFUsQyGExBxOTOXrMGFknjALedkLoq9IN3Djnw4kxGYv
  60    vl3hVYBJpixusUgOK5LhYwowQayeczPoMA0Ef5KAZwJY9lUZ2UYBKMqdoNpdJuDz
  61    q4QOxlkqUvZxWTEHqNmlfX4/2w71ZiAqpwIDAQAB
  62    -----END PUBLIC KEY-----
  63    (%i6) close(ostream);
  64    (%o6)                                true
  65    (%i7) md5sum(string);
  66    (%o7)                  b5f2033ccb6f4066874aa5a2308bd561
  67
  68    The result is checked against openssl in GNU/Linux.
  69
  70    (%i8) system("openssl dgst -md5 '/home/volker/pub_key_temp.pem' > temp ; cat temp");
  71    MD5(/home/volker/pub_key_temp.pem)= b5f2033ccb6f4066874aa5a2308bd561
  72    (%o8)                                  0
  73
  74 |#
  75
  76 (in-package :maxima)
  77
  78 (eval-when
  79     (:compile-toplevel :execute)
  80   (defvar old-ibase-md5 *read-base*)
  81   (setq *read-base* 10.) )
  82
  83
  84 (defvar *h5* nil)
  85 (defvar *w5* nil)
  86
  87 (defvar *k5* (make-array 64. :element-type 'integer :initial-element 0))
  88 (do ((i 0 (1+ i)))
  89     ((= i 64.))
  90   (setf (svref *k5* i) (floor (* (abs (sin (+ i 1.0))) #x100000000))) )
  91
  92 (defvar *s5*
  93   #( 7. 12. 17. 22.   7. 12. 17. 22.   7. 12. 17. 22.   7. 12. 17. 22.
  94      5.  9. 14. 20.   5.  9. 14. 20.   5.  9. 14. 20.   5.  9. 14. 20.
  95      4. 11. 16. 23.   4. 11. 16. 23.   4. 11. 16. 23.   4. 11. 16. 23.
  96      6. 10. 15. 21.   6. 10. 15. 21.   6. 10. 15. 21.   6. 10. 15. 21. ))
  97
  98
  99 (declaim (inline md5-not md5+ md5-left-rotation))
 100
 101 (defun md5-not (i32)
 102   (logand (lognot i32) #xffffffff) )
 103
 104 (defun md5+ (&rest args)
 105   (logand (apply #'+ args) #xffffffff) )
 106
 107 (defun md5-left-rotation (i32 k)
 108   (logior (logand (ash i32 k) #xffffffff) (ash i32 (- k 32.))) )
 109
 110
 111 (defun md5-worker ()
 112   (multiple-value-bind (a b c d) (apply #'values *h5*)
 113     (let (f g tmp hlp)
 114       (do ((i 0 (1+ i)))
 115           ((= i 64.))
 116         (cond
 117           ((< i 16.)
 118             (setq f (logior (logand b c) (logand (md5-not b) d))
 119                   g i ))
 120           ((< i 32.)
 121             (setq f (logior (logand b d) (logand c (md5-not d)))
 122                   g (logand (+ (* 5 i) 1) #xf) ))
 123           ((< i 48.)
 124             (setq f (logxor b c d)
 125                   g (logand (+ (* 3 i) 5) #xf) ))
 126           (t
 127             (setq f (logxor c (logior b (md5-not d)))
 128                   g (logand (* 7 i) #xf) )))
 129         (setq tmp d
 130               d c
 131               c b
 132               hlp (md5+ a f (svref *k5* i) (svref *w5* g))
 133               hlp (md5-left-rotation hlp (svref *s5* i))
 134               b (md5+ b hlp)
 135               a tmp ))
 136       (setq *h5* (mapcar #'md5+ (list a b c d) *h5*)) )))
 137
 138
 139 (defun swap-endian64 (i64) ;; little-endian <--> big-endian
 140   (do ((masq #xff (ash masq 8))
 141        (sh 0 (- sh 8)) w )
 142       ((= sh -64.) (nreverse w))
 143     (push (ash (logand i64 masq) sh) w) ))
 144
 145 (defun swap-endian32 (i32)
 146   (logior (ash (logand i32 #xff) 24.)
 147           (ash (logand i32 #xff00) 8.)
 148           (ash (logand i32 #xff0000) -8.)
 149           (ash (logand i32 #xff000000) -24.) ))
 150
 151
 152 (defun md5-words (vec) ;; 32 bit little-endian
 153   (let ((w (make-array 16. :element-type 'integer :initial-element 0))
 154         (inc -1) )
 155     (do ((i 0 (1+ i)))
 156         ((= i 16.) w)
 157       (setf (svref w i)
 158         (logior      (svref vec (incf inc))
 159                 (ash (svref vec (incf inc))  8.)
 160                 (ash (svref vec (incf inc)) 16.)
 161                 (ash (svref vec (incf inc)) 24.) )))))
 162
 163 (defun md5-update (bytes)
 164   (setq *w5* (md5-words (coerce bytes 'vector)))
 165   (md5-worker) )
 166
 167 (defun md5-final (bytes off len)
 168   (when bytes (setq bytes (append bytes '(#x80)))) ;; don't modify bytes
 169   (when (= 0 off) (setq bytes '(#x80)))
 170   (if (<= off 55.)
 171     (let* ((bits (ash len 3))
 172            (len64 (swap-endian64 bits))
 173            (pad (make-list (- 55. off) :initial-element 0)) )
 174       (md5-update (append bytes pad len64)) )
 175     (let ((pad (make-list (- 63. off) :initial-element 0)))
 176       (md5-update (append bytes pad))
 177       (md5-final nil -1 len) )))
 178
 179
 180 (defmfun $md5sum (s &optional (rtype '$string))
 181   (let (bytes len)
 182     (cond
 183       ((stringp s)
 184         (setq bytes (string-to-octets s)) )
 185       ((and (integerp s) (>= s 0))
 186         (setq bytes (number-to-octets s)) )
 187       (($listp s)
 188         (setq bytes (cdr s)) )
 189       ((streamp s)
 190        (return-from md5sum-impl (md5sum-stream s rtype)))
 191       (t
 192         (gf-merror (intl:gettext
 193           "`md5sum': Argument must be a string, non-negative integer, list of octets, or stream." ))))
 194     (setq len (length bytes)
 195           *h5* '(#x67452301 #xefcdab89 #x98badcfe #x10325476) )
 196     (do ((off len))
 197         ((< off 64.) (md5-final bytes off len))
 198       (setq off (- off 64.))
 199       (md5-update (butlast bytes off))
 200       (setq bytes (last bytes off)) )
 201     (setq *h5* (mapcar #'swap-endian32 *h5*))
 202     (md5sum-return rtype)))
 203
 204 (defun md5sum-return (rtype)
 205   (cond
 206     ((equal rtype '$list)
 207       (cons '(mlist simp)
 208         (reduce #'nconc (mapcar #'word-to-octets *h5*)) ))
 209     ((equal rtype '$number)
 210       (reduce #'(lambda (x y) (logior (ash x 32.) y)) *h5*) )
 211     ((equal rtype '$string)
 212       (nstring-downcase (format nil "~{~8,'0x~}" *h5*)) )
 213     (t
 214       (gf-merror (intl:gettext
 215         "`md5sum': Optional argument must be 'list, 'number or 'string." )))))
 216
 217 (defun md5sum-stream (s rtype)
 218   (setq *h5* '(#x67452301 #xefcdab89 #x98badcfe #x10325476))
 219   (let ((bytes (make-list 64.)) (len 0))
 220     (do
 221       ((len-1 (read-sequence bytes s)))
 222       ((< len-1 64.) (md5-final (butlast bytes (- (length bytes) len-1)) len-1 (+ len len-1)))
 223       (md5-update bytes)
 224       (setq len (+ len len-1))
 225       (setq len-1 (read-sequence bytes s))))
 226
 227   (setq *h5* (mapcar #'swap-endian32 *h5*))
 228   (md5sum-return rtype))
 229
 230 (eval-when
 231     (:compile-toplevel :execute)
 232   (setq *read-base* old-ibase-md5) )