[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: DRAFT Add (guix openpgp).
|
From: |
guix-commits |
|
Subject: |
01/01: DRAFT Add (guix openpgp). |
|
Date: |
Wed, 1 Jan 2020 18:08:35 -0500 (EST) |
civodul pushed a commit to branch wip-openpgp
in repository guix.
commit b486a9bb885866dc82a4dc19a24e33dee207262e
Author: Ludovic Courtès <address@hidden>
Date: Thu Jan 2 00:03:58 2020 +0100
DRAFT Add (guix openpgp).
DRAFT: This needs tests.
* guix/openpgp.scm: New file.
* Makefile.am (MODULES): Add it.
---
Makefile.am | 1 +
guix/openpgp.scm | 981 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 982 insertions(+)
diff --git a/Makefile.am b/Makefile.am
index 7474b7f..357518b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -70,6 +70,7 @@ MODULES = \
guix/docker.scm \
guix/json.scm \
guix/records.scm \
+ guix/openpgp.scm \
guix/pki.scm \
guix/progress.scm \
guix/combinators.scm \
diff --git a/guix/openpgp.scm b/guix/openpgp.scm
new file mode 100644
index 0000000..7f99864
--- /dev/null
+++ b/guix/openpgp.scm
@@ -0,0 +1,981 @@
+;; -*- mode: scheme; coding: utf-8 -*-
+;; Copyright © 2010, 2012 Göran Weinholt <address@hidden>
+;; Copyright © 2020 Ludovic Courtès <address@hidden>
+
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the "Software"),
+;; to deal in the Software without restriction, including without limitation
+;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;; and/or sell copies of the Software, and to permit persons to whom the
+;; Software is furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;; DEALINGS IN THE SOFTWARE.
+
+;;; This code was originally written by Göran Weinholt for Industria and
+;;; released under the Expat license shown above. It was then modified by
+;;; Ludovic Courtès for use in GNU Guix: turned into a native Guile module,
+;;; ported to Guile-Gcrypt, and extended and simplified in other ways.
+
+(define-module (guix openpgp)
+ #:export (get-openpgp-keyring
+ get-openpgp-keyring/keyid
+ get-openpgp-detached-signature/ascii
+ (get-packet . get-openpgp-packet)
+ verify-openpgp-signature
+ port-ascii-armored?
+
+ openpgp-signature?
+ openpgp-signature-issuer
+ (openpgp-signature-pkalg
+ . openpgp-signature-public-key-algorithm)
+ (openpgp-signature-halg
+ . openpgp-signature-hash-algorithm)
+ openpgp-signature-creation-time
+ openpgp-signature-expiration-time
+
+ openpgp-user-id?
+ openpgp-user-id-value
+ openpgp-user-attribute?
+
+ openpgp-public-key?
+ openpgp-public-key-subkey?
+ openpgp-public-key-value
+ openpgp-public-key-fingerprint openpgp-format-fingerprint
+ openpgp-public-key-id
+
+ read-radix-64)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-60)
+ #:use-module (ice-9 match)
+ #:use-module ((ice-9 rdelim) #:select (read-line))
+ #:use-module (ice-9 vlist)
+ #:use-module (gcrypt hash)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (gcrypt base64)
+ #:use-module ((guix build utils) #:select (dump-port)))
+
+;;; Commentary:
+;;;
+;;; Procedures for dealing with OpenPGP messages.
+;;;
+;;; XXX: Currently only does enough to verify detached signatures of
+;;; binary data. Sanity checks on self-signatures, subkey binding
+;;; signatures, etc is left as an exercise for the program that manages
+;;; the keyring.
+;;;
+;;; 4880 OpenPGP Message Format. J. Callas, L. Donnerhacke, H. Finney, D.
+;;; Shaw, R. Thayer. November 2007. (Format: TXT=203706 bytes) (Obsoletes
+;;; RFC1991, RFC2440) (Updated by RFC5581) (Status: PROPOSED STANDARD)
+;;;
+;;; Each User ID on a public key has a self-signature made by the key.
+;;; Each subkey also has a self-signature that binds it to the primary
+;;; key, and a self-signature that binds the primary key to the subkey.
+;;;
+;;; Code:
+
+(define-syntax print
+ (syntax-rules ()
+ #;
+ ((_ . args) ; ;
+ (begin ; ;
+ (for-each display (list . args)) ; ;
+ (newline)))
+ ((_ . args) (values))))
+
+(define-syntax-rule (define-alias new old)
+ (define-syntax new (identifier-syntax old)))
+
+(define-alias fx+ +)
+(define-alias fx- -)
+(define-alias fx* *)
+(define-alias fx/ /)
+(define-alias fxdiv quotient)
+(define-alias fxand logand)
+(define-alias fxbit-set? bit-set?)
+(define-alias fxbit-field bit-field)
+(define-alias bitwise-bit-field bit-field)
+(define-alias fxarithmetic-shift-left ash)
+(define-inlinable (fxarithmetic-shift-right i n) (ash i (- n)))
+(define-inlinable (port-eof? port) (eof-object? (lookahead-u8 port)))
+
+(define (string-hex-pad str)
+ (if (odd? (string-length str))
+ (string-append "0" str)
+ str))
+
+(define (unixtime n)
+ (time-monotonic->date (make-time 'time-monotonic 0 n)))
+
+
+;;;
+;;; Bitwise I/O.
+;;;
+;;; TODO: Use Bytestructures instead.
+;;;
+
+(define-syntax-rule (integer-read size)
+ (lambda (port)
+ "Read from PORT a big-endian integer of SIZE bytes. Return the EOF object
+on end-of-file."
+ (let ((buf (make-bytevector size)))
+ (match (get-bytevector-n! port buf 0 size)
+ (size (bytevector-uint-ref buf 0 (endianness big) size))
+ (_ (eof-object))))))
+
+(define get-u16 (integer-read 2))
+(define get-u32 (integer-read 4))
+(define get-u64 (integer-read 8))
+
+(define-syntax get-integers
+ (syntax-rules ()
+ "Read from PORT integers of the given TYPE, in big endian encoding. Each
+TYPE must be one of u8, u16, u32, u64, or _, as in this example:
+
+ (get-integers port u8 _ _ _ u32 u16)
+
+In the case of _ (wildcard), one byte is read and discarded. Return as many
+values as there are TYPEs."
+ ((_ port type ...)
+ (letrec-syntax ((get-integer (syntax-rules (u8 u16 u32 u64)
+ ((x u8) (get-u8 port))
+ ((x u16) (get-u16 port))
+ ((x u32) (get-u32 port))
+ ((x u64) (get-u64 port))))
+ (values* (syntax-rules (_)
+ ((x (result (... ...)))
+ (values result (... ...)))
+ ((x (result (... ...)) _ rest (... ...))
+ (let ((x (get-u8 port)))
+ (values* (result (... ...))
+ rest (... ...))))
+ ((x (result (... ...)) t rest (... ...))
+ (let ((x (get-integer t)))
+ (values* (result (... ...) x)
+ rest (... ...)))))))
+ (values* () type ...)))))
+
+(define (bytevector->uint bv)
+ (bytevector-uint-ref bv 0 (endianness big)
+ (bytevector-length bv)))
+
+(define-syntax-rule (integer-write size)
+ (lambda (port integer)
+ "Write INTEGER to PORT as a SIZE-byte integer and as big endian."
+ (let ((bv (make-bytevector size)))
+ (bytevector-uint-set! bv 0 integer (endianness big) size)
+ (put-bytevector port bv))))
+
+(define put-u16 (integer-write 2))
+(define put-u32 (integer-write 4))
+(define put-u64 (integer-write 8))
+
+(define-syntax put-integers
+ (syntax-rules ()
+ "Write the given integers as big endian to PORT. For example:
+
+ (put-integers port u8 42 u32 #x7777)
+
+writes to PORT the value 42 as an 8-bit integer and the value #x7777 as a
+32-bit integer."
+ ((_ port)
+ #t)
+ ((_ port type value rest ...)
+ (let-syntax ((put (syntax-rules (u8 u16 u32 u64)
+ ((_ u8 port integer)
+ (put-u8 port integer))
+ ((_ u16 port integer)
+ (put-u16 port integer))
+ ((_ u32 port integer)
+ (put-u32 port integer))
+ ((_ u64 port integer)
+ (put-u64 port integer)))))
+ (begin
+ (put type port value)
+ (put-integers port rest ...))))))
+
+(define-syntax-rule (integers->bytevector type value rest ...)
+ "Return the the TYPE/VALUE integers representation as a bytevector."
+ (let-values (((port get) (open-bytevector-output-port)))
+ (put-integers port type value rest ...)
+ (force-output port)
+ (get)))
+
+
+(define (bytevector->bitnames bv names)
+ (define (bit-set? bv i)
+ (let ((idx (fxarithmetic-shift-right i 3))
+ (bit (fxand i #b111)))
+ (and (< idx (bytevector-length bv))
+ (fxbit-set? (bytevector-u8-ref bv idx) bit))))
+ (do ((names names (cdr names))
+ (i 0 (fx+ i 1))
+ (bits '()
+ (if (bit-set? bv i)
+ (cons (car names) bits)
+ bits)))
+ ((null? names) (reverse bits))))
+
+(define (openpgp-format-fingerprint bv)
+ (define (h i)
+ (string-pad (string-upcase
+ (number->string
+ (bytevector-u16-ref bv (* i 2) (endianness big))
+ 16))
+ 4 #\0))
+ (string-append (h 0) " " (h 1) " " (h 2) " " (h 3) " " (h 4)
+ " "
+ (h 5) " " (h 6) " " (h 7) " " (h 8) " " (h 9)))
+
+;;; Constants
+
+
+(define PACKET-SESSION-KEY 1)
+(define PACKET-SIGNATURE 2)
+(define PACKET-SYMMETRIC-SESSION-KEY 3)
+(define PACKET-ONE-PASS-SIGNATURE 4)
+(define PACKET-SECRET-KEY 5)
+(define PACKET-PUBLIC-KEY 6)
+(define PACKET-SECRET-SUBKEY 7)
+(define PACKET-COMPRESSED-DATA 8)
+(define PACKET-SYMMETRIC-ENCRYPTED-DATA 9)
+(define PACKET-MARKER 10)
+(define PACKET-LITERAL-DATA 11)
+(define PACKET-TRUST 12)
+(define PACKET-USER-ID 13)
+(define PACKET-PUBLIC-SUBKEY 14)
+(define PACKET-USER-ATTRIBUTE 17)
+(define PACKET-SYMMETRIC-ENCRYPTED/PROTECTED-DATA 18)
+(define PACKET-MDC 19)
+
+(define PUBLIC-KEY-RSA 1)
+(define PUBLIC-KEY-RSA-ENCRYPT-ONLY 2)
+(define PUBLIC-KEY-RSA-SIGN-ONLY 3)
+(define PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY 16)
+(define PUBLIC-KEY-DSA 17)
+(define PUBLIC-KEY-ECDH 18) ;RFC-6637
+(define PUBLIC-KEY-ECDSA 19) ;RFC-6639
+(define PUBLIC-KEY-ELGAMAL 20) ;encrypt + sign (legacy)
+(define PUBLIC-KEY-EDDSA 22) ;"not yet assigned" says GPG
+
+(define (public-key-algorithm id)
+ (cond ((= id PUBLIC-KEY-RSA) 'rsa)
+ ((= id PUBLIC-KEY-DSA) 'dsa)
+ ((= id PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) 'elgamal)
+ ((= id PUBLIC-KEY-EDDSA) 'eddsa)
+ (else id)))
+
+(define SYMMETRIC-KEY-PLAINTEXT 0)
+(define SYMMETRIC-KEY-IDEA 1)
+(define SYMMETRIC-KEY-TRIPLE-DES 2)
+(define SYMMETRIC-KEY-CAST5-128 3)
+(define SYMMETRIC-KEY-BLOWFISH-128 4)
+(define SYMMETRIC-KEY-AES-128 7)
+(define SYMMETRIC-KEY-AES-192 8)
+(define SYMMETRIC-KEY-AES-256 9)
+(define SYMMETRIC-KEY-TWOFISH-256 10)
+(define SYMMETRIC-KEY-CAMELLIA-128 11) ;RFC-5581
+(define SYMMETRIC-KEY-CAMELLIA-192 12)
+(define SYMMETRIC-KEY-CAMELLIA-256 13)
+
+(define (symmetric-key-algorithm id)
+ (cond ((= id SYMMETRIC-KEY-PLAINTEXT) 'plaintext)
+ ((= id SYMMETRIC-KEY-IDEA) 'idea)
+ ((= id SYMMETRIC-KEY-TRIPLE-DES) 'tdea)
+ ((= id SYMMETRIC-KEY-CAST5-128) 'cast5-128)
+ ((= id SYMMETRIC-KEY-BLOWFISH-128) 'blowfish-128)
+ ((= id SYMMETRIC-KEY-AES-128) 'aes-128)
+ ((= id SYMMETRIC-KEY-AES-192) 'aes-192)
+ ((= id SYMMETRIC-KEY-AES-256) 'aes-256)
+ ((= id SYMMETRIC-KEY-TWOFISH-256) 'twofish-256)
+ (else id)))
+
+(define HASH-MD5 1)
+(define HASH-SHA-1 2)
+(define HASH-RIPE-MD160 3)
+(define HASH-SHA-256 8)
+(define HASH-SHA-384 9)
+(define HASH-SHA-512 10)
+(define HASH-SHA-224 11)
+
+(define (openpgp-hash-algorithm id)
+ (cond ((= id HASH-MD5) (hash-algorithm md5))
+ ((= id HASH-SHA-1) (hash-algorithm sha1))
+ ((= id HASH-RIPE-MD160) (hash-algorithm rmd160))
+ ((= id HASH-SHA-256) (hash-algorithm sha256))
+ ((= id HASH-SHA-384) (hash-algorithm sha384))
+ ((= id HASH-SHA-512) (hash-algorithm sha512))
+ ((= id HASH-SHA-224) (hash-algorithm sha224))
+ (else (error "unknown hash algorithm" id))))
+
+(define COMPRESSION-UNCOMPRESSED 0)
+(define COMPRESSION-ZIP 1) ;deflate
+
+(define COMPRESSION-ZLIB 2)
+(define COMPRESSION-BZIP2 3)
+
+(define (compression-algorithm id)
+ (cond ((= id COMPRESSION-UNCOMPRESSED) 'uncompressed)
+ ((= id COMPRESSION-ZIP) 'deflate)
+ ((= id COMPRESSION-ZLIB) 'zlib)
+ ((= id COMPRESSION-BZIP2) 'bzip2)
+ (else id)))
+
+(define SUBPACKET-SIGNATURE-CTIME 2)
+(define SUBPACKET-SIGNATURE-ETIME 3)
+ ;; 4 = Exportable Certification
+
+(define SUBPACKET-TRUST-SIGNATURE 5)
+ ;; 6 = Regular Expression
+
+(define SUBPACKET-REVOCABLE 7)
+(define SUBPACKET-KEY-ETIME 9)
+(define SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS 11)
+ ;; 12 = Revocation Key
+
+(define SUBPACKET-ISSUER 16)
+(define SUBPACKET-NOTATION-DATA 20)
+(define SUBPACKET-PREFERRED-HASH-ALGORITHMS 21)
+(define SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS 22)
+(define SUBPACKET-KEY-SERVER-PREFERENCES 23)
+(define SUBPACKET-PREFERRED-KEY-SERVER 24)
+(define SUBPACKET-PRIMARY-USER-ID 25)
+(define SUBPACKET-POLICY-URI 26)
+(define SUBPACKET-KEY-FLAGS 27)
+(define SUBPACKET-SIGNER-USER-ID 28)
+(define SUBPACKET-REASON-FOR-REVOCATION 29)
+(define SUBPACKET-FEATURES 30)
+ ;; 31 = Signature Target
+
+(define SUBPACKET-EMBEDDED-SIGNATURE 32)
+
+(define SIGNATURE-BINARY #x00)
+(define SIGNATURE-TEXT #x01)
+(define SIGNATURE-STANDALONE #x02)
+(define SIGNATURE-GENERIC-CERT #x10)
+(define SIGNATURE-PERSONA-CERT #x11)
+(define SIGNATURE-CASUAL-CERT #x12)
+(define SIGNATURE-POSITIVE-CERT #x13)
+(define SIGNATURE-SUBKEY-BINDING #x18)
+(define SIGNATURE-PRIMARY-KEY-BINDING #x19)
+(define SIGNATURE-DIRECT #x1f)
+(define SIGNATURE-KEY-REVOCATION #x20)
+(define SIGNATURE-SUBKEY-REVOCATION #x28)
+(define SIGNATURE-CERT-REVOCATION #x30)
+(define SIGNATURE-TIMESTAMP #x40)
+(define SIGNATURE-THIRD-PARTY #x50)
+
+;;; Parsing
+
+ ;; Look at the tag byte and see if it looks reasonable, if it does
+ ;; then the file is likely not armored. Does not move the port
+ ;; position.
+
+(define (port-ascii-armored? p)
+ (let ((tag (lookahead-u8 p)))
+ (cond ((eof-object? tag) #f)
+ ((not (fxbit-set? tag 7)) #t)
+ (else
+ (let ((type (if (fxbit-set? tag 6)
+ (fxbit-field tag 0 6)
+ (fxbit-field tag 2 6))))
+ (not (<= PACKET-SESSION-KEY type PACKET-MDC)))))))
+
+(define (get-mpi p)
+ (let* ((bitlen (get-u16 p))
+ (bytelen (fxdiv (fx+ bitlen 7) 8)))
+ (print " MPI of length " bitlen " " (list bytelen))
+ (bytevector->uint (get-bytevector-n p bytelen))))
+
+(define (get-v4-length p)
+ ;; TODO: indeterminate length (only for data packets)
+ (let ((o1 (get-u8 p)))
+ (cond ((< o1 192) o1)
+ ((< o1 255)
+ (+ (fxarithmetic-shift-left (fx- o1 192) 8)
+ (get-u8 p)
+ 192))
+ ((= o1 255)
+ (get-u32 p)))))
+
+(define (get-packet p)
+ (if (port-eof? p)
+ (eof-object)
+ (get-packet* p get-data)))
+
+(define (get-packet* p get-data)
+ (let ((tag (get-u8 p)))
+ ;; (unless (fxbit-set? tag 7) (error 'get-packet "Invalid tag" tag))
+ (cond ((fxbit-set? tag 6) ;New packet format
+ (let ((tag (fxbit-field tag 0 6))
+ (len (get-v4-length p)))
+ (get-data p tag len)))
+ (else ;Old packet format
+ (let ((tag (fxbit-field tag 2 6))
+ (len (case (fxbit-field tag 0 2)
+ ((0) (get-u8 p))
+ ((1) (get-u16 p))
+ ((2) (get-u32 p))
+ ((3) #f))))
+ (get-data p tag len))))))
+
+(define (get-data p tag len)
+ (let ((pp (if len
+ (open-bytevector-input-port (get-bytevector-n p len))
+ p))) ;indeterminate length
+ (cond
+ ((= tag PACKET-SIGNATURE)
+ (get-signature pp))
+ ((= tag PACKET-PUBLIC-KEY)
+ (get-public-key pp #f))
+ ((= tag PACKET-TRUST)
+ 'openpgp-trust) ;non-standard format?
+ ((= tag PACKET-USER-ID)
+ (get-user-id pp len))
+ ((= tag PACKET-PUBLIC-SUBKEY)
+ (get-public-key pp #t))
+ ((= tag PACKET-USER-ATTRIBUTE)
+ (get-user-attribute pp len))
+ (else
+ (error 'get-data "Unsupported packet type" tag)))))
+
+;;; Signatures
+
+(define-record-type <openpgp-signature>
+ (make-openpgp-signature version type pkalg halg hashl16
+ append-data hashed-subpackets unhashed-subpackets
+ value)
+ openpgp-signature?
+ (version openpgp-signature-version)
+ (type openpgp-signature-type)
+ (pkalg openpgp-signature-pkalg)
+ (halg openpgp-signature-halg)
+ (hashl16 openpgp-signature-hashl16)
+ (append-data openpgp-signature-append-data) ;append to data when
hashing
+ (hashed-subpackets openpgp-signature-hashed-subpackets)
+ (unhashed-subpackets openpgp-signature-unhashed-subpackets)
+ (value openpgp-signature-value))
+
+(define (openpgp-signature-issuer sig)
+ (cond ((assq 'issuer (openpgp-signature-unhashed-subpackets sig)) => cdr)
+ ;; XXX: is the issuer always in the unhashed subpackets?
+ (else #f)))
+
+(define (openpgp-signature-creation-time sig)
+ (cond ((assq 'signature-ctime (openpgp-signature-hashed-subpackets sig))
+ => (lambda (x) (unixtime (cdr x))))
+ ;; XXX: should be an error?
+ (else #f)))
+
+(define (openpgp-signature-expiration-time sig)
+ (cond ((assq 'signature-etime (openpgp-signature-hashed-subpackets sig))
+ => (lambda (x)
+ (unixtime (+ (cdr x)
+ (openpgp-signature-creation-time sig)))))
+ (else #f)))
+
+
+ ;; Read one ASCII armored detached OpenPGP signature
+
+(define (get-openpgp-detached-signature/ascii p)
+ (define who 'get-openpgp-detached-signatures/ascii)
+ (let-values (((type data) (get-delimited-base64 p)))
+ (cond ((eof-object? data) data)
+ ((string=? type "PGP SIGNATURE")
+ (let ((pkt (get-packet (open-bytevector-input-port data))))
+ (unless (openpgp-signature? pkt)
+ (error who "Expected an OpenPGP signature" pkt))
+ pkt))
+ (else
+ (error who "Expected PGP SIGNATURE" type)))))
+
+ ;; returns (good-signature key-data)
+ ;; or (bad-signature key-data)
+ ;; or (missing-key key-id)
+
+(define (hash-algorithm-name algorithm) ;XXX: should be in Guile-Gcrypt
+ "Return the name of ALGORITHM, a 'hash-algorithm' integer, as a symbol."
+ (letrec-syntax ((->name (syntax-rules ()
+ ((_) #f)
+ ((_ name rest ...)
+ (if (= algorithm (hash-algorithm name))
+ 'name
+ (->name rest ...))))))
+ (->name sha1 sha256 sha384 sha512 sha224
+ sha3-224 sha3-256 sha3-384 sha3-512)))
+
+(define (verify-openpgp-signature sig keyring dataport)
+ "Verify that the data read from DATAPORT matches SIG, an
+<openpgp-signature>. Fetch the public key of the issuer of SIG from KEYRING,
+a keyring as returned by 'get-openpgp-keyring'. Return two values: a status
+symbol, such as 'bad-signature or 'missing-key, and additional info, such as
+the issuer's OpenPGP public key extracted from KEYRING."
+ (define (check key sig)
+ (let*-values (((hash-algorithm) (openpgp-signature-halg sig))
+ ((port get-hash) (open-hash-port hash-algorithm)))
+ (dump-port dataport port)
+
+ ;; As per RFC4880 Section 5.2.4 ("Computing Signatures"), hash some of
+ ;; the fields from the signature packet.
+ (for-each (cut put-bytevector port <>)
+ (openpgp-signature-append-data sig))
+ (close-port port)
+
+ (let* ((signature (openpgp-signature-value sig))
+ (public-key (openpgp-public-key-value key))
+ (hash (get-hash))
+ (data (sexp->canonical-sexp
+ `(data
+ (flags pkcs1) ;FIXME: pkcs1 is for RSA
+ (hash ,(hash-algorithm-name hash-algorithm)
+ ,hash)))))
+ (values (if (verify signature data public-key)
+ 'good-signature
+ 'bad-signature)
+ key))))
+
+ ;; TODO: Support SIGNATURE-TEXT.
+ (if (= (openpgp-signature-type sig) SIGNATURE-BINARY)
+ (let* ((issuer (openpgp-signature-issuer sig))
+ (key-data (match (vhash-assv issuer keyring)
+ ((_ . lst) lst)
+ (#f '()))))
+ ;; Find the primary key or subkey that made the signature.
+ (let ((key (find (lambda (k)
+ (and (openpgp-public-key? k)
+ (= (openpgp-public-key-id k) issuer)))
+ key-data)))
+ (if key
+ (begin
+ (print "Signature made with key: " key)
+ (check key sig))
+ (values 'missing-key issuer))))
+ (values 'unsupported-signature sig)))
+
+(define (get-signature p)
+ (define who 'get-signature)
+ (define (get-sig p pkalg)
+ (cond ((= pkalg PUBLIC-KEY-RSA)
+ (print "RSA signature")
+ (string->canonical-sexp
+ (format #f "(sig-val (rsa (s #~a#)))"
+ (string-hex-pad
+ (number->string (get-mpi p) 16)))))
+ ((= pkalg PUBLIC-KEY-DSA)
+ (print "DSA signature")
+ (let* ((r (get-mpi p)) (s (get-mpi p)))
+ (string->canonical-sexp
+ (format #f "(sig-val (dsa (r #~a#) (s #~a#)))"
+ (string-hex-pad (number->string r 16))
+ (string-hex-pad (number->string s 16))))))
+ ;; TODO: PUBLIC-KEY-EDDSA
+ (else
+ (list 'unsupported-algorithm
+ (public-key-algorithm pkalg)
+ (get-bytevector-all p)))))
+ (let ((version (get-u8 p)))
+ (case version
+ ((3)
+ (let-values (((hmlen type ctime keyid pkalg halg hashl16)
+ (get-integers p u8 u8 u32 u64 u8 u8 u16)))
+ (unless (= hmlen 5)
+ (error who "Invalid signature packet"))
+ (print "Signature type: " type " creation time: " (unixtime ctime))
+ (print "Hash algorithm: " (openpgp-hash-algorithm halg))
+ (let ((value (get-sig p pkalg)))
+ (unless (port-eof? p)
+ (print "Trailing data in signature: " (get-bytevector-all p)))
+ (make-openpgp-signature version type
+ (public-key-algorithm pkalg)
+ (openpgp-hash-algorithm halg) hashl16
+ (list (integers->bytevector u8 type
+ u32 ctime))
+ ;; Emulate hashed subpackets
+ (list (cons 'signature-ctime ctime))
+ ;; Unhashed subpackets
+ (list (cons 'issuer keyid))
+ value))))
+ ((4)
+ (let*-values (((type pkalg halg) (get-integers p u8 u8 u8))
+ ((hashed-subpackets)
+ (get-bytevector-n p (get-u16 p)))
+ ((unhashed-subpackets)
+ (get-bytevector-n p (get-u16 p)))
+ ((hashl16) (get-u16 p)))
+ (print "Signature type: " type)
+ (print "Hash algorithm: " (openpgp-hash-algorithm halg))
+ (let ((value (get-sig p pkalg)))
+ (unless (port-eof? p)
+ (print "Trailing data in signature: " (get-bytevector-all p)))
+ (let* ((subpacket-len (bytevector-length hashed-subpackets))
+ (append-data
+ (list
+ (integers->bytevector u8 version
+ u8 type
+ u8 pkalg
+ u8 halg
+ u16 subpacket-len)
+ hashed-subpackets
+ ;; http://www.rfc-editor.org/errata_search.php?rfc=4880
+ ;; Errata ID: 2214.
+ (integers->bytevector u8 #x04
+ u8 #xff
+ u32 (+ 6 subpacket-len)))))
+ (make-openpgp-signature version type
+ (public-key-algorithm pkalg)
+ (openpgp-hash-algorithm halg) hashl16
+ append-data
+ (parse-subpackets hashed-subpackets)
+ (parse-subpackets unhashed-subpackets)
+ value)))))
+ (else
+ (print "Unsupported signature version: " version)
+ 'unsupported-signature-version))))
+
+(define (parse-subpackets bv)
+ (define (parse tag data)
+ (let ((type (fxbit-field tag 0 7))
+ (critical? (fxbit-set? tag 7)))
+ (cond
+ ((= type SUBPACKET-SIGNATURE-CTIME)
+ (cons 'signature-ctime
+ (bytevector-u32-ref data 0 (endianness big))))
+ ((= type SUBPACKET-SIGNATURE-ETIME)
+ (cons 'signature-etime
+ (bytevector-u32-ref data 0 (endianness big))))
+ ((= type SUBPACKET-TRUST-SIGNATURE)
+ (cons 'trust-signature
+ (bytevector-u8-ref data 0)))
+ ((= type SUBPACKET-REVOCABLE)
+ (cons 'revocable
+ (= (bytevector-u8-ref data 0) 1)))
+ ((= type SUBPACKET-KEY-ETIME)
+ (cons 'key-etime
+ (bytevector-u32-ref data 0 (endianness big))))
+ ((= type SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS)
+ (cons 'preferred-symmetric-algorithms
+ (map symmetric-key-algorithm (bytevector->u8-list data))))
+ ((= type SUBPACKET-ISSUER)
+ (cons 'issuer
+ (bytevector-u64-ref data 0 (endianness big))))
+ ((= type SUBPACKET-NOTATION-DATA)
+ (let ((p (open-bytevector-input-port data)))
+ (let-values (((f1 nlen vlen)
+ (get-integers p u8 _ _ _ u16 u16)))
+ (let* ((name (get-bytevector-n p nlen))
+ (value (get-bytevector-n p vlen)))
+ (cons 'notation-data
+ (list (utf8->string name)
+ (if (fxbit-set? f1 7)
+ (utf8->string value)
+ value)))))))
+ ((= type SUBPACKET-PREFERRED-HASH-ALGORITHMS)
+ (cons 'preferred-hash-algorithms
+ (map openpgp-hash-algorithm (bytevector->u8-list data))))
+ ((= type SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS)
+ (cons 'preferred-compression-algorithms
+ (map compression-algorithm (bytevector->u8-list data))))
+ ((= type SUBPACKET-KEY-SERVER-PREFERENCES)
+ (cons 'key-server-preferences
+ (if (and (>= (bytevector-length data) 1)
+ (fxbit-set? (bytevector-u8-ref data 0) 7))
+ (list 'no-modify)
+ (list))))
+ ((= type SUBPACKET-PREFERRED-KEY-SERVER)
+ (cons 'preferred-key-server (utf8->string data)))
+ ((= type SUBPACKET-PRIMARY-USER-ID)
+ (cons 'primary-user-id (not (zero? (bytevector-u8-ref data 0)))))
+ ((= type SUBPACKET-POLICY-URI)
+ (cons 'policy-uri (utf8->string data)))
+ ((= type SUBPACKET-KEY-FLAGS)
+ (cons 'key-flags (bytevector->bitnames
+ data
+ '(certification sign-data
+ communications-encryption
+ storage-encryption
+ split-key authentication
+ group-key))))
+ ((= type SUBPACKET-SIGNER-USER-ID)
+ (cons 'signer-user-id (utf8->string data)))
+ ((= type SUBPACKET-REASON-FOR-REVOCATION)
+ (let* ((p (open-bytevector-input-port data))
+ (revocation-code (get-u8 p)))
+ (cons 'reason-for-revocation
+ (list revocation-code
+ (if (port-eof? p)
+ ""
+ (utf8->string (get-bytevector-all p)))))))
+ ((= type SUBPACKET-FEATURES)
+ (cons 'features (bytevector->bitnames
+ data '(modification-detection))))
+ ((= type SUBPACKET-EMBEDDED-SIGNATURE)
+ (cons 'embedded-signature
+ (get-signature (open-bytevector-input-port data))))
+ (else
+ ;; Unknown subpacket type. If it is critical, then the
+ ;; signature should be considered invalid.
+ (print "Unknown subpacket type: " type)
+ (list 'unsupported-subpacket type critical? data)))))
+ (let ((p (open-bytevector-input-port bv)))
+ (let lp ((subpackets '()))
+ ;; In case of multiple subpackets of the same type, the last
+ ;; one should be used. Therefore the list is not reversed
+ ;; here.
+ (if (port-eof? p)
+ subpackets
+ (let* ((len (- (get-v4-length p) 1))
+ (tag (get-u8 p))
+ (sp (parse tag (get-bytevector-n p len))))
+ (print "#;Subpacket " sp)
+ (lp (cons sp subpackets)))))))
+
+;;; Public keys
+
+
+(define-record-type <openpgp-public-key>
+ (make-openpgp-public-key version subkey? time value fingerprint)
+ openpgp-public-key?
+ (version openpgp-public-key-version)
+ (subkey? openpgp-public-key-subkey?)
+ (time openpgp-public-key-time)
+ (value openpgp-public-key-value)
+ (fingerprint openpgp-public-key-fingerprint))
+
+(define (openpgp-public-key-id k)
+ (let ((bv (openpgp-public-key-fingerprint k)))
+ (bytevector-u64-ref bv
+ (- (bytevector-length bv) 8)
+ (endianness big))))
+
+(define (get-public-key p subkey?)
+ (define who 'get-public-key)
+ (define (fingerprint p)
+ (let ((len (port-position p)))
+ (set-port-position! p 0)
+ (let-values (((sha1-port get)
+ (open-hash-port (hash-algorithm sha1))))
+ (put-u8 sha1-port #x99)
+ (put-bytevector sha1-port
+ (uint-list->bytevector (list len)
+ (endianness big)
+ 2))
+ (dump-port p sha1-port)
+ (close-port sha1-port)
+ (get))))
+ (define (get-key p alg)
+ (cond ((= alg PUBLIC-KEY-RSA)
+ (print "Public RSA key")
+ (let* ((n (get-mpi p)) (e (get-mpi p)))
+ (string->canonical-sexp
+ (format #f "(public-key (rsa (n #~a#) (e #~a#)))"
+ (string-hex-pad (number->string n 16))
+ (string-hex-pad (number->string e 16))))))
+ ((= alg PUBLIC-KEY-DSA)
+ (print "Public DSA key")
+ (let* ((p* (get-mpi p)) (q (get-mpi p))
+ (g (get-mpi p)) (y (get-mpi p)))
+ (make-dsa-public-key p* q g y)))
+ #;
+ ((= alg PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) ; ; ; ;
+ (print "Public El-Gamal Key") ; ; ; ;
+ (let* ((p* (get-mpi p)) (g (get-mpi p)) (y (get-mpi p))) ; ; ; ;
+ (make-public-elgamal-key p* g y)))
+ ((= alg PUBLIC-KEY-EDDSA)
+ ;; See
+ ;; <https://tools.ietf.org/html/draft-koch-eddsa-for-openpgp-04>
+ ;; and openpgp-oid.c in GnuPG.
+ (print "EdDSA signature")
+ (let* ((len (get-u8 p))
+ (oid (bytevector->uint (get-bytevector-n p len)))
+ (q (get-mpi p)))
+ (define curve
+ (match oid
+ (#x2b06010401da470f01 'Ed25519)
+ (#x2b060104019755010501 'Curve25519)))
+
+ (string->canonical-sexp
+ (format #f "(public-key (curve ~a)(flags eddsa)(q #~a#))"
+ curve
+ (string-hex-pad (number->string q 16))))))
+ (else
+ (list 'unsupported-algorithm
+ (public-key-algorithm alg)
+ (get-bytevector-all p)))))
+ (let ((version (get-u8 p)))
+ (case version
+ ((4)
+ (let-values (((ctime alg) (get-integers p u32 u8)))
+ (print "Key creation time: " (unixtime ctime))
+ (let ((key (get-key p alg)))
+ (unless (port-eof? p)
+ ;; Probably an error? Gonna cause trouble anyway.
+ (print "Trailing data in public key: " (get-bytevector-all p)))
+ (let ((digest (fingerprint p)))
+ (make-openpgp-public-key version subkey? ctime key
+ digest)))))
+ (else
+ (print "Unsupported public key version: " version)
+ 'unsupported-public-key-version))))
+
+(define (openpgp-public-key-primary? key)
+ (and (openpgp-public-key? key)
+ (not (openpgp-public-key-subkey? key))))
+
+;;; User IDs and User attributes
+
+
+(define-record-type <openpgp-user-id>
+ (make-openpgp-user-id value unparsed)
+ openpgp-user-id?
+ (value openpgp-user-id-value)
+ (unparsed openpgp-user-id-unparsed))
+
+(define (get-user-id p len)
+ (let ((unparsed (get-bytevector-n p len)))
+ (make-openpgp-user-id (utf8->string unparsed) unparsed)))
+
+(define-record-type <openpgp-user-attribute>
+ (make-openpgp-user-attribute unparsed)
+ openpgp-user-attribute?
+ (unparsed openpgp-user-attribute-unparsed))
+
+(define (get-user-attribute p len)
+ (let ((bv (get-bytevector-n p len)))
+ ;; TODO: bv contains subpackets. Type 1 is JFIF.
+ (make-openpgp-user-attribute bv)))
+
+;;; Keyring management
+
+ ;; Reads a keyring from the binary input port p. It must not be
+ ;; ASCII armored.
+
+(define* (get-openpgp-keyring port #:optional (keyring vlist-null)
+ #:key (limit -1))
+ (let lp ((pkt (get-packet port))
+ (limit limit)
+ (keyring keyring))
+ (print "#;key " pkt)
+ (cond ((or (zero? limit) (eof-object? pkt))
+ keyring)
+ ((openpgp-public-key-primary? pkt)
+ (pk 'primary pkt)
+ ;; Read signatures, user id's, subkeys
+ (let lp* ((pkt (get-packet port))
+ (pkts (list pkt))
+ (key-ids (list (openpgp-public-key-id pkt))))
+ (print "#;keydata " pkt)
+ (cond ((or (eof-object? pkt)
+ (eq? pkt 'unsupported-public-key-version)
+ (openpgp-public-key-primary? pkt))
+ ;; KEYRING is indexed by key-id. Key ids for both the
+ ;; primary key and subkeys all point to the list of
+ ;; packets.
+ (lp pkt
+ (- limit 1)
+ (fold (cut vhash-consv <> pkts <>) keyring key-ids)))
+ ((openpgp-public-key? pkt) ;subkey
+ (lp* (get-packet port) (cons pkt pkts)
+ (cons (openpgp-public-key-id pkt) key-ids)))
+ (else
+ (lp* (get-packet port) (cons pkt pkts) key-ids)))))
+ (else
+ ;; Skip until there's a primary key. Ignore errors...
+ (lp (get-packet port) limit keyring)))))
+
+ ;; XXX: should probably detect ascii armoring
+
+(define (openpgp-keyring-from-file filename)
+ (call-with-input-file filename
+ (lambda (p) (get-openpgp-keyring p))))
+
+
+;;;
+;;; Radix-64 (RFC4880).
+;;;
+
+(define (crc24 bv)
+ "Compute a CRC24 as described in RFC4880, Section 6.1."
+ (define poly #x1864cfb)
+
+ (let loop ((crc #xb704ce)
+ (index 0))
+ (if (= index (bytevector-length bv))
+ (logand crc #xffffff)
+ (let ((crc (logxor (ash (bytevector-u8-ref bv index) 16)
+ crc)))
+ (let inner ((i 0)
+ (crc crc))
+ (if (< i 8)
+ (let ((crc (ash crc 1)))
+ (inner (+ i 1)
+ (if (zero? (logand crc #x1000000))
+ crc
+ (logxor crc poly))))
+ (loop crc (+ index 1))))))))
+
+(define %begin-block-prefix "-----BEGIN PGP ")
+(define %begin-block-suffix "-----")
+
+(define %end-block-prefix "-----END PGP ")
+(define %end-block-suffix "-----")
+
+(define (read-radix-64 port)
+ "Read from PORT an ASCII-armored Radix-64 stream, decode it, and return the
+result as a bytevector. Return #f if PORT does not contain a valid Radix-64
+stream."
+ ;; This is the same as 'get-delimited-base64', except that it implements the
+ ;; CRC24 check.
+ (define (skip-headers port)
+ ;; Skip the Radix-64 "armor headers".
+ (match (read-line port)
+ ((? eof-object? eof) eof)
+ ((= string-trim-both "") "")
+ (_ (skip-headers port))))
+
+ (let ((line (string-trim-right (read-line port))))
+ (and (string-prefix? %begin-block-prefix line)
+ (string-suffix? %begin-block-suffix line)
+ (let* ((kind (string-drop-right
+ (string-drop line (string-length %begin-block-prefix))
+ (string-length %begin-block-suffix)))
+ (end (string-append %end-block-prefix kind
+ %end-block-suffix)))
+ (skip-headers port)
+ (let loop ((lines '()))
+ (let ((line (read-line port)))
+ (match line
+ ((? eof-object?)
+ #f)
+ ((= string-trim-both "")
+ (loop lines))
+ ((= string-trim-both str)
+ (if (string=? str end)
+ (match lines
+ ((crc lines ...)
+ ;; The last line should be the CRC, starting with an
+ ;; "=" sign.
+ (let ((crc (and (string-prefix? "=" crc)
+ (base64-decode (string-drop crc 1))))
+ (data (base64-decode
+ (string-concatenate-reverse lines))))
+ (and crc (= (bytevector->uint crc) (crc24 data))
+ data)))
+ (_
+ #f))
+ (loop (cons str lines)))))))))))