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