;;;; gpgme.lisp
;;; Copyright (C) 2006 g10 Code GmbH
;;;
;;; This file is part of GPGME-CL.
;;;
;;; GPGME-CL is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; GPGME-CL is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GPGME; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;; TODO
;;; Set up the library.
(in-package :gpgme)
(deftype byte-array ()
'(simple-array (unsigned-byte 8) (*)))
(deftype character-array ()
'(simple-array character (*)))
;;; Debugging.
(defvar *debug* nil "If debugging output should be given or not.")
;;; Load the foreign library.
(define-foreign-library libgpgme
(:unix "libgpgme.so")
(t (:default "libgpgme")))
(use-foreign-library libgpgme)
;;; System dependencies.
; Access to ERRNO.
(defcfun ("strerror" c-strerror) :string
(err :int))
(defun get-errno ()
*errno*)
(defun set-errno (errno)
(setf *errno* errno))
(define-condition system-error (error)
((errno :initarg :errno :reader system-error-errno))
(:report (lambda (c stream)
(format stream "System error: ~A: ~A"
(system-error-errno c)
(c-strerror (system-error-errno c)))))
(:documentation "Signalled when an errno is encountered."))
; Needed to write passphrases.
(defcfun ("write" c-write) ssize-t
(fd :int)
(buffer :string) ; Actually :pointer, but we only need string.
(size size-t))
(defun system-write (fd buffer size)
(let ((res (c-write fd buffer size)))
(when (< res 0) (error 'system-error :errno (get-errno)))
res))
;;;
;;; C Interface Definitions
;;;
;;; Data Type Interface
;;; Some new data types used for easier translation.
;;; The number of include certs. Translates to NIL for default.
(defctype cert-int-t
(:wrapper :int
:from-c translate-cert-int-t-from-foreign
:to-c translate-cert-int-t-to-foreign))
;;; A string that may be NIL to indicate a null pointer.
(defctype string-or-nil-t
(:wrapper :string
:to-c translate-string-or-nil-t-to-foreign))
;;; Some opaque data types used by GPGME.
(defctype gpgme-ctx-t
(:wrapper :pointer
:to-c translate-gpgme-ctx-t-to-foreign)
"The GPGME context type.")
(defctype gpgme-data-t
(:wrapper :pointer
:to-c translate-gpgme-data-t-to-foreign)
"The GPGME data object type.")
;;; Wrappers for the libgpg-error library.
(defctype gpgme-error-t
(:wrapper gpg-error::gpg-error-t
:from-c translate-gpgme-error-t-from-foreign
:to-c translate-gpgme-error-t-to-foreign)
"The GPGME error type.")
(defctype gpgme-error-no-signal-t
(:wrapper gpg-error::gpg-error-t
:from-c translate-gpgme-error-no-signal-t-from-foreign)
"The GPGME error type (this version does not signal conditions in translation.")
(defctype gpgme-err-code-t gpg-error::gpg-err-code-t
"The GPGME error code type.")
(defctype gpgme-err-source-t gpg-error::gpg-err-source-t
"The GPGME error source type.")
(defun gpgme-err-make (source code)
"Construct an error value from an error code and source."
(gpg-err-make source code))
(defun gpgme-error (code)
"Construct an error value from an error code."
(gpgme-err-make :gpg-err-source-gpgme code))
(defun gpgme-err-code (err)
"Retrieve an error code from the error value ERR."
(gpg-err-code err))
(defun gpgme-err-source (err)
"Retrieve an error source from the error value ERR."
(gpg-err-source err))
(defun gpgme-strerror (err)
"Return a string containing a description of the error code."
(gpg-strerror err))
(defun gpgme-strsource (err)
"Return a string containing a description of the error source."
(gpg-strsource err))
(defun gpgme-err-code-from-errno (err)
"Retrieve the error code for the system error. If the system error
is not mapped, :gpg-err-unknown-errno is returned."
(gpg-err-code-from-errno err))
(defun gpgme-err-code-to-errno (code)
"Retrieve the system error for the error code. If this is not a
system error, 0 is returned."
(gpg-err-code-to-errno code))
(defun gpgme-err-make-from-errno (source err)
(gpg-err-make-from-errno source err))
(defun gpgme-error-from-errno (err)
(gpg-error-from-errno err))
;;;
(defcenum gpgme-data-encoding-t
"The possible encoding mode of gpgme-data-t objects."
(:none 0)
(:binary 1)
(:base64 2)
(:armor 3)
(:url 4)
(:urlesc 5)
(:url0 6)
(:mime 7))
;;;
(defcenum gpgme-pubkey-algo-t
"Public key algorithms from libgcrypt."
(:rsa 1)
(:rsa-e 2)
(:rsa-s 3)
(:elg-e 16)
(:dsa 17)
(:ecc 18)
(:elg 20)
(:ecdsa 301)
(:ecdh 302)
(:eddsa 303))
(defcenum gpgme-hash-algo-t
"Hash algorithms from libgcrypt."
(:none 0)
(:md5 1)
(:sha1 2)
(:rmd160 3)
(:md2 5)
(:tiger 6)
(:haval 7)
(:sha256 8)
(:sha384 9)
(:sha512 10)
(:sha224 11)
(:md4 301)
(:crc32 302)
(:crc32-rfc1510 303)
(:crc24-rfc2440 304))
;;;
(defcenum gpgme-sig-mode-t
"The available signature modes."
(:none 0)
(:detach 1)
(:clear 2))
;;;
(defcenum gpgme-validity-t
"The available validities for a trust item or key."
(:unknown 0)
(:undefined 1)
(:never 2)
(:marginal 3)
(:full 4)
(:ultimate 5))
;;;
(defcenum gpgme-protocol-t
"The available protocols."
(:openpgp 0)
(:cms 1)
(:gpgconf 2)
(:assuan 3)
(:g13 4)
(:uiserver 5)
(:spawn 6)
(:default 254)
(:unknown 255))
;;;
(defbitfield (gpgme-keylist-mode-t :unsigned-int)
"The available keylist mode flags."
(:local 1)
(:extern 2)
(:sigs 4)
(:sig-notations)
(:with-secret 16)
(:with-tofu 32)
(:ephemeral 128)
(:validate 256))
;;;
(defbitfield (gpgme-sig-notation-flags-t :unsigned-int)
"The available signature notation flags."
(:human-readable 1)
(:critical 2))
(defctype gpgme-sig-notation-t
(:wrapper :pointer
:from-c translate-gpgme-sig-notation-t-from-foreign)
"Signature notation pointer type.")
;; FIXME: Doesn't this depend on endianness?
(defbitfield (gpgme-sig-notation-bitfield :unsigned-int)
(:human-readable 1)
(:critical 2))
(defcstruct gpgme-sig-notation
"Signature notations."
(next gpgme-sig-notation-t)
(name :pointer)
(value :pointer)
(name-len :int)
(value-len :int)
(flags gpgme-sig-notation-flags-t)
(bitfield gpgme-sig-notation-bitfield))
;;;
(defcenum gpgme-status-code-t
"The possible status codes for the edit operation."
(:eof 0)
(:enter 1)
(:leave 2)
(:abort 3)
(:goodsig 4)
(:badsig 5)
(:errsig 6)
(:badarmor 7)
(:rsa-or-idea 8)
(:keyexpired 9)
(:keyrevoked 10)
(:trust-undefined 11)
(:trust-never 12)
(:trust-marginal 13)
(:trust-fully 14)
(:trust-ultimate 15)
(:shm-info 16)
(:shm-get 17)
(:shm-get-bool 18)
(:shm-get-hidden 19)
(:need-passphrase 20)
(:validsig 21)
(:sig-id 22)
(:enc-to 23)
(:nodata 24)
(:bad-passphrase 25)
(:no-pubkey 26)
(:no-seckey 27)
(:need-passphrase-sym 28)
(:decryption-failed 29)
(:decryption-okay 30)
(:missing-passphrase 31)
(:good-passphrase 32)
(:goodmdc 33)
(:badmdc 34)
(:errmdc 35)
(:imported 36)
(:import-ok 37)
(:import-problem 38)
(:import-res 39)
(:file-start 40)
(:file-done 41)
(:file-error 42)
(:begin-decryption 43)
(:end-decryption 44)
(:begin-encryption 45)
(:end-encryption 46)
(:delete-problem 47)
(:get-bool 48)
(:get-line 49)
(:get-hidden 50)
(:got-it 51)
(:progress 52)
(:sig-created 53)
(:session-key 54)
(:notation-name 55)
(:notation-data 56)
(:policy-url 57)
(:begin-stream 58)
(:end-stream 59)
(:key-created 60)
(:userid-hint 61)
(:unexpected 62)
(:inv-recp 63)
(:no-recp 64)
(:already-signed 65)
(:sigexpired 66)
(:expsig 67)
(:expkeysig 68)
(:truncated 69)
(:error 70)
(:newsig 71)
(:revkeysig 72)
(:sig-subpacket 73)
(:need-passphrase-pin 74)
(:sc-op-failure 75)
(:sc-op-success 76)
(:cardctrl 77)
(:backup-key-created 78)
(:pka-trust-bad 79)
(:pka-trust-good 80)
(:plaintext 81)
(:inv-sgnr 82)
(:no-sgnr 83)
(:success 84)
(:decryption-info 85)
(:plaintext-length 86)
(:mountpoint 87)
(:pinentry-launched 88)
(:attribute 89)
(:begin-signing 90)
(:key-not-created 91)
(:inquire-maxlen 92)
(:failure 93)
(:key-considered 94)
(:tofu-user 95)
(:tofu-stats 96)
(:tofu-stats-long 97)
(:notation-flags 98)
(:decryption-compliance-mode 99)
(:verification-compliance-mode 100))
;;;
(defctype gpgme-engine-info-t
(:wrapper :pointer
:from-c translate-gpgme-engine-info-t-to-foreign)
"The engine information structure pointer type.")
(defcstruct gpgme-engine-info
"Engine information."
(next gpgme-engine-info-t)
(protocol gpgme-protocol-t)
(file-name :string)
(version :string)
(req-version :string)
(home-dir :string))
;;;
(defctype gpgme-subkey-t
(:wrapper :pointer
:from-c translate-gpgme-subkey-t-from-foreign)
"A subkey from a key.")
;; FIXME: Doesn't this depend on endianness?
(defbitfield (gpgme-subkey-bitfield :unsigned-int)
"The subkey bitfield."
(:revoked 1)
(:expired 2)
(:disabled 4)
(:invalid 8)
(:can-encrypt 16)
(:can-sign 32)
(:can-certify 64)
(:secret 128)
(:can-authenticate 256)
(:is-qualified 512)
(:is-cardkey 1024)
(:is-de-vs 2048))
(defcstruct gpgme-subkey
"Subkey from a key."
(next gpgme-subkey-t)
(bitfield gpgme-subkey-bitfield)
(pubkey-algo gpgme-pubkey-algo-t)
(length :unsigned-int)
(keyid :string)
(-keyid :char :count 17)
(fpr :string)
(timestamp :long)
(expires :long))
(defctype gpgme-key-sig-t
(:wrapper :pointer
:from-c translate-gpgme-key-sig-t-from-foreign)
"A signature on a user ID.")
;; FIXME: Doesn't this depend on endianness?
(defbitfield (gpgme-key-sig-bitfield :unsigned-int)
"The key signature bitfield."
(:revoked 1)
(:expired 2)
(:invalid 4)
(:exportable 16))
(defcstruct gpgme-key-sig
"A signature on a user ID."
(next gpgme-key-sig-t)
(bitfield gpgme-key-sig-bitfield)
(pubkey-algo gpgme-pubkey-algo-t)
(keyid :string)
(-keyid :char :count 17)
(timestamp :long)
(expires :long)
(status gpgme-error-no-signal-t)
(-class :unsigned-int)
(uid :string)
(name :string)
(email :string)
(comment :string)
(sig-class :unsigned-int))
(defctype gpgme-user-id-t
(:wrapper :pointer
:from-c translate-gpgme-user-id-t-from-foreign)
"A user ID from a key.")
;; FIXME: Doesn't this depend on endianness?
(defbitfield (gpgme-user-id-bitfield :unsigned-int)
"The user ID bitfield."
(:revoked 1)
(:invalid 2))
(defcstruct gpgme-user-id
"A user ID from a key."
(next gpgme-user-id-t)
(bitfield gpgme-user-id-bitfield)
(validity gpgme-validity-t)
(uid :string)
(name :string)
(email :string)
(comment :string)
(signatures gpgme-key-sig-t)
(-last-keysig gpgme-key-sig-t))
(defctype gpgme-key-t
(:wrapper :pointer
:from-c translate-gpgme-key-t-from-foreign
:to-c translate-gpgme-key-t-to-foreign)
"A key from the keyring.")
;; FIXME: Doesn't this depend on endianness?
(defbitfield (gpgme-key-bitfield :unsigned-int)
"The key bitfield."
(:revoked 1)
(:expired 2)
(:disabled 4)
(:invalid 8)
(:can-encrypt 16)
(:can-sign 32)
(:can-certify 64)
(:secret 128)
(:can-authenticate 256)
(:is-qualified 512))
(defcstruct gpgme-key
"A signature on a user ID."
(-refs :unsigned-int)
(bitfield gpgme-key-bitfield)
(protocol gpgme-protocol-t)
(issuer-serial :string)
(issuer-name :string)
(chain-id :string)
(owner-trust gpgme-validity-t)
(subkeys gpgme-subkey-t)
(uids gpgme-user-id-t)
(-last-subkey gpgme-subkey-t)
(-last-uid gpgme-user-id-t)
(keylist-mode gpgme-keylist-mode-t))
;;;
;;; There is no support in CFFI to define callback C types and have
;;; automatic type checking with the callback definition.
(defctype gpgme-passphrase-cb-t :pointer)
(defctype gpgme-progress-cb-t :pointer)
(defctype gpgme-edit-cb-t :pointer)
;;;
;;; Function Interface
;;;
;;; Context management functions.
(defcfun ("gpgme_new" c-gpgme-new) gpgme-error-t
(ctx :pointer))
(defcfun ("gpgme_release" c-gpgme-release) :void
(ctx gpgme-ctx-t))
(defcfun ("gpgme_set_protocol" c-gpgme-set-protocol) gpgme-error-t
(ctx gpgme-ctx-t)
(proto gpgme-protocol-t))
(defcfun ("gpgme_get_protocol" c-gpgme-get-protocol) gpgme-protocol-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_get_protocol_name" c-gpgme-get-protocol-name) :string
(proto gpgme-protocol-t))
(defcfun ("gpgme_set_armor" c-gpgme-set-armor) :void
(ctx gpgme-ctx-t)
(yes :boolean))
(defcfun ("gpgme_get_armor" c-gpgme-get-armor) :boolean
(ctx gpgme-ctx-t))
(defcfun ("gpgme_set_textmode" c-gpgme-set-textmode) :void
(ctx gpgme-ctx-t)
(yes :boolean))
(defcfun ("gpgme_get_textmode" c-gpgme-get-textmode) :boolean
(ctx gpgme-ctx-t))
(defconstant +include-certs-default+ -256)
(defcfun ("gpgme_set_include_certs" c-gpgme-set-include-certs) :void
(ctx gpgme-ctx-t)
(nr-of-certs cert-int-t))
(defcfun ("gpgme_get_include_certs" c-gpgme-get-include-certs) cert-int-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_set_keylist_mode" c-gpgme-set-keylist-mode) gpgme-error-t
(ctx gpgme-ctx-t)
(mode gpgme-keylist-mode-t))
(defcfun ("gpgme_get_keylist_mode" c-gpgme-get-keylist-mode)
gpgme-keylist-mode-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_set_passphrase_cb" c-gpgme-set-passphrase-cb) :void
(ctx gpgme-ctx-t)
(cb gpgme-passphrase-cb-t)
(hook-value :pointer))
(defcfun ("gpgme_get_passphrase_cb" c-gpgme-get-passphrase-cb) :void
(ctx gpgme-ctx-t)
(cb-p :pointer)
(hook-value-p :pointer))
(defcfun ("gpgme_set_progress_cb" c-gpgme-set-progress-cb) :void
(ctx gpgme-ctx-t)
(cb gpgme-progress-cb-t)
(hook-value :pointer))
(defcfun ("gpgme_get_progress_cb" c-gpgme-get-progress-cb) :void
(ctx gpgme-ctx-t)
(cb-p :pointer)
(hook-value-p :pointer))
(defcfun ("gpgme_set_locale" c-gpgme-set-locale) gpgme-error-t
(ctx gpgme-ctx-t)
(category :int)
(value string-or-nil-t))
(defcfun ("gpgme_ctx_get_engine_info" c-gpgme-ctx-get-engine-info)
gpgme-engine-info-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_ctx_set_engine_info" c-gpgme-ctx-set-engine-info)
gpgme-error-t
(ctx gpgme-ctx-t)
(proto gpgme-protocol-t)
(file-name string-or-nil-t)
(home-dir string-or-nil-t))
;;;
(defcfun ("gpgme_pubkey_algo_name" c-gpgme-pubkey-algo-name) :string
(algo gpgme-pubkey-algo-t))
(defcfun ("gpgme_hash_algo_name" c-gpgme-hash-algo-name) :string
(algo gpgme-hash-algo-t))
;;;
(defcfun ("gpgme_signers_clear" c-gpgme-signers-clear) :void
(ctx gpgme-ctx-t))
(defcfun ("gpgme_signers_add" c-gpgme-signers-add) gpgme-error-t
(ctx gpgme-ctx-t)
(key gpgme-key-t))
(defcfun ("gpgme_signers_enum" c-gpgme-signers-enum) gpgme-key-t
(ctx gpgme-ctx-t)
(seq :int))
;;;
(defcfun ("gpgme_sig_notation_clear" c-gpgme-sig-notation-clear) :void
(ctx gpgme-ctx-t))
(defcfun ("gpgme_sig_notation_add" c-gpgme-sig-notation-add) gpgme-error-t
(ctx gpgme-ctx-t)
(name :string)
(value string-or-nil-t)
(flags gpgme-sig-notation-flags-t))
(defcfun ("gpgme_sig_notation_get" c-gpgme-sig-notation-get)
gpgme-sig-notation-t
(ctx gpgme-ctx-t))
;;; Run Control.
;;; There is no support in CFFI to define callback C types and have
;;; automatic type checking with the callback definition.
(defctype gpgme-io-cb-t :pointer)
(defctype gpgme-register-io-cb-t :pointer)
(defctype gpgme-remove-io-cb-t :pointer)
(defcenum gpgme-event-io-t
"The possible events on I/O event callbacks."
(:start 0)
(:done 1)
(:next-key 2)
(:next-trustitem 3))
(defctype gpgme-event-io-cb-t :pointer)
(defcstruct gpgme-io-cbs
"I/O callbacks."
(add gpgme-register-io-cb-t)
(add-priv :pointer)
(remove gpgme-remove-io-cb-t)
(event gpgme-event-io-cb-t)
(event-priv :pointer))
(defctype gpgme-io-cbs-t :pointer)
(defcfun ("gpgme_set_io_cbs" c-gpgme-set-io-cbs) :void
(ctx gpgme-ctx-t)
(io-cbs gpgme-io-cbs-t))
(defcfun ("gpgme_get_io_cbs" c-gpgme-get-io-cbs) :void
(ctx gpgme-ctx-t)
(io-cbs gpgme-io-cbs-t))
(defcfun ("gpgme_wait" c-gpgme-wait) gpgme-ctx-t
(ctx gpgme-ctx-t)
(status-p :pointer)
(hang :int))
;;; Functions to handle data objects.
;;; There is no support in CFFI to define callback C types and have
;;; automatic type checking with the callback definition.
(defctype gpgme-data-read-cb-t :pointer)
(defctype gpgme-data-write-cb-t :pointer)
(defctype gpgme-data-seek-cb-t :pointer)
(defctype gpgme-data-release-cb-t :pointer)
(defcstruct gpgme-data-cbs
"Data callbacks."
(read gpgme-data-read-cb-t)
(write gpgme-data-write-cb-t)
(seek gpgme-data-seek-cb-t)
(release gpgme-data-release-cb-t))
(defctype gpgme-data-cbs-t :pointer
"Data callbacks pointer.")
(defcfun ("gpgme_data_read" c-gpgme-data-read) ssize-t
(dh gpgme-data-t)
(buffer :pointer)
(size size-t))
(defcfun ("gpgme_data_write" c-gpgme-data-write) ssize-t
(dh gpgme-data-t)
(buffer :pointer)
(size size-t))
(defcfun ("gpgme_data_seek" c-gpgme-data-seek) off-t
(dh gpgme-data-t)
(offset off-t)
(whence :int))
(defcfun ("gpgme_data_new" c-gpgme-data-new) gpgme-error-t
(dh-p :pointer))
(defcfun ("gpgme_data_release" c-gpgme-data-release) :void
(dh gpgme-data-t))
(defcfun ("gpgme_data_new_from_mem" c-gpgme-data-new-from-mem) gpgme-error-t
(dh-p :pointer)
(buffer :pointer)
(size size-t)
(copy :int))
(defcfun ("gpgme_data_release_and_get_mem" c-gpgme-data-release-and-get-mem)
:pointer
(dh gpgme-data-t)
(len-p :pointer))
(defcfun ("gpgme_data_new_from_cbs" c-gpgme-data-new-from-cbs) gpgme-error-t
(dh-p :pointer)
(cbs gpgme-data-cbs-t)
(handle :pointer))
(defcfun ("gpgme_data_new_from_fd" c-gpgme-data-new-from-fd) gpgme-error-t
(dh-p :pointer)
(fd :int))
(defcfun ("gpgme_data_new_from_stream" c-gpgme-data-new-from-stream)
gpgme-error-t
(dh-p :pointer)
(stream :pointer))
(defcfun ("gpgme_data_get_encoding" c-gpgme-data-get-encoding)
gpgme-data-encoding-t
(dh gpgme-data-t))
(defcfun ("gpgme_data_set_encoding" c-gpgme-data-set-encoding)
gpgme-error-t
(dh gpgme-data-t)
(enc gpgme-data-encoding-t))
(defcfun ("gpgme_data_get_file_name" c-gpgme-data-get-file-name) :string
(dh gpgme-data-t))
(defcfun ("gpgme_data_set_file_name" c-gpgme-data-set-file-name) gpgme-error-t
(dh gpgme-data-t)
(file-name string-or-nil-t))
(defcfun ("gpgme_data_new_from_file" c-gpgme-data-new-from-file) gpgme-error-t
(dh-p :pointer)
(fname :string)
(copy :int))
(defcfun ("gpgme_data_new_from_filepart" c-gpgme-data-new-from-filepart)
gpgme-error-t
(dh-p :pointer)
(fname :string)
(fp :pointer)
(offset off-t)
(length size-t))
;;; Key and trust functions.
(defcfun ("gpgme_get_key" c-gpgme-get-key) gpgme-error-t
(ctx gpgme-ctx-t)
(fpr :string)
(key-p :pointer)
(secret :boolean))
(defcfun ("gpgme_key_ref" c-gpgme-key-ref) :void
(key gpgme-key-t))
(defcfun ("gpgme_key_unref" c-gpgme-key-unref) :void
(key gpgme-key-t))
;;; Crypto operations.
(defcfun ("gpgme_cancel" c-gpgme-cancel) gpgme-error-t
(ctx gpgme-ctx-t))
;;;
(defctype gpgme-invalid-key-t
(:wrapper :pointer
:from-c translate-gpgme-invalid-key-t-from-foreign)
"An invalid key structure.")
(defcstruct gpgme-invalid-key
"An invalid key structure."
(next gpgme-invalid-key-t)
(fpr :string)
(reason gpgme-error-no-signal-t))
;;; Encryption.
(defcstruct gpgme-op-encrypt-result
"Encryption result structure."
(invalid-recipients gpgme-invalid-key-t))
(defctype gpgme-op-encrypt-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-encrypt-result-t-from-foreign)
"An encryption result structure.")
(defcfun ("gpgme_op_encrypt_result" c-gpgme-op-encrypt-result)
gpgme-op-encrypt-result-t
(ctx gpgme-ctx-t))
(defbitfield gpgme-encrypt-flags-t
(:always-trust 1)
(:no-encrypt-to 2)
(:prepare 4)
(:expect-sign 8)
(:no-compress 16)
(:symmetric 32)
(:throw-keyids 64)
(:wrap 128)
(:want-address 256))
(defcfun ("gpgme_op_encrypt_start" c-gpgme-op-encrypt-start) gpgme-error-t
(ctx gpgme-ctx-t)
(recp :pointer) ; Key array.
(flags gpgme-encrypt-flags-t)
(plain gpgme-data-t)
(cipher gpgme-data-t))
(defcfun ("gpgme_op_encrypt" c-gpgme-op-encrypt) gpgme-error-t
(ctx gpgme-ctx-t)
(recp :pointer) ; Key array.
(flags gpgme-encrypt-flags-t)
(plain gpgme-data-t)
(cipher gpgme-data-t))
(defcfun ("gpgme_op_encrypt_sign_start" c-gpgme-op-encrypt-sign-start)
gpgme-error-t
(ctx gpgme-ctx-t)
(recp :pointer) ; Key array.
(flags gpgme-encrypt-flags-t)
(plain gpgme-data-t)
(cipher gpgme-data-t))
(defcfun ("gpgme_op_encrypt_sign" c-gpgme-op-encrypt-sign) gpgme-error-t
(ctx gpgme-ctx-t)
(recp :pointer) ; Key array.
(flags gpgme-encrypt-flags-t)
(plain gpgme-data-t)
(cipher gpgme-data-t))
;;; Decryption.
(defctype gpgme-recipient-t
(:wrapper :pointer
:from-c translate-gpgme-recipient-t-from-foreign)
"A recipient structure.")
(defcstruct gpgme-recipient
"Recipient structure."
(next gpgme-recipient-t)
(keyid :string)
(-keyid :char :count 17)
(pubkey-algo gpgme-pubkey-algo-t)
(status gpgme-error-no-signal-t))
(defbitfield gpgme-op-decrypt-result-bitfield
"Decryption result structure bitfield."
(:wrong-key-usage 1)
(:is-de-vs 2)
(:is-mine 4))
(defcstruct gpgme-op-decrypt-result
"Decryption result structure."
(unsupported-algorithm :string)
(bitfield gpgme-op-decrypt-result-bitfield)
(recipients gpgme-recipient-t)
(file-name :string))
(defctype gpgme-op-decrypt-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-decrypt-result-t-from-foreign)
"A decryption result structure.")
(defcfun ("gpgme_op_decrypt_result" c-gpgme-op-decrypt-result)
gpgme-op-decrypt-result-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_op_decrypt_start" c-gpgme-op-decrypt-start) gpgme-error-t
(ctx gpgme-ctx-t)
(cipher gpgme-data-t)
(plain gpgme-data-t))
(defcfun ("gpgme_op_decrypt" c-gpgme-op-decrypt) gpgme-error-t
(ctx gpgme-ctx-t)
(cipher gpgme-data-t)
(plain gpgme-data-t))
(defcfun ("gpgme_op_decrypt_verify_start" c-gpgme-op-decrypt-verify-start)
gpgme-error-t
(ctx gpgme-ctx-t)
(cipher gpgme-data-t)
(plain gpgme-data-t))
(defcfun ("gpgme_op_decrypt_verify" c-gpgme-op-decrypt-verify) gpgme-error-t
(ctx gpgme-ctx-t)
(cipher gpgme-data-t)
(plain gpgme-data-t))
;;; Signing.
(defctype gpgme-new-signature-t
(:wrapper :pointer
:from-c translate-gpgme-new-signature-t-from-foreign)
"A new signature structure.")
(defcstruct gpgme-new-signature
"New signature structure."
(next gpgme-new-signature-t)
(type gpgme-sig-mode-t)
(pubkey-algo gpgme-pubkey-algo-t)
(hash-algo gpgme-hash-algo-t)
(-obsolete-class :unsigned-long)
(timestamp :long)
(fpr :string)
(-obsolete-class-2 :unsigned-int)
(sig-class :unsigned-int))
(defcstruct gpgme-op-sign-result
"Signing result structure."
(invalid-signers gpgme-invalid-key-t)
(signatures gpgme-new-signature-t))
(defctype gpgme-op-sign-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-sign-result-t-from-foreign)
"A signing result structure.")
(defcfun ("gpgme_op_sign_result" c-gpgme-op-sign-result)
gpgme-op-sign-result-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_op_sign_start" c-gpgme-op-sign-start) gpgme-error-t
(ctx gpgme-ctx-t)
(plain gpgme-data-t)
(sig gpgme-data-t)
(mode gpgme-sig-mode-t))
(defcfun ("gpgme_op_sign" c-gpgme-op-sign) gpgme-error-t
(ctx gpgme-ctx-t)
(plain gpgme-data-t)
(sig gpgme-data-t)
(mode gpgme-sig-mode-t))
;;; Verify.
(defbitfield (gpgme-sigsum-t :unsigned-int)
"Flags used for the summary field in a gpgme-signature-t."
(:valid #x0001)
(:green #x0002)
(:red #x0004)
(:key-revoked #x0010)
(:key-expired #x0020)
(:sig-expired #x0040)
(:key-missing #x0080)
(:crl-missing #x0100)
(:crl-too-old #x0200)
(:bad-policy #x0400)
(:sys-error #x0800)
(:tofu-conflict #x1000))
(defctype gpgme-signature-t
(:wrapper :pointer
:from-c translate-gpgme-signature-t-from-foreign)
"A signature structure.")
;; FIXME: Doesn't this depend on endianness?
(defbitfield (gpgme-signature-bitfield :unsigned-int)
"The signature bitfield."
(:wrong-key-usage 1)
(:pka-trust 2)
(:chain-model 4)
(:is-de-vs 8))
(defcstruct gpgme-signature
"Signature structure."
(next gpgme-signature-t)
(summary gpgme-sigsum-t)
(fpr :string)
(status gpgme-error-no-signal-t)
(notations gpgme-sig-notation-t)
(timestamp :unsigned-long)
(exp-timestamp :unsigned-long)
(bitfield gpgme-signature-bitfield)
(validity gpgme-validity-t)
(validity-reason gpgme-error-no-signal-t)
(pubkey-algo gpgme-pubkey-algo-t)
(hash-algo gpgme-hash-algo-t))
(defcstruct gpgme-op-verify-result
"Verify result structure."
(signatures gpgme-signature-t)
(file-name :string))
(defctype gpgme-op-verify-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-verify-result-t-from-foreign)
"A verify result structure.")
(defcfun ("gpgme_op_verify_result" c-gpgme-op-verify-result)
gpgme-op-verify-result-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_op_verify_start" c-gpgme-op-verify-start) gpgme-error-t
(ctx gpgme-ctx-t)
(sig gpgme-data-t)
(signed-text gpgme-data-t)
(plaintext gpgme-data-t))
(defcfun ("gpgme_op_verify" c-gpgme-op-verify) gpgme-error-t
(ctx gpgme-ctx-t)
(sig gpgme-data-t)
(signed-text gpgme-data-t)
(plaintext gpgme-data-t))
;;; Import.
(defbitfield (gpgme-import-flags-t :unsigned-int)
"Flags used for the import status field."
(:new #x0001)
(:uid #x0002)
(:sig #x0004)
(:subkey #x0008)
(:secret #x0010))
(defctype gpgme-import-status-t
(:wrapper :pointer
:from-c translate-gpgme-import-status-t-from-foreign)
"An import status structure.")
(defcstruct gpgme-import-status
"New import status structure."
(next gpgme-import-status-t)
(fpr :string)
(result gpgme-error-no-signal-t)
(status :unsigned-int))
(defcstruct gpgme-op-import-result
"Import result structure."
(considered :int)
(no-user-id :int)
(imported :int)
(imported-rsa :int)
(unchanged :int)
(new-user-ids :int)
(new-sub-keys :int)
(new-signatures :int)
(new-revocations :int)
(secret-read :int)
(secret-imported :int)
(secret-unchanged :int)
(skipped-new-keys :int)
(not-imported :int)
(imports gpgme-import-status-t))
(defctype gpgme-op-import-result-t
(:wrapper :pointer
:from-c translate-gpgme-op-import-result-t-from-foreign)
"An import status result structure.")
(defcfun ("gpgme_op_import_result" c-gpgme-op-import-result)
gpgme-op-import-result-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_op_import_start" c-gpgme-op-import-start) gpgme-error-t
(ctx gpgme-ctx-t)
(keydata gpgme-data-t))
(defcfun ("gpgme_op_import" c-gpgme-op-import) gpgme-error-t
(ctx gpgme-ctx-t)
(keydata gpgme-data-t))
;;; Export.
(defcfun ("gpgme_op_export_start" c-gpgme-op-export-start) gpgme-error-t
(ctx gpgme-ctx-t)
(pattern :string)
(reserved :unsigned-int)
(keydata gpgme-data-t))
(defcfun ("gpgme_op_export" c-gpgme-op-export) gpgme-error-t
(ctx gpgme-ctx-t)
(pattern :string)
(reserved :unsigned-int)
(keydata gpgme-data-t))
;;; FIXME: Extended export interfaces require array handling.
;;; Key generation.
(defbitfield (gpgme-genkey-flags-t :unsigned-int)
"Flags used for the key generation result bitfield."
(:primary #x0001)
(:sub #x0002)
(:uid #x0004))
(defcstruct gpgme-op-genkey-result
"Key generation result structure."
(bitfield gpgme-genkey-flags-t)
(fpr :string))
(defctype gpgme-op-genkey-result-t :pointer
"A key generation result structure.")
(defcfun ("gpgme_op_genkey_result" c-gpgme-op-genkey-result)
gpgme-op-genkey-result-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_op_genkey_start" c-gpgme-op-genkey-start) gpgme-error-t
(ctx gpgme-ctx-t)
(parms :string)
(pubkey gpgme-data-t)
(seckey gpgme-data-t))
(defcfun ("gpgme_op_genkey" c-gpgme-op-genkey) gpgme-error-t
(ctx gpgme-ctx-t)
(parms :string)
(pubkey gpgme-data-t)
(seckey gpgme-data-t))
;;; Key deletion.
(defcfun ("gpgme_op_delete_start" c-gpgme-op-delete-start) gpgme-error-t
(ctx gpgme-ctx-t)
(key gpgme-key-t)
(allow-secret :int))
(defcfun ("gpgme_op_delete" c-gpgme-op-delete) gpgme-error-t
(ctx gpgme-ctx-t)
(key gpgme-key-t)
(allow-secret :int))
;;; FIXME: Add edit interfaces.
;;; Keylist interface.
(defbitfield (gpgme-keylist-flags-t :unsigned-int)
"Flags used for the key listing result bitfield."
(:truncated #x0001))
(defcstruct gpgme-op-keylist-result
"Key listing result structure."
(bitfield gpgme-keylist-flags-t))
(defctype gpgme-op-keylist-result-t :pointer
"A key listing result structure.")
(defcfun ("gpgme_op_keylist_result" c-gpgme-op-keylist-result)
gpgme-op-keylist-result-t
(ctx gpgme-ctx-t))
(defcfun ("gpgme_op_keylist_start" c-gpgme-op-keylist-start) gpgme-error-t
(ctx gpgme-ctx-t)
(pattern :string)
(secret_only :boolean))
;;; FIXME: Extended keylisting requires array handling.
(defcfun ("gpgme_op_keylist_next" c-gpgme-op-keylist-next) gpgme-error-t
(ctx gpgme-ctx-t)
(r-key :pointer))
(defcfun ("gpgme_op_keylist_end" c-gpgme-op-keylist-end) gpgme-error-t
(ctx gpgme-ctx-t))
;;; Various functions.
(defcfun ("gpgme_check_version" c-gpgme-check-version) :string
(req-version string-or-nil-t))
(defcfun ("gpgme_get_engine_info" c-gpgme-get-engine-info) gpgme-error-t
(engine-info-p :pointer))
(defcfun ("gpgme_set_engine_info" c-gpgme-set-engine-info) gpgme-error-t
(proto gpgme-protocol-t)
(file-name string-or-nil-t)
(home-dir string-or-nil-t))
(defcfun ("gpgme_engine_check_version" c-gpgme-engine-check-verson)
gpgme-error-t
(proto gpgme-protocol-t))
;;;
;;; L I S P I N T E R F A C E
;;;
;;;
;;; Lisp type translators.
;;;
;;; Both directions.
;;; cert-int-t is a helper type that takes care of representing the
;;; default number of certs as NIL.
(defun translate-cert-int-t-from-foreign (value)
(cond
((eql value +include-certs-default+) nil)
(t value)))
(defun translate-cert-int-t-to-foreign (value)
(cond
(value value)
(t +include-certs-default+)))
;;; string-or-nil-t translates a null pointer to NIL and vice versa.
;;; Translation from foreign null pointer already works as expected.
(defun translate-string-or-nil-t-to-foreign (value)
(cond
(value value)
(t (null-pointer))))
;;; Output only.
;;; These type translators only convert from foreign type, because we
;;; never use these types in the other direction.
;;; Convert gpgme-engine-info-t linked lists into a list of property
;;; lists. Note that this converter will automatically be invoked
;;; recursively.
;;;
;;; FIXME: Should we use a hash table (or struct, or clos) instead of
;;; property list, as recommended by the Lisp FAQ?
(defun translate-gpgme-engine-info-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next protocol file-name version req-version home-dir)
value (:struct gpgme-engine-info))
(append (list protocol (list
:file-name file-name
:version version
:req-version req-version
:home-dir home-dir))
next)))))
(defun translate-gpgme-invalid-key-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next fpr reason)
value (:struct gpgme-invalid-key))
(append (list (list :fpr fpr
:reason reason))
next)))))
(defun translate-gpgme-op-encrypt-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((invalid-recipients)
value (:struct gpgme-op-encrypt-result))
(list :encrypt
(list :invalid-recipients invalid-recipients))))))
(defun translate-gpgme-recipient-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next keyid pubkey-algo status)
value (:struct gpgme-recipient))
(append (list (list :keyid keyid
:pubkey-algo pubkey-algo
:status status))
next)))))
(defun translate-gpgme-op-decrypt-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((unsupported-algorithm bitfield recipients file-name)
value (:struct gpgme-op-decrypt-result))
(list :decrypt (list :unsupported-algorithm unsupported-algorithm
:bitfield bitfield
:recipients recipients
:file-name file-name))))))
(defun translate-gpgme-new-signature-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next type pubkey-algo hash-algo timestamp fpr sig-class)
value (:struct gpgme-new-signature))
(append (list (list :type type
:pubkey-algo pubkey-algo
:hash-algo hash-algo
:timestamp timestamp
:fpr fpr
:sig-class sig-class))
next)))))
(defun translate-gpgme-op-sign-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((invalid-signers signatures)
value (:struct gpgme-op-sign-result))
(list :sign (list :invalid-signers invalid-signers
:signatures signatures))))))
(defun translate-gpgme-signature-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next summary fpr status notations timestamp
exp-timestamp bitfield validity validity-reason
pubkey-algo hash-algo)
value (:struct gpgme-signature))
(append (list (list :summary summary
:fpr fpr
:status status
:notations notations
:timestamp timestamp
:exp-timestamp exp-timestamp
:bitfield bitfield
:validity validity
:validity-reason validity-reason
:pubkey-algo pubkey-algo))
next)))))
(defun translate-gpgme-op-verify-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((signatures file-name)
value (:struct gpgme-op-verify-result))
(list :verify (list :signatures signatures
:file-name file-name))))))
(defun translate-gpgme-import-status-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next fpr result status)
value (:struct gpgme-import-status))
(append (list (list :fpr fpr
:result result
:status status))
next)))))
(defun translate-gpgme-op-import-result-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((considered no-user-id imported imported-rsa unchanged
new-user-ids new-sub-keys new-signatures
new-revocations secret-read secret-imported
secret-unchanged skipped-new-keys not-imported
imports)
value (:struct gpgme-op-import-result))
(list :verify (list :considered considered
:no-user-id no-user-id
:imported imported
:imported-rsa imported-rsa
:unchanged unchanged
:new-user-ids new-user-ids
:new-sub-keys new-sub-keys
:new-signatures new-signatures
:new-revocations new-revocations
:secret-read secret-read
:secret-imported secret-imported
:secret-unchanged secret-unchanged
:skipped-new-keys skipped-new-keys
:not-imported not-imported
:imports imports))))))
;;; Error handling.
;;; Use gpgme-error-no-signal-t to suppress automatic error handling
;;; at translation time.
;;;
;;; FIXME: Part of this probably should be in gpg-error!
(define-condition gpgme-error (error)
((value :initarg :gpgme-error :reader gpgme-error-value))
(:report (lambda (c stream)
(format stream "GPGME returned error: ~A (~A)"
(gpgme-strerror (gpgme-error-value c))
(gpgme-strsource (gpgme-error-value c)))))
(:documentation "Signalled when a GPGME function returns an error."))
(defun translate-gpgme-error-t-from-foreign (value)
"Raise a GPGME-ERROR if VALUE is non-zero."
(when (not (eql (gpgme-err-code value) :gpg-err-no-error))
(error 'gpgme-error :gpgme-error value))
(gpg-err-canonicalize value))
(defun translate-gpgme-error-t-to-foreign (value)
"Canonicalize the error value."
(if (eql (gpgme-err-code value) :gpg-err-no-error)
0
(gpg-err-as-value value)))
(defun translate-gpgme-error-no-signal-t-from-foreign (value)
"Canonicalize the error value."
(gpg-err-canonicalize value))
;;; *INTERNAL* Lispy Function Interface that is still close to the C
;;; interface.
;;; Passphrase callback management.
;;; Maybe: Instead, use subclassing, and provide a customizable
;;; default implementation for ease-of-use.
(defvar *passphrase-handles* (make-hash-table)
"Hash table with GPGME context address as key and the corresponding
passphrase callback object as value.")
(defcallback passphrase-cb gpgme-error-t ((handle :pointer)
(uid-hint :string)
(passphrase-info :string)
(prev-was-bad :boolean)
(fd :int))
(handler-case
(let* ((passphrase-cb
(gethash (pointer-address handle) *passphrase-handles*))
(passphrase
(cond
((functionp passphrase-cb)
(concatenate 'string
(funcall passphrase-cb uid-hint passphrase-info
prev-was-bad)
'(#\Newline)))
(t (concatenate 'string passphrase-cb '(#\Newline)))))
(passphrase-len (length passphrase))
;; FIXME: Could be more robust.
(res (system-write fd passphrase passphrase-len)))
(cond
((< res passphrase-len) ; FIXME: Blech. A weak attempt to be robust.
(gpgme-error :gpg-err-inval))
(t (gpgme-error :gpg-err-no-error))))
(gpgme-error (err) (gpgme-error-value err))
(system-error (err) (gpgme-error-from-errno (system-error-errno err)))
;; FIXME: The original error gets lost here.
(condition (err) (progn
(when *debug*
(format t "DEBUG: passphrase-cb: Unexpressable: ~A~%"
err))
(gpgme-error :gpg-err-general)))))
;;; CTX is a C-pointer to the context.
(defun gpgme-set-passphrase-cb (ctx cb)
"Set the passphrase callback for CTX."
(let ((handle (pointer-address ctx)))
(cond
(cb (setf (gethash handle *passphrase-handles*) cb)
(c-gpgme-set-passphrase-cb ctx (callback passphrase-cb) ctx))
(t (c-gpgme-set-passphrase-cb ctx (null-pointer) (null-pointer))
(remhash handle *passphrase-handles*)))))
;;; Progress callback management.
;;; Maybe: Instead, use subclassing, and provide a customizable
;;; default implementation for ease-of-use.
(defvar *progress-handles* (make-hash-table)
"Hash table with GPGME context address as key and the corresponding
progress callback object as value.")
(defcallback progress-cb :void ((handle :pointer)
(what :string)
(type :int)
(current :int)
(total :int))
(handler-case
(let* ((progress-cb
(gethash (pointer-address handle) *progress-handles*)))
(funcall progress-cb what type current total))
;; FIXME: The original error gets lost here.
(condition (err) (when *debug*
(format t "DEBUG: progress-cb: Unexpressable: ~A~%"
err)))))
;;; CTX is a C-pointer to the context.
(defun gpgme-set-progress-cb (ctx cb)
"Set the progress callback for CTX."
(let ((handle (pointer-address ctx)))
(cond
(cb (setf (gethash handle *progress-handles*) cb)
(c-gpgme-set-progress-cb ctx (callback progress-cb) ctx))
(t (c-gpgme-set-progress-cb ctx (null-pointer) (null-pointer))
(remhash handle *progress-handles*)))))
;;; Context management.
(defun gpgme-new (&key (protocol :openpgp) armor textmode include-certs
keylist-mode passphrase progress file-name home-dir)
"Allocate a new GPGME context."
(with-foreign-object (ctx-p 'gpgme-ctx-t)
(c-gpgme-new ctx-p)
(let ((ctx (mem-ref ctx-p 'gpgme-ctx-t)))
;;; Set locale?
(gpgme-set-protocol ctx protocol)
(gpgme-set-armor ctx armor)
(gpgme-set-textmode ctx textmode)
(when include-certs (gpgme-set-include-certs ctx include-certs))
(when keylist-mode (gpgme-set-keylist-mode ctx keylist-mode))
(gpgme-set-passphrase-cb ctx passphrase)
(gpgme-set-progress-cb ctx progress)
(gpgme-set-engine-info ctx protocol
:file-name file-name :home-dir home-dir)
(when *debug* (format t "DEBUG: gpgme-new: ~A~%" ctx))
ctx)))
(defun gpgme-release (ctx)
"Release a GPGME context."
(when *debug* (format t "DEBUG: gpgme-release: ~A~%" ctx))
(c-gpgme-release ctx))
(defun gpgme-set-protocol (ctx proto)
"Set the protocol to be used by CTX to PROTO."
(c-gpgme-set-protocol ctx proto))
(defun gpgme-get-protocol (ctx)
"Get the protocol used with CTX."
(c-gpgme-get-protocol ctx))
;;; FIXME: How to do pretty printing?
;;;
;;; gpgme-get-protocol-name
(defun gpgme-set-armor (ctx armor)
"If ARMOR is true, enable armor mode in CTX, disable it otherwise."
(c-gpgme-set-armor ctx armor))
(defun gpgme-armor-p (ctx)
"Return true if armor mode is set for CTX."
(c-gpgme-get-armor ctx))
(defun gpgme-set-textmode (ctx textmode)
"If TEXTMODE is true, enable text mode mode in CTX, disable it otherwise."
(c-gpgme-set-textmode ctx textmode))
(defun gpgme-textmode-p (ctx)
"Return true if text mode mode is set for CTX."
(c-gpgme-get-textmode ctx))
(defun gpgme-set-include-certs (ctx &optional certs)
"Include up to CERTS certificates in an S/MIME message."
(c-gpgme-set-include-certs ctx certs))
(defun gpgme-get-include-certs (ctx)
"Return the number of certs to include in an S/MIME message,
or NIL if the default is used."
(c-gpgme-get-include-certs ctx))
(defun gpgme-get-keylist-mode (ctx)
"Get the keylist mode in CTX."
(c-gpgme-get-keylist-mode ctx))
(defun gpgme-set-keylist-mode (ctx mode)
"Set the keylist mode in CTX."
(c-gpgme-set-keylist-mode ctx mode))
;;; FIXME: How to handle locale? cffi-grovel?
(defun gpgme-get-engine-info (&optional ctx)
"Retrieve the engine info for CTX, or the default if CTX is omitted."
(cond
(ctx (c-gpgme-ctx-get-engine-info ctx))
(t (with-foreign-object (info-p 'gpgme-engine-info-t)
(c-gpgme-get-engine-info info-p)
(mem-ref info-p 'gpgme-engine-info-t)))))
(defun gpgme-set-engine-info (ctx proto &key file-name home-dir)
"Set the engine info for CTX, or the default if CTX is NIL."
(cond
(ctx (c-gpgme-ctx-set-engine-info ctx proto file-name home-dir))
(t (c-gpgme-set-engine-info proto file-name home-dir))))
;;; FIXME: How to do pretty printing?
;;;
;;; gpgme_pubkey_algo_name, gpgme_hash_algo_name
(defun gpgme-set-signers (ctx keys)
"Set the signers for the context CTX."
(c-gpgme-signers-clear ctx)
(dolist (key keys) (c-gpgme-signers-add ctx key)))
;;;
(defun gpgme-set-sig-notation (ctx notations)
"Set the sig notation for the context CTX."
(c-gpgme-sig-notation-clear ctx)
(dolist (notation notations)
(c-gpgme-sig-notation-add
ctx (first notation) (second notation) (third notation))))
(defun gpgme-get-sig-notation (ctx)
"Get the signature notation data for the context CTX."
(c-gpgme-sig-notation-get ctx))
;;; FIXME: Add I/O callback interface, for integration with clg.
;;; FIXME: Add gpgme_wait?
;;; Streams
;;; -------
;;;
;;; GPGME uses standard streams. You can define your own streams, or
;;; use the existing file or string streams.
;;;
;;; A stream-spec is either a stream, or a list with a stream as its
;;; first argument followed by keyword parameters: encoding,
;;; file-name.
;;;
;;; FIXME: Eventually, we should provide a class that can be mixed
;;; into stream classes and which provides accessors for encoding and
;;; file-names. This interface should be provided in addition to the
;;; above sleazy interface, because the sleazy interface is easier to
;;; use (less typing), and is quite sufficient in a number of cases.
;;;
;;; For best results, streams with element type (unsigned-byte 8)
;;; should be used. Character streams may work if armor mode is used.
;;; Do we need to provide access to GPGME data objects through streams
;;; as well? It seems to me that specific optimizations, like
;;; directly writing to file descriptors, is better done by extending
;;; the sleazy syntax (stream-spec) instead of customized streams.
;;; Customized streams do buffering, and this may mess up things. Mmh.
(defvar *data-handles* (make-hash-table)
"Hash table with GPGME data user callback handle address as key
and the corresponding stream as value.")
;;; The release callback removes the stream from the *data-handles*
;;; hash and releases the CBS structure that is used as the key in
;;; that hash. It is implicitly invoked (through GPGME) by
;;; gpgme-data-release.
(defcallback data-release-cb :void ((handle :pointer))
(unwind-protect (remhash (pointer-address handle) *data-handles*)
(when (not (null-pointer-p handle)) (foreign-free handle))))
(defcallback data-read-cb ssize-t ((handle :pointer) (buffer :pointer)
(size size-t))
(when *debug* (format t "DEBUG: gpgme-data-read-cb: want ~A~%" size))
(let ((stream (gethash (pointer-address handle) *data-handles*)))
(cond
(stream
(let* ((stream-type (stream-element-type stream))
(seq (make-array size :element-type stream-type))
(read (read-sequence seq stream)))
(cond
((equal stream-type '(unsigned-byte 8))
(dotimes (i read)
(setf (mem-aref buffer :unsigned-char i)
(aref (the byte-array seq) i))))
((eql stream-type 'character)
(dotimes (i read)
(setf (mem-aref buffer :unsigned-char i)
(char-code (aref (the character-array seq) i)))))
(t
(dotimes (i read)
(setf (mem-aref buffer :unsigned-char i)
(coerce (aref seq i) '(unsigned-byte 8))))))
(when *debug* (format t "DEBUG: gpgme-data-read-cb: read ~A~%" read))
read))
(t
(set-errno +ebadf+)
-1))))
(defcallback data-write-cb ssize-t ((handle :pointer) (buffer :pointer)
(size size-t))
(when *debug* (format t "DEBUG: gpgme-data-write-cb: want ~A~%" size))
(let ((stream (gethash (pointer-address handle) *data-handles*)))
(cond
(stream
(let* ((stream-type (stream-element-type stream))
(seq (make-array size :element-type stream-type)))
(cond
((equal stream-type '(unsigned-byte 8))
(dotimes (i size)
(setf (aref (the byte-array seq) i)
(mem-aref buffer :unsigned-char i))))
((eql stream-type 'character)
(dotimes (i size)
(setf (aref (the character-array seq) i)
(code-char (mem-aref buffer :unsigned-char i)))))
(t
(dotimes (i size)
(setf (aref seq i)
(coerce (mem-aref buffer :unsigned-char i) stream-type)))))
(write-sequence seq stream)
size))
(t
(set-errno +ebadf+)
-1))))
;;; This little helper macro allows us to swallow the cbs structure by
;;; simply setting it to a null pointer, but still protect against
;;; conditions.
(defmacro with-cbs-swallowed ((cbs) &body body)
`(let ((,cbs (foreign-alloc '(:struct gpgme-data-cbs))))
(unwind-protect (progn ,@body)
(when (not (null-pointer-p ,cbs)) (foreign-free ,cbs)))))
(defun gpgme-data-new (stream &key encoding file-name)
"Allocate a new GPGME data object for STREAM."
(with-foreign-object (dh-p 'gpgme-data-t)
;;; We allocate one CBS structure for each stream we wrap in a
;;; data object. Although we could also share all these
;;; structures, as they contain the very same callbacks, we need a
;;; unique C pointer as handle anyway to look up the stream in the
;;; callback. This is a convenient one to use.
(with-cbs-swallowed (cbs)
(setf (foreign-slot-value cbs '(:struct gpgme-data-cbs) 'read)
(callback data-read-cb))
(setf (foreign-slot-value cbs '(:struct gpgme-data-cbs) 'write)
(callback data-write-cb))
(setf (foreign-slot-value cbs '(:struct gpgme-data-cbs) 'seek)
(null-pointer))
(setf (foreign-slot-value cbs '(:struct gpgme-data-cbs) 'release)
(callback data-release-cb))
(c-gpgme-data-new-from-cbs dh-p cbs cbs)
(let ((dh (mem-ref dh-p 'gpgme-data-t)))
(when encoding (gpgme-data-set-encoding dh encoding))
(when file-name (gpgme-data-set-file-name dh file-name))
;;; Install the stream into the hash table and swallow the cbs
;;; structure while protecting against any errors.
(unwind-protect
(progn
(setf (gethash (pointer-address cbs) *data-handles*) stream)
(setf cbs (null-pointer)))
(when (not (null-pointer-p cbs)) (c-gpgme-data-release dh)))
(when *debug* (format t "DEBUG: gpgme-data-new: ~A~%" dh))
dh))))
;;; This function releases a GPGME data object. It implicitly
;;; invokes the data-release-cb function to clean up associated junk.
(defun gpgme-data-release (dh)
"Release a GPGME data object."
(when *debug* (format t "DEBUG: gpgme-data-release: ~A~%" dh))
(c-gpgme-data-release dh))
(defclass data ()
(c-data) ; The C data object pointer
(:documentation "The GPGME data type."))
(defmethod initialize-instance :after ((data data) &key streamspec
&allow-other-keys)
(let ((c-data (if (listp streamspec)
(apply #'gpgme-data-new streamspec)
(gpgme-data-new streamspec)))
(cleanup t))
(unwind-protect
(progn
(setf (slot-value data 'c-data) c-data)
(finalize data (lambda () (gpgme-data-release c-data)))
(setf cleanup nil))
(if cleanup (gpgme-data-release c-data)))))
(defun translate-gpgme-data-t-to-foreign (value)
;; Allow a pointer to be passed directly for the finalizer to work.
(cond
((null value) (null-pointer))
((pointerp value) value)
(t (slot-value value 'c-data))))
(defmacro with-gpgme-data ((dh streamspec) &body body)
`(let ((,dh (make-instance 'data :streamspec ,streamspec)))
,@body))
(defun gpgme-data-get-encoding (dh)
"Get the encoding associated with the data object DH."
(c-gpgme-data-get-encoding dh))
(defun gpgme-data-set-encoding (dh encoding)
"Set the encoding associated with the data object DH to ENCODING."
(c-gpgme-data-set-encoding dh encoding))
(defun gpgme-data-get-file-name (dh)
"Get the file name associated with the data object DH."
(c-gpgme-data-get-file-name dh))
(defun gpgme-data-set-file-name (dh file-name)
"Set the file name associated with the data object DH to FILE-NAME."
(c-gpgme-data-set-file-name dh file-name))
;;; FIXME: Add key accessor interfaces.
(defun gpgme-get-key (ctx fpr &optional secret)
"Get the key with the fingerprint FPR from the context CTX."
(with-foreign-object (key-p 'gpgme-key-t)
(c-gpgme-get-key ctx fpr key-p secret)
(mem-ref key-p 'gpgme-key-t)))
(defun gpgme-key-ref (key)
"Acquire an additional reference to the key KEY."
(when *debug* (format t "DEBUG: gpgme-key-ref: ~A~%" key))
(c-gpgme-key-ref key))
(defun gpgme-key-unref (key)
"Release a reference to the key KEY."
(when *debug* (format t "DEBUG: gpgme-key-unref: ~A~%" key))
(c-gpgme-key-unref key))
;;; FIXME: We REALLY need pretty printing for keys and all the other
;;; big structs.
;;; Various interfaces.
(defun gpgme-check-version (&optional req-version)
(c-gpgme-check-version req-version))
;;;
;;; The *EXPORTED* CLOS interface.
;;;
;;; The context type.
;;; We wrap the C context pointer into a class object to be able to
;;; stick a finalizer on it.
(defclass context ()
(c-ctx ; The C context object pointer.
signers ; The list of signers.
sig-notation) ; The list of signers.
(:documentation "The GPGME context type."))
(defmethod initialize-instance :after ((ctx context) &rest rest
&key &allow-other-keys)
(let ((c-ctx (apply #'gpgme-new rest))
(cleanup t))
(unwind-protect
(progn (setf (slot-value ctx 'c-ctx) c-ctx)
(finalize ctx (lambda () (gpgme-release c-ctx)))
(setf cleanup nil))
(if cleanup (gpgme-release c-ctx)))))
(defun translate-gpgme-ctx-t-to-foreign (value)
;; Allow a pointer to be passed directly for the finalizer to work.
(if (pointerp value) value (slot-value value 'c-ctx)))
(defmacro context (&rest rest)
"Create a new GPGME context."
`(make-instance 'context ,@rest))
;;; The context type: Accessor functions.
;;; The context type: Accessor functions: Protocol.
(defgeneric protocol (ctx)
(:documentation "Get the protocol of CONTEXT."))
(defmethod protocol ((ctx context))
(gpgme-get-protocol ctx))
(defgeneric (setf protocol) (protocol ctx)
(:documentation "Set the protocol of CONTEXT to PROTOCOL."))
;;; FIXME: Adjust translator to reject invalid protocols. Currently,
;;; specifying an invalid protocol throws a "NIL is not 32 signed int"
;;; error. This is suboptimal.
(defmethod (setf protocol) (protocol (ctx context))
(gpgme-set-protocol ctx protocol))
;;; The context type: Accessor functions: Armor.
;;; FIXME: Is it good style to make foop setf-able? Or should it be
;;; foo/foop for set/get?
(defgeneric armorp (ctx)
(:documentation "Get the armor flag of CONTEXT."))
(defmethod armorp ((ctx context))
(gpgme-armor-p ctx))
(defgeneric (setf armorp) (armor ctx)
(:documentation "Set the armor flag of CONTEXT to ARMOR."))
(defmethod (setf armorp) (armor (ctx context))
(gpgme-set-armor ctx armor))
;;; The context type: Accessor functions: Textmode.
;;; FIXME: Is it good style to make foop setf-able? Or should it be
;;; foo/foop for set/get?
(defgeneric textmodep (ctx)
(:documentation "Get the text mode flag of CONTEXT."))
(defmethod textmodep ((ctx context))
(gpgme-textmode-p ctx))
(defgeneric (setf textmodep) (textmode ctx)
(:documentation "Set the text mode flag of CONTEXT to TEXTMODE."))
(defmethod (setf textmodep) (textmode (ctx context))
(gpgme-set-textmode ctx textmode))
;;; The context type: Accessor functions: Include Certs.
(defgeneric include-certs (ctx)
(:documentation "Get the number of included certificates in an
S/MIME message, or NIL if the default is used."))
(defmethod include-certs ((ctx context))
(gpgme-get-include-certs ctx))
(defgeneric (setf include-certs) (certs ctx)
(:documentation "Return the number of certificates to include in an
S/MIME message, or NIL if the default is used."))
(defmethod (setf include-certs) (certs (ctx context))
(gpgme-set-include-certs ctx certs))
;;; The context type: Accessor functions: Engine info.
(defgeneric engine-info (ctx)
(:documentation "Retrieve the engine info for CTX."))
(defmethod engine-info ((ctx context))
(gpgme-get-engine-info ctx))
(defgeneric (setf engine-info) (info ctx)
(:documentation "Set the engine info for CTX."))
(defmethod (setf engine-info) (info (ctx context))
(dolist (proto '(:openpgp :cms))
(let ((pinfo (getf info proto)))
(when pinfo
(gpgme-set-engine-info ctx proto :file-name (getf pinfo :file-name)
:home-dir (getf pinfo :home-dir))))))
;;; The context type: Accessor functions: Keylist mode.
(defgeneric keylist-mode (ctx)
(:documentation "Get the keylist mode of CTX."))
(defmethod keylist-mode ((ctx context))
(gpgme-get-keylist-mode ctx))
(defgeneric (setf keylist-mode) (mode ctx)
(:documentation "Set the keylist mode of CTX to MODE."))
(defmethod (setf keylist-mode) (mode (ctx context))
(gpgme-set-keylist-mode ctx mode))
;;; The context type: Accessor functions: Signers.
(defgeneric signers (ctx)
(:documentation "Get the signers of CTX."))
(defmethod signers ((ctx context))
(slot-value ctx 'signers))
(defgeneric (setf signers) (signers ctx)
(:documentation "Set the signers of CTX to SIGNERS."))
(defmethod (setf keylist-mode) (signers (ctx context))
(gpgme-set-signers ctx signers)
(setf (slot-value ctx 'signers) signers))
;;; The context type: Accessor functions: Sig notations.
(defgeneric sig-notations (ctx)
(:documentation "Get the signature notations of CTX."))
(defmethod sig-notations ((ctx context))
(slot-value ctx 'signers))
(defgeneric (setf sig-notations) (notations ctx)
(:documentation "Set the signatire notations of CTX to NOTATIONS."))
(defmethod (setf sig-notations) (notations (ctx context))
(gpgme-set-signers ctx notations)
(setf (slot-value ctx 'notations) notations))
;;; The context type: Support macros.
(defmacro with-context ((ctx &rest rest) &body body)
`(let ((,ctx (make-instance 'context ,@rest)))
,@body))
;;; The key type.
(defclass key ()
(c-key) ; The C key object pointer.
(:documentation "The GPGME key type."))
;;; In the initializer, we swallow the c-key argument.
(defmethod initialize-instance :after ((key key) &key c-key
&allow-other-keys)
(setf (slot-value key 'c-key) c-key)
(finalize key (lambda () (gpgme-key-unref c-key))))
(defun translate-gpgme-key-t-from-foreign (value)
(when *debug* (format t "DEBUG: import key: ~A~%" value))
(make-instance 'key :c-key value))
(defun translate-gpgme-key-t-to-foreign (value)
;; Allow a pointer to be passed directly for the finalizer to work.
(if (pointerp value) value (slot-value value 'c-key)))
(defmethod print-object ((key key) stream)
(print-unreadable-object (key stream :type t :identity t)
(format stream "~s" (fpr key))))
;;; The key type: Accessor functions.
;;; FIXME: The bitfield and flags contain redundant information at
;;; this point. FIXME: Deal nicer with zero-length name (policy url)
;;; and zero length value (omit?) and human-readable (convert to string).
;;; FIXME: Turn binary data into sequence or vector or what it should be.
;;; FIXME: Turn the whole thing into a hash?
(defun translate-gpgme-sig-notation-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next name value name-len value-len flags bitfield)
value (:struct gpgme-sig-notation))
(append (list (list
:name name
:value value
:name-len name-len
:value-len value-len
:flags flags
:bitfield bitfield))
next)))))
;;; FIXME: Deal nicer with timestamps. bitfield field name?
(defun translate-gpgme-subkey-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next bitfield pubkey-algo length keyid fpr timestamp expires)
value (:struct gpgme-subkey))
(append (list (list
:bitfield bitfield
:pubkey-algo pubkey-algo
:length length
:keyid keyid
:fpr fpr
:timestamp timestamp
:expires expires))
next)))))
(defun translate-gpgme-key-sig-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next bitfield pubkey-algo keyid timestamp expires status
uid name email comment sig-class)
value (:struct gpgme-key-sig))
(append (list (list
:bitfield bitfield
:pubkey-algo pubkey-algo
:keyid keyid
:timestamp timestamp
:expires expires
:status status
:uid uid
:name name
:email email
:comment comment
:sig-class sig-class))
next)))))
(defun translate-gpgme-user-id-t-from-foreign (value)
(cond
((null-pointer-p value) nil)
(t (with-foreign-slots
((next bitfield validity uid name email comment signatures)
value (:struct gpgme-user-id))
(append (list (list
:bitfield bitfield
:validity validity
:uid uid
:name name
:email email
:comment comment
:signatures signatures))
next)))))
(defun key-data (key)
(with-slots (c-key) key
(with-foreign-slots
((bitfield protocol issuer-serial issuer-name chain-id
owner-trust subkeys uids keylist-mode)
c-key (:struct gpgme-key))
(list
:bitfield bitfield
:protocol protocol
:issuer-serial issuer-serial
:issuer-name issuer-name
:chain-id chain-id
:owner-trust owner-trust
:subkeys subkeys
:uids uids
:keylist-mode keylist-mode))
))
(defgeneric fpr (key)
(:documentation "Get the primary fingerprint of the key."))
(defmethod fpr ((key key))
(getf (car (getf (key-data key) :subkeys)) :fpr))
;;; The context type: Crypto-Operations.
(defgeneric get-key (ctx fpr &optional secret)
(:documentation "Get the (secret) key FPR from CTX."))
(defmethod get-key ((ctx context) fpr &optional secret)
(gpgme-get-key ctx fpr secret))
;;; Encrypt.
(defgeneric op-encrypt (ctx recp plain cipher &key always-trust sign)
(:documentation "Encrypt."))
(defmethod op-encrypt ((ctx context) recp plain cipher
&key always-trust sign)
(with-foreign-object (c-recp :pointer (+ 1 (length recp)))
(dotimes (i (length recp))
(setf (mem-aref c-recp 'gpgme-key-t i) (elt recp i)))
(setf (mem-aref c-recp :pointer (length recp)) (null-pointer))
(with-gpgme-data (in plain)
(with-gpgme-data (out cipher)
(let ((flags))
(if always-trust (push :always-trust flags))
(cond
(sign
(c-gpgme-op-encrypt-sign ctx c-recp flags in out)
(append (c-gpgme-op-encrypt-result ctx)
(c-gpgme-op-sign-result ctx)))
(t
(c-gpgme-op-encrypt ctx c-recp flags in out)
(c-gpgme-op-encrypt-result ctx))))))))
;;; Decrypt.
(defgeneric op-decrypt (ctx cipher plain &key verify)
(:documentation "Decrypt."))
(defmethod op-decrypt ((ctx context) cipher plain &key verify)
(with-gpgme-data (in cipher)
(with-gpgme-data (out plain)
(cond
(verify
(c-gpgme-op-decrypt-verify ctx in out)
(append (c-gpgme-op-decrypt-result ctx)
(c-gpgme-op-verify-result ctx)))
(t
(c-gpgme-op-decrypt ctx in out)
(c-gpgme-op-decrypt-result ctx))))))
;;; Signing.
(defgeneric op-sign (ctx plain sig &optional mode)
(:documentation "Sign."))
(defmethod op-sign ((ctx context) plain sig &optional (mode :none))
(with-gpgme-data (in plain)
(with-gpgme-data (out sig)
(c-gpgme-op-sign ctx in out mode)
(c-gpgme-op-sign-result ctx))))
;;; Verify.
(defgeneric op-verify (ctx sig text &key detached)
(:documentation "Verify."))
(defmethod op-verify ((ctx context) sig text &key detached)
(with-gpgme-data (in sig)
(with-gpgme-data (on text)
(c-gpgme-op-verify ctx in (if detached on nil)
(if detached nil on))
(c-gpgme-op-verify-result ctx))))
;;; Import.
(defgeneric op-import (ctx keydata)
(:documentation "Import."))
(defmethod op-import ((ctx context) keydata)
(with-gpgme-data (in keydata)
(c-gpgme-op-import ctx in)
(c-gpgme-op-import-result ctx)))
;;; Export.
(defgeneric op-export (ctx pattern keydata)
(:documentation "Export public key data matching PATTERN to the
stream KEYDATA."))
(defmethod op-export ((ctx context) pattern keydata)
(with-gpgme-data (dh keydata)
(c-gpgme-op-export ctx pattern 0 dh)))
;;; Key generation.
;;;
;;; Initialization
;;;
(defun check-version (&optional req-version)
"Check that the GPGME version requirement is satisfied."
(gpgme-check-version req-version))
(defparameter *version* (check-version)
"The version number of GPGME used.")