2006-07-06 Marcus Brinkmann <marcus@g10code.de>
[gpgme.git] / lang / cl / gpgme.lisp
1 ;;;; gpgme.lisp
2
3 ;;; Copyright (C) 2006 g10 Code GmbH
4 ;;;
5 ;;; This file is part of GPGME-CL.
6 ;;;
7 ;;; GPGME-CL is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 2 of the License, or
10 ;;; (at your option) any later version.
11 ;;;
12 ;;; GPGME-CL is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15 ;;; Lesser General Public License for more details.
16 ;;;
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GPGME; if not, write to the Free Software Foundation,
19 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
20
21 ;;; TODO
22
23 ;;; Set up the library.
24
25 (in-package :gpgme)
26
27 ;;; Debugging.
28
29 (defvar *debug* nil "If debugging output should be given or not.")
30
31 ;;; Load the foreign library.
32
33 (define-foreign-library libgpgme
34   (:unix "libgpgme.so")
35   (t (:default "libgpgme")))
36
37 (use-foreign-library libgpgme)
38
39 ;;; System dependencies.
40
41 ; FIXME: Use cffi-grovel?  cffi-unix?
42
43 (defctype size-t :unsigned-int
44   :documentation "The system size_t type.")
45
46 (defctype ssize-t :int
47   :documentation "The system ssize_t type.")
48
49 ; FIXME: Ouch.  Grovel?  Helper function?
50 (defconstant +seek-set+ 0)
51 (defconstant +seek-cur+ 1)
52 (defconstant +seek-end+ 2)
53 (defctype off-t :long-long
54   :documentation "The system off_t type.")
55
56 (defcfun ("strerror" c-strerror) :string
57   (err :int))
58
59 ; Access to ERRNO.
60 ; FIXME: Ouch.  Should be grovel + helper function.
61
62 (define-condition system-error (error)
63   ((errno :initarg :errno :reader system-error-errno))
64   (:report (lambda (c stream)
65              (format stream "System error: ~A: ~A"
66                      (system-error-errno c)
67                      (c-strerror (system-error-errno c)))))
68   (:documentation "Signalled when an errno is encountered."))
69
70 (defconstant +ebadf+ 1)
71
72 ; Ouch.
73 (defun get-errno ()
74   +ebadf+)
75
76 ;;; More about errno below.
77
78 ; Needed to write passphrases.
79 (defcfun ("write" c-write) ssize-t
80   (fd :int)
81   (buffer :string) ; Actually :pointer, but we only need string.
82   (size size-t))
83
84 (defun system-write (fd buffer size)
85   (let ((res (c-write fd buffer size)))
86     (when (< res 0) (error 'system-error :errno (get-errno)))
87     res))
88
89 ;;; More about errno here.
90
91 (defun set-errno (errno)
92   (cond
93                                         ; Works on GNU/Linux.
94     ((eql errno +ebadf+) (system-write -1 (null-pointer) 0))
95     (t (error 'invalid-errno :errno errno))))
96
97 ;;;
98 ;;; C Interface Definitions
99 ;;;
100
101 ;;; Data Type Interface
102
103 ;;; Some new data types used for easier translation.
104
105 ;;; The number of include certs.  Translates to NIL for default.
106 (defctype cert-int-t :int)
107
108 ;;; A string that may be NIL to indicate a null pointer.
109 (defctype string-or-nil-t :string)
110
111 ;;; Some opaque data types used by GPGME.
112
113 (defctype gpgme-ctx-t :pointer
114   :documentation "The GPGME context type.")
115
116 (defctype gpgme-data-t :pointer
117   :documentation "The GPGME data object type.")
118
119 ;;; Wrappers for the libgpg-error library.
120
121 (defctype gpgme-error-t gpg-error::gpg-error-t
122   :documentation "The GPGME error type.")
123
124 (defctype gpgme-error-no-signal-t gpg-error::gpg-error-t
125   :documentation "The GPGME error type (this version does not
126   signal conditions in translation.")
127
128 (defctype gpgme-err-code-t gpg-error::gpg-err-code-t
129   :documentation "The GPGME error code type.")
130
131 (defctype gpgme-err-source-t gpg-error::gpg-err-source-t
132   :documentation "The GPGME error source type.")
133
134 (defun gpgme-err-make (source code)
135   "Construct an error value from an error code and source."
136   (gpg-err-make source code))
137
138 (defun gpgme-error (code)
139   "Construct an error value from an error code."
140   (gpgme-err-make :gpg-err-source-gpgme code))
141
142 (defun gpgme-err-code (err)
143   "Retrieve an error code from the error value ERR."
144   (gpg-err-code err))
145
146 (defun gpgme-err-source (err)
147   "Retrieve an error source from the error value ERR."
148   (gpg-err-source err))
149
150 (defun gpgme-strerror (err)
151   "Return a string containig a description of the error code."
152   (gpg-strerror err))
153
154 (defun gpgme-strsource (err)
155   "Return a string containig a description of the error source."
156   (gpg-strsource err))
157
158 (defun gpgme-err-code-from-errno (err)
159   "Retrieve the error code for the system error.  If the system error
160    is not mapped, :gpg-err-unknown-errno is returned."
161   (gpg-err-code-from-errno err))
162
163 (defun gpgme-err-code-to-errno (code)
164   "Retrieve the system error for the error code.  If this is not a
165    system error, 0 is returned."
166   (gpg-err-code-to-errno code))
167
168 (defun gpgme-err-make-from-errno (source err)
169   (gpg-err-make-from-errno source err))
170
171 (defun gpgme-error-from-errno (err)
172   (gpg-error-from-errno err))
173
174 ;;;
175
176 (defcenum gpgme-data-encoding-t
177   "The possible encoding mode of gpgme-data-t objects."
178   (:none 0)
179   (:binary 1)
180   (:base64 2)
181   (:armor 3))
182
183 ;;;
184
185 (defcenum gpgme-pubkey-algo-t
186   "Public key algorithms from libgcrypt."
187   (:rsa 1)
188   (:rsa-e 2)
189   (:rsa-s 3)
190   (:elg-e 16)
191   (:dsa 17)
192   (:elg 20))
193
194 (defcenum gpgme-hash-algo-t
195   "Hash algorithms from libgcrypt."
196   (:none 0)
197   (:md5 1)
198   (:sha1 2)
199   (:rmd160 3)
200   (:md2 5)
201   (:tiger 6)
202   (:haval 7)
203   (:sha256 8)
204   (:sha384 9)
205   (:sha512 10)
206   (:md4 301)
207   (:crc32 302)
208   (:crc32-rfc1510 303)
209   (:crc24-rfc2440 304))
210
211 ;;;
212
213 (defcenum gpgme-sig-mode-t
214   "The available signature modes."
215   (:none 0)
216   (:detach 1)
217   (:clear 2))
218
219 ;;;
220
221 (defcenum gpgme-validity-t
222   "The available validities for a trust item or key."
223   (:unknown 0)
224   (:undefined 1)
225   (:never 2)
226   (:marginal 3)
227   (:full 4)
228   (:ultimate 5))
229
230 ;;;
231
232 (defcenum gpgme-protocol-t
233   "The available protocols."
234   (:openpgp 0)
235   (:cms 1))
236
237 ;;;
238
239 (defbitfield (gpgme-keylist-mode-t :unsigned-int)
240   "The available keylist mode flags."
241   (:local 1)
242   (:extern 2)
243   (:sigs 4)
244   (:validate 256))
245
246 ;;;
247
248 (defbitfield (gpgme-sig-notation-flags-t :unsigned-int)
249   "The available signature notation flags."
250   (:human-readable 1)
251   (:critical 2))
252
253 (defctype gpgme-sig-notation-t :pointer
254   :documentation "Signature notation pointer type.")
255
256 ;; FIXME: Doesn't this depend on endianess?
257 (defbitfield (gpgme-sig-notation-bitfield :unsigned-int)
258   (:human-readable 1)
259   (:critical 2))
260
261 (defcstruct gpgme-sig-notation
262   "Signature notations."
263   (next gpgme-sig-notation-t)
264   (name :pointer)
265   (value :pointer)
266   (name-len :int)
267   (value-len :int)
268   (flags gpgme-sig-notation-flags-t)
269   (bitfield gpgme-sig-notation-bitfield))
270
271 ;;;
272
273 ;; FIXME: Add status codes.
274 (defcenum gpgme-status-code-t
275   "The possible status codes for the edit operation."
276   (:eof 0)
277   (:enter 1))
278
279 ;;;
280
281 (defctype gpgme-engine-info-t :pointer
282   :documentation "The engine information structure pointer type.")
283
284 (defcstruct gpgme-engine-info
285   "Engine information."
286   (next gpgme-engine-info-t)
287   (protocol gpgme-protocol-t)
288   (file-name :string)
289   (version :string)
290   (req-version :string)
291   (home-dir :string))
292
293 ;;;
294
295 (defctype gpgme-subkey-t :pointer
296   :documentation "A subkey from a key.")
297
298 ;; FIXME: Doesn't this depend on endianess?
299 (defbitfield (gpgme-subkey-bitfield :unsigned-int)
300   "The subkey bitfield."
301   (:revoked 1)
302   (:expired 2)
303   (:disabled 4)
304   (:invalid 8)
305   (:can-encrypt 16)
306   (:can-sign 32)
307   (:can-certify 64)
308   (:secret 128)
309   (:can-authenticate 256)
310   (:is-qualified 512))
311
312 (defcstruct gpgme-subkey
313   "Subkey from a key."
314   (next gpgme-subkey-t)
315   (bitfield gpgme-subkey-bitfield)
316   (pubkey-algo gpgme-pubkey-algo-t)
317   (length :unsigned-int)
318   (keyid :string)
319   (-keyid :char :count 17)
320   (fpr :string)
321   (timestamp :long)
322   (expires :long))
323
324
325 (defctype gpgme-key-sig-t :pointer
326   :documentation "A signature on a user ID.")
327
328 ;; FIXME: Doesn't this depend on endianess?
329 (defbitfield (gpgme-key-sig-bitfield :unsigned-int)
330   "The key signature bitfield."
331   (:revoked 1)
332   (:expired 2)
333   (:invalid 4)
334   (:exportable 16))
335
336 (defcstruct gpgme-key-sig
337   "A signature on a user ID."
338   (next gpgme-key-sig-t)
339   (bitfield gpgme-key-sig-bitfield)
340   (pubkey-algo gpgme-pubkey-algo-t)
341   (keyid :string)
342   (-keyid :char :count 17)
343   (timestamp :long)
344   (expires :long)
345   (status gpgme-error-no-signal-t)
346   (-class :unsigned-int)
347   (uid :string)
348   (name :string)
349   (email :string)
350   (comment :string)
351   (sig-class :unsigned-int))
352
353
354 (defctype gpgme-user-id-t :pointer
355   :documentation "A user ID from a key.")
356
357 ;; FIXME: Doesn't this depend on endianess?
358 (defbitfield (gpgme-user-id-bitfield :unsigned-int)
359   "The user ID bitfield."
360   (:revoked 1)
361   (:invalid 2))
362
363 (defcstruct gpgme-user-id
364   "A user ID from a key."
365   (next gpgme-user-id-t)
366   (bitfield gpgme-user-id-bitfield)
367   (validity gpgme-validity-t)
368   (uid :string)
369   (name :string)
370   (email :string)
371   (comment :string)
372   (signatures gpgme-key-sig-t)
373   (-last-keysig gpgme-key-sig-t))
374
375
376 (defctype gpgme-key-t :pointer
377   :documentation "A key from the keyring.")
378
379 ;; FIXME: Doesn't this depend on endianess?
380 (defbitfield (gpgme-key-bitfield :unsigned-int)
381   "The key bitfield."
382   (:revoked 1)
383   (:expired 2)
384   (:disabled 4)
385   (:invalid 8)
386   (:can-encrypt 16)
387   (:can-sign 32)
388   (:can-certify 64)
389   (:secret 128)
390   (:can-authenticate 256)
391   (:is-qualified 512))
392
393 (defcstruct gpgme-key
394   "A signature on a user ID."
395   (-refs :unsigned-int)
396   (bitfield gpgme-key-bitfield)
397   (protocol gpgme-protocol-t)
398   (issuer-serial :string)
399   (issuer-name :string)
400   (chain-id :string)
401   (owner-trust gpgme-validity-t)
402   (subkeys gpgme-subkey-t)
403   (uids gpgme-user-id-t)
404   (-last-subkey gpgme-subkey-t)
405   (-last-uid gpgme-user-id-t)
406   (keylist-mode gpgme-keylist-mode-t))
407
408 ;;;
409
410 ;;; There is no support in CFFI to define callback C types and have
411 ;;; automatic type checking with the callback definition.
412
413 (defctype gpgme-passphrase-cb-t :pointer)
414
415 (defctype gpgme-progress-cb-t :pointer)
416
417 (defctype gpgme-edit-cb-t :pointer)
418
419
420 ;;;
421 ;;; Function Interface
422 ;;;
423
424 ;;; Context management functions.
425
426 (defcfun ("gpgme_new" c-gpgme-new) gpgme-error-t
427   (ctx :pointer))
428
429 (defcfun ("gpgme_release" c-gpgme-release) :void
430   (ctx gpgme-ctx-t))
431
432 (defcfun ("gpgme_set_protocol" c-gpgme-set-protocol) gpgme-error-t
433   (ctx gpgme-ctx-t)
434   (proto gpgme-protocol-t))
435
436 (defcfun ("gpgme_get_protocol" c-gpgme-get-protocol) gpgme-protocol-t
437   (ctx gpgme-ctx-t))
438
439 (defcfun ("gpgme_get_protocol_name" c-gpgme-get-protocol-name) :string
440   (proto gpgme-protocol-t))
441
442 (defcfun ("gpgme_set_armor" c-gpgme-set-armor) :void
443   (ctx gpgme-ctx-t)
444   (yes :boolean))
445
446 (defcfun ("gpgme_get_armor" c-gpgme-get-armor) :boolean
447   (ctx gpgme-ctx-t))
448
449 (defcfun ("gpgme_set_textmode" c-gpgme-set-textmode) :void
450   (ctx gpgme-ctx-t)
451   (yes :boolean))
452
453 (defcfun ("gpgme_get_textmode" c-gpgme-get-textmode) :boolean
454   (ctx gpgme-ctx-t))
455
456 (defconstant +include-certs-default+ -256)
457
458 (defcfun ("gpgme_set_include_certs" c-gpgme-set-include-certs) :void
459   (ctx gpgme-ctx-t)
460   (nr-of-certs cert-int-t))
461
462 (defcfun ("gpgme_get_include_certs" c-gpgme-get-include-certs) cert-int-t
463   (ctx gpgme-ctx-t))
464
465 (defcfun ("gpgme_set_keylist_mode" c-gpgme-set-keylist-mode) gpgme-error-t
466   (ctx gpgme-ctx-t)
467   (mode gpgme-keylist-mode-t))
468
469 (defcfun ("gpgme_get_keylist_mode" c-gpgme-get-keylist-mode)
470     gpgme-keylist-mode-t
471   (ctx gpgme-ctx-t))
472
473 (defcfun ("gpgme_set_passphrase_cb" c-gpgme-set-passphrase-cb) :void
474   (ctx gpgme-ctx-t)
475   (cb gpgme-passphrase-cb-t)
476   (hook-value :pointer))
477
478 (defcfun ("gpgme_get_passphrase_cb" c-gpgme-get-passphrase-cb) :void
479   (ctx gpgme-ctx-t)
480   (cb-p :pointer)
481   (hook-value-p :pointer))
482
483 (defcfun ("gpgme_set_progress_cb" c-gpgme-set-progress-cb) :void
484   (ctx gpgme-ctx-t)
485   (cb gpgme-progress-cb-t)
486   (hook-value :pointer))
487
488 (defcfun ("gpgme_get_progress_cb" c-gpgme-get-progress-cb) :void
489   (ctx gpgme-ctx-t)
490   (cb-p :pointer)
491   (hook-value-p :pointer))
492
493 (defcfun ("gpgme_set_locale" c-gpgme-set-locale) gpgme-error-t
494   (ctx gpgme-ctx-t)
495   (category :int)
496   (value string-or-nil-t))
497
498 (defcfun ("gpgme_ctx_get_engine_info" c-gpgme-ctx-get-engine-info)
499     gpgme-engine-info-t
500   (ctx gpgme-ctx-t))
501
502 (defcfun ("gpgme_ctx_set_engine_info" c-gpgme-ctx-set-engine-info)
503     gpgme-error-t
504   (ctx gpgme-ctx-t)
505   (proto gpgme-protocol-t)
506   (file-name string-or-nil-t)
507   (home-dir string-or-nil-t))
508
509 ;;;
510
511 (defcfun ("gpgme_pubkey_algo_name" c-gpgme-pubkey-algo-name) :string
512   (algo gpgme-pubkey-algo-t))
513
514 (defcfun ("gpgme_hash_algo_name" c-gpgme-hash-algo-name) :string
515   (algo gpgme-hash-algo-t))
516
517 ;;;
518
519 (defcfun ("gpgme_signers_clear" c-gpgme-signers-clear) :void
520   (ctx gpgme-ctx-t))
521
522 (defcfun ("gpgme_signers_add" c-gpgme-signers-add) gpgme-error-t
523   (ctx gpgme-ctx-t)
524   (key gpgme-key-t))
525
526 (defcfun ("gpgme_signers_enum" c-gpgme-signers-enum) gpgme-key-t
527   (ctx gpgme-ctx-t)
528   (seq :int))
529
530 ;;;
531
532 (defcfun ("gpgme_sig_notation_clear" c-gpgme-sig-notation-clear) :void
533   (ctx gpgme-ctx-t))
534
535 (defcfun ("gpgme_sig_notation_add" c-gpgme-sig-notation-add) gpgme-error-t
536   (ctx gpgme-ctx-t)
537   (name :string)
538   (value string-or-nil-t)
539   (flags gpgme-sig-notation-flags-t))
540
541 (defcfun ("gpgme_sig_notation_get" c-gpgme-sig-notation-get)
542     gpgme-sig-notation-t
543   (ctx gpgme-ctx-t))
544
545 ;;; Run Control.
546
547 ;;; There is no support in CFFI to define callback C types and have
548 ;;; automatic type checking with the callback definition.
549
550 (defctype gpgme-io-cb-t :pointer)
551
552 (defctype gpgme-register-io-cb-t :pointer)
553
554 (defctype gpgme-remove-io-cb-t :pointer)
555
556 (defcenum gpgme-event-io-t
557   "The possible events on I/O event callbacks."
558   (:start 0)
559   (:done 1)
560   (:next-key 2)
561   (:next-trustitem 3))
562
563 (defctype gpgme-event-io-cb-t :pointer)
564
565 (defcstruct gpgme-io-cbs
566   "I/O callbacks."
567   (add gpgme-register-io-cb-t)
568   (add-priv :pointer)
569   (remove gpgme-remove-io-cb-t)
570   (event gpgme-event-io-cb-t)
571   (event-priv :pointer))
572
573 (defctype gpgme-io-cbs-t :pointer)
574
575 (defcfun ("gpgme_set_io_cbs" c-gpgme-set-io-cbs) :void
576   (ctx gpgme-ctx-t)
577   (io-cbs gpgme-io-cbs-t))
578
579 (defcfun ("gpgme_get_io_cbs" c-gpgme-get-io-cbs) :void
580   (ctx gpgme-ctx-t)
581   (io-cbs gpgme-io-cbs-t))
582
583 (defcfun ("gpgme_wait" c-gpgme-wait) gpgme-ctx-t
584   (ctx gpgme-ctx-t)
585   (status-p :pointer)
586   (hang :int))
587
588 ;;; Functions to handle data objects.
589
590 ;;; There is no support in CFFI to define callback C types and have
591 ;;; automatic type checking with the callback definition.
592
593 (defctype gpgme-data-read-cb-t :pointer)
594 (defctype gpgme-data-write-cb-t :pointer)
595 (defctype gpgme-data-seek-cb-t :pointer)
596 (defctype gpgme-data-release-cb-t :pointer)
597
598 (defcstruct gpgme-data-cbs
599   "Data callbacks."
600   (read gpgme-data-read-cb-t)
601   (write gpgme-data-write-cb-t)
602   (seek gpgme-data-seek-cb-t)
603   (release gpgme-data-release-cb-t))
604
605 (defctype gpgme-data-cbs-t :pointer
606   :documentation "Data callbacks pointer.")
607
608 (defcfun ("gpgme_data_read" c-gpgme-data-read) ssize-t
609   (dh gpgme-data-t)
610   (buffer :pointer)
611   (size size-t))
612
613 (defcfun ("gpgme_data_write" c-gpgme-data-write) ssize-t
614   (dh gpgme-data-t)
615   (buffer :pointer)
616   (size size-t))
617
618 (defcfun ("gpgme_data_seek" c-gpgme-data-seek) off-t
619   (dh gpgme-data-t)
620   (offset off-t)
621   (whence :int))
622
623 (defcfun ("gpgme_data_new" c-gpgme-data-new) gpgme-error-t
624   (dh-p :pointer))
625
626 (defcfun ("gpgme_data_release" c-gpgme-data-release) :void
627   (dh gpgme-data-t))
628
629 (defcfun ("gpgme_data_new_from_mem" c-gpgme-data-new-from-mem) gpgme-error-t
630   (dh-p :pointer)
631   (buffer :pointer)
632   (size size-t)
633   (copy :int))
634
635 (defcfun ("gpgme_data_release_and_get_mem" c-gpgme-data-release-and-get-mem)
636     :pointer
637   (dh gpgme-data-t)
638   (len-p :pointer))
639
640 (defcfun ("gpgme_data_new_from_cbs" c-gpgme-data-new-from-cbs) gpgme-error-t
641   (dh-p :pointer)
642   (cbs gpgme-data-cbs-t)
643   (handle :pointer))
644
645 (defcfun ("gpgme_data_new_from_fd" c-gpgme-data-new-from-fd) gpgme-error-t
646   (dh-p :pointer)
647   (fd :int))
648
649 (defcfun ("gpgme_data_new_from_stream" c-gpgme-data-new-from-stream)
650     gpgme-error-t
651   (dh-p :pointer)
652   (stream :pointer))
653
654 (defcfun ("gpgme_data_get_encoding" c-gpgme-data-get-encoding)
655     gpgme-data-encoding-t
656   (dh gpgme-data-t))
657
658 (defcfun ("gpgme_data_set_encoding" c-gpgme-data-set-encoding)
659     gpgme-error-t
660   (dh gpgme-data-t)
661   (enc gpgme-data-encoding-t))
662
663 (defcfun ("gpgme_data_get_file_name" c-gpgme-data-get-file-name) :string
664   (dh gpgme-data-t))
665
666 (defcfun ("gpgme_data_set_file_name" c-gpgme-data-set-file-name) gpgme-error-t
667   (dh gpgme-data-t)
668   (file-name string-or-nil-t))
669
670 (defcfun ("gpgme_data_new_from_file" c-gpgme-data-new-from-file) gpgme-error-t
671   (dh-p :pointer)
672   (fname :string)
673   (copy :int))
674
675 (defcfun ("gpgme_data_new_from_filepart" c-gpgme-data-new-from-filepart)
676     gpgme-error-t
677   (dh-p :pointer)
678   (fname :string)
679   (fp :pointer)
680   (offset off-t)
681   (length size-t))
682
683 ;;; Key and trust functions.
684
685 (defcfun ("gpgme_get_key" c-gpgme-get-key) gpgme-error-t
686   (ctx gpgme-ctx-t)
687   (fpr :string)
688   (key-p :pointer)
689   (secret :boolean))
690
691 (defcfun ("gpgme_key_ref" c-gpgme-key-ref) :void
692   (key gpgme-key-t))
693
694 (defcfun ("gpgme_key_unref" c-gpgme-key-unref) :void
695   (key gpgme-key-t))
696
697 ;;; Crypto operations.
698
699 (defcfun ("gpgme_cancel" c-gpgme-cancel) gpgme-error-t
700   (ctx gpgme-ctx-t))
701
702 ;;;
703
704 (defctype gpgme-invalid-key-t :pointer
705   :documentation "An invalid key structure.")
706
707 (defcstruct gpgme-invalid-key
708   "An invalid key structure."
709   (next gpgme-invalid-key-t)
710   (fpr :string)
711   (reason gpgme-error-no-signal-t))
712
713 ;;; Encryption.
714
715 (defcstruct gpgme-op-encrypt-result
716   "Encryption result structure."
717   (invalid-recipients gpgme-invalid-key-t))
718
719 (defctype gpgme-op-encrypt-result-t :pointer
720   :documentation "An encryption result structure.")
721
722 (defcfun ("gpgme_op_encrypt_result" c-gpgme-op-encrypt-result)
723     gpgme-op-encrypt-result-t
724   (ctx gpgme-ctx-t))
725
726 (defbitfield gpgme-encrypt-flags-t
727   (:always-trust 1))
728
729 (defcfun ("gpgme_op_encrypt_start" c-gpgme-op-encrypt-start) gpgme-error-t
730   (ctx gpgme-ctx-t)
731   (recp :pointer) ; Key array.
732   (flags gpgme-encrypt-flags-t)
733   (plain gpgme-data-t)
734   (cipher gpgme-data-t))
735
736 (defcfun ("gpgme_op_encrypt" c-gpgme-op-encrypt) gpgme-error-t
737   (ctx gpgme-ctx-t)
738   (recp :pointer) ; Key array.
739   (flags gpgme-encrypt-flags-t)
740   (plain gpgme-data-t)
741   (cipher gpgme-data-t))
742
743 (defcfun ("gpgme_op_encrypt_sign_start" c-gpgme-op-encrypt-sign-start)
744     gpgme-error-t
745   (ctx gpgme-ctx-t)
746   (recp :pointer) ; Key array.
747   (flags gpgme-encrypt-flags-t)
748   (plain gpgme-data-t)
749   (cipher gpgme-data-t))
750
751 (defcfun ("gpgme_op_encrypt_sign" c-gpgme-op-encrypt-sign) gpgme-error-t
752   (ctx gpgme-ctx-t)
753   (recp :pointer) ; Key array.
754   (flags gpgme-encrypt-flags-t)
755   (plain gpgme-data-t)
756   (cipher gpgme-data-t))
757
758 ;;; Decryption.
759
760 (defctype gpgme-recipient-t :pointer
761   :documentation "A recipient structure.")
762
763 (defcstruct gpgme-recipient
764   "Recipient structure."
765   (next gpgme-recipient-t)
766   (keyid :string)
767   (-keyid :char :count 17)
768   (pubkey-algo gpgme-pubkey-algo-t)
769   (status gpgme-error-no-signal-t))
770
771 (defbitfield gpgme-op-decrypt-result-bitfield
772   "Decryption result structure bitfield."
773   (:wrong-key-usage 1))
774
775 (defcstruct gpgme-op-decrypt-result
776   "Decryption result structure."
777   (unsupported-algorithm :string)
778   (bitfield gpgme-op-decrypt-result-bitfield)
779   (recipients gpgme-recipient-t)
780   (file-name :string))
781
782 (defctype gpgme-op-decrypt-result-t :pointer
783   :documentation "A decryption result structure.")
784
785 (defcfun ("gpgme_op_decrypt_result" c-gpgme-op-decrypt-result)
786     gpgme-op-decrypt-result-t
787   (ctx gpgme-ctx-t))
788
789 (defcfun ("gpgme_op_decrypt_start" c-gpgme-op-decrypt-start) gpgme-error-t
790   (ctx gpgme-ctx-t)
791   (cipher gpgme-data-t)
792   (plain gpgme-data-t))
793
794 (defcfun ("gpgme_op_decrypt" c-gpgme-op-decrypt) gpgme-error-t
795   (ctx gpgme-ctx-t)
796   (cipher gpgme-data-t)
797   (plain gpgme-data-t))
798
799 (defcfun ("gpgme_op_decrypt_verify_start" c-gpgme-op-decrypt-verify-start)
800     gpgme-error-t
801   (ctx gpgme-ctx-t)
802   (cipher gpgme-data-t)
803   (plain gpgme-data-t))
804
805 (defcfun ("gpgme_op_decrypt_verify" c-gpgme-op-decrypt-verify) gpgme-error-t
806   (ctx gpgme-ctx-t)
807   (cipher gpgme-data-t)
808   (plain gpgme-data-t))
809
810 ;;; Signing.
811
812 (defctype gpgme-new-signature-t :pointer
813   :documentation "A new signature structure.")
814
815 (defcstruct gpgme-new-signature
816   "New signature structure."
817   (next gpgme-new-signature-t)
818   (type gpgme-sig-mode-t)
819   (pubkey-algo gpgme-pubkey-algo-t)
820   (hash-algo gpgme-hash-algo-t)
821   (-obsolete-class :unsigned-long)
822   (timestamp :long)
823   (fpr :string)
824   (-obsolete-class-2 :unsigned-int)
825   (sig-class :unsigned-int))
826
827 (defcstruct gpgme-op-sign-result
828   "Signing result structure."
829   (invalid-signers gpgme-invalid-key-t)
830   (signatures gpgme-new-signature-t))
831
832 (defctype gpgme-op-sign-result-t :pointer
833   :documentation "A signing result structure.")
834
835 (defcfun ("gpgme_op_sign_result" c-gpgme-op-sign-result)
836     gpgme-op-sign-result-t
837   (ctx gpgme-ctx-t))
838
839 (defcfun ("gpgme_op_sign_start" c-gpgme-op-sign-start) gpgme-error-t
840   (ctx gpgme-ctx-t)
841   (plain gpgme-data-t)
842   (sig gpgme-data-t)
843   (mode gpgme-sig-mode-t))
844
845 (defcfun ("gpgme_op_sign" c-gpgme-op-sign) gpgme-error-t
846   (ctx gpgme-ctx-t)
847   (plain gpgme-data-t)
848   (sig gpgme-data-t)
849   (mode gpgme-sig-mode-t))
850
851 ;;; Verify.
852
853 (defbitfield (gpgme-sigsum-t :unsigned-int)
854   "Flags used for the summary field in a gpgme-signature-t."
855   (:valid #x0001)
856   (:green #x0002)
857   (:red #x0004)
858   (:key-revoked #x0010)
859   (:key-expired #x0020)
860   (:sig-expired #x0040)
861   (:key-missing #x0080)
862   (:crl-missing #x0100)
863   (:crl-too-old #x0200)
864   (:bad-policy #x0400)
865   (:sys-error #x0800))
866
867 (defctype gpgme-signature-t :pointer
868   :documentation "A signature structure.")
869
870 ;; FIXME: Doesn't this depend on endianess?
871 (defbitfield (gpgme-signature-bitfield :unsigned-int)
872   "The signature bitfield."
873   (:wrong-key-usage 1))
874
875 (defcstruct gpgme-signature
876   "Signature structure."
877   (next gpgme-signature-t)
878   (summary gpgme-sigsum-t)
879   (fpr :string)
880   (status gpgme-error-no-signal-t)
881   (notations gpgme-sig-notation-t)
882   (timestamp :unsigned-long)
883   (exp-timestamp :unsigned-long)
884   (bitfield gpgme-signature-bitfield)
885   (validity gpgme-validity-t)
886   (validity-reason gpgme-error-no-signal-t)
887   (pubkey-algo gpgme-pubkey-algo-t)
888   (hash-algo gpgme-hash-algo-t))
889
890 (defcstruct gpgme-op-verify-result
891   "Verify result structure."
892   (signatures gpgme-signature-t)
893   (file-name :string))
894
895 (defctype gpgme-op-verify-result-t :pointer
896   :documentation "A verify result structure.")
897
898 (defcfun ("gpgme_op_verify_result" c-gpgme-op-verify-result)
899     gpgme-op-verify-result-t
900   (ctx gpgme-ctx-t))
901
902 (defcfun ("gpgme_op_verify_start" c-gpgme-op-verify-start) gpgme-error-t
903   (ctx gpgme-ctx-t)
904   (sig gpgme-data-t)
905   (signed-text gpgme-data-t)
906   (plaintext gpgme-data-t))
907
908 (defcfun ("gpgme_op_verify" c-gpgme-op-verify) gpgme-error-t
909   (ctx gpgme-ctx-t)
910   (sig gpgme-data-t)
911   (signed-text gpgme-data-t)
912   (plaintext gpgme-data-t))
913
914 ;;; Import.
915
916 (defbitfield (gpgme-import-flags-t :unsigned-int)
917   "Flags used for the import status field."
918   (:new #x0001)
919   (:uid #x0002)
920   (:sig #x0004)
921   (:subkey #x0008)
922   (:secret #x0010))
923
924 (defctype gpgme-import-status-t :pointer
925   :documentation "An import status structure.")
926
927 (defcstruct gpgme-import-status
928   "New import status structure."
929   (next gpgme-import-status-t)
930   (fpr :string)
931   (result gpgme-error-no-signal-t)
932   (status :unsigned-int))
933
934 (defcstruct gpgme-op-import-result
935   "Import result structure."
936   (considered :int)
937   (no-user-id :int)
938   (imported :int)
939   (imported-rsa :int)
940   (unchanged :int)
941   (new-user-ids :int)
942   (new-sub-keys :int)
943   (new-signatures :int)
944   (new-revocations :int)
945   (secret-read :int)
946   (secret-imported :int)
947   (secret-unchanged :int)
948   (skipped-new-keys :int)
949   (not-imported :int)
950   (imports gpgme-import-status-t))
951
952 (defctype gpgme-op-import-result-t :pointer
953   :documentation "An import status result structure.")
954
955 (defcfun ("gpgme_op_import_result" c-gpgme-op-import-result)
956     gpgme-op-import-result-t
957   (ctx gpgme-ctx-t))
958
959 (defcfun ("gpgme_op_import_start" c-gpgme-op-import-start) gpgme-error-t
960   (ctx gpgme-ctx-t)
961   (keydata gpgme-data-t))
962
963 (defcfun ("gpgme_op_import" c-gpgme-op-import) gpgme-error-t
964   (ctx gpgme-ctx-t)
965   (keydata gpgme-data-t))
966
967 ;;; Export.
968
969 (defcfun ("gpgme_op_export_start" c-gpgme-op-export-start) gpgme-error-t
970   (ctx gpgme-ctx-t)
971   (pattern :string)
972   (reserved :unsigned-int)
973   (keydata gpgme-data-t))
974
975 (defcfun ("gpgme_op_export" c-gpgme-op-export) gpgme-error-t
976   (ctx gpgme-ctx-t)
977   (pattern :string)
978   (reserved :unsigned-int)
979   (keydata gpgme-data-t))
980
981 ;;; FIXME: Extended export interfaces require array handling.
982
983 ;;; Key generation.
984
985 (defbitfield (gpgme-genkey-flags-t :unsigned-int)
986   "Flags used for the key generation result bitfield."
987   (:primary #x0001)
988   (:sub #x0002))
989
990 (defcstruct gpgme-op-genkey-result
991   "Key generation result structure."
992   (bitfield gpgme-genkey-flags-t)
993   (fpr :string))
994
995 (defctype gpgme-op-genkey-result-t :pointer
996   :documentation "A key generation result structure.")
997
998 (defcfun ("gpgme_op_genkey_result" c-gpgme-op-genkey-result)
999     gpgme-op-genkey-result-t
1000   (ctx gpgme-ctx-t))
1001
1002 (defcfun ("gpgme_op_genkey_start" c-gpgme-op-genkey-start) gpgme-error-t
1003   (ctx gpgme-ctx-t)
1004   (parms :string)
1005   (pubkey gpgme-data-t)
1006   (seckey gpgme-data-t))
1007
1008 (defcfun ("gpgme_op_genkey" c-gpgme-op-genkey) gpgme-error-t
1009   (ctx gpgme-ctx-t)
1010   (parms :string)
1011   (pubkey gpgme-data-t)
1012   (seckey gpgme-data-t))
1013
1014 ;;; Key deletion.
1015
1016 (defcfun ("gpgme_op_delete_start" c-gpgme-op-delete-start) gpgme-error-t
1017   (ctx gpgme-ctx-t)
1018   (key gpgme-key-t)
1019   (allow-secret :int))
1020
1021 (defcfun ("gpgme_op_delete" c-gpgme-op-delete) gpgme-error-t
1022   (ctx gpgme-ctx-t)
1023   (key gpgme-key-t)
1024   (allow-secret :int))
1025
1026 ;;; FIXME: Add edit interfaces.
1027
1028 ;;; Keylist interface.
1029
1030 (defbitfield (gpgme-keylist-flags-t :unsigned-int)
1031   "Flags used for the key listing result bitfield."
1032   (:truncated #x0001))
1033
1034 (defcstruct gpgme-op-keylist-result
1035   "Key listing result structure."
1036   (bitfield gpgme-keylist-flags-t))
1037
1038 (defctype gpgme-op-keylist-result-t :pointer
1039   :documentation "A key listing result structure.")
1040
1041 (defcfun ("gpgme_op_keylist_result" c-gpgme-op-keylist-result)
1042     gpgme-op-keylist-result-t
1043   (ctx gpgme-ctx-t))
1044
1045 (defcfun ("gpgme_op_keylist_start" c-gpgme-op-keylist-start) gpgme-error-t
1046   (ctx gpgme-ctx-t)
1047   (pattern :string)
1048   (secret_only :boolean))
1049
1050 ;;; FIXME: Extended keylisting requires array handling.
1051
1052 (defcfun ("gpgme_op_keylist_next" c-gpgme-op-keylist-next) gpgme-error-t
1053   (ctx gpgme-ctx-t)
1054   (r-key :pointer))
1055
1056 (defcfun ("gpgme_op_keylist_end" c-gpgme-op-keylist-end) gpgme-error-t
1057   (ctx gpgme-ctx-t))
1058
1059 ;;; Various functions.
1060
1061 (defcfun ("gpgme_check_version" c-gpgme-check-version) :string
1062   (req-version string-or-nil-t))
1063
1064 (defcfun ("gpgme_get_engine_info" c-gpgme-get-engine-info) gpgme-error-t
1065   (engine-info-p :pointer))
1066
1067 (defcfun ("gpgme_set_engine_info" c-gpgme-set-engine-info) gpgme-error-t
1068   (proto gpgme-protocol-t)
1069   (file-name string-or-nil-t)
1070   (home-dir string-or-nil-t))
1071
1072 (defcfun ("gpgme_engine_check_version" c-gpgme-engine-check-verson)
1073     gpgme-error-t
1074   (proto gpgme-protocol-t))
1075
1076 ;;;
1077 ;;;  L I S P   I N T E R F A C E
1078 ;;;
1079
1080 ;;;
1081 ;;; Lisp type translators.
1082 ;;;
1083
1084 ;;; Both directions.
1085
1086 ;;; cert-int-t is a helper type that takes care of representing the
1087 ;;; default number of certs as NIL.
1088
1089 (defmethod translate-from-foreign (value (type (eql 'cert-int-t)))
1090   (cond
1091     ((eql value +include-certs-default+) nil)
1092     (t value)))
1093
1094 (defmethod translate-to-foreign (value (type (eql 'cert-int-t)))
1095   (cond
1096     (value value)
1097     (t +include-certs-default+)))
1098
1099 ;;; string-or-nil-t translates a null pointer to NIL and vice versa.
1100 ;;; Translation from foreign null pointer already works as expected.
1101 ;;; FIXME: May the "to foreign" conversion problem be a bug in CFFI?
1102
1103 (defmethod translate-to-foreign (value (type (eql 'string-or-nil-t)))
1104   (cond
1105     (value value)
1106     (t (null-pointer))))
1107
1108 ;;; Output only.
1109
1110 ;;; These type translators only convert from foreign type, because we
1111 ;;; never use these types in the other direction.
1112
1113 ;;; Convert gpgme-engine-info-t linked lists into a list of property
1114 ;;; lists.  Note that this converter will automatically be invoked
1115 ;;; recursively.
1116 ;;;
1117 ;;; FIXME: Should we use a hash table (or struct, or clos) instead of
1118 ;;; property list, as recommended by the Lisp FAQ?
1119
1120 (defmethod translate-from-foreign (value (type (eql 'gpgme-engine-info-t)))
1121   (cond
1122     ((null-pointer-p value) nil)
1123     (t (with-foreign-slots
1124            ((next protocol file-name version req-version home-dir)
1125             value gpgme-engine-info)
1126          (append (list protocol (list
1127                              :file-name file-name
1128                              :version version
1129                              :req-version req-version
1130                              :home-dir home-dir))
1131                  next)))))
1132
1133 (defmethod translate-from-foreign (value (type (eql 'gpgme-invalid-key-t)))
1134   (cond
1135     ((null-pointer-p value) nil)
1136     (t (with-foreign-slots
1137            ((next fpr reason)
1138             value gpgme-invalid-key)
1139          (append (list (list :fpr fpr
1140                              :reason reason))
1141                  next)))))
1142
1143 (defmethod translate-from-foreign (value
1144                                    (type (eql 'gpgme-op-encrypt-result-t)))
1145   (cond
1146     ((null-pointer-p value) nil)
1147     (t (with-foreign-slots
1148            ((invalid-recipients)
1149             value gpgme-op-encrypt-result)
1150          (list :encrypt
1151                (list :invalid-recipients invalid-recipients))))))
1152
1153 (defmethod translate-from-foreign (value (type (eql 'gpgme-recipient-t)))
1154   (cond
1155     ((null-pointer-p value) nil)
1156     (t (with-foreign-slots
1157            ((next keyid pubkey-algo status)
1158             value gpgme-recipient)
1159          (append (list (list :keyid keyid
1160                              :pubkey-algo pubkey-algo
1161                              :status status))
1162                  next)))))
1163
1164 (defmethod translate-from-foreign (value
1165                                    (type (eql 'gpgme-op-decrypt-result-t)))
1166   (cond
1167     ((null-pointer-p value) nil)
1168     (t (with-foreign-slots
1169            ((unsupported-algorithm bitfield recipients file-name)
1170             value gpgme-op-decrypt-result)
1171          (list :decrypt (list :unsupported-algorithm unsupported-algorithm
1172                               :bitfield bitfield
1173                               :recipients recipients
1174                               :file-name file-name))))))
1175
1176 (defmethod translate-from-foreign (value (type (eql 'gpgme-new-signature-t)))
1177   (cond
1178     ((null-pointer-p value) nil)
1179     (t (with-foreign-slots
1180            ((next type pubkey-algo hash-algo timestamp fpr sig-class)
1181             value gpgme-new-signature)
1182          (append (list (list :type type
1183                              :pubkey-algo pubkey-algo
1184                              :hash-algo hash-algo
1185                              :timestamp timestamp
1186                              :fpr fpr
1187                              :sig-class sig-class))
1188                  next)))))
1189
1190 (defmethod translate-from-foreign (value
1191                                    (type (eql 'gpgme-op-sign-result-t)))
1192   (cond
1193     ((null-pointer-p value) nil)
1194     (t (with-foreign-slots
1195            ((invalid-signers signatures)
1196             value gpgme-op-sign-result)
1197          (list :sign (list :invalid-signers invalid-signers
1198                            :signatures signatures))))))
1199
1200 (defmethod translate-from-foreign (value (type (eql 'gpgme-signature-t)))
1201   (cond
1202     ((null-pointer-p value) nil)
1203     (t (with-foreign-slots
1204            ((next summary fpr status notations timestamp
1205                   exp-timestamp bitfield validity validity-reason
1206                   pubkey-algo hash-algo)
1207             value gpgme-signature)
1208          (append (list (list :summary summary
1209                              :fpr fpr
1210                              :status status
1211                              :notations notations
1212                              :timestamp timestamp
1213                              :exp-timestamp exp-timestamp
1214                              :bitfield bitfield
1215                              :validity validity
1216                              :validity-reason validity-reason
1217                              :pubkey-algo pubkey-algo))
1218                  next)))))
1219
1220 (defmethod translate-from-foreign (value
1221                                    (type (eql 'gpgme-op-verify-result-t)))
1222   (cond
1223     ((null-pointer-p value) nil)
1224     (t (with-foreign-slots
1225            ((signatures file-name)
1226             value gpgme-op-verify-result)
1227          (list :verify (list :signatures signatures
1228                              :file-name file-name))))))
1229
1230 (defmethod translate-from-foreign (value (type (eql 'gpgme-import-status-t)))
1231   (cond
1232     ((null-pointer-p value) nil)
1233     (t (with-foreign-slots
1234            ((next fpr result status)
1235             value gpgme-import-status)
1236          (append (list (list :fpr fpr
1237                              :result result
1238                              :status status))
1239                  next)))))
1240
1241 (defmethod translate-from-foreign (value
1242                                    (type (eql 'gpgme-op-import-result-t)))
1243   (cond
1244     ((null-pointer-p value) nil)
1245     (t (with-foreign-slots
1246            ((considered no-user-id imported imported-rsa unchanged
1247                         new-user-ids new-sub-keys new-signatures
1248                         new-revocations secret-read secret-imported
1249                         secret-unchanged skipped-new-keys not-imported
1250                         imports)
1251             value gpgme-op-import-result)
1252          (list :verify (list :considered considered
1253                              :no-user-id no-user-id
1254                              :imported imported
1255                              :imported-rsa imported-rsa
1256                              :unchanged unchanged
1257                              :new-user-ids new-user-ids
1258                              :new-sub-keys new-sub-keys
1259                              :new-signatures new-signatures
1260                              :new-revocations new-revocations
1261                              :secret-read secret-read
1262                              :secret-imported secret-imported
1263                              :secret-unchanged secret-unchanged
1264                              :skipped-new-keys skipped-new-keys
1265                              :not-imported not-imported
1266                              :imports imports))))))
1267
1268 ;;; Error handling.
1269
1270 ;;; Use gpgme-error-no-signal-t to suppress automatic error handling
1271 ;;; at translation time.
1272 ;;;
1273 ;;; FIXME: Part of this probably should be in gpg-error!
1274
1275 (define-condition gpgme-error (error)
1276   ((value :initarg :gpgme-error :reader gpgme-error-value))
1277   (:report (lambda (c stream)
1278              (format stream "GPGME returned error: ~A (~A)"
1279                      (gpgme-strerror (gpgme-error-value c))
1280                      (gpgme-strsource (gpgme-error-value c)))))
1281   (:documentation "Signalled when a GPGME function returns an error."))
1282
1283 (defmethod translate-from-foreign (value (name (eql 'gpgme-error-t)))
1284   "Raise a GPGME-ERROR if VALUE is non-zero."
1285   (when (not (eql (gpgme-err-code value) :gpg-err-no-error))
1286     (error 'gpgme-error :gpgme-error value))
1287   (gpg-err-canonicalize value))
1288
1289 (defmethod translate-to-foreign (value (name (eql 'gpgme-error-t)))
1290   "Canonicalize the error value."
1291   (if (eql (gpgme-err-code value) :gpg-err-no-error)
1292       0
1293       (gpg-err-as-value value)))
1294
1295 (defmethod translate-from-foreign (value (name (eql 'gpgme-error-no-signal-t)))
1296   "Canonicalize the error value."
1297   (gpg-err-canonicalize value))
1298
1299
1300 ;;; *INTERNAL* Lispy Function Interface that is still close to the C
1301 ;;; interface.
1302
1303 ;;; Passphrase callback management.
1304
1305 ;;; Maybe: Instead, use subclassing, and provide a customizable
1306 ;;; default implementation for ease-of-use.
1307
1308 (defvar *passphrase-handles* (make-hash-table)
1309   "Hash table with GPGME context address as key and the corresponding
1310    passphrase callback object as value.")
1311
1312 (defcallback passphrase-cb gpgme-error-t ((handle :pointer)
1313                                           (uid-hint :string)
1314                                           (passphrase-info :string)
1315                                           (prev-was-bad :boolean)
1316                                           (fd :int))
1317   (handler-case
1318       (let* ((passphrase-cb
1319               (gethash (pointer-address handle) *passphrase-handles*))
1320              (passphrase
1321               (cond
1322                 ((functionp passphrase-cb)
1323                  (concatenate 'string
1324                               (funcall passphrase-cb uid-hint passphrase-info
1325                                        prev-was-bad)
1326                               '(#\Newline)))
1327                 (t (concatenate 'string passphrase-cb '(#\Newline)))))
1328              (passphrase-len (length passphrase))
1329              ;; FIXME: Could be more robust.
1330              (res (system-write fd passphrase passphrase-len)))
1331         (cond
1332           ((< res passphrase-len) ; FIXME: Blech.  A weak attempt to be robust.
1333            (gpgme-error :gpg-err-inval))
1334           (t (gpgme-error :gpg-err-no-error))))
1335     (gpgme-error (err) (gpgme-error-value err))
1336     (system-error (err) (gpgme-error-from-errno (system-error-errno err)))
1337     ;; FIXME: The original error gets lost here.  
1338     (condition (err) (progn
1339                        (when *debug*
1340                          (format t "DEBUG: passphrase-cb: Unexpressable: ~A~%"
1341                                  err))
1342                        (gpgme-error :gpg-err-general)))))
1343
1344 ;;; CTX is a C-pointer to the context.
1345 (defun gpgme-set-passphrase-cb (ctx cb)
1346   "Set the passphrase callback for CTX."
1347   (let ((handle (pointer-address ctx)))
1348     (cond
1349       (cb (setf (gethash handle *passphrase-handles*) cb)
1350           (c-gpgme-set-passphrase-cb ctx (callback passphrase-cb) ctx))
1351       (t (c-gpgme-set-passphrase-cb ctx (null-pointer) (null-pointer))
1352          (remhash handle *passphrase-handles*)))))
1353
1354 ;;; Progress callback management.
1355
1356 ;;; Maybe: Instead, use subclassing, and provide a customizable
1357 ;;; default implementation for ease-of-use.
1358
1359 (defvar *progress-handles* (make-hash-table)
1360   "Hash table with GPGME context address as key and the corresponding
1361    progress callback object as value.")
1362
1363 (defcallback progress-cb :void ((handle :pointer)
1364                                 (what :string)
1365                                 (type :int)
1366                                 (current :int)
1367                                 (total :int))
1368   (handler-case
1369       (let* ((progress-cb
1370               (gethash (pointer-address handle) *progress-handles*)))
1371         (funcall progress-cb what type current total))
1372     ;; FIXME: The original error gets lost here.  
1373     (condition (err) (when *debug*
1374                        (format t "DEBUG: progress-cb: Unexpressable: ~A~%"
1375                                err)))))
1376
1377 ;;; CTX is a C-pointer to the context.
1378 (defun gpgme-set-progress-cb (ctx cb)
1379   "Set the progress callback for CTX."
1380   (let ((handle (pointer-address ctx)))
1381     (cond
1382       (cb (setf (gethash handle *progress-handles*) cb)
1383           (c-gpgme-set-progress-cb ctx (callback progress-cb) ctx))
1384       (t (c-gpgme-set-progress-cb ctx (null-pointer) (null-pointer))
1385          (remhash handle *progress-handles*)))))
1386
1387 ;;; Context management.
1388
1389 (defun gpgme-new (&key (protocol :openpgp) armor textmode include-certs
1390                   keylist-mode passphrase progress file-name home-dir)
1391   "Allocate a new GPGME context."
1392   (with-foreign-object (ctx-p 'gpgme-ctx-t)
1393     (c-gpgme-new ctx-p)
1394     (let ((ctx (mem-ref ctx-p 'gpgme-ctx-t)))
1395       ;;; Set locale?
1396       (gpgme-set-protocol ctx protocol)
1397       (gpgme-set-armor ctx armor)
1398       (gpgme-set-textmode ctx textmode)
1399       (when include-certs (gpgme-set-include-certs ctx include-certs))
1400       (when keylist-mode (gpgme-set-keylist-mode ctx keylist-mode))
1401       (gpgme-set-passphrase-cb ctx passphrase)
1402       (gpgme-set-progress-cb ctx progress)
1403       (gpgme-set-engine-info ctx protocol
1404                              :file-name file-name :home-dir home-dir)
1405       (when *debug* (format t "DEBUG: gpgme-new: ~A~%" ctx))
1406       ctx)))
1407
1408 (defun gpgme-release (ctx)
1409   "Release a GPGME context."
1410   (when *debug* (format t "DEBUG: gpgme-release: ~A~%" ctx))
1411   (c-gpgme-release ctx))
1412
1413 (defun gpgme-set-protocol (ctx proto)
1414   "Set the protocol to be used by CTX to PROTO."
1415   (c-gpgme-set-protocol ctx proto))
1416
1417 (defun gpgme-get-protocol (ctx)
1418   "Get the protocol used with CTX."
1419   (c-gpgme-get-protocol ctx))
1420
1421 ;;; FIXME: How to do pretty printing?
1422 ;;;
1423 ;;; gpgme-get-protocol-name
1424
1425 (defun gpgme-set-armor (ctx armor)
1426   "If ARMOR is true, enable armor mode in CTX, disable it otherwise."
1427  (c-gpgme-set-armor ctx armor))
1428
1429 (defun gpgme-armor-p (ctx)
1430   "Return true if armor mode is set for CTX."
1431   (c-gpgme-get-armor ctx))
1432
1433 (defun gpgme-set-textmode (ctx textmode)
1434   "If TEXTMODE is true, enable text mode mode in CTX, disable it otherwise."
1435  (c-gpgme-set-textmode ctx textmode))
1436
1437 (defun gpgme-textmode-p (ctx)
1438   "Return true if text mode mode is set for CTX."
1439   (c-gpgme-get-textmode ctx))
1440
1441 (defun gpgme-set-include-certs (ctx &optional certs)
1442   "Include up to CERTS certificates in an S/MIME message."
1443   (c-gpgme-set-include-certs ctx certs))
1444
1445 (defun gpgme-get-include-certs (ctx)
1446   "Return the number of certs to include in an S/MIME message,
1447    or NIL if the default is used."
1448   (c-gpgme-get-include-certs ctx))
1449
1450 (defun gpgme-get-keylist-mode (ctx)
1451   "Get the keylist mode in CTX."
1452   (c-gpgme-get-keylist-mode ctx))
1453
1454 (defun gpgme-set-keylist-mode (ctx mode)
1455   "Set the keylist mode in CTX."
1456   (c-gpgme-set-keylist-mode ctx mode))
1457
1458
1459 ;;; FIXME: How to handle locale?  cffi-grovel?
1460
1461 (defun gpgme-get-engine-info (&optional ctx)
1462   "Retrieve the engine info for CTX, or the default if CTX is omitted."
1463   (cond
1464     (ctx (c-gpgme-ctx-get-engine-info ctx))
1465     (t (with-foreign-object (info-p 'gpgme-engine-info-t)
1466          (c-gpgme-get-engine-info info-p)
1467          (mem-ref info-p 'gpgme-engine-info-t)))))
1468
1469 (defun gpgme-set-engine-info (ctx proto &key file-name home-dir)
1470   "Set the engine info for CTX, or the default if CTX is NIL."
1471   (cond
1472     (ctx (c-gpgme-ctx-set-engine-info ctx proto file-name home-dir))
1473     (t (c-gpgme-set-engine-info proto file-name home-dir))))
1474
1475 ;;; FIXME: How to do pretty printing?
1476 ;;;
1477 ;;; gpgme_pubkey_algo_name, gpgme_hash_algo_name
1478
1479 (defun gpgme-set-signers (ctx keys)
1480   "Set the signers for the context CTX."
1481   (c-gpgme-signers-clear ctx)
1482   (dolist (key keys) (c-gpgme-signers-add ctx key)))
1483
1484 ;;;
1485
1486 (defun gpgme-set-sig-notation (ctx notations)
1487   "Set the sig notation for the context CTX."
1488   (c-gpgme-sig-notation-clear ctx)
1489   (dolist (notation notations)
1490     (c-gpgme-sig-notation-add
1491      ctx (first notation) (second notation) (third notation))))
1492
1493 (defun gpgme-get-sig-notation (ctx)
1494   "Get the signature notation data for the context CTX."
1495   (c-gpgme-sig-notation-get ctx))
1496
1497 ;;; FIXME: Add I/O callback interface, for integration with clg.
1498
1499 ;;; FIXME: Add gpgme_wait?
1500
1501 ;;; Streams
1502 ;;; -------
1503 ;;;
1504 ;;; GPGME uses standard streams.  You can define your own streams, or
1505 ;;; use the existing file or string streams.
1506 ;;;
1507 ;;; A stream-spec is either a stream, or a list with a stream as its
1508 ;;; first argument followed by keyword parameters: encoding,
1509 ;;; file-name.
1510 ;;;
1511 ;;; FIXME: Eventually, we should provide a class that can be mixed
1512 ;;; into stream classes and which provides accessors for encoding and
1513 ;;; file-names.  This interface should be provided in addition to the
1514 ;;; above sleazy interface, because the sleazy interface is easier to
1515 ;;; use (less typing), and is quite sufficient in a number of cases.
1516 ;;;
1517 ;;; For best results, streams with element type (unsigned-byte 8)
1518 ;;; should be used.  Character streams may work if armor mode is used.
1519
1520 ;;; Do we need to provide access to GPGME data objects through streams
1521 ;;; as well?  It seems to me that specific optimizations, like
1522 ;;; directly writing to file descriptors, is better done by extending
1523 ;;; the sleazy syntax (stream-spec) instead of customized streams.
1524 ;;; Customized streams do buffering, and this may mess up things.  Mmh.
1525
1526 (defvar *data-handles* (make-hash-table)
1527   "Hash table with GPGME data user callback handle address as key
1528    and the corresponding stream as value.")
1529
1530 ;;; The release callback removes the stream from the *data-handles*
1531 ;;; hash and releases the CBS structure that is used as the key in
1532 ;;; that hash.  It is implicitely invoked (through GPGME) by
1533 ;;; gpgme-data-release.
1534 (defcallback data-release-cb :void ((handle :pointer))
1535   (unwind-protect (remhash (pointer-address handle) *data-handles*)
1536     (when (not (null-pointer-p handle)) (foreign-free handle))))
1537
1538 (defcallback data-read-cb ssize-t ((handle :pointer) (buffer :pointer)
1539                                    (size size-t))
1540   (when *debug* (format t "DEBUG: gpgme-data-read-cb: want ~A~%" size))
1541   (let ((stream (gethash (pointer-address handle) *data-handles*)))
1542     (cond
1543       (stream
1544        (let* ((stream-type (stream-element-type stream))
1545               (seq (make-array size :element-type stream-type))
1546               (read (read-sequence seq stream)))
1547          (loop for i from 0 to (- read 1)
1548                do (setf (mem-aref buffer :unsigned-char i)
1549                         ;;; FIXME: This is a half-assed attempt at
1550                         ;;; supporting character streams.
1551                         (cond
1552                           ((eql stream-type 'character)
1553                            (char-code (elt seq i)))
1554                           (t (coerce (elt seq i) stream-type)))))
1555          (when *debug* (format t "DEBUG: gpgme-data-read-cb: read ~A~%" read))
1556          read))
1557       (t (set-errno +ebadf+)
1558          -1))))
1559
1560 (defcallback data-write-cb ssize-t ((handle :pointer) (buffer :pointer)
1561                                    (size size-t))
1562   (when *debug* (format t "DEBUG: gpgme-data-write-cb: want ~A~%" size))
1563   (let ((stream (gethash (pointer-address handle) *data-handles*)))
1564     (cond
1565       (stream
1566        (let* ((stream-type (stream-element-type stream))
1567               (seq (make-array size :element-type stream-type)))
1568          (loop for i from 0 to (- size 1)
1569                do (setf (elt seq i)
1570                         ;;; FIXME: This is a half-assed attempt at
1571                         ;;; supporting character streams.
1572                         (cond
1573                           ((eql stream-type 'character)
1574                            (code-char (mem-aref buffer :unsigned-char i)))
1575                           (t (coerce (mem-aref buffer :unsigned-char i)
1576                                      stream-type)))))
1577          (write-sequence seq stream)
1578          ;;; FIXME: What about write errors?
1579          size))
1580       (t (set-errno +ebadf+)
1581          -1))))
1582
1583 ;;; This little helper macro allows us to swallow the cbs structure by
1584 ;;; simply setting it to a null pointer, but still protect against
1585 ;;; conditions.
1586 (defmacro with-cbs-swallowed ((cbs) &body body)
1587   `(let ((,cbs (foreign-alloc 'gpgme-data-cbs)))
1588     (unwind-protect (progn ,@body)
1589       (when (not (null-pointer-p ,cbs)) (foreign-free ,cbs)))))
1590
1591 ;;; FIXME: Wrap the object and attach to it a finalizer.  Requires new
1592 ;;; CFFI.  Should we use an OO interface, ie make-instance?  For now,
1593 ;;; we do not provide direct access to data objects.
1594 (defun gpgme-data-new (stream &key encoding file-name)
1595   "Allocate a new GPGME data object for STREAM."
1596   (with-foreign-object (dh-p 'gpgme-data-t)
1597     ;;; We allocate one CBS structure for each stream we wrap in a
1598     ;;; data object.  Although we could also share all these
1599     ;;; structures, as they contain the very same callbacks, we need a
1600     ;;; unique C pointer as handle anyway to look up the stream in the
1601     ;;; callback.  This is a convenient one to use.
1602     (with-cbs-swallowed (cbs)
1603       (setf
1604        (foreign-slot-value cbs 'gpgme-data-cbs 'read) (callback data-read-cb)
1605        (foreign-slot-value cbs 'gpgme-data-cbs 'write) (callback data-write-cb)
1606        (foreign-slot-value cbs 'gpgme-data-cbs 'seek) (null-pointer)
1607        (foreign-slot-value cbs 'gpgme-data-cbs 'release) (callback
1608                                                           data-release-cb))
1609       (c-gpgme-data-new-from-cbs dh-p cbs cbs)
1610       (let ((dh (mem-ref dh-p 'gpgme-data-t)))
1611         (when encoding (gpgme-data-set-encoding dh encoding))
1612         (when file-name (gpgme-data-set-file-name dh file-name))
1613         ;;; Install the stream into the hash table and swallow the cbs
1614         ;;; structure while protecting against any errors.
1615         (unwind-protect
1616              (progn
1617                (setf (gethash (pointer-address cbs) *data-handles*) stream)
1618                (setf cbs (null-pointer)))
1619           (when (not (null-pointer-p cbs)) (c-gpgme-data-release dh)))
1620         (when *debug* (format t "DEBUG: gpgme-data-new: ~A~%" dh))
1621         dh))))
1622
1623 ;;; This function releases a GPGME data object.  It implicitely
1624 ;;; invokes the data-release-cb function to clean up associated junk.
1625 (defun gpgme-data-release (dh)
1626   "Release a GPGME data object."
1627   (when *debug* (format t "DEBUG: gpgme-data-release: ~A~%" dh))
1628   (c-gpgme-data-release dh))
1629
1630 (defmacro with-gpgme-data ((dh streamspec) &body body)
1631   `(let ((,dh (if (listp ,streamspec)
1632                   (apply 'gpgme-data-new ,streamspec)
1633                   (gpgme-data-new ,streamspec))))
1634     (unwind-protect (progn ,@body)
1635       (when (not (null-pointer-p ,dh)) (gpgme-data-release ,dh)))))
1636
1637 (defun gpgme-data-get-encoding (dh)
1638   "Get the encoding associated with the data object DH."
1639   (c-gpgme-data-get-encoding dh))
1640
1641 (defun gpgme-data-set-encoding (dh encoding)
1642   "Set the encoding associated with the data object DH to ENCODING."
1643   (c-gpgme-data-set-encoding dh encoding))
1644
1645 (defun gpgme-data-get-file-name (dh)
1646   "Get the file name associated with the data object DH."
1647   (c-gpgme-data-get-file-name dh))
1648
1649 (defun gpgme-data-set-file-name (dh file-name)
1650   "Set the file name associated with the data object DH to FILE-NAME."
1651   (c-gpgme-data-set-file-name dh file-name))
1652
1653 ;;; FIXME: Add key accessor interfaces.
1654
1655 (defun gpgme-get-key (ctx fpr &optional secret)
1656   "Get the key with the fingerprint FPR from the context CTX."
1657   (with-foreign-object (key-p 'gpgme-key-t)
1658     (c-gpgme-get-key ctx fpr key-p secret)
1659     (mem-ref key-p 'gpgme-key-t)))
1660
1661 (defun gpgme-key-ref (key)
1662   "Acquire an additional reference to the key KEY."
1663   (when *debug* (format t "DEBUG: gpgme-key-ref: ~A~%" key))
1664   (c-gpgme-key-ref key))
1665
1666 (defun gpgme-key-unref (key)
1667   "Release a reference to the key KEY."
1668   (when *debug* (format t "DEBUG: gpgme-key-unref: ~A~%" key))
1669   (c-gpgme-key-unref key))
1670
1671 ;;; FIXME: We REALLY need pretty printing for keys and all the other
1672 ;;; big structs.
1673
1674 ;;; Various interfaces.
1675
1676 (defun gpgme-check-version (&optional req-version)
1677   (c-gpgme-check-version req-version))
1678
1679 ;;;
1680 ;;; The *EXPORTED* CLOS interface.
1681 ;;;
1682
1683 ;;; The context type.
1684
1685 ;;; We wrap the C context pointer into a class object to be able to
1686 ;;; stick a finalizer on it.
1687
1688 (defclass context ()
1689   (c-ctx  ; The C context object pointer.
1690    signers ; The list of signers.
1691    sig-notation) ; The list of signers.
1692   (:documentation "The GPGME context type."))
1693
1694 (defmethod initialize-instance :after ((ctx context) &rest rest
1695                                        &key &allow-other-keys)
1696   (let ((c-ctx (apply #'gpgme-new rest))
1697         (cleanup t))
1698     (unwind-protect
1699          (progn (setf (slot-value ctx 'c-ctx) c-ctx)
1700                 (finalize ctx (lambda () (gpgme-release c-ctx)))
1701                 (setf cleanup nil))
1702       (if cleanup (gpgme-release c-ctx)))))
1703
1704 (defmethod translate-to-foreign (value (type (eql 'gpgme-ctx-t)))
1705   ;; Allow a pointer to be passed directly for the finalizer to work.
1706   (if (pointerp value) value (slot-value value 'c-ctx)))
1707
1708 (defmacro context (&rest rest)
1709   "Create a new GPGME context."
1710   `(make-instance 'context ,@rest))
1711
1712 ;;; The context type: Accessor functions.
1713
1714 ;;; The context type: Accessor functions: Protocol.
1715
1716 (defgeneric protocol (ctx)
1717   (:documentation "Get the protocol of CONTEXT."))
1718
1719 (defmethod protocol ((ctx context))
1720   (gpgme-get-protocol ctx))
1721
1722 (defgeneric (setf protocol) (protocol ctx)
1723   (:documentation "Set the protocol of CONTEXT to PROTOCOL."))
1724
1725 ;;; FIXME: Adjust translator to reject invalid protocols.  Currently,
1726 ;;; specifing an invalid protocol throws a "NIL is not 32 signed int"
1727 ;;; error.  This is suboptimal.
1728 (defmethod (setf protocol) (protocol (ctx context))
1729   (gpgme-set-protocol ctx protocol))
1730
1731 ;;; The context type: Accessor functions: Armor.
1732 ;;; FIXME: Is it good style to make foop setf-able?  Or should it be
1733 ;;; foo/foop for set/get?
1734
1735 (defgeneric armorp (ctx)
1736   (:documentation "Get the armor flag of CONTEXT."))
1737
1738 (defmethod armorp ((ctx context))
1739   (gpgme-armor-p ctx))
1740
1741 (defgeneric (setf armorp) (armor ctx)
1742   (:documentation "Set the armor flag of CONTEXT to ARMOR."))
1743
1744 (defmethod (setf armorp) (armor (ctx context))
1745   (gpgme-set-armor ctx armor))
1746
1747 ;;; The context type: Accessor functions: Textmode.
1748 ;;; FIXME: Is it good style to make foop setf-able?  Or should it be
1749 ;;; foo/foop for set/get?
1750
1751 (defgeneric textmodep (ctx)
1752   (:documentation "Get the text mode flag of CONTEXT."))
1753
1754 (defmethod textmodep ((ctx context))
1755   (gpgme-textmode-p ctx))
1756
1757 (defgeneric (setf textmodep) (textmode ctx)
1758   (:documentation "Set the text mode flag of CONTEXT to TEXTMODE."))
1759
1760 (defmethod (setf textmodep) (textmode (ctx context))
1761   (gpgme-set-textmode ctx textmode))
1762
1763 ;;; The context type: Accessor functions: Include Certs.
1764
1765 (defgeneric include-certs (ctx)
1766   (:documentation "Get the number of included certificates in an
1767                    S/MIME message, or NIL if the default is used."))
1768
1769 (defmethod include-certs ((ctx context))
1770   (gpgme-get-include-certs ctx))
1771
1772 (defgeneric (setf include-certs) (certs ctx)
1773   (:documentation "Return the number of certificates to include in an
1774                    S/MIME message, or NIL if the default is used."))
1775
1776 (defmethod (setf include-certs) (certs (ctx context))
1777   (gpgme-set-include-certs ctx certs))
1778
1779 ;;; The context type: Accessor functions: Engine info.
1780
1781 (defgeneric engine-info (ctx)
1782   (:documentation "Retrieve the engine info for CTX."))
1783
1784 (defmethod engine-info ((ctx context))
1785   (gpgme-get-engine-info ctx))
1786
1787 (defgeneric (setf engine-info) (info ctx)
1788   (:documentation "Set the engine info for CTX."))
1789
1790 (defmethod (setf engine-info) (info (ctx context))
1791   (dolist (proto '(:openpgp :cms))
1792     (let ((pinfo (getf info proto)))
1793       (when pinfo
1794         (gpgme-set-engine-info ctx proto :file-name (getf pinfo :file-name)
1795                                :home-dir (getf pinfo :home-dir))))))
1796
1797 ;;; The context type: Accessor functions: Keylist mode.
1798
1799 (defgeneric keylist-mode (ctx)
1800   (:documentation "Get the keylist mode of CTX."))
1801
1802 (defmethod keylist-mode ((ctx context))
1803   (gpgme-get-keylist-mode ctx))
1804
1805 (defgeneric (setf keylist-mode) (mode ctx)
1806   (:documentation "Set the keylist mode of CTX to MODE."))
1807
1808 (defmethod (setf keylist-mode) (mode (ctx context))
1809   (gpgme-set-keylist-mode ctx mode))
1810
1811 ;;; The context type: Accessor functions: Signers.
1812
1813 (defgeneric signers (ctx)
1814   (:documentation "Get the signers of CTX."))
1815
1816 (defmethod signers ((ctx context))
1817   (slot-value ctx 'signers))
1818
1819 (defgeneric (setf signers) (signers ctx)
1820   (:documentation "Set the signers of CTX to SIGNERS."))
1821
1822 (defmethod (setf keylist-mode) (signers (ctx context))
1823   (gpgme-set-signers ctx signers)
1824   (setf (slot-value ctx 'signers) signers))
1825
1826 ;;; The context type: Accessor functions: Sig notations.
1827
1828 (defgeneric sig-notations (ctx)
1829   (:documentation "Get the signature notations of CTX."))
1830
1831 (defmethod sig-notations ((ctx context))
1832   (slot-value ctx 'signers))
1833
1834 (defgeneric (setf sig-notations) (notations ctx)
1835   (:documentation "Set the signatire notations of CTX to NOTATIONS."))
1836
1837 (defmethod (setf sig-notations) (notations (ctx context))
1838   (gpgme-set-signers ctx notations)
1839   (setf (slot-value ctx 'notations) notations))
1840
1841 ;;; The context type: Support macros.
1842
1843 (defmacro with-context ((ctx &rest rest) &body body)
1844   `(let ((,ctx (make-instance 'context ,@rest)))
1845     ,@body))
1846
1847 ;;; The key type.
1848
1849 (defclass key ()
1850   (c-key)  ; The C key object pointer.
1851   (:documentation "The GPGME key type."))
1852
1853 ;;; In the initializer, we swallow the c-key argument.
1854 (defmethod initialize-instance :after ((key key) &key c-key
1855                                        &allow-other-keys)
1856   (setf (slot-value key 'c-key) c-key)
1857   (finalize key (lambda () (gpgme-key-unref c-key))))
1858
1859 (defmethod translate-from-foreign (value (type (eql 'gpgme-key-t)))
1860   (when *debug* (format t "DEBUG: import key: ~A~%" value))
1861   (make-instance 'key :c-key value))
1862
1863 (defmethod translate-to-foreign (value (type (eql 'gpgme-key-t)))
1864   ;; Allow a pointer to be passed directly for the finalizer to work.
1865   (if (pointerp value) value (slot-value value 'c-key)))
1866
1867 (defmethod print-object ((key key) stream)
1868   (print-unreadable-object (key stream :type t :identity t)
1869     (format stream "~s" (fpr key))))
1870
1871 ;;; The key type: Accessor functions.
1872
1873 ;;; FIXME: The bitfield and flags contain redundant information at
1874 ;;; this point.  FIXME: Deal nicer with zero-length name (policy url)
1875 ;;; and zero length value (omit?) and human-readable (convert to string).
1876 ;;; FIXME: Turn binary data into sequence or vector or what it should be.
1877 ;;; FIXME: Turn the whole thing into a hash?
1878 (defmethod translate-from-foreign (value (type (eql 'gpgme-sig-notation-t)))
1879   (cond
1880     ((null-pointer-p value) nil)
1881     (t (with-foreign-slots
1882            ((next name value name-len value-len flags bitfield)
1883             value gpgme-sig-notation)
1884          (append (list (list
1885                         :name name
1886                         :value value
1887                         :name-len name-len
1888                         :value-len value-len
1889                         :flags flags
1890                         :bitfield bitfield))
1891                  next)))))
1892
1893 ;;; FIXME: Deal nicer with timestamps.  bitfield field name?
1894 (defmethod translate-from-foreign (value (type (eql 'gpgme-subkey-t)))
1895   (cond
1896     ((null-pointer-p value) nil)
1897     (t (with-foreign-slots
1898            ((next bitfield pubkey-algo length keyid fpr timestamp expires)
1899             value gpgme-subkey)
1900          (append (list (list
1901                         :bitfield bitfield
1902                         :pubkey-algo pubkey-algo
1903                         :length length
1904                         :keyid keyid
1905                         :fpr fpr
1906                         :timestamp timestamp
1907                         :expires expires))
1908                  next)))))
1909
1910 (defmethod translate-from-foreign (value (type (eql 'gpgme-key-sig-t)))
1911   (cond
1912     ((null-pointer-p value) nil)
1913     (t (with-foreign-slots
1914            ((next bitfield pubkey-algo keyid timestamp expires status
1915                   uid name email comment sig-class)
1916             value gpgme-key-sig)
1917          (append (list (list
1918                         :bitfield bitfield
1919                         :pubkey-algo pubkey-algo
1920                         :keyid keyid
1921                         :timestamp timestamp
1922                         :expires expires
1923                         :status status
1924                         :uid uid
1925                         :name name
1926                         :email email
1927                         :comment comment
1928                         :sig-class sig-class))
1929                  next)))))
1930
1931 (defmethod translate-from-foreign (value (type (eql 'gpgme-user-id-t)))
1932   (cond
1933     ((null-pointer-p value) nil)
1934     (t (with-foreign-slots
1935            ((next bitfield validity uid name email comment signatures)
1936             value gpgme-user-id)
1937          (append (list (list
1938                         :bitfield bitfield
1939                         :validity validity
1940                         :uid uid
1941                         :name name
1942                         :email email
1943                         :comment comment
1944                         :signatures signatures))
1945                  next)))))
1946
1947 (defun key-data (key)
1948   (with-slots (c-key) key
1949     (with-foreign-slots
1950         ((bitfield protocol issuer-serial issuer-name chain-id
1951                    owner-trust subkeys uids keylist-mode)
1952          c-key gpgme-key)
1953       (list
1954        :bitfield bitfield
1955        :protocol protocol
1956        :issuer-serial issuer-serial
1957        :issuer-name issuer-name
1958        :chain-id chain-id
1959        :owner-trust owner-trust
1960        :subkeys subkeys
1961        :uids uids
1962        :keylist-mode keylist-mode))
1963     ))
1964
1965
1966 (defgeneric fpr (key)
1967   (:documentation "Get the primary fingerprint of the key."))
1968
1969 (defmethod fpr ((key key))
1970   (getf (car (getf (key-data key) :subkeys)) :fpr))
1971
1972
1973 ;;; The context type: Crypto-Operations.
1974
1975 (defgeneric get-key (ctx fpr &optional secret)
1976   (:documentation "Get the (secret) key FPR from CTX."))
1977
1978 (defmethod get-key ((ctx context) fpr &optional secret)
1979   (gpgme-get-key ctx fpr secret))
1980
1981 ;;; Encrypt.
1982
1983 (defgeneric op-encrypt (ctx recp plain cipher &key always-trust sign)
1984   (:documentation "Encrypt."))
1985
1986 (defmethod op-encrypt ((ctx context) recp plain cipher
1987                        &key always-trust sign)
1988   (with-foreign-object (c-recp :pointer (+ 1 (length recp)))
1989     (dotimes (i (length recp))
1990       (setf (mem-aref c-recp 'gpgme-key-t i) (elt recp i)))
1991     (setf (mem-aref c-recp :pointer (length recp)) (null-pointer))
1992     (with-gpgme-data (in plain)
1993       (with-gpgme-data (out cipher)
1994         (let ((flags))
1995           (if always-trust (push :always-trust flags))
1996           (cond
1997             (sign
1998              (c-gpgme-op-encrypt-sign ctx c-recp flags in out)
1999              (append (c-gpgme-op-encrypt-result ctx)
2000                      (c-gpgme-op-sign-result ctx)))
2001             (t
2002              (c-gpgme-op-encrypt ctx c-recp flags in out)
2003              (c-gpgme-op-encrypt-result ctx))))))))
2004
2005 ;;; Decrypt.
2006
2007 (defgeneric op-decrypt (ctx cipher plain &key verify)
2008   (:documentation "Decrypt."))
2009
2010 (defmethod op-decrypt ((ctx context) cipher plain &key verify)
2011   (with-gpgme-data (in cipher)
2012     (with-gpgme-data (out plain)
2013       (cond
2014         (verify
2015          (c-gpgme-op-decrypt-verify ctx in out)
2016          (append (c-gpgme-op-decrypt-result ctx)
2017                  (c-gpgme-op-verify-result ctx)))
2018         (t
2019          (c-gpgme-op-decrypt ctx in out)
2020          (c-gpgme-op-decrypt-result ctx))))))
2021
2022 ;;; Signing.
2023
2024 (defgeneric op-sign (ctx plain sig &optional mode)
2025   (:documentation "Sign."))
2026
2027 (defmethod op-sign ((ctx context) plain sig &optional (mode :none))
2028   (with-gpgme-data (in plain)
2029     (with-gpgme-data (out sig)
2030       (c-gpgme-op-sign ctx in out mode)
2031       (c-gpgme-op-sign-result ctx))))
2032
2033 ;;; Verify.
2034
2035 (defgeneric op-verify (ctx sig text &key detached)
2036   (:documentation "Verify."))
2037
2038 (defmethod op-verify ((ctx context) sig text &key detached)
2039   (with-gpgme-data (in sig)
2040     (with-gpgme-data (on text)
2041       (c-gpgme-op-verify ctx in (if detached on nil)
2042                          (if detached nil on))
2043       (c-gpgme-op-verify-result ctx))))
2044
2045 ;;; Import.
2046
2047 (defgeneric op-import (ctx keydata)
2048   (:documentation "Import."))
2049
2050 (defmethod op-import ((ctx context) keydata)
2051   (with-gpgme-data (in keydata)
2052     (c-gpgme-op-import ctx in)
2053     (c-gpgme-op-import-result ctx)))
2054
2055 ;;; Export.
2056
2057 (defgeneric op-export (ctx pattern keydata)
2058   (:documentation "Export public key data matching PATTERN to the
2059                    stream KEYDATA."))
2060
2061 (defmethod op-export ((ctx context) pattern keydata)
2062   (with-gpgme-data (dh keydata)
2063     (c-gpgme-op-export ctx pattern 0 dh)))
2064
2065 ;;; Key generation.
2066
2067
2068 ;;;
2069 ;;; Initialization
2070 ;;;
2071
2072 (defun check-version (&optional req-version)
2073   "Check that the GPGME version requirement is satisfied."
2074   (gpgme-check-version req-version))
2075
2076 (defparameter *version* (check-version)
2077   "The version number of GPGME used.")