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     (:compile-toplevel :execute)
 119   (defvar old-ibase-cryptools *read-base*)
 120   (setq *read-base* 10.) )
 121
 122
 123 ;; -- string-octet-conversions: --------------------------------------------- ;;
 124
 125 (defun $string_to_octets (str &optional enc)
 126   (unless (stringp str)
 127     (gf-merror (intl:gettext "`string_to_octets': argument must be a string.")) )
 128     (cons '(mlist simp) (string-to-octets str enc)) )
 129
 130 (defun string-to-octets (str &optional enc)
 131   (setq enc (get-encoding enc "string_to_octets"))
 132   (let ((ov #+ccl (ccl:encode-string-to-octets str :external-format enc) ;; maybe these (CCL, ECL) ..
 133             #+clisp (ext:convert-string-to-bytes str enc)
 134             #+ecl (ecl-string-to-octets str enc)                         ;; .. could move to intl.lisp
 135             #- (or ccl clisp ecl) (intl::string-to-octets str enc) ))    ;; GCL ignores enc
 136     (coerce ov 'list) ))
 137 ;;
 138 #+ecl
 139 (defun ecl-string-to-octets (str enc)
 140   (let ((a (make-array
 141              (ceiling (* 1.2 (length str))) ;; initially add 20 % for non-ascii chars
 142              :element-type '(unsigned-byte 8)
 143              :adjustable t
 144              :fill-pointer 0 )))
 145     (with-open-stream
 146       (stream (ext:make-sequence-output-stream a :external-format enc))
 147       (format stream str)
 148       a )))
 149
 150
 151 (defun $octets_to_string (ol &optional enc)
 152   (unless ($listp ol)
 153     (gf-merror (intl:gettext
 154       "`octets_to_string': argument must be a list of octets." )))
 155   (octets-to-string (cdr ol) enc) )
 156
 157 (defun octets-to-string (ol &optional enc)
 158   (setq enc (get-encoding enc "octets_to_string"))
 159   (let ((ov (map-into
 160               (make-array (length ol) :element-type '(unsigned-byte 8))
 161               #'identity
 162               ol )))
 163     #+ccl (ccl:decode-string-from-octets ov :external-format enc)
 164     #+clisp (ext:convert-string-from-bytes ov enc)
 165     #+ecl (ecl-octets-to-string ov enc)
 166     #- (or ccl clisp ecl) (intl::octets-to-string ov enc) ))
 167 ;;
 168 #+ecl
 169 (defun ecl-octets-to-string (ov enc)
 170   (with-open-stream
 171     (stream (ext:make-sequence-input-stream ov :external-format enc))
 172     (read-line stream) ))
 173
 174
 175 ;; -- number-octet-conversions: --------------------------------------------- ;;
 176
 177 (defun word-to-octets (n) ;; assume that n fits into a word
 178   (do ((k 4 (1- k)) octs)
 179       ((= k 0) octs)
 180     (push (logand n #xff) octs)
 181     (setq n (ash n -8.)) ))
 182
 183 (defun number-to-octets (n)
 184   (do (octs) (())
 185     (push (logand n #xff) octs)
 186     (setq n (ash n -8.))
 187     (when (= n 0) (return octs)) ))
 188
 189 (defun octets-to-number (octs)
 190   (reduce #'(lambda (x y) (logior (ash x 8.) y)) octs) )
 191
 192 (defmfun $number_to_octets (n)
 193   (unless (and (integerp n) (>= n 0))
 194     (gf-merror (intl:gettext
 195       "`number_to_octets': Argument must be a non-negative integer." )))
 196   (cons '(mlist simp) (number-to-octets n)) )
 197
 198 (defmfun $octets_to_number (octs)
 199   (unless ($listp octs)
 200     (gf-merror (intl:gettext
 201       "`octets_to_number': Argument must be a list of octets." )))
 202   (octets-to-number (cdr octs)) )
 203
 204
 205 ;; -- object identifiers (OID): --------------------------------------------- ;;
 206
 207 ;; examples:
 208
 209 ;; 1.2.840.113549.1.1.1    -  RSA encryption
 210 ;; 1.3.14.3.2.26           -  SHA-1 hash algorithm
 211 ;; 2.16.840.1.101.3.4.2.1  -  SHA-256 hash algorithm
 212 ;; 1.3.132.0.6             -  secp112r1 - SEC 2 recommended elliptic curve
 213
 214
 215 (defun oid-number-to-7bit (n)
 216   (let (lst res)
 217     (do () (())
 218       (setq lst (cons (logand n 127.) lst)
 219             n (ash n -7) )
 220       (when (= n 0) (return)) )
 221     (setq lst (nreverse lst)
 222           res (list (car lst)) )
 223     (dolist (bit7 (cdr lst) res)
 224       (setq res (cons (logior bit7 128.) res)) )))
 225 ;;
 226 (defun oid-to-octets (str)
 227   (let* ((*read-base* 10.)
 228          (lst (mapcar #'(lambda (s) (with-input-from-string (a s) (read a)))
 229                       (split str ".") )) ;; stringproc.lisp/split
 230           oct octs )
 231     (when (< (length lst) 2)
 232       (gf-merror (intl:gettext "No valid OID: ~m") str) )
 233     (setq oct (+ (* 40. (car lst)) (cadr lst))
 234           octs (list oct) )
 235     (dolist (n (cddr lst) octs)
 236       (setq octs (append octs (oid-number-to-7bit n))) )))
 237 ;;
 238 (defmfun $oid_to_octets (str)
 239   (cons '(mlist simp) (oid-to-octets str)) )
 240
 241
 242
 243 (defun oid-split (lst)
 244   (do (res n) (())
 245     (setq n (car lst)
 246           res (cons n res)
 247           lst (cdr lst) )
 248     (when (or (null lst) (not (logbitp 7 n)))
 249       (return (values (nreverse res) lst)) )))
 250 ;;
 251 (defun octets-to-oid-1 (lst)
 252   (let ((res 0))
 253     (dolist (n lst)
 254       (setq res (logior (logand n 127.) res))
 255       (unless (logbitp 7 n) (return res))
 256       (setq res (ash res 7)) )))
 257 ;;
 258 (defun octets-to-oid (lst)
 259   (if (= (length lst) 0)
 260     ""
 261     (let (str (tmp (car lst)) (*print-base* 10.))
 262       (setq lst (cdr lst))
 263       (multiple-value-bind (q r) (truncate tmp 40.)
 264         (setq str ($sconcat q "." r))
 265         (do () ((null lst) str)
 266           (multiple-value-setq (tmp lst) (oid-split lst))
 267           (setq str ($sconcat str "." (octets-to-oid-1 tmp))) )))))
 268 ;;
 269 (defmfun $octets_to_oid (octets)
 270   (octets-to-oid (cdr octets)) )
 271
 272
 273 ;; -- CRC24 checksum: ------------------------------------------------------- ;;
 274
 275 (defun crc24sum (lst)
 276   (let ((r #xb704ce)
 277         (poly #x1864cfb) )
 278     (dolist (oct lst r)
 279       (setq r (logxor r (ash oct 16.)))
 280       (dotimes (i 8)
 281         (setq r (ash r 1))
 282         (when (logbitp 24. r) (setq r (logxor r poly))) ))))
 283 ;;
 284 (defmfun $crc24sum (octets &optional (rtype '$string))
 285   (if ($listp octets)
 286     (let ((crc24 (crc24sum (cdr octets))))
 287       (cond
 288         ((equal rtype '$list)
 289           (cons '(mlist simp) (number-to-octets crc24)) )
 290         ((equal rtype '$number)
 291           crc24 )
 292         ((equal rtype '$string)
 293           (nstring-downcase (format nil "~6,'0x" crc24)) )
 294         (t
 295           (gf-merror (intl:gettext
 296             "`crc24sum': Optional argument must be 'list, 'number or 'string." )))))
 297     (gf-merror (intl:gettext
 298       "`crc24sum': Argument must be a list of octets." ))))
 299
 300
 301 (eval-when
 302     (:compile-toplevel :execute)
 303   (setq *read-base* old-ibase-cryptools) )