tests/openpgp/defs.scm

   1 ;; Common definitions for the OpenPGP test scripts.
   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 ;;
  21 ;; Constants.
  22 ;;
  23
  24 (define usrname1 "one@example.com")
  25 (define usrpass1 "def")
  26 (define usrname2 "two@example.com")
  27 (define usrpass2 "")
  28 (define usrname3 "three@example.com")
  29 (define usrpass3 "")
  30
  31 (define dsa-usrname1 "pgp5")
  32 ;; we use the sub key because we do not yet have the logic to to derive
  33 ;; the first encryption key from a keyblock (I guess) (Well of course
  34 ;; we have this by now and the notation below will lookup the primary
  35 ;; first and then search for the encryption subkey.)
  36 (define dsa-usrname2 "0xCB879DE9")
  37
  38 (define keys
  39   (package
  40    (define (new fpr grip uids subkeys)
  41      (package))
  42    (define (subkey fpr grip)
  43      (package))
  44    (define alfa (new "A0FF4590BB6122EDEF6E3C542D727CC768697734"
  45                      "76F7E2B35832976B50A27A282D9B87E44577EB66"
  46                      '("alfa@example.net" "alpha@example.net")
  47                      (list
  48                       (subkey "3B3FBC948FE59301ED629EFB6AE6D7EE46A871F8"
  49                               "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"))))
  50    (define one (new "289B0EF1D105E124B6F626020EF77096D74C5F22"
  51                     "50B2D4FA4122C212611048BC5FC31BD44393626E"
  52                     '("one@example.com")
  53                     (list
  54                      (subkey "EB467DCA4AD7676A6A62B2ABABAB28A247BE2775"
  55                              "7E201E28B6FEB2927B321F443205F4724EBE637E"))))
  56    (define two (new "C1DEBB34EA8B71009EAFA474973D50E1C40FDECF"
  57                     "343D8AF79796EE107D645A2787A9D9252F924E6F"
  58                     '("two@example.com")
  59                     (list
  60                      (subkey "CD3D0F5701CBFCACB2A4907305A37887B27907AA"
  61                              "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"))))))
  62
  63 (define key-file1 "samplekeys/rsa-rsa-sample-1.asc")
  64 (define key-file2 "samplekeys/ed25519-cv25519-sample-1.asc")
  65
  66 (define plain-files '("plain-1" "plain-2" "plain-3"))
  67 (define data-files '("data-500" "data-9000" "data-32000" "data-80000"))
  68 (define exp-files '())
  69
  70 (let ((verbose (string->number (getenv "verbose"))))
  71   (if (number? verbose)
  72       (*set-verbose!* verbose)))
  73
  74 (define (qualify executable)
  75   (string-append executable (getenv "EXEEXT")))
  76
  77 (define (getenv' key default)
  78   (let ((value (getenv key)))
  79     (if (string=? "" value)
  80         default
  81         value)))
  82
  83 (define tools
  84   '((gpgv "GPGV" "g10/gpgv")
  85     (gpg-connect-agent "GPG_CONNECT_AGENT" "tools/gpg-connect-agent")
  86     (gpgconf "GPGCONF" "tools/gpgconf")
  87     (gpg-preset-passphrase "GPG_PRESET_PASSPHRASE"
  88                            "agent/gpg-preset-passphrase")
  89     (gpgtar "GPGTAR" "tools/gpgtar")
  90     (gpg-zip "GPGZIP" "tools/gpg-zip")
  91     (pinentry "PINENTRY" "tests/openpgp/fake-pinentry")))
  92
  93 (define (tool-hardcoded which)
  94   (let ((t (assoc which tools))
  95         (prefix (getenv "BIN_PREFIX")))
  96     (getenv' (cadr t)
  97              (qualify (if (string=? prefix "")
  98                           (string-append (getenv "objdir") "/" (caddr t))
  99                           (string-append prefix "/" (basename (caddr t))))))))
 100
 101 (define (gpg-conf . args)
 102   (let ((s (call-popen `(,(tool-hardcoded 'gpgconf) ,@args) "")))
 103     (map (lambda (line) (string-split line #\:))
 104          (string-split-newlines s))))
 105 (define :gc:c:name car)
 106 (define :gc:c:description cadr)
 107 (define :gc:c:pgmname caddr)
 108
 109 (setenv "GNUPG_BUILDDIR" (getenv "objdir") #t)
 110 (define gpg-components (gpg-conf '--build-prefix (getenv "objdir")
 111                                  '--list-components))
 112
 113 (define (tool which)
 114   (case which
 115     ((gpg gpg-agent scdaemon gpgsm dirmngr)
 116      (:gc:c:pgmname (assoc (symbol->string which) gpg-components)))
 117     (else
 118      (tool-hardcoded which))))
 119
 120 (define (gpg-has-option? option)
 121   (string-contains? (call-popen `(,(tool 'gpg) --dump-options) "")
 122                     option))
 123
 124 (define have-opt-always-trust
 125   (catch #f
 126          (call-check `(,(tool 'gpg) --gpgconf-test --always-trust))
 127          #t))
 128
 129 (define GPG `(,(tool 'gpg) --no-permission-warning
 130               ,@(if have-opt-always-trust '(--always-trust) '())))
 131 (define GPGV `(,(tool 'gpgv)))
 132 (define PINENTRY (tool 'pinentry))
 133
 134 (define (tr:gpg input args)
 135   (tr:spawn input `(,@GPG --output **out** ,@args **in**)))
 136
 137 (define (pipe:gpg args)
 138   (pipe:spawn `(,@GPG --output - ,@args -)))
 139
 140 (define (gpg-with-colons args)
 141   (let ((s (call-popen `(,@GPG --with-colons ,@args) "")))
 142     (map (lambda (line) (string-split line #\:))
 143          (string-split-newlines s))))
 144
 145 ;; Convenient accessors for the colon output.
 146 (define (:type x)   (string->symbol (list-ref x 0)))
 147 (define (:length x) (string->number (list-ref x 2)))
 148 (define (:alg x) (string->number (list-ref x 3)))
 149 (define (:expire x) (list-ref x 6))
 150 (define (:fpr x) (list-ref x 9))
 151 (define (:cap x) (list-ref x 11))
 152
 153 (define (have-public-key? key)
 154   (catch #f
 155          (pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
 156                                          (equal? key::fpr (:fpr l))))
 157                         (gpg-with-colons `(--list-keys ,key::fpr))))))
 158
 159 (define (have-secret-key? key)
 160   (catch #f
 161          (pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
 162                                          (equal? key::fpr (:fpr l))))
 163                         (gpg-with-colons `(--list-secret-keys ,key::fpr))))))
 164
 165 (define (have-secret-key-file? key)
 166   (file-exists? (path-join (getenv "GNUPGHOME") "private-keys-v1.d"
 167                            (string-append key::grip ".key"))))
 168
 169 (define (get-config what)
 170   (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;))
 171
 172 (define all-pubkey-algos (delay (get-config "pubkeyname")))
 173 (define all-hash-algos (delay (get-config "digestname")))
 174 (define all-cipher-algos (delay (get-config "ciphername")))
 175 (define all-compression-algos (delay (get-config "compressname")))
 176
 177 (define (have-pubkey-algo? x)
 178   (not (not (member x (force all-pubkey-algos)))))
 179 (define (have-hash-algo? x)
 180   (not (not (member x (force all-hash-algos)))))
 181 (define (have-cipher-algo? x)
 182   (not (not (member x (force all-cipher-algos)))))
 183
 184 (define (gpg-pipe args0 args1 errfd)
 185   (lambda (source sink)
 186     (let* ((p (pipe))
 187            (task0 (spawn-process-fd `(,@GPG ,@args0)
 188                    source (:write-end p) errfd))
 189            (_ (close (:write-end p)))
 190            (task1 (spawn-process-fd `(,@GPG ,@args1)
 191                    (:read-end p) sink errfd)))
 192       (close (:read-end p))
 193       (wait-processes (list GPG GPG) (list task0 task1) #t))))
 194
 195 (setenv "GPG_AGENT_INFO" "" #t)
 196 (setenv "GNUPGHOME" (getcwd) #t)
 197
 198 ;;
 199 ;; GnuPG helper.
 200 ;;
 201
 202 ;; Call GPG to obtain the hash sums.  Either specify an input file in
 203 ;; ARGS, or an string in INPUT.  Returns a list of (<algo>
 204 ;; "<hashsum>") lists.
 205 (define (gpg-hash-string args input)
 206   (map
 207    (lambda (line)
 208      (let ((p (string-split line #\:)))
 209        (list (string->number (cadr p)) (caddr p))))
 210    (string-split-newlines
 211     (call-popen `(,@GPG --with-colons ,@args) input))))
 212
 213 ;; Dearmor a file.
 214 (define (dearmor source-name sink-name)
 215   (pipe:do
 216    (pipe:open source-name (logior O_RDONLY O_BINARY))
 217    (pipe:spawn `(,@GPG --dearmor))
 218    (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
 219
 220 ;;
 221 ;; Support for test environment creation and teardown.
 222 ;;
 223
 224 (define (make-test-data filename size)
 225   (call-with-binary-output-file
 226    filename
 227    (lambda (port)
 228      (display (make-random-string size) port))))
 229
 230 (define (create-gpghome)
 231   (log "Creating test environment...")
 232
 233   (srandom (getpid))
 234   (make-test-data "random_seed" 600)
 235
 236   (log "Creating configuration files")
 237   (for-each
 238    (lambda (name)
 239      (file-copy (in-srcdir (string-append name ".tmpl")) name)
 240      (let ((p (open-input-output-file name)))
 241        (cond
 242         ((string=? "gpg.conf" name)
 243          (if have-opt-always-trust
 244              (display "no-auto-check-trustdb\n" p))
 245          (display (string-append "agent-program "
 246                                  (tool 'gpg-agent)
 247                                  "|--debug-quick-random\n") p)
 248          (display "allow-weak-digest-algos\n" p))
 249         ((string=? "gpg-agent.conf" name)
 250          (display (string-append "pinentry-program " PINENTRY "\n") p)))))
 251    '("gpg.conf" "gpg-agent.conf")))
 252
 253 ;; Initialize the test environment, install appropriate configuration
 254 ;; and start the agent, without any keys.
 255 (define (setup-environment)
 256   (create-gpghome)
 257   (start-agent))
 258
 259 (define (create-legacy-gpghome)
 260   (log "Creating sample data files")
 261   (for-each
 262    (lambda (size)
 263      (make-test-data (string-append "data-" (number->string size))
 264                      size))
 265    '(500 9000 32000 80000))
 266
 267   (log "Unpacking samples")
 268   (for-each
 269    (lambda (name)
 270      (dearmor (in-srcdir (string-append name "o.asc")) name))
 271    '("plain-1" "plain-2" "plain-3" "plain-large"))
 272
 273   (mkdir "private-keys-v1.d" "-rwx")
 274
 275   (log "Storing private keys")
 276   (for-each
 277    (lambda (name)
 278      (dearmor (in-srcdir (string-append "/privkeys/" name ".asc"))
 279               (string-append "private-keys-v1.d/" name ".key")))
 280    '("50B2D4FA4122C212611048BC5FC31BD44393626E"
 281      "7E201E28B6FEB2927B321F443205F4724EBE637E"
 282      "13FDB8809B17C5547779F9D205C45F47CE0217CE"
 283      "343D8AF79796EE107D645A2787A9D9252F924E6F"
 284      "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"
 285      "0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255"
 286      "FD692BD59D6640A84C8422573D469F84F3B98E53"
 287      "76F7E2B35832976B50A27A282D9B87E44577EB66"
 288      "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
 289      "00FE67F28A52A8AA08FFAED20AF832DA916D1985"
 290      "1DF48228FEFF3EC2481B106E0ACA8C465C662CC5"
 291      "A2832820DC9F40751BDCD375BB0945BA33EC6B4C"
 292      "ADE710D74409777B7729A7653373D820F67892E0"
 293      "CEFC51AF91F68A2904FBFF62C4F075A4785B803F"
 294      "1E28F20E41B54C2D1234D896096495FF57E08D18"
 295      "EB33B687EB8581AB64D04852A54453E85F3DF62D"
 296      "C6A6390E9388CDBAD71EAEA698233FE5E04F001E"
 297      "D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3"))
 298
 299   (log "Importing public demo and test keys")
 300   (for-each
 301    (lambda (file)
 302      (call-check `(,@GPG --yes --import ,(in-srcdir file))))
 303    (list "pubdemo.asc" "pubring.asc" key-file1))
 304
 305   (pipe:do
 306    (pipe:open (in-srcdir "pubring.pkr.asc") (logior O_RDONLY O_BINARY))
 307    (pipe:spawn `(,@GPG --dearmor))
 308    (pipe:spawn `(,@GPG --yes --import))))
 309
 310 (define (preset-passphrases)
 311   (log "Presetting passphrases")
 312   ;; one@example.com
 313   (call-check `(,(tool 'gpg-preset-passphrase)
 314                 --preset --passphrase def
 315                 "50B2D4FA4122C212611048BC5FC31BD44393626E"))
 316   (call-check `(,(tool 'gpg-preset-passphrase)
 317                 --preset --passphrase def
 318                 "7E201E28B6FEB2927B321F443205F4724EBE637E"))
 319   ;; alpha@example.net
 320   (call-check `(,(tool 'gpg-preset-passphrase)
 321                 --preset --passphrase abc
 322                 "76F7E2B35832976B50A27A282D9B87E44577EB66"))
 323   (call-check `(,(tool 'gpg-preset-passphrase)
 324                 --preset --passphrase abc
 325                 "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD")))
 326
 327 ;; Initialize the test environment, install appropriate configuration
 328 ;; and start the agent, with the keys from the legacy test suite.
 329 (define (setup-legacy-environment)
 330   (create-gpghome)
 331   (if (member "--unpack-tarball" *args*)
 332       (begin
 333         (call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
 334         (start-agent))
 335       (begin
 336         (start-agent)
 337         (create-legacy-gpghome)))
 338   (preset-passphrases))
 339
 340 ;; Create the socket dir and start the agent.
 341 (define (start-agent)
 342   (log "Starting gpg-agent...")
 343   (atexit stop-agent)
 344   (catch (log "Warning: Creating socket directory failed:" (car *error*))
 345          (call-popen `(,(tool 'gpgconf) --create-socketdir) ""))
 346   (call-check `(,(tool 'gpg-connect-agent) --verbose
 347                 ,(string-append "--agent-program=" (tool 'gpg-agent)
 348                                 "|--debug-quick-random")
 349                 /bye)))
 350
 351 ;; Stop the agent and remove the socket dir.
 352 (define (stop-agent)
 353   (log "Stopping gpg-agent...")
 354   (catch (log "Warning: Removing socket directory failed.")
 355          (call-popen `(,(tool 'gpgconf) --remove-socketdir) ""))
 356   (call-check `(,(tool 'gpg-connect-agent) --verbose --no-autostart
 357                 killagent /bye)))