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 dependend.
  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   #+gcl (compile eval)
  80   #-gcl (:compile-toplevel :execute)
  81     (defvar old-ibase-md5 *read-base*)
  82     (setq *read-base* 10.) )
  83
  84
  85 (defvar *h5* nil)
  86 (defvar *w5* nil)
  87
  88 (defvar *k5* (make-array 64. :element-type 'integer :initial-element 0))
  89 (do ((i 0 (1+ i)))
  90     ((= i 64.))
  91   (setf (svref *k5* i) (floor (* (abs (sin (+ i 1.0))) #x100000000))) )
  92
  93 (defvar *s5*
  94   #( 7. 12. 17. 22.   7. 12. 17. 22.   7. 12. 17. 22.   7. 12. 17. 22.
  95      5.  9. 14. 20.   5.  9. 14. 20.   5.  9. 14. 20.   5.  9. 14. 20.
  96      4. 11. 16. 23.   4. 11. 16. 23.   4. 11. 16. 23.   4. 11. 16. 23.
  97      6. 10. 15. 21.   6. 10. 15. 21.   6. 10. 15. 21.   6. 10. 15. 21. ))
  98
  99
 100 (declaim (inline md5-not md5+ md5-left-rotation))
 101
 102 (defun md5-not (i32)
 103   (logand (lognot i32) #xffffffff) )
 104
 105 (defun md5+ (&rest args)
 106   (logand (apply #'+ args) #xffffffff) )
 107
 108 (defun md5-left-rotation (i32 k)
 109   (logior (logand (ash i32 k) #xffffffff) (ash i32 (- k 32.))) )
 110
 111
 112 (defun md5-worker ()
 113   (multiple-value-bind (a b c d) (apply #'values *h5*)
 114     (let (f g tmp hlp)
 115       (do ((i 0 (1+ i)))
 116           ((= i 64.))
 117         (cond
 118           ((< i 16.)
 119             (setq f (logior (logand b c) (logand (md5-not b) d))
 120                   g i ))
 121           ((< i 32.)
 122             (setq f (logior (logand b d) (logand c (md5-not d)))
 123                   g (logand (+ (* 5 i) 1) #xf) ))
 124           ((< i 48.)
 125             (setq f (logxor b c d)
 126                   g (logand (+ (* 3 i) 5) #xf) ))
 127           (t
 128             (setq f (logxor c (logior b (md5-not d)))
 129                   g (logand (* 7 i) #xf) )))
 130         (setq tmp d
 131               d c
 132               c b
 133               hlp (md5+ a f (svref *k5* i) (svref *w5* g))
 134               hlp (md5-left-rotation hlp (svref *s5* i))
 135               b (md5+ b hlp)
 136               a tmp ))
 137       (setq *h5* (mapcar #'md5+ (list a b c d) *h5*)) )))
 138
 139
 140 (defun swap-endian64 (i64) ;; little-endian <--> big-endian
 141   (do ((masq #xff (ash masq 8))
 142        (sh 0 (- sh 8)) w )
 143       ((= sh -64.) (nreverse w))
 144     (push (ash (logand i64 masq) sh) w) ))
 145
 146 (defun swap-endian32 (i32)
 147   (logior (ash (logand i32 #xff) 24.)
 148           (ash (logand i32 #xff00) 8.)
 149           (ash (logand i32 #xff0000) -8.)
 150           (ash (logand i32 #xff000000) -24.) ))
 151
 152
 153 (defun md5-words (vec) ;; 32 bit little-endian
 154   (let ((w (make-array 16. :element-type 'integer :initial-element 0))
 155         (inc -1) )
 156     (do ((i 0 (1+ i)))
 157         ((= i 16.) w)
 158       (setf (svref w i)
 159         (logior      (svref vec (incf inc))
 160                 (ash (svref vec (incf inc))  8.)
 161                 (ash (svref vec (incf inc)) 16.)
 162                 (ash (svref vec (incf inc)) 24.) )))))
 163
 164 (defun md5-update (bytes)
 165   (setq *w5* (md5-words (coerce bytes 'vector)))
 166   (md5-worker) )
 167
 168 (defun md5-final (bytes off len)
 169   (when bytes (setq bytes (append bytes '(#x80)))) ;; don't modify bytes
 170   (when (= 0 off) (setq bytes '(#x80)))
 171   (if (<= off 55.)
 172     (let* ((bits (ash len 3))
 173            (len64 (swap-endian64 bits))
 174            (pad (make-list (- 55. off) :initial-element 0)) )
 175       (md5-update (append bytes pad len64)) )
 176     (let ((pad (make-list (- 63. off) :initial-element 0)))
 177       (md5-update (append bytes pad))
 178       (md5-final nil -1 len) )))
 179
 180
 181 (defmfun $md5sum (s &optional (rtype '$string))
 182   (let (bytes len)
 183     (cond
 184       ((stringp s)
 185         (setq bytes (string-to-octets s)) )
 186       ((and (integerp s) (>= s 0))
 187         (setq bytes (number-to-octets s)) )
 188       (($listp s)
 189         (setq bytes (cdr s)) )
 190       ((streamp s)
 191        (return-from md5sum-impl (md5sum-stream s rtype)))
 192       (t
 193         (gf-merror (intl:gettext
 194           "`md5sum': Argument must be a string, non-negative integer, list of octets, or stream." ))))
 195     (setq len (length bytes)
 196           *h5* '(#x67452301 #xefcdab89 #x98badcfe #x10325476) )
 197     (do ((off len))
 198         ((< off 64.) (md5-final bytes off len))
 199       (setq off (- off 64.))
 200       (md5-update (butlast bytes off))
 201       (setq bytes (last bytes off)) )
 202     (setq *h5* (mapcar #'swap-endian32 *h5*))
 203     (md5sum-return rtype)))
 204
 205 (defun md5sum-return (rtype)
 206   (cond
 207     ((equal rtype '$list)
 208       (cons '(mlist simp)
 209         (reduce #'nconc (mapcar #'word-to-octets *h5*)) ))
 210     ((equal rtype '$number)
 211       (reduce #'(lambda (x y) (logior (ash x 32.) y)) *h5*) )
 212     ((equal rtype '$string)
 213       (nstring-downcase (format nil "~{~8,'0x~}" *h5*)) )
 214     (t
 215       (gf-merror (intl:gettext
 216         "`md5sum': Optional argument must be 'list, 'number or 'string." )))))
 217
 218 (defun md5sum-stream (s rtype)
 219   (setq *h5* '(#x67452301 #xefcdab89 #x98badcfe #x10325476))
 220   (let ((bytes (make-list 64.)) (len 0))
 221     (do
 222       ((len-1 (read-sequence bytes s)))
 223       ((< len-1 64.) (md5-final (butlast bytes (- (length bytes) len-1)) len-1 (+ len len-1)))
 224       (md5-update bytes)
 225       (setq len (+ len len-1))
 226       (setq len-1 (read-sequence bytes s))))
 227
 228   (setq *h5* (mapcar #'swap-endian32 *h5*))
 229   (md5sum-return rtype))
 230
 231 (eval-when
 232   #+gcl (compile eval)
 233   #-gcl (:compile-toplevel :execute)
 234     (setq *read-base* old-ibase-md5) )