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