guix/git-authenticate.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019, 2020, 2021, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix git-authenticate)
  20   #:use-module (git)
  21   #:autoload   (gcrypt hash) (sha256)
  22   #:use-module (guix base16)
  23   #:autoload   (guix base64) (base64-encode)
  24   #:use-module ((guix git)
  25                 #:select (commit-difference
  26                           commit-descendant?
  27                           false-if-git-not-found))
  28   #:use-module (guix i18n)
  29   #:use-module ((guix diagnostics) #:select (formatted-message))
  30   #:use-module (guix openpgp)
  31   #:use-module ((guix utils)
  32                 #:select (cache-directory with-atomic-file-output))
  33   #:use-module ((guix build utils)
  34                 #:select (mkdir-p))
  35   #:use-module (guix progress)
  36   #:use-module (srfi srfi-1)
  37   #:use-module (srfi srfi-11)
  38   #:use-module (srfi srfi-26)
  39   #:use-module (srfi srfi-34)
  40   #:use-module (srfi srfi-35)
  41   #:use-module (rnrs bytevectors)
  42   #:use-module (rnrs io ports)
  43   #:use-module (ice-9 match)
  44   #:autoload   (ice-9 pretty-print) (pretty-print)
  45   #:export (read-authorizations
  46             commit-signing-key
  47             commit-authorized-keys
  48             authenticate-commit
  49             authenticate-commits
  50             load-keyring-from-reference
  51             previously-authenticated-commits
  52             cache-authenticated-commit
  53
  54             repository-cache-key
  55             authenticate-repository
  56
  57             git-authentication-error?
  58             git-authentication-error-commit
  59             unsigned-commit-error?
  60             unauthorized-commit-error?
  61             unauthorized-commit-error-signing-key
  62             signature-verification-error?
  63             signature-verification-error-keyring
  64             signature-verification-error-signature
  65             missing-key-error?
  66             missing-key-error-signature))
  67
  68 ;;; Commentary:
  69 ;;;
  70 ;;; This module provides tools to authenticate a range of Git commits.  A
  71 ;;; commit is considered "authentic" if and only if it is signed by an
  72 ;;; authorized party.  Parties authorized to sign a commit are listed in the
  73 ;;; '.guix-authorizations' file of the parent commit.
  74 ;;;
  75 ;;; Code:
  76
  77 (define-condition-type &git-authentication-error &error
  78   git-authentication-error?
  79   (commit  git-authentication-error-commit))
  80
  81 (define-condition-type &unsigned-commit-error &git-authentication-error
  82   unsigned-commit-error?)
  83
  84 (define-condition-type &unauthorized-commit-error &git-authentication-error
  85   unauthorized-commit-error?
  86   (signing-key unauthorized-commit-error-signing-key))
  87
  88 (define-condition-type &signature-verification-error &git-authentication-error
  89   signature-verification-error?
  90   (signature signature-verification-error-signature)
  91   (keyring   signature-verification-error-keyring))
  92
  93 (define-condition-type &missing-key-error &git-authentication-error
  94   missing-key-error?
  95   (signature missing-key-error-signature))
  96
  97
  98 (define* (commit-signing-key repo commit-id keyring
  99                              #:key (disallowed-hash-algorithms '(sha1)))
 100   "Return the OpenPGP key that signed COMMIT-ID (an OID).  Raise an exception
 101 if the commit is unsigned, has an invalid signature, has a signature using one
 102 of the hash algorithms in DISALLOWED-HASH-ALGORITHMS, or if its signing key is
 103 not in KEYRING."
 104   (let-values (((signature signed-data)
 105                 (catch 'git-error
 106                   (lambda ()
 107                     (commit-extract-signature repo commit-id))
 108                   (lambda _
 109                     (values #f #f)))))
 110     (unless signature
 111       (raise (make-compound-condition
 112               (condition (&unsigned-commit-error (commit commit-id)))
 113               (formatted-message (G_ "commit ~a lacks a signature")
 114                                  (oid->string commit-id)))))
 115
 116     (let ((signature (string->openpgp-packet signature)))
 117       (when (memq (openpgp-signature-hash-algorithm signature)
 118                   `(,@disallowed-hash-algorithms md5))
 119         (raise (make-compound-condition
 120                 (condition (&unsigned-commit-error (commit commit-id)))
 121                 (formatted-message (G_ "commit ~a has a ~a signature, \
 122 which is not permitted")
 123                                    (oid->string commit-id)
 124                                    (openpgp-signature-hash-algorithm
 125                                     signature)))))
 126
 127       (with-fluids ((%default-port-encoding "UTF-8"))
 128         (let-values (((status data)
 129                       (verify-openpgp-signature signature keyring
 130                                                 (open-input-string signed-data))))
 131           (match status
 132             ('bad-signature
 133              ;; There's a signature but it's invalid.
 134              (raise (make-compound-condition
 135                      (condition
 136                       (&signature-verification-error (commit commit-id)
 137                                                      (signature signature)
 138                                                      (keyring keyring)))
 139                      (formatted-message (G_ "signature verification failed \
 140 for commit ~a")
 141                                         (oid->string commit-id)))))
 142             ('missing-key
 143              (raise (make-compound-condition
 144                      (condition (&missing-key-error (commit commit-id)
 145                                                     (signature signature)))
 146                      (formatted-message (G_ "could not authenticate \
 147 commit ~a: key ~a is missing")
 148                                         (oid->string commit-id)
 149                                         (openpgp-format-fingerprint data)))))
 150             ('good-signature data)))))))
 151
 152 (define (read-authorizations port)
 153   "Read authorizations in the '.guix-authorizations' format from PORT, and
 154 return a list of authorized fingerprints."
 155   (match (read port)
 156     (('authorizations ('version 0)
 157                       (((? string? fingerprints) _ ...) ...)
 158                       _ ...)
 159      (map (lambda (fingerprint)
 160             (base16-string->bytevector
 161              (string-downcase (string-filter char-set:graphic fingerprint))))
 162           fingerprints))))
 163
 164 (define* (commit-authorized-keys repository commit
 165                                  #:optional (default-authorizations '()))
 166   "Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on
 167 authorizations listed in its parent commits.  If one of the parent commits
 168 does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
 169   (define (parents-have-authorizations-file? commit)
 170     ;; Return true if at least one of the parents of COMMIT has the
 171     ;; '.guix-authorizations' file.
 172     (find (lambda (commit)
 173             (false-if-git-not-found
 174              (tree-entry-bypath (commit-tree commit)
 175                                 ".guix-authorizations")))
 176           (commit-parents commit)))
 177
 178   (define (assert-parents-lack-authorizations commit)
 179     ;; If COMMIT removes the '.guix-authorizations' file found in one of its
 180     ;; parents, raise an error.
 181     (when (parents-have-authorizations-file? commit)
 182       (raise (make-compound-condition
 183               (condition
 184                (&unauthorized-commit-error (commit (commit-id commit))
 185                                            (signing-key #f)))
 186               (formatted-message (G_ "commit ~a attempts \
 187 to remove '.guix-authorizations' file")
 188                                  (oid->string (commit-id commit)))))))
 189
 190   (define (commit-authorizations commit)
 191     (catch 'git-error
 192       (lambda ()
 193         (let* ((tree  (commit-tree commit))
 194                (entry (tree-entry-bypath tree ".guix-authorizations"))
 195                (blob  (blob-lookup repository (tree-entry-id entry))))
 196           (read-authorizations
 197            (open-bytevector-input-port (blob-content blob)))))
 198       (lambda (key error)
 199         (if (= (git-error-code error) GIT_ENOTFOUND)
 200             (begin
 201               ;; Prevent removal of '.guix-authorizations' since it would make
 202               ;; it trivial to force a fallback to DEFAULT-AUTHORIZATIONS.
 203               (assert-parents-lack-authorizations commit)
 204               default-authorizations)
 205             (throw key error)))))
 206
 207   (match (commit-parents commit)
 208     (() default-authorizations)
 209     (parents
 210      (apply lset-intersection bytevector=?
 211             (map commit-authorizations parents)))))
 212
 213 (define* (authenticate-commit repository commit keyring
 214                               #:key (default-authorizations '()))
 215   "Authenticate COMMIT from REPOSITORY and return the signing key fingerprint.
 216 Raise an error when authentication fails.  If one of the parent commits does
 217 not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
 218   (define id
 219     (commit-id commit))
 220
 221   (define recent-commit?
 222     (false-if-git-not-found
 223      (tree-entry-bypath (commit-tree commit) ".guix-authorizations")))
 224
 225   (define signing-key
 226     (commit-signing-key repository id keyring
 227                         ;; Reject SHA1 signatures unconditionally as suggested
 228                         ;; by the authors of "SHA-1 is a Shambles" (2019).
 229                         ;; Accept it for "historical" commits (there are such
 230                         ;; signatures from April 2020 in the repository).
 231                         #:disallowed-hash-algorithms
 232                         (if recent-commit? '(sha1) '())))
 233
 234   (unless (member (openpgp-public-key-fingerprint signing-key)
 235                   (commit-authorized-keys repository commit
 236                                           default-authorizations))
 237     (raise (make-compound-condition
 238             (condition
 239              (&unauthorized-commit-error (commit id)
 240                                          (signing-key signing-key)))
 241             (formatted-message (G_ "commit ~a not signed by an authorized \
 242 key: ~a")
 243                                (oid->string id)
 244                                (openpgp-format-fingerprint
 245                                 (openpgp-public-key-fingerprint
 246                                  signing-key))))))
 247
 248   signing-key)
 249
 250 (define (load-keyring-from-blob repository oid keyring)
 251   "Augment KEYRING with the keyring available in the blob at OID, which may or
 252 may not be ASCII-armored."
 253   (let* ((blob (blob-lookup repository oid))
 254          (port (open-bytevector-input-port (blob-content blob))))
 255     (get-openpgp-keyring (if (port-ascii-armored? port)
 256                              (open-bytevector-input-port (read-radix-64 port))
 257                              port)
 258                          keyring)))
 259
 260 (define (load-keyring-from-reference repository reference)
 261   "Load the '.key' files from the tree at REFERENCE in REPOSITORY and return
 262 an OpenPGP keyring."
 263   (let* ((reference (branch-lookup repository reference BRANCH-ALL))
 264          (target    (reference-target reference))
 265          (commit    (commit-lookup repository target))
 266          (tree      (commit-tree commit)))
 267     (fold (lambda (name keyring)
 268             (if (string-suffix? ".key" name)
 269                 (let ((entry (tree-entry-bypath tree name)))
 270                   (load-keyring-from-blob repository
 271                                           (tree-entry-id entry)
 272                                           keyring))
 273                 keyring))
 274           %empty-keyring
 275           (tree-list tree))))
 276
 277 (define* (authenticate-commits repository commits
 278                                #:key
 279                                (default-authorizations '())
 280                                (keyring-reference "keyring")
 281                                (keyring (load-keyring-from-reference
 282                                          repository keyring-reference))
 283                                (report-progress (const #t)))
 284   "Authenticate COMMITS, a list of commit objects, calling REPORT-PROGRESS for
 285 each of them.  Return an alist showing the number of occurrences of each key.
 286 If KEYRING is omitted, the OpenPGP keyring is loaded from KEYRING-REFERENCE in
 287 REPOSITORY."
 288   (fold (lambda (commit stats)
 289           (report-progress)
 290           (let ((signer (authenticate-commit repository commit keyring
 291                                              #:default-authorizations
 292                                              default-authorizations)))
 293             (match (assq signer stats)
 294               (#f          (cons `(,signer . 1) stats))
 295               ((_ . count) (cons `(,signer . ,(+ count 1))
 296                                  (alist-delete signer stats))))))
 297         '()
 298         commits))
 299
 300 \f
 301 ;;;
 302 ;;; Caching.
 303 ;;;
 304
 305 (define (authenticated-commit-cache-file key)
 306   "Return the name of the file that contains the cache of
 307 previously-authenticated commits for KEY."
 308   (string-append (cache-directory) "/authentication/" key))
 309
 310 (define (previously-authenticated-commits key)
 311   "Return the previously-authenticated commits under KEY as a list of commit
 312 IDs (hex strings)."
 313   (catch 'system-error
 314     (lambda ()
 315       (call-with-input-file (authenticated-commit-cache-file key)
 316         (lambda (port)
 317           ;; If PORT has the wrong permissions, it might have been tampered
 318           ;; with by another user so ignore its contents.
 319           (if (= #o600 (stat:perms (stat port)))
 320               (read port)
 321               (begin
 322                 (chmod port #o600)
 323                 '())))))
 324     (lambda args
 325       (if (= ENOENT (system-error-errno args))
 326           '()
 327           (apply throw args)))))
 328
 329 (define (cache-authenticated-commit key commit-id)
 330   "Record in ~/.cache, under KEY, COMMIT-ID and its closure as
 331 authenticated (only COMMIT-ID is written to cache, though)."
 332   (define %max-cache-length
 333     ;; Maximum number of commits in cache.
 334     200)
 335
 336   (let ((lst  (delete-duplicates
 337                (cons commit-id (previously-authenticated-commits key))))
 338         (file (authenticated-commit-cache-file key)))
 339     (mkdir-p (dirname file))
 340     (with-atomic-file-output file
 341       (lambda (port)
 342         (let ((lst (if (> (length lst) %max-cache-length)
 343                        (take lst %max-cache-length) ;truncate
 344                        lst)))
 345           (chmod port #o600)
 346           (display ";; List of previously-authenticated commits.\n\n"
 347                    port)
 348           (pretty-print lst port))))))
 349
 350 \f
 351 ;;;
 352 ;;; High-level interface.
 353 ;;;
 354
 355 (define (repository-cache-key repository)
 356   "Return a unique key to store the authenticate commit cache for REPOSITORY."
 357   (string-append "checkouts/"
 358                  (base64-encode
 359                   (sha256 (string->utf8 (repository-directory repository))))))
 360
 361 (define (verify-introductory-commit repository keyring commit expected-signer)
 362   "Look up COMMIT in REPOSITORY, and raise an exception if it is not signed by
 363 EXPECTED-SIGNER."
 364   (define actual-signer
 365     (openpgp-public-key-fingerprint
 366      (commit-signing-key repository (commit-id commit) keyring)))
 367
 368   (unless (bytevector=? expected-signer actual-signer)
 369     (raise (formatted-message (G_ "initial commit ~a is signed by '~a' \
 370 instead of '~a'")
 371                               (oid->string (commit-id commit))
 372                               (openpgp-format-fingerprint actual-signer)
 373                               (openpgp-format-fingerprint expected-signer)))))
 374
 375 (define* (authenticate-repository repository start signer
 376                                   #:key
 377                                   (keyring-reference "keyring")
 378                                   (cache-key (repository-cache-key repository))
 379                                   (end (reference-target
 380                                         (repository-head repository)))
 381                                   (authentic-commits '())
 382                                   (historical-authorizations '())
 383                                   (make-reporter
 384                                    (const progress-reporter/silent)))
 385   "Authenticate REPOSITORY up to commit END, an OID.  Authentication starts
 386 with commit START, an OID, which must be signed by SIGNER; an exception is
 387 raised if that is not the case.  Commits listed in AUTHENTIC-COMMITS and their
 388 closure are considered authentic.  Return an alist mapping OpenPGP public keys
 389 to the number of commits signed by that key that have been traversed.
 390
 391 The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY, where
 392 KEYRING-REFERENCE is the name of a branch.  The list of authenticated commits
 393 is cached in the authentication cache under CACHE-KEY.
 394
 395 HISTORICAL-AUTHORIZATIONS must be a list of OpenPGP fingerprints (bytevectors)
 396 denoting the authorized keys for commits whose parent lack the
 397 '.guix-authorizations' file."
 398   (define start-commit
 399     (commit-lookup repository start))
 400   (define end-commit
 401     (commit-lookup repository end))
 402
 403   (define keyring
 404     (load-keyring-from-reference repository keyring-reference))
 405
 406   (define authenticated-commits
 407     ;; Previously-authenticated commits that don't need to be checked again.
 408     (filter-map (lambda (id)
 409                   (false-if-git-not-found
 410                    (commit-lookup repository (string->oid id))))
 411                 (append (previously-authenticated-commits cache-key)
 412                         authentic-commits)))
 413
 414   (define commits
 415     ;; Commits to authenticate, excluding the closure of
 416     ;; AUTHENTICATED-COMMITS.
 417     (commit-difference end-commit start-commit
 418                        authenticated-commits))
 419
 420   ;; When COMMITS is empty, it's because END-COMMIT is in the closure of
 421   ;; START-COMMIT and/or AUTHENTICATED-COMMITS, in which case it's known to
 422   ;; be authentic already.
 423   (if (null? commits)
 424       '()
 425       (let ((reporter (make-reporter start-commit end-commit commits)))
 426         ;; If it's our first time, verify START-COMMIT's signature.
 427         (when (null? authenticated-commits)
 428           (verify-introductory-commit repository keyring
 429                                       start-commit signer))
 430
 431         ;; Make sure END-COMMIT is a descendant of START-COMMIT or of one of
 432         ;; AUTHENTICATED-COMMITS, which are known to be descendants of
 433         ;; START-COMMIT.
 434         (unless (commit-descendant? end-commit
 435                                     (cons start-commit
 436                                           authenticated-commits))
 437           (raise (formatted-message
 438                   (G_ "commit ~a is not a descendant of introductory commit ~a")
 439                   (oid->string (commit-id end-commit))
 440                   (oid->string (commit-id start-commit)))))
 441
 442         (let ((stats (call-with-progress-reporter reporter
 443                        (lambda (report)
 444                          (authenticate-commits repository commits
 445                                                #:keyring keyring
 446                                                #:default-authorizations
 447                                                historical-authorizations
 448                                                #:report-progress report)))))
 449           (cache-authenticated-commit cache-key
 450                                       (oid->string (commit-id end-commit)))
 451
 452           stats))))