share/stringproc/cryptools.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 **** tools for cryptography ****************************************************
  20
  21    Copyright Volker van Nek, 2015
  22
  23    1. string_to_octets(string [,encoding]) and octets_to_string(octets [,encoding]).
  24    The default encoding depends on the underlying Lisp, the platform and the
  25    application. The following example shows Maxima/GCL in a GNU/Linux terminal.
  26    GCL uses no format definition and simply passes through the utf-8-octets encoded
  27    by the terminal.
  28
  29    (%i1) octets: string_to_octets("abc");
  30    (%o1)                            [61, 62, 63]
  31    (%i2) octets_to_string(octets);
  32    (%o2)                                 abc
  33    (%i3) ibase : obase : 16.$
  34    (%i4) string: unicode(3bb);
  35    (%o4)                                 λ
  36    (%i5) octets: string_to_octets(string);
  37    (%o5)                             [0CE, 0BB]
  38    (%i6) octets_to_string(octets);
  39    (%o6)                                 λ
  40    (%i7) utf8_to_unicode(octets);
  41    (%o7)                                 3BB
  42
  43    Maxima/SBCL in a GNU/Linux terminal using the optional encoding argument.
  44
  45    (%i1) ibase : obase : 16.$
  46    (%i2) string: simplode(map(unicode, [3b1,3b2,3b3]));
  47    (%o2)                                 αβγ
  48    (%i3) octets: string_to_octets(string, "ucs-2be");
  49    (%o3)                      [3, 0B1, 3, 0B2, 3, 0B3]
  50    (%i4) octets_to_string(octets, "ucs-2be");
  51    (%o4)                                 αβγ
  52    (%i5) octets: string_to_octets(string, "iso-8859-7");
  53    (%o5)                           [0E1, 0E2, 0E3]
  54    (%i6) octets_to_string(octets, "iso-8859-7");
  55    (%o6)                                 αβγ
  56
  57    Examples of supported encodings:
  58    CCL,CLISP,SBCL: utf-8, ucs-2be, iso-8859-1, cp1252, cp850
  59    CMUCL: utf-8, utf-16-be, iso8859-1, cp1252
  60    ECL: utf-8, ucs-2be, iso-8859-1, windows-cp1252, dos-cp850
  61
  62    2. number_to_octets(number) and octets_to_number(octets).
  63
  64    (%i1) ibase : obase : 16.$
  65    (%i2) octets: [0ca,0fe,0ba,0be]$
  66    (%i3) number: octets_to_number(octets);
  67    (%o3)                            0cafebabe
  68    (%i4) number_to_octets(number);
  69    (%o4)                      [0CA, 0FE, 0BA, 0BE]
  70
  71
  72    3. octets_to_oid(octets) and oid_to_octets(string) compute object identifiers
  73    (OIDs) from lists of octets and convert OIDs back to octets.
  74
  75    (%i1) ibase : obase : 16.$
  76    (%i2) oid: octets_to_oid([2A,86,48,86,0F7,0D,1,1,1]);
  77    (%o2)                      1.2.840.113549.1.1.1
  78    (%i3) oid_to_octets(oid);
  79    (%o3)               [2A, 86, 48, 86, 0F7, 0D, 1, 1, 1]
  80
  81
  82    4. crc24sum(octets) returns the crc24 checksum of an octet-list. The returned
  83    value is a string (default), a number or a list of octets.
  84
  85    Example: OpenPGP uses crc24
  86
  87       -----BEGIN PGP SIGNATURE-----
  88    Version: GnuPG v2.0.22 (GNU/Linux)
  89
  90    iQEcBAEBAgAGBQJVdCTzAAoJEG/1Mgf2DWAqCSYH/AhVFwhu1D89C3/QFcgVvZTM
  91    wnOYzBUURJAL/cT+IngkLEpp3hEbREcugWp+Tm6aw3R4CdJ7G3FLxExBH/5KnDHi
  92    rBQu+I7+3ySK2hpryQ6Wx5J9uZSa4YmfsNteR8up0zGkaulJeWkS4pjiRM+auWVe
  93    vajlKZCIK52P080DG7Q2dpshh4fgTeNwqCuCiBhQ73t8g1IaLdhDN6EzJVjGIzam
  94    /spqT/sTo6sw8yDOJjvU+Qvn6/mSMjC/YxjhRMaQt9EMrR1AZ4ukBF5uG1S7mXOH
  95    WdiwkSPZ3gnIBhM9SuC076gLWZUNs6NqTeE3UzMjDAFhH3jYk1T7mysCvdtIkms=
  96    =WmeC
  97    -----END PGP SIGNATURE-----
  98
  99    (%i1) ibase : obase : 16.$
 100    (%i2) sig64 : sconcat(
 101      "iQEcBAEBAgAGBQJVdCTzAAoJEG/1Mgf2DWAqCSYH/AhVFwhu1D89C3/QFcgVvZTM",
 102      "wnOYzBUURJAL/cT+IngkLEpp3hEbREcugWp+Tm6aw3R4CdJ7G3FLxExBH/5KnDHi",
 103      "rBQu+I7+3ySK2hpryQ6Wx5J9uZSa4YmfsNteR8up0zGkaulJeWkS4pjiRM+auWVe",
 104      "vajlKZCIK52P080DG7Q2dpshh4fgTeNwqCuCiBhQ73t8g1IaLdhDN6EzJVjGIzam",
 105      "/spqT/sTo6sw8yDOJjvU+Qvn6/mSMjC/YxjhRMaQt9EMrR1AZ4ukBF5uG1S7mXOH",
 106      "WdiwkSPZ3gnIBhM9SuC076gLWZUNs6NqTeE3UzMjDAFhH3jYk1T7mysCvdtIkms=" )$
 107    (%i3) octets: base64_decode(sig64, 'list)$
 108    (%i4) crc24: crc24sum(octets, 'list);
 109    (%o4)                          [5A, 67, 82]
 110    (%i5) base64(crc24);
 111    (%o5)                              WmeC
 112
 113 |#
 114
 115 (in-package :maxima)
 116
 117 (eval-when
 118   #+gcl (compile eval)
 119   #-gcl (:compile-toplevel :execute)
 120     (defvar old-ibase-cryptools *read-base*)
 121     (setq *read-base* 10.) )
 122
 123
 124 ;; -- string-octet-conversions: --------------------------------------------- ;;
 125
 126 (defun $string_to_octets (str &optional enc)
 127   (unless (stringp str)
 128     (gf-merror (intl:gettext "`string_to_octets': argument must be a string.")) )
 129     (cons '(mlist simp) (string-to-octets str enc)) )
 130
 131 (defun string-to-octets (str &optional enc)
 132   (setq enc (get-encoding enc "string_to_octets"))
 133   (let ((ov #+ccl (ccl:encode-string-to-octets str :external-format enc) ;; maybe these (CCL, ECL) ..
 134             #+clisp (ext:convert-string-to-bytes str enc)
 135             #+ecl (ecl-string-to-octets str enc)                         ;; .. could move to intl.lisp
 136             #- (or ccl clisp ecl) (intl::string-to-octets str enc) ))    ;; GCL ignores enc
 137     (coerce ov 'list) ))
 138 ;;
 139 #+ecl
 140 (defun ecl-string-to-octets (str enc)
 141   (let ((a (make-array
 142              (ceiling (* 1.2 (length str))) ;; initially add 20 % for non-ascii chars
 143              :element-type '(unsigned-byte 8)
 144              :adjustable t
 145              :fill-pointer 0 )))
 146     (with-open-stream
 147       (stream (ext:make-sequence-output-stream a :external-format enc))
 148       (format stream str)
 149       a )))
 150
 151
 152 (defun $octets_to_string (ol &optional enc)
 153   (unless ($listp ol)
 154     (gf-merror (intl:gettext
 155       "`octets_to_string': argument must be a list of octets." )))
 156   (octets-to-string (cdr ol) enc) )
 157
 158 (defun octets-to-string (ol &optional enc)
 159   (setq enc (get-encoding enc "octets_to_string"))
 160   (let ((ov (map-into
 161               (make-array (length ol) :element-type '(unsigned-byte 8))
 162               #'identity
 163               ol )))
 164     #+ccl (ccl:decode-string-from-octets ov :external-format enc)
 165     #+clisp (ext:convert-string-from-bytes ov enc)
 166     #+ecl (ecl-octets-to-string ov enc)
 167     #- (or ccl clisp ecl) (intl::octets-to-string ov enc) ))
 168 ;;
 169 #+ecl
 170 (defun ecl-octets-to-string (ov enc)
 171   (with-open-stream
 172     (stream (ext:make-sequence-input-stream ov :external-format enc))
 173     (read-line stream) ))
 174
 175
 176 ;; -- number-octet-conversions: --------------------------------------------- ;;
 177
 178 (defun word-to-octets (n) ;; assume that n fits into a word
 179   (do ((k 4 (1- k)) octs)
 180       ((= k 0) octs)
 181     (push (logand n #xff) octs)
 182     (setq n (ash n -8.)) ))
 183
 184 (defun number-to-octets (n)
 185   (do (octs) (())
 186     (push (logand n #xff) octs)
 187     (setq n (ash n -8.))
 188     (when (= n 0) (return octs)) ))
 189
 190 (defun octets-to-number (octs)
 191   (reduce #'(lambda (x y) (logior (ash x 8.) y)) octs) )
 192
 193 (defmfun $number_to_octets (n)
 194   (unless (and (integerp n) (>= n 0))
 195     (gf-merror (intl:gettext
 196       "`number_to_octets': Argument must be a non-negative integer." )))
 197   (cons '(mlist simp) (number-to-octets n)) )
 198
 199 (defmfun $octets_to_number (octs)
 200   (unless ($listp octs)
 201     (gf-merror (intl:gettext
 202       "`octets_to_number': Argument must be a list of octets." )))
 203   (octets-to-number (cdr octs)) )
 204
 205
 206 ;; -- object identifiers (OID): --------------------------------------------- ;;
 207
 208 ;; examples:
 209
 210 ;; 1.2.840.113549.1.1.1    -  RSA encryption
 211 ;; 1.3.14.3.2.26           -  SHA-1 hash algorithm
 212 ;; 2.16.840.1.101.3.4.2.1  -  SHA-256 hash algorithm
 213 ;; 1.3.132.0.6             -  secp112r1 - SEC 2 recommended elliptic curve
 214
 215
 216 (defun oid-number-to-7bit (n)
 217   (let (lst res)
 218     (do () (())
 219       (setq lst (cons (logand n 127.) lst)
 220             n (ash n -7) )
 221       (when (= n 0) (return)) )
 222     (setq lst (nreverse lst)
 223           res (list (car lst)) )
 224     (dolist (bit7 (cdr lst) res)
 225       (setq res (cons (logior bit7 128.) res)) )))
 226 ;;
 227 (defun oid-to-octets (str)
 228   (let* ((*read-base* 10.)
 229          (lst (mapcar #'(lambda (s) (with-input-from-string (a s) (read a)))
 230                       (split str ".") )) ;; stringproc.lisp/split
 231           oct octs )
 232     (when (< (length lst) 2)
 233       (gf-merror (intl:gettext "No valid OID: ~m") str) )
 234     (setq oct (+ (* 40. (car lst)) (cadr lst))
 235           octs (list oct) )
 236     (dolist (n (cddr lst) octs)
 237       (setq octs (append octs (oid-number-to-7bit n))) )))
 238 ;;
 239 (defmfun $oid_to_octets (str)
 240   (cons '(mlist simp) (oid-to-octets str)) )
 241
 242
 243
 244 (defun oid-split (lst)
 245   (do (res n) (())
 246     (setq n (car lst)
 247           res (cons n res)
 248           lst (cdr lst) )
 249     (when (or (null lst) (not (logbitp 7 n)))
 250       (return (values (nreverse res) lst)) )))
 251 ;;
 252 (defun octets-to-oid-1 (lst)
 253   (let ((res 0))
 254     (dolist (n lst)
 255       (setq res (logior (logand n 127.) res))
 256       (unless (logbitp 7 n) (return res))
 257       (setq res (ash res 7)) )))
 258 ;;
 259 (defun octets-to-oid (lst)
 260   (if (= (length lst) 0)
 261     ""
 262     (let (str (tmp (car lst)) (*print-base* 10.))
 263       (setq lst (cdr lst))
 264       (multiple-value-bind (q r) (truncate tmp 40.)
 265         (setq str ($sconcat q "." r))
 266         (do () ((null lst) str)
 267           (multiple-value-setq (tmp lst) (oid-split lst))
 268           (setq str ($sconcat str "." (octets-to-oid-1 tmp))) )))))
 269 ;;
 270 (defmfun $octets_to_oid (octets)
 271   (octets-to-oid (cdr octets)) )
 272
 273
 274 ;; -- CRC24 checksum: ------------------------------------------------------- ;;
 275
 276 (defun crc24sum (lst)
 277   (let ((r #xb704ce)
 278         (poly #x1864cfb) )
 279     (dolist (oct lst r)
 280       (setq r (logxor r (ash oct 16.)))
 281       (dotimes (i 8)
 282         (setq r (ash r 1))
 283         (when (logbitp 24. r) (setq r (logxor r poly))) ))))
 284 ;;
 285 (defmfun $crc24sum (octets &optional (rtype '$string))
 286   (if ($listp octets)
 287     (let ((crc24 (crc24sum (cdr octets))))
 288       (cond
 289         ((equal rtype '$list)
 290           (cons '(mlist simp) (number-to-octets crc24)) )
 291         ((equal rtype '$number)
 292           crc24 )
 293         ((equal rtype '$string)
 294           (nstring-downcase (format nil "~6,'0x" crc24)) )
 295         (t
 296           (gf-merror (intl:gettext
 297             "`crc24sum': Optional argument must be 'list, 'number or 'string." )))))
 298     (gf-merror (intl:gettext
 299       "`crc24sum': Argument must be a list of octets." ))))
 300
 301
 302 (eval-when
 303   #+gcl (compile eval)
 304   #-gcl (:compile-toplevel :execute)
 305     (setq *read-base* old-ibase-cryptools) )