guile/tests/openpgp-keyring.scm

   1 ;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA.
   2 ;;; Copyright (C) 2007-2012 Free Software Foundation, Inc.
   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 keyring API part of GnuTLS-extra.
  24 ;;;
  25
  26 (use-modules (gnutls)
  27              (gnutls build tests)
  28              (srfi srfi-1)
  29              (srfi srfi-4))
  30
  31 (define %raw-keyring-file
  32   (search-path %load-path "openpgp-keyring.gpg"))
  33
  34 (define %ascii-keyring-file
  35   (search-path %load-path "openpgp-keyring.asc"))
  36
  37 (define %ids-in-keyring
  38   ;; The IDs of keys that are in the keyring.
  39   ;; Change me if you change the keyring file.
  40   (list '#u8(#x35 #x14 #x5c #xea
  41              #xa7 #xd9 #x3c #x3f)
  42         '#u8(#xbd #x57 #x2c #xdc
  43              #xcc #xc0 #x7c #x35)))
  44
  45 (define (file-size file)
  46   (stat:size (stat file)))
  47
  48 (define (valid-keyring? file format)
  49   ;; Return true if FILE contains a valid keyring encoded in FORMAT.
  50   (let ((raw-keyring (make-u8vector (file-size file))))
  51
  52     (uniform-vector-read! raw-keyring (open-input-file file))
  53
  54     (let ((keyring (import-openpgp-keyring raw-keyring format))
  55           (null-id (make-u8vector 8 0)))
  56
  57       (and (openpgp-keyring? keyring)
  58            (not (openpgp-keyring-contains-key-id? keyring null-id))
  59            (every (lambda (id)
  60                     (openpgp-keyring-contains-key-id? keyring id))
  61                   %ids-in-keyring)))))
  62
  63 (run-test
  64     (lambda ()
  65       (every valid-keyring?
  66              (list %raw-keyring-file
  67                    %ascii-keyring-file)
  68              (list openpgp-certificate-format/raw
  69                    openpgp-certificate-format/base64))))
  70
  71 ;;; arch-tag: 516bf608-5c8b-4787-abe9-5f7b6e6d660b