1;; Common definitions for the OpenPGP test scripts. 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(let ((verbose (string->number (getenv "verbose")))) 21 (if (number? verbose) 22 (*set-verbose!* verbose))) 23 24(define (qualify executable) 25 (string-append executable (getenv "EXEEXT"))) 26 27(define (getenv' key default) 28 (let ((value (getenv key))) 29 (if (string=? "" value) 30 default 31 value))) 32 33(define (percent-decode s) 34 (define (decode c) 35 (if (and (> (length c) 2) (char=? #\% (car c))) 36 (integer->char (string->number (string #\# #\x (cadr c) (caddr c)))) 37 #f)) 38 (let loop ((i 0) (c (string->list s)) (r (make-string (string-length s)))) 39 (if (null? c) 40 (substring r 0 i) 41 (let ((decoded (decode c))) 42 (string-set! r i (if decoded decoded (car c))) 43 (loop (+ 1 i) (if decoded (cdddr c) (cdr c)) r))))) 44(assert (equal? (percent-decode "") "")) 45(assert (equal? (percent-decode "%61") "a")) 46(assert (equal? (percent-decode "foob%61r") "foobar")) 47 48(define (percent-encode s) 49 (define (encode c) 50 `(#\% ,@(string->list (number->string (char->integer c) 16)))) 51 (let loop ((acc '()) (cs (reverse (string->list s)))) 52 (if (null? cs) 53 (list->string acc) 54 (case (car cs) 55 ((#\: #\%) 56 (loop (append (encode (car cs)) acc) (cdr cs))) 57 (else 58 (loop (cons (car cs) acc) (cdr cs))))))) 59(assert (equal? (percent-encode "") "")) 60(assert (equal? (percent-encode "%61") "%2561")) 61(assert (equal? (percent-encode "foob%61r") "foob%2561r")) 62 63(define tools 64 '((gpgv "GPGV" "g10/gpgv") 65 (gpg-connect-agent "GPG_CONNECT_AGENT" "tools/gpg-connect-agent") 66 (gpgconf "GPGCONF" "tools/gpgconf") 67 (gpg-preset-passphrase "GPG_PRESET_PASSPHRASE" 68 "agent/gpg-preset-passphrase") 69 (gpgtar "GPGTAR" "tools/gpgtar") 70 (tpm2daemon "TPM2DAEMON" "tpm2d/tpm2daemon") 71 (pinentry "PINENTRY" "tests/openpgp/fake-pinentry"))) 72 73(define with-valgrind? (not (string=? (getenv "with_valgrind") ""))) 74 75(define (tool-hardcoded which) 76 (let ((t (assoc which tools))) 77 (getenv' (cadr t) 78 (qualify (string-append (getenv "GNUPG_BUILD_ROOT") 79 "/" (caddr t)))))) 80 81;; You can splice VALGRIND into your argument vector to run programs 82;; under valgrind. For example, to run valgrind on gpg, you may want 83;; to redefine gpg: 84;; 85;; (set! gpg `(,@valgrind ,@gpg)) 86;; 87(define valgrind 88 '("/usr/bin/valgrind" -q --leak-check=no --track-origins=yes 89 --error-exitcode=154 --exit-on-first-error=yes)) 90 91(define (gpg-conf . args) 92 (gpg-conf' "" args)) 93(define (gpg-conf' input args) 94 (let ((s (call-popen `(,(tool-hardcoded 'gpgconf) 95 ,@args) input))) 96 (map (lambda (line) (map percent-decode (string-split line #\:))) 97 (string-split-newlines s)))) 98(define :gc:c:name car) 99(define :gc:c:description cadr) 100(define :gc:c:pgmname caddr) 101(define (:gc:o:name x) (list-ref x 0)) 102(define (:gc:o:flags x) (string->number (list-ref x 1))) 103(define (:gc:o:level x) (string->number (list-ref x 2))) 104(define (:gc:o:description x) (list-ref x 3)) 105(define (:gc:o:type x) (string->number (list-ref x 4))) 106(define (:gc:o:alternate-type x) (string->number (list-ref x 5))) 107(define (:gc:o:argument-name x) (list-ref x 6)) 108(define (:gc:o:default-value x) (list-ref x 7)) 109(define (:gc:o:default-argument x) (list-ref x 8)) 110(define (:gc:o:value x) (if (< (length x) 10) "" (list-ref x 9))) 111 112(define (gpg-config component key) 113 (package 114 (define (value) 115 (let* ((conf (assoc key (gpg-conf '--list-options component))) 116 (type (:gc:o:type conf)) 117 (value (:gc:o:value conf))) 118 (case type 119 ((0 2 3) (string->number value)) 120 ((1 32) (substring value 1 (string-length value)))))) 121 (define (update value) 122 (let ((value' (cond 123 ((string? value) (string-append "\"" value)) 124 ((number? value) (number->string value)) 125 (else (throw "Unsupported value" value))))) 126 (gpg-conf' (string-append key ":0:" (percent-encode value')) 127 `(--change-options ,component)))) 128 (define (clear) 129 (gpg-conf' (string-append key ":16:") 130 `(--change-options ,component))))) 131 132(define gpg-components (apply gpg-conf '(--list-components))) 133 134(define (tool which) 135 (case which 136 ((gpg gpg-agent scdaemon gpgsm dirmngr) 137 (:gc:c:pgmname (assoc (symbol->string which) gpg-components))) 138 (else 139 (tool-hardcoded which)))) 140 141(define (gpg-has-option? option) 142 (string-contains? (call-popen `(,(tool 'gpg) --dump-options) "") 143 option)) 144 145(define have-opt-always-trust 146 (catch #f 147 (with-ephemeral-home-directory (lambda ()) (lambda ()) 148 (call-check `(,(tool 'gpg) --gpgconf-test --always-trust))) 149 #t)) 150 151(define GPG `(,(tool 'gpg) --no-permission-warning 152 ,@(if have-opt-always-trust '(--always-trust) '()))) 153(define GPGV `(,(tool 'gpgv))) 154(define PINENTRY (tool 'pinentry)) 155(define TPM2DAEMON (tool 'tpm2daemon)) 156 157(define (tr:gpg input args) 158 (tr:spawn input `(,@GPG --output **out** ,@args **in**))) 159 160(define (pipe:gpg args) 161 (pipe:spawn `(,@GPG --output - ,@args))) 162 163(define (gpg-with-colons args) 164 (let ((s (call-popen `(,@GPG --with-colons ,@args) ""))) 165 (map (lambda (line) (string-split line #\:)) 166 (string-split-newlines s)))) 167 168(define (secinfo name) 169 (assoc "sec" (gpg-with-colons `(--list-secret-key ,name)))) 170(define (ssbinfo name) 171 (assoc "ssb" (gpg-with-colons `(--list-secret-key ,name)))) 172(define (fingerprint name) 173 (:fpr (assoc "fpr" (gpg-with-colons `(--list-secret-key ,name))))) 174;; convenient accessors for sec 175(define (:cardinfo x) (list-ref x 14)) 176;; Convenient accessors for the colon output of pub. 177(define (:type x) (string->symbol (list-ref x 0))) 178(define (:length x) (string->number (list-ref x 2))) 179(define (:alg x) (string->number (list-ref x 3))) 180(define (:expire x) (list-ref x 6)) 181(define (:fpr x) (list-ref x 9)) 182(define (:cap x) (list-ref x 11)) 183 184(define (have-public-key? key) 185 (catch #f 186 (pair? (filter (lambda (l) (and (equal? 'fpr (:type l)) 187 (equal? key::fpr (:fpr l)))) 188 (gpg-with-colons `(--list-keys ,key::fpr)))))) 189 190(define (have-secret-key? key) 191 (catch #f 192 (pair? (filter (lambda (l) (and (equal? 'fpr (:type l)) 193 (equal? key::fpr (:fpr l)))) 194 (gpg-with-colons `(--list-secret-keys ,key::fpr)))))) 195 196(define (have-secret-key-file? key) 197 (file-exists? (path-join (getenv "GNUPGHOME") "private-keys-v1.d" 198 (string-append key::grip ".key")))) 199 200(define (get-config what) 201 (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;)) 202 203(define all-pubkey-algos (delay (get-config "pubkeyname"))) 204(define all-hash-algos (delay (get-config "digestname"))) 205(define all-cipher-algos (delay (get-config "ciphername"))) 206(define all-compression-algos (delay (get-config "compressname"))) 207 208(define (have-pubkey-algo? x) 209 (not (not (member x (force all-pubkey-algos))))) 210(define (have-hash-algo? x) 211 (not (not (member x (force all-hash-algos))))) 212(define (have-cipher-algo? x) 213 (not (not (member x (force all-cipher-algos))))) 214(define (have-compression-algo? x) 215 (not (not (member x (force all-compression-algos))))) 216 217(define (gpg-pipe args0 args1 errfd) 218 (lambda (source sink) 219 (let* ((p (pipe)) 220 (task0 (spawn-process-fd `(,@GPG ,@args0) 221 source (:write-end p) errfd)) 222 (_ (close (:write-end p))) 223 (task1 (spawn-process-fd `(,@GPG ,@args1) 224 (:read-end p) sink errfd))) 225 (close (:read-end p)) 226 (wait-processes (list GPG GPG) (list task0 task1) #t)))) 227 228;; 229;; Do we have a software tpm 230;; 231(define have-swtpm? (not (and (string=? "" (getenv "TPMSERVER")) 232 (string=? "" (getenv "SWTPM"))))) 233(setenv "GPG_AGENT_INFO" "" #t) 234(setenv "GNUPGHOME" (getcwd) #t) 235(if have-swtpm? 236 (setenv "TPM_INTERFACE_TYPE" "socsim" #t)) 237(define GNUPGHOME (getcwd)) 238 239;; 240;; GnuPG helper. 241;; 242 243;; Call GPG to obtain the hash sums. Either specify an input file in 244;; ARGS, or an string in INPUT. Returns a list of (<algo> 245;; "<hashsum>") lists. 246(define (gpg-hash-string args input) 247 (map 248 (lambda (line) 249 (let ((p (string-split line #\:))) 250 (list (string->number (cadr p)) (caddr p)))) 251 (string-split-newlines 252 (call-popen `(,@GPG --with-colons ,@args) input)))) 253 254;; Dearmor a file. 255(define (dearmor source-name sink-name) 256 (pipe:do 257 (pipe:open source-name (logior O_RDONLY O_BINARY)) 258 (pipe:spawn `(,@GPG --dearmor)) 259 (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600))) 260 261(define (gpg-dump-packets source-name sink-name) 262 (pipe:do 263 (pipe:open source-name (logior O_RDONLY O_BINARY)) 264 (pipe:spawn `(,@GPG --list-packets)) 265 (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600))) 266 267;; 268;; Support for test environment creation and teardown. 269;; 270 271(define (make-test-data filename size) 272 (call-with-binary-output-file 273 filename 274 (lambda (port) 275 (display (make-random-string size) port)))) 276 277(define (create-file name . lines) 278 (catch #f (unlink name)) 279 (letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600))) 280 (let ((port (fdopen fd "wb"))) 281 (for-each (lambda (line) (display line port) (newline port)) 282 lines)))) 283 284(define (create-gpghome) 285 (log "Creating test environment...") 286 287 (srandom (getpid)) 288 (make-test-data "random_seed" 600) 289 290 (log "Creating configuration files") 291 292 (if (flag "--use-keyring" *args*) 293 (create-file "pubring.gpg")) 294 295 (create-file "gpg.conf" 296 ;;"log-file socket:///tmp/S.wklog" 297 ;;"verbose" 298 "no-greeting" 299 "no-secmem-warning" 300 "no-permission-warning" 301 "batch" 302 "no-auto-key-retrieve" 303 "no-auto-key-locate" 304 "allow-weak-digest-algos" 305 "ignore-mdc-error" 306 (if have-opt-always-trust 307 "no-auto-check-trustdb" "#no-auto-check-trustdb") 308 (string-append "agent-program " 309 (tool 'gpg-agent) 310 "|--debug-quick-random\n") 311 (if (flag "--use-keyboxd" *args*) 312 "use-keyboxd" "#use-keyboxd") 313 ) 314 (create-file "gpg-agent.conf" 315 "allow-preset-passphrase" 316 "debug-all" 317 "log-file gpg-agent.log" 318 "no-grab" 319 "enable-ssh-support" 320 "s2k-count 65536" 321 (string-append "pinentry-program " (tool 'pinentry)) 322 (string-append "tpm2daemon-program " (tool 'tpm2daemon)) 323 "disable-scdaemon") 324 (create-file "msg.txt" 325 "This is a test of TPM signing and encryption" 326 "With two lines of text")) 327 328;; Initialize the test environment, install appropriate configuration 329;; and start the agent, without any keys. 330(define (setup-environment) 331 (create-gpghome) 332 (start-agent) 333 (start-tpm)) 334 335(define (setup-environment-no-atexit) 336 (create-gpghome) 337 (start-agent #t)) 338 339;; Initialize the test environment, install appropriate configuration 340;; and start the agent, with the keys from the legacy test suite. 341(define (setup-legacy-environment) 342 (create-gpghome) 343 (if (member "--unpack-tarball" *args*) 344 (begin 345 (call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*))) 346 (start-agent)) 347 (begin 348 (start-agent) 349 (create-legacy-gpghome))) 350 (preset-passphrases)) 351 352;; start the tpm server 353(define (start-tpm) 354 (if have-swtpm? 355 (begin (define pid (call-check `(,(in-srcdir "tests" "tpm2dtests" "start_sw_tpm.sh")))) 356 (if (not (null? pid)) 357 (atexit (lambda () 358 (call-check `("/bin/kill" ,pid)))))))) 359 360;; Create the socket dir and start the agent. 361(define (start-agent . args) 362 (log "Starting gpg-agent...") 363 (let ((gnupghome (getenv "GNUPGHOME"))) 364 (if (null? args) 365 (atexit (lambda () 366 (with-home-directory gnupghome (stop-agent)))))) 367 (catch (log "Warning: Creating socket directory failed:" (car *error*)) 368 (gpg-conf '--create-socketdir)) 369 (call-check `(,(tool 'gpg-connect-agent) --verbose 370 ,(string-append "--agent-program=" (tool 'gpg-agent) 371 "|--debug-quick-random") 372 /bye))) 373 374;; Stop the agent and other daemons and remove the socket dir. 375(define (stop-agent) 376 (log "Stopping gpg-agent...") 377 (gpg-conf '--kill 'all) 378 (catch (log "Warning: Removing socket directory failed.") 379 (gpg-conf '--remove-socketdir))) 380 381;; Get the trust level for KEYID. Any remaining arguments are simply 382;; passed to GPG. 383;; 384;; This function only supports keys with a single user id. 385(define (gettrust keyid . args) 386 (let ((trust 387 (list-ref (assoc "pub" (gpg-with-colons 388 `(,@args 389 --list-keys ,keyid))) 1))) 390 (unless (and (= 1 (string-length trust)) 391 (member (string-ref trust 0) (string->list "oidreqnmfuws-"))) 392 (fail "Bad trust value:" trust)) 393 trust)) 394 395;; Check that KEYID's trust level matches EXPECTED-TRUST. Any 396;; remaining arguments are simply passed to GPG. 397;; 398;; This function only supports keys with a single user id. 399(define (checktrust keyid expected-trust . args) 400 (let ((trust (apply gettrust `(,keyid ,@args)))) 401 (unless (string=? trust expected-trust) 402 (fail keyid ": Expected trust to be" expected-trust 403 "but got" trust)))) 404 405(define (keytotpm name select) 406 (let ((result (call-with-io `(,@GPG --command-fd=0 --edit-key ,name ,select keytotpm) "y\n"))) 407 (if (= 0 (:retcode result)) 408 (:stdout result) 409 (throw "keytotpm failed" 410 (:stderr result))))) 411 412 413(define (quick-gen name algo) 414 (info "creating TPM " algo " key") 415 (call-check `(,@GPG --quick-generate-key ,name ,algo)) 416 (keytotpm name "key 0") 417 (unless (string=? (:cardinfo (secinfo name)) "TPM-Protected") 418 (throw "key is not in the TPM"))) 419 420(define (quick-add name algo) 421 (info "adding TPM encryption " algo " key") 422 (call-check `(,@GPG --quick-add-key ,(fingerprint name) ,algo "encr")) 423 (keytotpm name "key 1") 424 (unless (string=? (:cardinfo (ssbinfo name)) "TPM-Protected") 425 (throw "Added key is not in the TPM"))) 426 427(define (check-sig name) 428 (info "checking TPM signing") 429 (call-check `(,@GPG --default-key ,name --sign msg.txt)) 430 (call-check `(,@GPG --verify msg.txt.gpg)) 431 (unlink "msg.txt.gpg")) 432 433(define (check-encrypt name) 434 (info "Checking TPM decryption") 435 (call-check `(,@GPG --recipient ,name --encrypt msg.txt)) 436 (call-check `(,@GPG --output msg.out.txt --decrypt msg.txt.gpg)) 437 (unless (file=? "msg.txt" "msg.out.txt") 438 (throw "File did not decrypt to the same message")) 439 (unlink "msg.out.txt") 440 (unlink "msg.txt.gpg")) 441 442;; 443;; Tests are very simple: create primary key in TPM add encryption key 444;; in TPM (verifies TPM primary can certify secondary), sign a message 445;; with primary key and check signature encrypt a message with 446;; encryption key and check signature 447;; 448(define (test-tpm name algo) 449 (quick-gen name algo) 450 (quick-add name algo) 451 (check-sig name) 452 (check-encrypt name)) 453 454;; 455;; Enable checking with valgrind if the envvar "with_valgrind" is set 456;; 457(when with-valgrind? 458 (set! gpg `(,@valgrind ,@gpg))) 459 460 461;;(set! *args* (append *args* (list "--use-keyboxd"))) 462 463 464;; end 465