guix/git-authenticate.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019, 2020 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 false-if-git-not-found))
  26   #:use-module (guix i18n)
  27   #:use-module (guix openpgp)
  28   #:use-module ((guix utils)
  29                 #:select (cache-directory with-atomic-file-output))
  30   #:use-module ((guix build utils)
  31                 #:select (mkdir-p))
  32   #:use-module (guix progress)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-11)
  35   #:use-module (srfi srfi-26)
  36   #:use-module (srfi srfi-34)
  37   #:use-module (srfi srfi-35)
  38   #:use-module (rnrs bytevectors)
  39   #:use-module (rnrs io ports)
  40   #:use-module (ice-9 match)
  41   #:autoload   (ice-9 pretty-print) (pretty-print)
  42   #:export (read-authorizations
  43             commit-signing-key
  44             commit-authorized-keys
  45             authenticate-commit
  46             authenticate-commits
  47             load-keyring-from-reference
  48             previously-authenticated-commits
  49             cache-authenticated-commit
  50
  51             repository-cache-key
  52             authenticate-repository
  53
  54             git-authentication-error?
  55             git-authentication-error-commit
  56             unsigned-commit-error?
  57             unauthorized-commit-error?
  58             unauthorized-commit-error-signing-key
  59             signature-verification-error?
  60             signature-verification-error-keyring
  61             signature-verification-error-signature
  62             missing-key-error?
  63             missing-key-error-signature))
  64
  65 ;;; Commentary:
  66 ;;;
  67 ;;; This module provides tools to authenticate a range of Git commits.  A
  68 ;;; commit is considered "authentic" if and only if it is signed by an
  69 ;;; authorized party.  Parties authorized to sign a commit are listed in the
  70 ;;; '.guix-authorizations' file of the parent commit.
  71 ;;;
  72 ;;; Code:
  73
  74 (define-condition-type &git-authentication-error &error
  75   git-authentication-error?
  76   (commit  git-authentication-error-commit))
  77
  78 (define-condition-type &unsigned-commit-error &git-authentication-error
  79   unsigned-commit-error?)
  80
  81 (define-condition-type &unauthorized-commit-error &git-authentication-error
  82   unauthorized-commit-error?
  83   (signing-key unauthorized-commit-error-signing-key))
  84
  85 (define-condition-type &signature-verification-error &git-authentication-error
  86   signature-verification-error?
  87   (signature signature-verification-error-signature)
  88   (keyring   signature-verification-error-keyring))
  89
  90 (define-condition-type &missing-key-error &git-authentication-error
  91   missing-key-error?
  92   (signature missing-key-error-signature))
  93
  94
  95 (define* (commit-signing-key repo commit-id keyring
  96                              #:key (disallowed-hash-algorithms '(sha1)))
  97   "Return the OpenPGP key that signed COMMIT-ID (an OID).  Raise an exception
  98 if the commit is unsigned, has an invalid signature, has a signature using one
  99 of the hash algorithms in DISALLOWED-HASH-ALGORITHMS, or if its signing key is
 100 not in KEYRING."
 101   (let-values (((signature signed-data)
 102                 (catch 'git-error
 103                   (lambda ()
 104                     (commit-extract-signature repo commit-id))
 105                   (lambda _
 106                     (values #f #f)))))
 107     (unless signature
 108       (raise (condition
 109               (&unsigned-commit-error (commit commit-id))
 110               (&message
 111                (message (format #f (G_ "commit ~a lacks a signature")
 112                                 (oid->string commit-id)))))))
 113
 114     (let ((signature (string->openpgp-packet signature)))
 115       (when (memq (openpgp-signature-hash-algorithm signature)
 116                   `(,@disallowed-hash-algorithms md5))
 117         (raise (condition
 118                 (&unsigned-commit-error (commit commit-id))
 119                 (&message
 120                  (message (format #f (G_ "commit ~a has a ~a signature, \
 121 which is not permitted")
 122                                   (oid->string commit-id)
 123                                   (openpgp-signature-hash-algorithm
 124                                    signature)))))))
 125
 126       (with-fluids ((%default-port-encoding "UTF-8"))
 127         (let-values (((status data)
 128                       (verify-openpgp-signature signature keyring
 129                                                 (open-input-string signed-data))))
 130           (match status
 131             ('bad-signature
 132              ;; There's a signature but it's invalid.
 133              (raise (condition
 134                      (&signature-verification-error (commit commit-id)
 135                                                     (signature signature)
 136                                                     (keyring keyring))
 137                      (&message
 138                       (message (format #f (G_ "signature verification failed \
 139 for commit ~a")
 140                                        (oid->string commit-id)))))))
 141             ('missing-key
 142              (raise (condition
 143                      (&missing-key-error (commit commit-id)
 144                                          (signature signature))
 145                      (&message
 146                       (message (format #f (G_ "could not authenticate \
 147 commit ~a: key ~a is missing")
 148                                        (oid->string commit-id)
 149                                        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 (condition
 183               (&unauthorized-commit-error (commit (commit-id commit))
 184                                           (signing-key #f))
 185               (&message
 186                (message (format #f (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 (condition
 238             (&unauthorized-commit-error (commit id)
 239                                         (signing-key signing-key))
 240             (&message
 241              (message (format #f (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 (condition
 370             (&message
 371              (message (format #f (G_ "initial commit ~a is signed by '~a' \
 372 instead of '~a'")
 373                               (oid->string (commit-id commit))
 374                               (openpgp-format-fingerprint actual-signer)
 375                               (openpgp-format-fingerprint expected-signer))))))))
 376
 377 (define* (authenticate-repository repository start signer
 378                                   #:key
 379                                   (keyring-reference "keyring")
 380                                   (cache-key (repository-cache-key repository))
 381                                   (end (reference-target
 382                                         (repository-head repository)))
 383                                   (historical-authorizations '())
 384                                   (make-reporter
 385                                    (const progress-reporter/silent)))
 386   "Authenticate REPOSITORY up to commit END, an OID.  Authentication starts
 387 with commit START, an OID, which must be signed by SIGNER; an exception is
 388 raised if that is not the case.  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                 (previously-authenticated-commits cache-key)))
 412
 413   (define commits
 414     ;; Commits to authenticate, excluding the closure of
 415     ;; AUTHENTICATED-COMMITS.
 416     (commit-difference end-commit start-commit
 417                        authenticated-commits))
 418
 419   ;; When COMMITS is empty, it's because END-COMMIT is in the closure of
 420   ;; START-COMMIT and/or AUTHENTICATED-COMMITS, in which case it's known to
 421   ;; be authentic already.
 422   (if (null? commits)
 423       '()
 424       (let ((reporter (make-reporter start-commit end-commit commits)))
 425         ;; If it's our first time, verify START-COMMIT's signature.
 426         (when (null? authenticated-commits)
 427           (verify-introductory-commit repository keyring
 428                                       start-commit signer))
 429
 430         (let ((stats (call-with-progress-reporter reporter
 431                        (lambda (report)
 432                          (authenticate-commits repository commits
 433                                                #:keyring keyring
 434                                                #:default-authorizations
 435                                                historical-authorizations
 436                                                #:report-progress report)))))
 437           (cache-authenticated-commit cache-key
 438                                       (oid->string (commit-id end-commit)))
 439
 440           stats))))