tests/openpgp/quick-key-manipulation.scm

   1 #!/usr/bin/env gpgscm
   2
   3 ;; Copyright (C) 2016-2017 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 (in-srcdir "tests" "openpgp" "defs.scm"))
  21 (load (with-path "time.scm"))
  22 (setup-environment)
  23
  24 (define (exact id)
  25   (string-append "=" id))
  26
  27 (define (count-uids-of-secret-key id)
  28   (length (filter (lambda (x) (and (string=? "uid" (car x))
  29                                    (not (string=? "r" (cadr x)))))
  30                   (gpg-with-colons
  31                    `(--with-fingerprint
  32                      --list-secret-keys ,(exact id))))))
  33
  34 (define alpha "Alpha <alpha@invalid.example.net>")
  35 (define bravo "Bravo <bravo@invalid.example.net>")
  36 (define charlie "Charlie <charlie@invalid.example.net>")
  37
  38 (define (key-data key)
  39   (filter (lambda (x) (or (string=? (car x) "pub")
  40                           (string=? (car x) "sub")))
  41           (gpg-with-colons `(-k ,key))))
  42
  43 (setenv "PINENTRY_USER_DATA" "test" #t)
  44
  45 (info "Checking quick key generation...")
  46 (call-check `(,@GPG --quick-generate-key ,alpha))
  47
  48 (define keyinfo (gpg-with-colons `(-k ,(exact alpha))))
  49 (define fpr (:fpr (assoc "fpr" keyinfo)))
  50
  51 (assert (= 1 (count-uids-of-secret-key alpha)))
  52 (assert (not (equal? "" (:expire (assoc "pub" keyinfo)))))
  53
  54 (info "Checking that we can add a user ID...")
  55
  56 ;; Make sure the key capabilities don't change when we add a user id.
  57 ;; (See bug #2697.)
  58 (let ((pre (key-data (exact alpha)))
  59       (result (call-check `(,@GPG --quick-add-uid ,(exact alpha) ,bravo)))
  60       (post (key-data (exact alpha))))
  61   (if (not (equal? pre post))
  62       (begin
  63         (display "Key capabilities changed when adding a user id:")
  64         (newline)
  65         (display "  Pre: ")
  66         (display pre)
  67         (newline)
  68         (display " Post: ")
  69         (display post)
  70         (newline)
  71         (exit 1))))
  72
  73 (assert (= 2 (count-uids-of-secret-key alpha)))
  74 (assert (= 2 (count-uids-of-secret-key bravo)))
  75
  76 (info "Checking that we can mark an user ID as primary.")
  77 (call-check `(,@gpg --quick-set-primary-uid ,(exact alpha) ,alpha))
  78 (call-check `(,@gpg --quick-set-primary-uid ,(exact alpha) ,bravo))
  79 ;; XXX I don't know how to verify this.  The keylisting does not seem
  80 ;; to indicate the primary UID.
  81
  82 (info "Checking that we get an error making non-existent user ID the primary one.")
  83 (catch '()
  84        (call-check `(,@GPG --quick-set-primary-uid ,(exact alpha) ,charlie))
  85        (error "Expected an error, but get none."))
  86
  87 (info "Checking that we can revoke a user ID...")
  88 (call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,alpha))
  89
  90 (info "Checking that we get an error revoking a non-existent user ID.")
  91 (catch '()
  92        (call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,charlie))
  93        (error "Expected an error, but get none."))
  94
  95 (info "Checking that we get an error revoking the last valid user ID.")
  96 (catch '()
  97        (call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,bravo))
  98        (error "Expected an error, but get none."))
  99
 100 (assert (= 1 (count-uids-of-secret-key bravo)))
 101
 102 (info "Checking that we can change the expiration time.")
 103
 104 (define (expiration-time id)
 105   (:expire (assoc "pub" (gpg-with-colons `(-k ,id)))))
 106
 107 ;; Remove the expiration date.
 108 (call-check `(,@gpg --quick-set-expire ,fpr "0"))
 109 (assert (equal? "" (expiration-time fpr)))
 110
 111 ;; Make the key expire in one year.
 112 (call-check `(,@gpg --quick-set-expire ,fpr "1y"))
 113 (assert (time-matches? (+ (get-time) (years->seconds 1))
 114                        (string->number (expiration-time fpr))
 115                        (minutes->seconds 5)))
 116
 117
 118 ;;
 119 ;; Check --quick-addkey
 120 ;;
 121
 122 ;; Get the subkeys.
 123 (define (get-subkeys)
 124   (filter (lambda (x) (equal? "sub" (car x)))
 125           (gpg-with-colons `(-k ,fpr))))
 126
 127 ;; This keeps track of the number of subkeys.
 128 (define count (length (get-subkeys)))
 129
 130 (for-each-p
 131  "Checking that we can add subkeys..."
 132  (lambda (args check)
 133    (set! count (+ 1 count))
 134    (call-check `(,@gpg --quick-add-key ,fpr ,@args))
 135    (let ((subkeys (get-subkeys)))
 136      (assert (= count (length subkeys)))
 137      (if check (check (last subkeys)))))
 138  ;; A bunch of arguments...
 139  '(()
 140    (- - -)
 141    (default default never)
 142    (rsa "sign auth encr" "seconds=600") ;; GPGME uses this
 143    (rsa "auth,encr" "2") ;; "without a letter, days is assumed"
 144    ;; Sadly, the timestamp is truncated by the use of time_t on
 145    ;; systems where time_t is a signed 32 bit value.
 146    (rsa "sign" "2038-01-01")      ;; unix millennium
 147    (rsa "sign" "20380101T115500") ;; unix millennium
 148    ;; Once fixed, we can use later timestamps:
 149    ;; (rsa "sign" "2105-01-01")      ;; "last year GnuPG can represent is 2105"
 150    ;; (rsa "sign" "21050101T115500") ;; "last year GnuPG can represent is 2105"
 151    (rsa sign "2d")
 152    (rsa1024 sign "2w")
 153    (rsa2048 encr "2m")
 154    (rsa4096 sign,auth "2y")
 155    (future-default))
 156  ;; ... with functions to check that the created key matches the
 157  ;; expectations (or #f for no tests).
 158  (list
 159   #f
 160   #f
 161   (lambda (subkey)
 162     (assert (equal? "" (:expire subkey))))
 163   (lambda (subkey)
 164     (assert (= 1 (:alg subkey)))
 165     (assert (string-contains? (:cap subkey) "s"))
 166     (assert (string-contains? (:cap subkey) "a"))
 167     (assert (string-contains? (:cap subkey) "e"))
 168     (assert (time-matches? (+ (get-time) 600)
 169                            (string->number (:expire subkey))
 170                            (minutes->seconds 5))))
 171   (lambda (subkey)
 172     (assert (= 1 (:alg subkey)))
 173     (assert (string-contains? (:cap subkey) "a"))
 174     (assert (string-contains? (:cap subkey) "e"))
 175     (assert (time-matches? (+ (get-time) (days->seconds 2))
 176                            (string->number (:expire subkey))
 177                            (minutes->seconds 5))))
 178   (lambda (subkey)
 179     (assert (= 1 (:alg subkey)))
 180     (assert (string-contains? (:cap subkey) "s"))
 181     (assert (time-matches? 2145960000    ;; UTC 2038-01-01 12:00:00
 182                            ;; 4260254400 ;; UTC 2105-01-01 12:00:00
 183                            (string->number (:expire subkey))
 184                            ;; GnuPG choses the middle of the day (local time)
 185                            ;; when no hh:mm:ss is specified
 186                            (days->seconds 1))))
 187   (lambda (subkey)
 188     (assert (= 1 (:alg subkey)))
 189     (assert (string-contains? (:cap subkey) "s"))
 190     (assert (time-matches? 2145959700    ;; UTC 2038-01-01 11:55:00
 191                            ;; 4260254100 ;; UTC 2105-01-01 11:55:00
 192                            (string->number (:expire subkey))
 193                            (minutes->seconds 5))))
 194   (lambda (subkey)
 195     (assert (= 1 (:alg subkey)))
 196     (assert (string-contains? (:cap subkey) "s"))
 197     (assert (time-matches? (+ (get-time) (days->seconds 2))
 198                            (string->number (:expire subkey))
 199                            (minutes->seconds 5))))
 200   (lambda (subkey)
 201     (assert (= 1 (:alg subkey)))
 202     (assert (= 1024 (:length subkey)))
 203     (assert (string-contains? (:cap subkey) "s"))
 204     (assert (time-matches? (+ (get-time) (weeks->seconds 2))
 205                            (string->number (:expire subkey))
 206                            (minutes->seconds 5))))
 207   (lambda (subkey)
 208     (assert (= 1 (:alg subkey)))
 209     (assert (= 2048 (:length subkey)))
 210     (assert (string-contains? (:cap subkey) "e"))
 211     (assert (time-matches? (+ (get-time) (months->seconds 2))
 212                            (string->number (:expire subkey))
 213                            (minutes->seconds 5))))
 214   (lambda (subkey)
 215     (assert (= 1 (:alg subkey)))
 216     (assert (= 4096 (:length subkey)))
 217     (assert (string-contains? (:cap subkey) "s"))
 218     (assert (string-contains? (:cap subkey) "a"))
 219     (assert (time-matches? (+ (get-time) (years->seconds 2))
 220                            (string->number (:expire subkey))
 221                            (minutes->seconds 5))))
 222   #f))