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