guile/tests/openpgp-keys.scm

   1 ;;; GNUTLS-EXTRA --- Guile bindings for GnuTLS-EXTRA.
   2 ;;; Copyright (C) 2007  Free Software Foundation
   3 ;;;
   4 ;;; GNUTLS-EXTRA is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 3 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; GNUTLS-EXTRA is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License
  15 ;;; along with GNUTLS-EXTRA; if not, write to the Free Software
  16 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
  17 ;;; USA.
  18
  19 ;;; Written by Ludovic Courtès <ludo@chbouib.org>.
  20
  21
  22 ;;;
  23 ;;; Exercise the OpenPGP key API part of GnuTLS-extra.
  24 ;;;
  25
  26 (use-modules (gnutls)
  27              (gnutls extra)
  28              (srfi srfi-1)
  29              (srfi srfi-4)
  30              (srfi srfi-11))
  31
  32 (define %certificate-file
  33   (search-path %load-path "openpgp-pub.asc"))
  34
  35 (define %private-key-file
  36   (search-path %load-path "openpgp-sec.asc"))
  37
  38 (define %key-id
  39   ;; Change me if you change the key files.
  40   '#u8(#xbd #x57 #x2c #xdc #xcc #xc0 #x7c #x35))
  41
  42 (define (file-size file)
  43   (stat:size (stat file)))
  44
  45
  46 (dynamic-wind
  47
  48     (lambda ()
  49       #t)
  50
  51     (lambda ()
  52       (let ((raw-pubkey  (make-u8vector (file-size %certificate-file)))
  53             (raw-privkey (make-u8vector (file-size %private-key-file))))
  54
  55         (uniform-vector-read! raw-pubkey (open-input-file %certificate-file))
  56         (uniform-vector-read! raw-privkey (open-input-file %private-key-file))
  57
  58         (let ((pub (import-openpgp-certificate raw-pubkey
  59                                            openpgp-certificate-format/base64))
  60               (sec (import-openpgp-private-key raw-privkey
  61                                            openpgp-certificate-format/base64)))
  62
  63           (exit (and (openpgp-certificate? pub)
  64                      (openpgp-private-key? sec)
  65                      (equal? (openpgp-certificate-id pub) %key-id)
  66                      (u8vector? (openpgp-certificate-fingerprint pub))
  67                      (every string? (openpgp-certificate-names pub))
  68                      (member (openpgp-certificate-version pub) '(3 4))
  69                      (list? (openpgp-certificate-usage pub))
  70                      (let-values (((pk bits)
  71                                    (openpgp-certificate-algorithm pub)))
  72                        (and (string? (pk-algorithm->string pk))
  73                             (number? bits))))))))
  74
  75     (lambda ()
  76       ;; failure
  77       (exit 1)))
  78
  79 ;;; arch-tag: 2ee2a377-7f4d-4031-92a8-275090e4f83d