guix/pk-crypto.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix pk-crypto)
  20   #:use-module (guix base16)
  21   #:use-module (guix gcrypt)
  22
  23   #:use-module (system foreign)
  24   #:use-module (rnrs bytevectors)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 rdelim)
  27   #:export (canonical-sexp?
  28             error-source
  29             error-string
  30             string->canonical-sexp
  31             canonical-sexp->string
  32             read-file-sexp
  33             number->canonical-sexp
  34             canonical-sexp-car
  35             canonical-sexp-cdr
  36             canonical-sexp-nth
  37             canonical-sexp-nth-data
  38             canonical-sexp-length
  39             canonical-sexp-null?
  40             canonical-sexp-list?
  41             bytevector->hash-data
  42             hash-data->bytevector
  43             key-type
  44             sign
  45             verify
  46             generate-key
  47             find-sexp-token
  48             canonical-sexp->sexp
  49             sexp->canonical-sexp)
  50   #:re-export (gcrypt-version))
  51
  52 \f
  53 ;;; Commentary:
  54 ;;;
  55 ;;; Public key cryptographic routines from GNU Libgcrypt.
  56 ;;;;
  57 ;;; Libgcrypt uses "canonical s-expressions" to represent key material,
  58 ;;; parameters, and data.  We keep it as an opaque object to map them to
  59 ;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure
  60 ;;; memory, and (2) the read syntax is different.
  61 ;;;
  62 ;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in
  63 ;;; cases where it is safe to move data out of Libgcrypt---e.g., when
  64 ;;; processing ACL entries, public keys, etc.
  65 ;;;
  66 ;;; Canonical sexps were defined by Rivest et al. in the IETF draft at
  67 ;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI
  68 ;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.)
  69 ;;;
  70 ;;; Code:
  71
  72 ;; Libgcrypt "s-expressions".
  73 (define-wrapped-pointer-type <canonical-sexp>
  74   canonical-sexp?
  75   naked-pointer->canonical-sexp
  76   canonical-sexp->pointer
  77   (lambda (obj port)
  78     ;; Don't print OBJ's external representation: we don't want key material
  79     ;; to leak in backtraces and such.
  80     (format port "#<canonical-sexp ~a | ~a>"
  81             (number->string (object-address obj) 16)
  82             (number->string (pointer-address (canonical-sexp->pointer obj))
  83                             16))))
  84
  85 (define finalize-canonical-sexp!
  86   (libgcrypt-func "gcry_sexp_release"))
  87
  88 (define-inlinable (pointer->canonical-sexp ptr)
  89   "Return a <canonical-sexp> that wraps PTR."
  90   (let* ((sexp (naked-pointer->canonical-sexp ptr))
  91          (ptr* (canonical-sexp->pointer sexp)))
  92     ;; Did we already have a <canonical-sexp> object for PTR?
  93     (when (equal? ptr ptr*)
  94       ;; No, so we can safely add a finalizer (in Guile 2.0.9
  95       ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the
  96       ;; existing one.)
  97       (set-pointer-finalizer! ptr finalize-canonical-sexp!))
  98     sexp))
  99
 100 (define error-source
 101   (let* ((ptr  (libgcrypt-func "gcry_strsource"))
 102          (proc (pointer->procedure '* ptr (list int))))
 103     (lambda (err)
 104       "Return the error source (a string) for ERR, an error code as thrown
 105 along with 'gcry-error'."
 106       (pointer->string (proc err)))))
 107
 108 (define error-string
 109   (let* ((ptr  (libgcrypt-func "gcry_strerror"))
 110          (proc (pointer->procedure '* ptr (list int))))
 111     (lambda (err)
 112       "Return the error description (a string) for ERR, an error code as
 113 thrown along with 'gcry-error'."
 114       (pointer->string (proc err)))))
 115
 116 (define string->canonical-sexp
 117   (let* ((ptr  (libgcrypt-func "gcry_sexp_new"))
 118          (proc (pointer->procedure int ptr `(* * ,size_t ,int))))
 119     (lambda (str)
 120       "Parse STR and return the corresponding gcrypt s-expression."
 121
 122       ;; When STR comes from 'canonical-sexp->string', it may contain
 123       ;; characters that are really meant to be interpreted as bytes as in a C
 124       ;; 'char *'.  Thus, convert STR to ISO-8859-1 so the byte values of the
 125       ;; characters are preserved.
 126       (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
 127              (err  (proc sexp (string->pointer str "ISO-8859-1") 0 1)))
 128         (if (= 0 err)
 129             (pointer->canonical-sexp (dereference-pointer sexp))
 130             (throw 'gcry-error 'string->canonical-sexp err))))))
 131
 132 (define-syntax GCRYSEXP_FMT_ADVANCED
 133   (identifier-syntax 3))
 134
 135 (define canonical-sexp->string
 136   (let* ((ptr  (libgcrypt-func "gcry_sexp_sprint"))
 137          (proc (pointer->procedure size_t ptr `(* ,int * ,size_t))))
 138     (lambda (sexp)
 139       "Return a textual representation of SEXP."
 140       (let loop ((len 1024))
 141         (let* ((buf  (bytevector->pointer (make-bytevector len)))
 142                (size (proc (canonical-sexp->pointer sexp)
 143                            GCRYSEXP_FMT_ADVANCED buf len)))
 144           (if (zero? size)
 145               (loop (* len 2))
 146               (pointer->string buf size "ISO-8859-1")))))))
 147
 148 (define (read-file-sexp file)
 149   "Return the canonical sexp read from FILE."
 150   (call-with-input-file file
 151     (compose string->canonical-sexp
 152              read-string)))
 153
 154 (define canonical-sexp-car
 155   (let* ((ptr  (libgcrypt-func "gcry_sexp_car"))
 156          (proc (pointer->procedure '* ptr '(*))))
 157     (lambda (lst)
 158       "Return the first element of LST, an sexp, if that element is a list;
 159 return #f if LST or its first element is not a list (this is different from
 160 the usual Lisp 'car'.)"
 161       (let ((result (proc (canonical-sexp->pointer lst))))
 162         (if (null-pointer? result)
 163             #f
 164             (pointer->canonical-sexp result))))))
 165
 166 (define canonical-sexp-cdr
 167   (let* ((ptr  (libgcrypt-func "gcry_sexp_cdr"))
 168          (proc (pointer->procedure '* ptr '(*))))
 169     (lambda (lst)
 170       "Return the tail of LST, an sexp, or #f if LST is not a list."
 171       (let ((result (proc (canonical-sexp->pointer lst))))
 172         (if (null-pointer? result)
 173             #f
 174             (pointer->canonical-sexp result))))))
 175
 176 (define canonical-sexp-nth
 177   (let* ((ptr  (libgcrypt-func "gcry_sexp_nth"))
 178          (proc (pointer->procedure '* ptr `(* ,int))))
 179     (lambda (lst index)
 180       "Return the INDEXth nested element of LST, an s-expression.  Return #f
 181 if that element does not exist, or if it's an atom.  (Note: this is obviously
 182 different from Scheme's 'list-ref'.)"
 183       (let ((result (proc (canonical-sexp->pointer lst) index)))
 184         (if (null-pointer? result)
 185             #f
 186             (pointer->canonical-sexp result))))))
 187
 188 (define (dereference-size_t p)
 189   "Return the size_t value pointed to by P."
 190   (bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
 191                        0 (native-endianness)
 192                        (sizeof size_t)))
 193
 194 (define canonical-sexp-length
 195   (let* ((ptr  (libgcrypt-func "gcry_sexp_length"))
 196          (proc (pointer->procedure int ptr '(*))))
 197     (lambda (sexp)
 198       "Return the length of SEXP if it's a list (including the empty list);
 199 return zero if SEXP is an atom."
 200       (proc (canonical-sexp->pointer sexp)))))
 201
 202 (define token-string?
 203   (let ((token-cs (char-set-union char-set:digit
 204                                   char-set:letter
 205                                   (char-set #\- #\. #\/ #\_
 206                                             #\: #\* #\+ #\=))))
 207     (lambda (str)
 208       "Return #t if STR is a token as per Section 4.3 of
 209 <http://people.csail.mit.edu/rivest/Sexp.txt>."
 210       (and (not (string-null? str))
 211            (string-every token-cs str)
 212            (not (char-set-contains? char-set:digit (string-ref str 0)))))))
 213
 214 (define canonical-sexp-nth-data
 215   (let* ((ptr  (libgcrypt-func "gcry_sexp_nth_data"))
 216          (proc (pointer->procedure '* ptr `(* ,int *))))
 217     (lambda (lst index)
 218       "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
 219 \"octet string\") the INDEXth data element (atom) of LST, an s-expression.
 220 Return #f if that element does not exist, or if it's a list."
 221       (let* ((size*  (bytevector->pointer (make-bytevector (sizeof '*))))
 222              (result (proc (canonical-sexp->pointer lst) index size*)))
 223         (if (null-pointer? result)
 224             #f
 225             (let* ((len (dereference-size_t size*))
 226                    (str (pointer->string result len "ISO-8859-1")))
 227               ;; The sexp spec speaks of "tokens" and "octet strings".
 228               ;; Sometimes these octet strings are actual strings (text),
 229               ;; sometimes they're bytevectors, and sometimes they're
 230               ;; multi-precision integers (MPIs).  Only the application knows.
 231               ;; However, for convenience, we return a symbol when a token is
 232               ;; encountered since tokens are frequent (at least in the 'car'
 233               ;; of each sexp.)
 234               (if (token-string? str)
 235                   (string->symbol str)   ; an sexp "token"
 236                   (bytevector-copy       ; application data, textual or binary
 237                    (pointer->bytevector result len)))))))))
 238
 239 (define (number->canonical-sexp number)
 240   "Return an s-expression representing NUMBER."
 241   (string->canonical-sexp (string-append "#" (number->string number 16) "#")))
 242
 243 (define* (bytevector->hash-data bv
 244                                 #:optional
 245                                 (hash-algo "sha256")
 246                                 #:key (key-type 'ecc))
 247   "Given BV, a bytevector containing a hash of type HASH-ALGO, return an
 248 s-expression suitable for use as the 'data' argument for 'sign'.  KEY-TYPE
 249 must be a symbol: 'dsa, 'ecc, or 'rsa."
 250   (string->canonical-sexp
 251    (format #f "(data (flags ~a) (hash \"~a\" #~a#))"
 252            (case key-type
 253              ((ecc dsa) "rfc6979")
 254              ((rsa)     "pkcs1")
 255              (else (error "unknown key type" key-type)))
 256            hash-algo
 257            (bytevector->base16-string bv))))
 258
 259 (define (key-type sexp)
 260   "Return a symbol denoting the type of public or private key represented by
 261 SEXP--e.g., 'rsa', 'ecc'--or #f if SEXP does not denote a valid key."
 262   (case (canonical-sexp-nth-data sexp 0)
 263     ((public-key private-key)
 264      (canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0))
 265     (else #f)))
 266
 267 (define* (hash-data->bytevector data)
 268   "Return two values: the hash value (a bytevector), and the hash algorithm (a
 269 string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
 270 Return #f if DATA does not conform."
 271   (let ((hash (find-sexp-token data 'hash)))
 272     (if hash
 273         (let ((algo  (canonical-sexp-nth-data hash 1))
 274               (value (canonical-sexp-nth-data hash 2)))
 275           (values value (symbol->string algo)))
 276         (values #f #f))))
 277
 278 (define sign
 279   (let* ((ptr  (libgcrypt-func "gcry_pk_sign"))
 280          (proc (pointer->procedure int ptr '(* * *))))
 281     (lambda (data secret-key)
 282       "Sign DATA, a canonical s-expression representing a suitable hash, with
 283 SECRET-KEY (a canonical s-expression whose car is 'private-key'.)  Note that
 284 DATA must be a 'data' s-expression, as returned by
 285 'bytevector->hash-data' (info \"(gcrypt) Cryptographic Functions\")."
 286       (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
 287              (err (proc sig (canonical-sexp->pointer data)
 288                         (canonical-sexp->pointer secret-key))))
 289         (if (= 0 err)
 290             (pointer->canonical-sexp (dereference-pointer sig))
 291             (throw 'gcry-error 'sign err))))))
 292
 293 (define verify
 294   (let* ((ptr  (libgcrypt-func "gcry_pk_verify"))
 295          (proc (pointer->procedure int ptr '(* * *))))
 296     (lambda (signature data public-key)
 297       "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
 298 which are gcrypt s-expressions."
 299       (zero? (proc (canonical-sexp->pointer signature)
 300                    (canonical-sexp->pointer data)
 301                    (canonical-sexp->pointer public-key))))))
 302
 303 (define generate-key
 304   (let* ((ptr  (libgcrypt-func "gcry_pk_genkey"))
 305          (proc (pointer->procedure int ptr '(* *))))
 306     (lambda (params)
 307       "Return as an s-expression a new key pair for PARAMS.  PARAMS must be an
 308 s-expression like: (genkey (rsa (nbits 4:2048)))."
 309       (let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
 310              (err (proc key (canonical-sexp->pointer params))))
 311         (if (zero? err)
 312             (pointer->canonical-sexp (dereference-pointer key))
 313             (throw 'gcry-error 'generate-key err))))))
 314
 315 (define find-sexp-token
 316   (let* ((ptr  (libgcrypt-func "gcry_sexp_find_token"))
 317          (proc (pointer->procedure '* ptr `(* * ,size_t))))
 318     (lambda (sexp token)
 319       "Find in SEXP the first element whose 'car' is TOKEN and return it;
 320 return #f if not found."
 321       (let* ((token (string->pointer (symbol->string token)))
 322              (res   (proc (canonical-sexp->pointer sexp) token 0)))
 323         (if (null-pointer? res)
 324             #f
 325             (pointer->canonical-sexp res))))))
 326
 327 (define-inlinable (canonical-sexp-null? sexp)
 328   "Return #t if SEXP is the empty-list sexp."
 329   (null-pointer? (canonical-sexp->pointer sexp)))
 330
 331 (define (canonical-sexp-list? sexp)
 332   "Return #t if SEXP is a list."
 333   (or (canonical-sexp-null? sexp)
 334       (> (canonical-sexp-length sexp) 0)))
 335
 336 (define (canonical-sexp-fold proc seed sexp)
 337   "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp."
 338   (if (canonical-sexp-list? sexp)
 339       (let ((len (canonical-sexp-length sexp)))
 340         (let loop ((index  0)
 341                    (result seed))
 342           (if (= index len)
 343               result
 344               (loop (+ 1 index)
 345                     ;; XXX: Call 'nth-data' *before* 'nth' to work around
 346                     ;; <https://bugs.g10code.com/gnupg/issue1594>, which
 347                     ;; affects 1.6.0 and earlier versions.
 348                     (proc (or (canonical-sexp-nth-data sexp index)
 349                               (canonical-sexp-nth sexp index))
 350                           result)))))
 351       (error "sexp is not a list" sexp)))
 352
 353 (define (canonical-sexp->sexp sexp)
 354   "Return a Scheme sexp corresponding to SEXP.  This is particularly useful to
 355 compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to
 356 use pattern matching."
 357   (if (canonical-sexp-list? sexp)
 358       (reverse
 359        (canonical-sexp-fold (lambda (item result)
 360                               (cons (if (canonical-sexp? item)
 361                                         (canonical-sexp->sexp item)
 362                                         item)
 363                                     result))
 364                             '()
 365                             sexp))
 366
 367       ;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a
 368       ;; non-list sexp (!), so we first enlist SEXP, then get at its buffer.
 369       (let ((sexp (string->canonical-sexp
 370                    (string-append "(" (canonical-sexp->string sexp)
 371                                   ")"))))
 372         (or (canonical-sexp-nth-data sexp 0)
 373             (canonical-sexp-nth sexp 0)))))
 374
 375 (define (sexp->canonical-sexp sexp)
 376   "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by
 377 'canonical-sexp->sexp'."
 378   ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
 379   ;; much better.
 380   (string->canonical-sexp
 381     (call-with-output-string
 382      (lambda (port)
 383        (define (write item)
 384          (cond ((list? item)
 385                 (display "(" port)
 386                 (for-each write item)
 387                 (display ")" port))
 388                ((symbol? item)
 389                 (format port " ~a" item))
 390                ((bytevector? item)
 391                 (format port " #~a#"
 392                         (bytevector->base16-string item)))
 393                (else
 394                 (error "unsupported sexp item type" item))))
 395
 396        (write sexp)))))
 397
 398 (define (gcrypt-error-printer port key args default-printer)
 399   "Print the gcrypt error specified by ARGS."
 400   (match args
 401     ((proc err)
 402      (format port "In procedure ~a: ~a: ~a"
 403              proc (error-source err) (error-string err)))))
 404
 405 (set-exception-printer! 'gcry-error gcrypt-error-printer)
 406
 407 ;;; pk-crypto.scm ends here