tests/openpgp/quick-key-manipulation.scm

   1 #!/usr/bin/env gpgscm
   2
   3 ;; Copyright (C) 2016 g10 Code GmbH
   4 ;;
   5 ;; This file is part of GnuPG.
   6 ;;
   7 ;; GnuPG is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 3 of the License, or
  10 ;; (at your option) any later version.
  11 ;;
  12 ;; GnuPG is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program; if not, see <http://www.gnu.org/licenses/>.
  19
  20 (load (with-path "defs.scm"))
  21 (setup-environment)
  22
  23  ;; XXX because of --always-trust, the trustdb is not created.
  24  ;; Therefore, we redefine GPG without --always-trust.
  25 (define GPG `(,(tool 'gpg) --no-permission-warning))
  26
  27 (define (exact id)
  28   (string-append "=" id))
  29
  30 (define (count-uids-of-secret-key id)
  31   (length (filter (lambda (x) (and (string=? "uid" (car x))
  32                                    (not (string=? "r" (cadr x)))))
  33                   (gpg-with-colons
  34                    `(--with-fingerprint
  35                      --list-secret-keys ,(exact id))))))
  36
  37 (define alpha "Alpha <alpha@invalid.example.net>")
  38 (define bravo "Bravo <bravo@invalid.example.net>")
  39
  40 (define (key-data key)
  41   (filter (lambda (x) (or (string=? (car x) "pub")
  42                           (string=? (car x) "sub")))
  43           (gpg-with-colons `(-k ,key))))
  44
  45 (setenv "PINENTRY_USER_DATA" "test" #t)
  46
  47 (info "Checking quick key generation...")
  48 (call-check `(,@GPG --quick-generate-key ,alpha))
  49
  50 (define keyinfo (gpg-with-colons `(-k ,(exact alpha))))
  51 (define fpr (:fpr (assoc "fpr" keyinfo)))
  52
  53 (assert (= 1 (count-uids-of-secret-key alpha)))
  54 (assert (not (equal? "" (:expire (assoc "pub" keyinfo)))))
  55
  56 (info "Checking that we can add a user ID...")
  57
  58 ;; Make sure the key capabilities don't change when we add a user id.
  59 ;; (See bug #2697.)
  60 (let ((pre (key-data (exact alpha)))
  61       (result (call-check `(,@GPG --quick-add-uid ,(exact alpha) ,bravo)))
  62       (post (key-data (exact alpha))))
  63   (if (not (equal? pre post))
  64       (begin
  65         (display "Key capabilities changed when adding a user id:")
  66         (newline)
  67         (display "  Pre: ")
  68         (display pre)
  69         (newline)
  70         (display " Post: ")
  71         (display post)
  72         (newline)
  73         (exit 1))))
  74
  75 (assert (= 2 (count-uids-of-secret-key alpha)))
  76 (assert (= 2 (count-uids-of-secret-key bravo)))
  77
  78 (info "Checking that we can revoke a user ID...")
  79 (call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,alpha))
  80
  81 (assert (= 1 (count-uids-of-secret-key bravo)))
  82
  83 (info "Checking that we can change the expiration time.")
  84
  85 (define (expiration-time id)
  86   (:expire (assoc "pub" (gpg-with-colons `(-k ,id)))))
  87
  88 ;; Remove the expiration date.
  89 (call-check `(,@gpg --quick-set-expire ,fpr "0"))
  90 (assert (equal? "" (expiration-time fpr)))
  91
  92 ;; Make the key expire in one year.
  93 (call-check `(,@gpg --quick-set-expire ,fpr "1y"))
  94 ;; XXX It'd be nice to check that the value is right.
  95 (assert (not (equal? "" (expiration-time fpr))))
  96
  97
  98 ;;
  99 ;; Check --quick-addkey
 100 ;;
 101
 102 ;; Get the subkeys.
 103 (define (get-subkeys)
 104   (filter (lambda (x) (equal? "sub" (car x)))
 105           (gpg-with-colons `(-k ,fpr))))
 106
 107 ;; This keeps track of the number of subkeys.
 108 (define count (length (get-subkeys)))
 109
 110 (for-each-p
 111  "Checking that we can add subkeys..."
 112  (lambda (args check)
 113    (set! count (+ 1 count))
 114    (call-check `(,@gpg --quick-add-key ,fpr ,@args))
 115    (let ((subkeys (get-subkeys)))
 116      (assert (= count (length subkeys)))
 117      (if check (check (last subkeys)))))
 118  ;; A bunch of arguments...
 119  '(()
 120    (- - -)
 121    (default default never)
 122    (rsa sign "2d")
 123    (rsa1024 sign "2w")
 124    (rsa2048 encr "2m")
 125    (rsa4096 sign,auth "2y")
 126    (future-default))
 127  ;; ... with functions to check that the created key matches the
 128  ;; expectations (or #f for no tests).
 129  (list
 130   #f
 131   #f
 132   (lambda (subkey)
 133     (assert (equal? "" (:expire subkey))))
 134   (lambda (subkey)
 135     (assert (= 1 (:alg subkey)))
 136     (assert (string-contains? (:cap subkey) "s"))
 137     (assert (not (equal? "" (:expire subkey)))))
 138   (lambda (subkey)
 139     (assert (= 1 (:alg subkey)))
 140     (assert (= 1024 (:length subkey)))
 141     (assert (string-contains? (:cap subkey) "s"))
 142     (assert (not (equal? "" (:expire subkey)))))
 143   (lambda (subkey)
 144     (assert (= 1 (:alg subkey)))
 145     (assert (= 2048 (:length subkey)))
 146     (assert (string-contains? (:cap subkey) "e"))
 147     (assert (not (equal? "" (:expire subkey)))))
 148   (lambda (subkey)
 149     (assert (= 1 (:alg subkey)))
 150     (assert (= 4096 (:length subkey)))
 151     (assert (string-contains? (:cap subkey) "s"))
 152     (assert (string-contains? (:cap subkey) "a"))
 153     (assert (not (equal? "" (:expire subkey)))))
 154   #f))