[jackhill/guix/guix.git] / build-aux / git-authenticate.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;;;
;;; Authenticate a range of commits.
;;;

(use-modules (git)
             (guix git)
             (guix openpgp)
             (guix base16)
             ((guix utils)
              #:select (cache-directory with-atomic-file-output))
             ((guix build utils) #:select (mkdir-p))
             (guix i18n)
             (guix progress)
             (srfi srfi-1)
             (srfi srfi-11)
             (srfi srfi-26)
             (srfi srfi-34)
             (srfi srfi-35)
             (rnrs bytevectors)
             (rnrs io ports)
             (ice-9 match)
             (ice-9 format)
             (ice-9 pretty-print))

\f
(define %committers
  ;; List of committers.  These are the user names found on
  ;; <https://savannah.gnu.org/project/memberlist.php?group=guix> along with
  ;; the fingerprint of the signing (sub)key.
  ;;
  ;; TODO: Replace this statically-defined list by an in-repo list.
  '(("andreas"
     "AD17 A21E F8AE D8F1 CC02  DBD9 F7D5 C9BF 765C 61E3")
    ("ajgrf"
     "2A39 3FFF 68F4 EF7A 3D29  12AF 6F51 20A0 22FB B2D5")
    ("alexvong1995"
     "306F CB8F 2C01 C25D 29D3  0556 61EF 502E F602 52F2")
    ("alezost"
     "4FB9 9F49 2B12 A365 7997  E664 8246 0C08 2A0E E98F")
    ("ambrevar"
     "50F3 3E2E 5B0C 3D90 0424  ABE8 9BDC F497 A4BB CC7F")
    ("apteryx"
     "27D5 86A4 F890 0854 329F  F09F 1260 E464 82E6 3562")
    ("arunisaac"
     "7F73 0343 F2F0 9F3C 77BF  79D3 2E25 EE8B 6180 2BB3")
    ("atheia"
     ;; primary: "3B12 9196 AE30 0C3C 0E90  A26F A715 5567 3271 9948"
     "9A2B 401E D001 0650 1584  BAAC 8BC4 F447 6E8A 8E00")
    ("bandali"
     ;; primary: "BE62 7373 8E61 6D6D 1B3A  08E8 A21A 0202 4881 6103"
     "39B3 3C8D 9448 0D2D DCC2  A498 8B44 A0CD C7B9 56F2")
    ("bavier"
     ;; primary: "34FF 38BC D151 25A6 E340  A0B5 3453 2F9F AFCA 8B8E"
     "A0C5 E352 2EF8 EF5C 64CD  B7F0 FD73 CAC7 19D3 2566")
    ("beffa"
     "3774 8024 880F D3FF DCA2  C9AB 5893 6E0E 2F1B 5A4C")
    ("benwoodcroft"
     "BCF8 F737 2CED 080A 67EB  592D 2A6A D9F4 AAC2 0DF6")
    ("biscuolo"
     "45CC 63B8 5258 C9D5 5F34  B239 D37D 0EA7 CECC 3912")
    ("boskovits"
     "7988 3B9F 7D6A 4DBF 3719  0367 2506 A96C CF63 0B21")
    ("brettgilio"
     "DFC0 C7F7 9EE6 0CA7 AE55  5E19 6722 43C4 A03F 0EEE")
    ("carl"
     ;; primary: "0401 7A2A 6D9A 0CCD C81D  8EC2 96AB 007F 1A7E D999"
     "09CD D25B 5244 A376 78F6  EEA8 0CC5 2153 1979 91A5")
    ("cbaines"
     "3E89 EEE7 458E 720D 9754  E0B2 5E28 A33B 0B84 F577")
    ("civodul"
     "3CE4 6455 8A84 FDC6 9DB4  0CFB 090B 1199 3D9A EBB5")
    ("cwebber"
     "510A 8628 E2A7 7678 8F8C  709C 4BC0 2592 5FF8 F4D3")
    ("dannym"
     ;; primary: "295A F991 6F46 F8A1 34B0  29DA 8086 3842 F0FE D83B"
     "76CE C6B1 7274 B465 C02D  B3D9 E71A 3554 2C30 BAA5")
    ("davexunit"
     "B3C0 DB4D AD73 BA5D 285E  19AE 5143 0234 CEFD 87C3")
    ("davexunit (2nd)"                            ;FIXME: to be confirmed!
     "8CCB A7F5 52B9 CBEA E1FB  2915 8328 C747 0FF1 D807")
    ("daviwil"
     "53C4 1E6E 41AA FE55 335A  CA5E 446A 2ED4 D940 BF14")
    ("dvc"
     "6909 6DFD D702 8BED ACC5  884B C5E0 51C7 9C0B ECDB")
    ("dvc (old)"
     "5F43 B681 0437 2F4B A898  A64B 33B9 E9FD E28D 2C23")
    ("efraim"
     "A28B F40C 3E55 1372 662D  14F7 41AA E7DC CA3D 8351")
    ("efraim (old)"
     "9157 41FE B22F A4E3 3B6E  8F8D F4C1 D391 7EAC EE93")
    ("glv"
     ;; primary: "2453 02B1 BAB1 F867 FDCA  96BC 8F3F 861F 82EB 7A9A"
     "CBC5 9C66 EC27 B971 7940  6B3E 6BE8 208A DF21 FE3F")
    ("hoebjo"
     "2219 43F4 9E9F 276F 9499  3382 BF28 6CB6 593E 5FFD")
    ("htgoebel"
     "B943 509D 633E 80DD 27FC  4EED 634A 8DFF D3F6 31DF")
    ("ipetkov"
     "7440 26BA 7CA3 C668 E940  1D53 0B43 1E98 3705 6942")
    ("iyzsong"
     ;; primary: "66A5 6D9C 9A98 BE7F 719A  B401 2652 5665 AE72 7D37"
     "0325 78A6 8298 94E7 2AA2  66F5 D415 BF25 3B51 5976")

    ;; https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00229.html
    ("janneke (old)"
     "DB34 CB51 D25C 9408 156F  CDD6 A12F 8797 8D70 1B99")
    ("janneke"
     "1A85 8392 E331 EAFD B8C2  7FFB F3C1 A0D9 C1D6 5273")

    ("jlicht"
     ;; primary: "1BA4 08C5 8BF2 0EA7 3179  635A 865D C0A3 DED9 B5D0"
     "E31D 9DDE EBA5 4A14 8A20  4550 DA45 97F9 47B4 1025")
    ("jmd"
     "8797 A26D 0854 2EAB 0285  A290 8A67 719C 2DE8 27B3")
    ("kkebreau"
     "83B6 703A DCCA 3B69 4BCE  2DA6 E6A5 EE3C 1946 7A0D")
    ("leungbk"
     "45E5 75FA 53EA 8BD6 1BCE  0B4E 3ADC 75F0 13D6 78F9")
    ("lfam"
     ;; primary: "4F71 6F9A 8FA2 C80E F1B5  E1BA 5E35 F231 DE1A C5E0"
     "B051 5948 F1E7 D3C1 B980  38A0 2646 FA30 BACA 7F08")
    ("lsl88"
     "2AE3 1395 932B E642 FC0E  D99C 9BED 6EDA 32E5 B0BC")
    ("marusich"
     "CBF5 9755 CBE7 E7EF EF18  3FB1 DD40 9A15 D822 469D")
    ("mbakke"
     "BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA")
    ("mhw"
     "D919 0965 CE03 199E AF28  B3BE 7CEF 2984 7562 C516")
    ("mothacehe"
     "4008 6A7E 0252 9B60 31FB  8607 8354 7635 3176 9CA6")
    ("mthl"
     "F2A3 8D7E EB2B 6640 5761  070D 0ADE E100 9460 4D37")
    ("nckx"
     ;; primary: "F5BC 5534 C36F 0087 B39D  36EF 1C9D C4FE B9DB 7C4B"
     "F5DA 2032 4B87 3D0B 7A38  7672 0DB0 FF88 4F55 6D79")
    ("nckx (revoked; not compromised)"
     ;; primary: "F5BC 5534 C36F 0087 B39D  36EF 1C9D C4FE B9DB 7C4B"
     "7E8F AED0 0944 78EF 72E6  4D16 D889 B0F0 18C5 493C")
    ("niedzejkob"
     "E576 BFB2 CF6E B13D F571  33B9 E315 A758 4613 1564")
    ("ngz"
     "ED0E F1C8 E126 BA83 1B48  5FE9 DA00 B4F0 48E9 2F2D")
    ("pelzflorian"
     "CEF4 CB91 4856 BA38 0A20  A7E2 3008 88CB 39C6 3817")
    ("pgarlick"
     ;; primary: "B68B DF22 73F9 DA0E 63C1  8A32 515B F416 9242 D600"
     "C699 ED09 E51B CE89 FD1D  A078 AAC7 E891 896B 568A")
    ("phant0mas"
     "3A86 380E 58A8 B942 8D39  60E1 327C 1EF3 8DF5 4C32")
    ("reepca"
     "74D6 A930 F44B 9B84 9EA5  5606 C166 AA49 5F7F 189C")
    ("rekado"
     "BCA6 89B6 3655 3801 C3C6  2150 197A 5888 235F ACAC")
    ("rhelling"
     "0154 E1B9 1CC9 D9EF 7764  8DE7 F3A7 27DB 44FC CA36")
    ("roelj (old)"
     "17CB 2812 EB63 3DFF 2C7F  0452 C3EC 1DCA 8430 72E1")
    ("roelj"
     ;; From commit cc51c03ff867d4633505354819c6d88af88bf919 (March 2020).
     ;; See <https://lists.gnu.org/archive/html/guix-devel/2020-03/msg00070.html>.
     "F556 FD94 FB8F 8B87 79E3  6832 CBD0 CD51 38C1 9AFC")
    ("roptat (old)"
     "B5FA E628 5B41 3728 B2A0  FAED 4311 1F45 2008 6A0C")
    ("roptat"
     ;; From commit 2cbede5935eb6a40173bbdf30a9ad22bf7574c22 (Jan. 2020).  See
     ;; <https://lists.gnu.org/archive/html/guix-devel/2020-01/msg00499.html>.
     "1EFB 0909 1F17 D28C CBF9  B13A 53D4 57B2 D636 EE82")
    ("samplet"
     ;; primary: "D6B0 C593 DA8C 5EDC A44C  7A58 C336 91F7 1188 B004"
     "A02C 2D82 0EF4 B25B A6B5  1D90 2AC6 A5EC 1C35 7C59")
    ("sleep_walker"
     "77DD AD2D 97F5 31BB C0F3  C7FD DFB5 EB09 AA62 5423")
    ("snape"
     "F494 72F4 7A59 00D5 C235  F212 89F9 6D48 08F3 59C7")
    ("steap"
     "4E26 CCE9 578E 0828 9855  BDD4 1C79 95D2 D5A3 8336")
    ("taylanub"
     "9ADE 9ECF 2B19 C180 9C99  5CEA A1F4 CFCC 5283 6BAC")

    ;; https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00826.html
    ("thomasd"
     ;; primary: "1DD1 681F E285 E07F 11DC  0C59 2E15 A6BC D77D 54FD"
     "3D2C DA58 819C 08C2 A649  D43D 5C3B 064C 724A 5726")
    ("thomasd (old)"
     "A5C5 92EA 606E 7106 A6A3  BC08 98B2 1575 91E1 2B08")

    ("toothbrush"
     "D712 1D73 A40A 7264 9E43  ED7D F284 6B1A 0D32 C442")
    ("vagrantc"
     "6580 7361 3BFC C5C7 E2E4  5D45 DC51 8FC8 7F97 16AA")
    ("wigust"
     ;; primary: "C955 CC5D C048 7FB1 7966  40A9 199A F6A3 67E9 4ABB"
     "7238 7123 8EAC EB63 4548  5857 167F 8EA5 001A FA9C")
    ("wingo"
     "FF47 8FB2 64DE 32EC 2967  25A3 DDC0 F535 8812 F8F2")))

(define %authorized-signing-keys
  ;; Fingerprint of authorized signing keys.
  (map (match-lambda
         ((name fingerprint)
          (base16-string->bytevector
           (string-downcase (string-filter char-set:graphic fingerprint)))))
       %committers))

(define %commits-with-bad-signature
  ;; Commits with a known-bad signature.
  '("6a34f4ccc8a5d4a48e25ad3c9c512f8634928b91"))  ;2016-12-29

(define %unsigned-commits
  ;; Commits lacking a signature.
  '())

(define (commit-signing-key repo commit-id keyring)
  "Return the OpenPGP key that signed COMMIT-ID (an OID).  Raise an exception
if the commit is unsigned, has an invalid signature, or if its signing key is
not in KEYRING."
  (let-values (((signature signed-data)
                (catch 'git-error
                  (lambda ()
                    (commit-extract-signature repo commit-id))
                  (lambda _
                    (values #f #f)))))
    (unless signature
      (raise (condition
              (&message
               (message (format #f (G_ "commit ~a lacks a signature")
                                commit-id))))))

    (let ((signature (string->openpgp-packet signature)))
      (with-fluids ((%default-port-encoding "UTF-8"))
        (let-values (((status data)
                      (verify-openpgp-signature signature keyring
                                                (open-input-string signed-data))))
          (match status
            ('bad-signature
             ;; There's a signature but it's invalid.
             (raise (condition
                     (&message
                      (message (format #f (G_ "signature verification failed \
for commit ~a")
                                       (oid->string commit-id)))))))
            ('missing-key
             (raise (condition
                     (&message
                      (message (format #f (G_ "could not authenticate \
commit ~a: key ~a is missing")
                                       (oid->string commit-id)
                                       data))))))
            ('good-signature data)))))))

(define (read-authorizations port)
  "Read authorizations in the '.guix-authorizations' format from PORT, and
return a list of authorized fingerprints."
  (match (read port)
    (('authorizations ('version 0)
                      (((? string? fingerprints) _ ...) ...)
                      _ ...)
     (map (lambda (fingerprint)
            (base16-string->bytevector
             (string-downcase (string-filter char-set:graphic fingerprint))))
          fingerprints))))

(define* (commit-authorized-keys repository commit
                                 #:optional (default-authorizations '()))
  "Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on
authorizations listed in its parent commits.  If one of the parent commits
does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
  (define (commit-authorizations commit)
    (catch 'git-error
      (lambda ()
        (let* ((tree  (commit-tree commit))
               (entry (tree-entry-bypath tree ".guix-authorizations"))
               (blob  (blob-lookup repository (tree-entry-id entry))))
          (read-authorizations
           (open-bytevector-input-port (blob-content blob)))))
      (lambda (key error)
        (if (= (git-error-code error) GIT_ENOTFOUND)
            default-authorizations
            (throw key error)))))

  (apply lset-intersection bytevector=?
         (map commit-authorizations (commit-parents commit))))

(define (authenticate-commit repository commit keyring)
  "Authenticate COMMIT from REPOSITORY and return the signing key fingerprint.
Raise an error when authentication fails."
  (define id
    (commit-id commit))

  (define signing-key
    (commit-signing-key repository id keyring))

  (unless (member (openpgp-public-key-fingerprint signing-key)
                  (commit-authorized-keys repository commit
                                          %authorized-signing-keys))
    (raise (condition
            (&message
             (message (format #f (G_ "commit ~a not signed by an authorized \
key: ~a")
                              (oid->string id)
                              (openpgp-format-fingerprint
                               (openpgp-public-key-fingerprint
                                signing-key))))))))

  signing-key)

(define (load-keyring-from-blob repository oid keyring)
  "Augment KEYRING with the keyring available in the blob at OID, which may or
may not be ASCII-armored."
  (let* ((blob (blob-lookup repository oid))
         (port (open-bytevector-input-port (blob-content blob))))
    (get-openpgp-keyring (if (port-ascii-armored? port)
                             (open-bytevector-input-port (read-radix-64 port))
                             port)
                         keyring)))

(define (load-keyring-from-reference repository reference)
  "Load the '.key' files from the tree at REFERENCE in REPOSITORY and return
an OpenPGP keyring."
  (let* ((reference (branch-lookup repository
                                   (string-append "origin/" reference)
                                   BRANCH-REMOTE))
         (target    (reference-target reference))
         (commit    (commit-lookup repository target))
         (tree      (commit-tree commit)))
    (fold (lambda (name keyring)
            (if (string-suffix? ".key" name)
                (let ((entry (tree-entry-bypath tree name)))
                  (load-keyring-from-blob repository
                                          (tree-entry-id entry)
                                          keyring))
                keyring))
          %empty-keyring
          (tree-list tree))))

(define* (authenticate-commits repository commits
                               #:key
                               (keyring-reference "keyring")
                               (report-progress (const #t)))
  "Authenticate COMMITS, a list of commit objects, calling REPORT-PROGRESS for
each of them.  Return an alist showing the number of occurrences of each key.
The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY."
  (define keyring
    (load-keyring-from-reference repository keyring-reference))

  (fold (lambda (commit stats)
          (report-progress)
          (let ((signer (authenticate-commit repository commit keyring)))
            (match (assq signer stats)
              (#f          (cons `(,signer . 1) stats))
              ((_ . count) (cons `(,signer . ,(+ count 1))
                                 (alist-delete signer stats))))))
        '()
        commits))

(define commit-short-id
  (compose (cut string-take <> 7) oid->string commit-id))

\f
;;;
;;; Caching.
;;;

(define (authenticated-commit-cache-file)
  "Return the name of the file that contains the cache of
previously-authenticated commits."
  (string-append (cache-directory) "/authentication/channels/guix"))

(define (previously-authenticated-commits)
  "Return the previously-authenticated commits as a list of commit IDs (hex
strings)."
  (catch 'system-error
    (lambda ()
      (call-with-input-file (authenticated-commit-cache-file)
        read))
    (lambda args
      (if (= ENOENT (system-error-errno args))
          '()
          (apply throw args)))))

(define (cache-authenticated-commit commit-id)
  "Record in ~/.cache COMMIT-ID and its closure as authenticated (only
COMMIT-ID is written to cache, though)."
  (define %max-cache-length
    ;; Maximum number of commits in cache.
    200)

  (let ((lst  (delete-duplicates
               (cons commit-id (previously-authenticated-commits))))
        (file (authenticated-commit-cache-file)))
    (mkdir-p (dirname file))
    (with-atomic-file-output file
      (lambda (port)
        (let ((lst (if (> (length lst) %max-cache-length)
                       (take lst %max-cache-length) ;truncate
                       lst)))
          (chmod port #o600)
          (display ";; List of previously-authenticated commits.\n\n"
                   port)
          (pretty-print lst port))))))

\f
;;;
;;; Entry point.
;;;

(define (git-authenticate args)
  (define repository
    (repository-open "."))

  (let loop ((args args))
    (match args
      ((_ start end)
       (define start-commit
         (commit-lookup repository (string->oid start)))
       (define end-commit
         (commit-lookup repository (string->oid end)))

       (define authenticated-commits
         ;; Previously-authenticated commits that don't need to be checked
         ;; again.
         (filter-map (lambda (id)
                       (false-if-exception
                        (commit-lookup repository (string->oid id))))
                     (previously-authenticated-commits)))

       (define commits
         ;; Commits to authenticate, excluding the closure of
         ;; AUTHENTICATED-COMMITS.
         (commit-difference end-commit start-commit
                            authenticated-commits))

       (define reporter
         (progress-reporter/bar (length commits)))

       (format #t (G_ "Authenticating ~a to ~a (~a commits)...~%")
               (commit-short-id start-commit)
               (commit-short-id end-commit)
               (length commits))

       (let ((stats (call-with-progress-reporter reporter
                      (lambda (report)
                        (authenticate-commits repository commits
                                              #:report-progress report)))))
         (cache-authenticated-commit (oid->string (commit-id end-commit)))

         (unless (null? stats)
           (format #t (G_ "Signing statistics:~%"))
           (for-each (match-lambda
                       ((signer . count)
                        (format #t "  ~a ~10d~%"
                                (openpgp-format-fingerprint
                                 (openpgp-public-key-fingerprint signer))
                                count)))
                     (sort stats
                           (match-lambda*
                             (((_ . count1) (_ . count2))
                              (> count1 count2))))))))
      ((command start)
       (let* ((head (repository-head repository))
              (end  (reference-target head)))
         (loop (list command start (oid->string end)))))
      (_
       (format (current-error-port)
               (G_ "Usage: git-authenticate START [END]

Authenticate commits START to END or the current head.\n"))))))
Commit	Line	Data
1e43ab2c	1	;;; GNU Guix --- Functional package management for GNU
62b9d3d4	2	;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
aa78c596	3	;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
1e43ab2c LC	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	;;;
	21	;;; Authenticate a range of commits.
	22	;;;
	23
	24	(use-modules (git)
	25	(guix git)
051a45e6	26	(guix openpgp)
051a45e6	27	(guix base16)
aea6ab2f LC	28	((guix utils)
aea6ab2f LC	29	#:select (cache-directory with-atomic-file-output))
787766ed	30	((guix build utils) #:select (mkdir-p))
1e43ab2c LC	31	(guix i18n)
	32	(guix progress)
	33	(srfi srfi-1)
	34	(srfi srfi-11)
	35	(srfi srfi-26)
	36	(srfi srfi-34)
	37	(srfi srfi-35)
92db1036	38	(rnrs bytevectors)
787766ed	39	(rnrs io ports)
1e43ab2c	40	(ice-9 match)
787766ed LC	41	(ice-9 format)
787766ed LC	42	(ice-9 pretty-print))
1e43ab2c LC	43
	44	\f
	45	(define %committers
	46	;; List of committers. These are the user names found on
	47	;; <https://savannah.gnu.org/project/memberlist.php?group=guix> along with
	48	;; the fingerprint of the signing (sub)key.
	49	;;
	50	;; TODO: Replace this statically-defined list by an in-repo list.
	51	'(("andreas"
	52	"AD17 A21E F8AE D8F1 CC02 DBD9 F7D5 C9BF 765C 61E3")
	53	("ajgrf"
	54	"2A39 3FFF 68F4 EF7A 3D29 12AF 6F51 20A0 22FB B2D5")
	55	("alexvong1995"
	56	"306F CB8F 2C01 C25D 29D3 0556 61EF 502E F602 52F2")
	57	("alezost"
	58	"4FB9 9F49 2B12 A365 7997 E664 8246 0C08 2A0E E98F")
	59	("ambrevar"
	60	"50F3 3E2E 5B0C 3D90 0424 ABE8 9BDC F497 A4BB CC7F")
	61	("apteryx"
	62	"27D5 86A4 F890 0854 329F F09F 1260 E464 82E6 3562")
	63	("arunisaac"
	64	"7F73 0343 F2F0 9F3C 77BF 79D3 2E25 EE8B 6180 2BB3")
	65	("atheia"
b2504b12	66	;; primary: "3B12 9196 AE30 0C3C 0E90 A26F A715 5567 3271 9948"
05f8a143	67	"9A2B 401E D001 0650 1584 BAAC 8BC4 F447 6E8A 8E00")
c2cf286c AB	68	("bandali"
	69	;; primary: "BE62 7373 8E61 6D6D 1B3A 08E8 A21A 0202 4881 6103"
	70	"39B3 3C8D 9448 0D2D DCC2 A498 8B44 A0CD C7B9 56F2")
1e43ab2c LC	71	("bavier"
	72	;; primary: "34FF 38BC D151 25A6 E340 A0B5 3453 2F9F AFCA 8B8E"
	73	"A0C5 E352 2EF8 EF5C 64CD B7F0 FD73 CAC7 19D3 2566")
	74	("beffa"
	75	"3774 8024 880F D3FF DCA2 C9AB 5893 6E0E 2F1B 5A4C")
	76	("benwoodcroft"
	77	"BCF8 F737 2CED 080A 67EB 592D 2A6A D9F4 AAC2 0DF6")
	78	("biscuolo"
	79	"45CC 63B8 5258 C9D5 5F34 B239 D37D 0EA7 CECC 3912")
	80	("boskovits"
	81	"7988 3B9F 7D6A 4DBF 3719 0367 2506 A96C CF63 0B21")
	82	("brettgilio"
	83	"DFC0 C7F7 9EE6 0CA7 AE55 5E19 6722 43C4 A03F 0EEE")
	84	("carl"
	85	;; primary: "0401 7A2A 6D9A 0CCD C81D 8EC2 96AB 007F 1A7E D999"
	86	"09CD D25B 5244 A376 78F6 EEA8 0CC5 2153 1979 91A5")
	87	("cbaines"
	88	"3E89 EEE7 458E 720D 9754 E0B2 5E28 A33B 0B84 F577")
	89	("civodul"
	90	"3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5")
	91	("cwebber"
	92	"510A 8628 E2A7 7678 8F8C 709C 4BC0 2592 5FF8 F4D3")
	93	("dannym"
	94	;; primary: "295A F991 6F46 F8A1 34B0 29DA 8086 3842 F0FE D83B"
	95	"76CE C6B1 7274 B465 C02D B3D9 E71A 3554 2C30 BAA5")
	96	("davexunit"
	97	"B3C0 DB4D AD73 BA5D 285E 19AE 5143 0234 CEFD 87C3")
	98	("davexunit (2nd)" ;FIXME: to be confirmed!
	99	"8CCB A7F5 52B9 CBEA E1FB 2915 8328 C747 0FF1 D807")
62b9d3d4 LC	100	("daviwil"
62b9d3d4 LC	101	"53C4 1E6E 41AA FE55 335A CA5E 446A 2ED4 D940 BF14")
1e43ab2c LC	102	("dvc"
	103	"6909 6DFD D702 8BED ACC5 884B C5E0 51C7 9C0B ECDB")
	104	("dvc (old)"
	105	"5F43 B681 0437 2F4B A898 A64B 33B9 E9FD E28D 2C23")
	106	("efraim"
	107	"A28B F40C 3E55 1372 662D 14F7 41AA E7DC CA3D 8351")
	108	("efraim (old)"
	109	"9157 41FE B22F A4E3 3B6E 8F8D F4C1 D391 7EAC EE93")
1e30d4e0 LC	110	("glv"
	111	;; primary: "2453 02B1 BAB1 F867 FDCA 96BC 8F3F 861F 82EB 7A9A"
	112	"CBC5 9C66 EC27 B971 7940 6B3E 6BE8 208A DF21 FE3F")
1e43ab2c LC	113	("hoebjo"
	114	"2219 43F4 9E9F 276F 9499 3382 BF28 6CB6 593E 5FFD")
	115	("htgoebel"
	116	"B943 509D 633E 80DD 27FC 4EED 634A 8DFF D3F6 31DF")
	117	("ipetkov"
	118	"7440 26BA 7CA3 C668 E940 1D53 0B43 1E98 3705 6942")
	119	("iyzsong"
	120	;; primary: "66A5 6D9C 9A98 BE7F 719A B401 2652 5665 AE72 7D37"
	121	"0325 78A6 8298 94E7 2AA2 66F5 D415 BF25 3B51 5976")
	122
	123	;; https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00229.html
	124	("janneke (old)"
	125	"DB34 CB51 D25C 9408 156F CDD6 A12F 8797 8D70 1B99")
	126	("janneke"
	127	"1A85 8392 E331 EAFD B8C2 7FFB F3C1 A0D9 C1D6 5273")
	128
	129	("jlicht"
	130	;; primary: "1BA4 08C5 8BF2 0EA7 3179 635A 865D C0A3 DED9 B5D0"
	131	"E31D 9DDE EBA5 4A14 8A20 4550 DA45 97F9 47B4 1025")
	132	("jmd"
	133	"8797 A26D 0854 2EAB 0285 A290 8A67 719C 2DE8 27B3")
	134	("kkebreau"
	135	"83B6 703A DCCA 3B69 4BCE 2DA6 E6A5 EE3C 1946 7A0D")
	136	("leungbk"
	137	"45E5 75FA 53EA 8BD6 1BCE 0B4E 3ADC 75F0 13D6 78F9")
	138	("lfam"
	139	;; primary: "4F71 6F9A 8FA2 C80E F1B5 E1BA 5E35 F231 DE1A C5E0"
	140	"B051 5948 F1E7 D3C1 B980 38A0 2646 FA30 BACA 7F08")
	141	("lsl88"
	142	"2AE3 1395 932B E642 FC0E D99C 9BED 6EDA 32E5 B0BC")
	143	("marusich"
	144	"CBF5 9755 CBE7 E7EF EF18 3FB1 DD40 9A15 D822 469D")
	145	("mbakke"
	146	"BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA")
	147	("mhw"
	148	"D919 0965 CE03 199E AF28 B3BE 7CEF 2984 7562 C516")
	149	("mothacehe"
	150	"4008 6A7E 0252 9B60 31FB 8607 8354 7635 3176 9CA6")
	151	("mthl"
	152	"F2A3 8D7E EB2B 6640 5761 070D 0ADE E100 9460 4D37")
	153	("nckx"
1e43ab2c LC	154	;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B"
1e43ab2c LC	155	"F5DA 2032 4B87 3D0B 7A38 7672 0DB0 FF88 4F55 6D79")
aa78c596 TGR	156	("nckx (revoked; not compromised)"
	157	;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B"
	158	"7E8F AED0 0944 78EF 72E6 4D16 D889 B0F0 18C5 493C")
56893b9b LC	159	("niedzejkob"
56893b9b LC	160	"E576 BFB2 CF6E B13D F571 33B9 E315 A758 4613 1564")
1e43ab2c LC	161	("ngz"
	162	"ED0E F1C8 E126 BA83 1B48 5FE9 DA00 B4F0 48E9 2F2D")
	163	("pelzflorian"
	164	"CEF4 CB91 4856 BA38 0A20 A7E2 3008 88CB 39C6 3817")
	165	("pgarlick"
	166	;; primary: "B68B DF22 73F9 DA0E 63C1 8A32 515B F416 9242 D600"
	167	"C699 ED09 E51B CE89 FD1D A078 AAC7 E891 896B 568A")
	168	("phant0mas"
	169	"3A86 380E 58A8 B942 8D39 60E1 327C 1EF3 8DF5 4C32")
	170	("reepca"
	171	"74D6 A930 F44B 9B84 9EA5 5606 C166 AA49 5F7F 189C")
	172	("rekado"
	173	"BCA6 89B6 3655 3801 C3C6 2150 197A 5888 235F ACAC")
	174	("rhelling"
	175	"0154 E1B9 1CC9 D9EF 7764 8DE7 F3A7 27DB 44FC CA36")
a1363a36	176	("roelj (old)"
1e43ab2c	177	"17CB 2812 EB63 3DFF 2C7F 0452 C3EC 1DCA 8430 72E1")
a1363a36 LC	178	("roelj"
	179	;; From commit cc51c03ff867d4633505354819c6d88af88bf919 (March 2020).
	180	;; See <https://lists.gnu.org/archive/html/guix-devel/2020-03/msg00070.html>.
	181	"F556 FD94 FB8F 8B87 79E3 6832 CBD0 CD51 38C1 9AFC")
cd903b04	182	("roptat (old)"
1e43ab2c	183	"B5FA E628 5B41 3728 B2A0 FAED 4311 1F45 2008 6A0C")
cd903b04 LC	184	("roptat"
	185	;; From commit 2cbede5935eb6a40173bbdf30a9ad22bf7574c22 (Jan. 2020). See
	186	;; <https://lists.gnu.org/archive/html/guix-devel/2020-01/msg00499.html>.
	187	"1EFB 0909 1F17 D28C CBF9 B13A 53D4 57B2 D636 EE82")
1e43ab2c LC	188	("samplet"
	189	;; primary: "D6B0 C593 DA8C 5EDC A44C 7A58 C336 91F7 1188 B004"
	190	"A02C 2D82 0EF4 B25B A6B5 1D90 2AC6 A5EC 1C35 7C59")
	191	("sleep_walker"
	192	"77DD AD2D 97F5 31BB C0F3 C7FD DFB5 EB09 AA62 5423")
	193	("snape"
	194	"F494 72F4 7A59 00D5 C235 F212 89F9 6D48 08F3 59C7")
1e43ab2c LC	195	("steap"
	196	"4E26 CCE9 578E 0828 9855 BDD4 1C79 95D2 D5A3 8336")
	197	("taylanub"
	198	"9ADE 9ECF 2B19 C180 9C99 5CEA A1F4 CFCC 5283 6BAC")
	199
	200	;; https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00826.html
	201	("thomasd"
a73a530d LC	202	;; primary: "1DD1 681F E285 E07F 11DC 0C59 2E15 A6BC D77D 54FD"
a73a530d LC	203	"3D2C DA58 819C 08C2 A649 D43D 5C3B 064C 724A 5726")
1e43ab2c LC	204	("thomasd (old)"
	205	"A5C5 92EA 606E 7106 A6A3 BC08 98B2 1575 91E1 2B08")
	206
	207	("toothbrush"
	208	"D712 1D73 A40A 7264 9E43 ED7D F284 6B1A 0D32 C442")
	209	("vagrantc"
	210	"6580 7361 3BFC C5C7 E2E4 5D45 DC51 8FC8 7F97 16AA")
	211	("wigust"
	212	;; primary: "C955 CC5D C048 7FB1 7966 40A9 199A F6A3 67E9 4ABB"
	213	"7238 7123 8EAC EB63 4548 5857 167F 8EA5 001A FA9C")
	214	("wingo"
	215	"FF47 8FB2 64DE 32EC 2967 25A3 DDC0 F535 8812 F8F2")))
	216
	217	(define %authorized-signing-keys
	218	;; Fingerprint of authorized signing keys.
	219	(map (match-lambda
	220	((name fingerprint)
051a45e6 LC	221	(base16-string->bytevector
051a45e6 LC	222	(string-downcase (string-filter char-set:graphic fingerprint)))))
1e43ab2c LC	223	%committers))
	224
	225	(define %commits-with-bad-signature
	226	;; Commits with a known-bad signature.
	227	'("6a34f4ccc8a5d4a48e25ad3c9c512f8634928b91")) ;2016-12-29
	228
	229	(define %unsigned-commits
	230	;; Commits lacking a signature.
	231	'())
	232
051a45e6 LC	233	(define (commit-signing-key repo commit-id keyring)
	234	"Return the OpenPGP key that signed COMMIT-ID (an OID). Raise an exception
	235	if the commit is unsigned, has an invalid signature, or if its signing key is
	236	not in KEYRING."
1e43ab2c LC	237	(let-values (((signature signed-data)
	238	(catch 'git-error
	239	(lambda ()
	240	(commit-extract-signature repo commit-id))
	241	(lambda _
	242	(values #f #f)))))
051a45e6 LC	243	(unless signature
	244	(raise (condition
	245	(&message
	246	(message (format #f (G_ "commit ~a lacks a signature")
	247	commit-id))))))
	248
	249	(let ((signature (string->openpgp-packet signature)))
	250	(with-fluids ((%default-port-encoding "UTF-8"))
	251	(let-values (((status data)
	252	(verify-openpgp-signature signature keyring
	253	(open-input-string signed-data))))
	254	(match status
	255	('bad-signature
	256	;; There's a signature but it's invalid.
	257	(raise (condition
	258	(&message
	259	(message (format #f (G_ "signature verification failed \
1e43ab2c	260	for commit ~a")
051a45e6 LC	261	(oid->string commit-id)))))))
	262	('missing-key
	263	(raise (condition
	264	(&message
	265	(message (format #f (G_ "could not authenticate \
1e43ab2c	266	commit ~a: key ~a is missing")
051a45e6 LC	267	(oid->string commit-id)
	268	data))))))
	269	('good-signature data)))))))
	270
92db1036 LC	271	(define (read-authorizations port)
	272	"Read authorizations in the '.guix-authorizations' format from PORT, and
	273	return a list of authorized fingerprints."
	274	(match (read port)
	275	(('authorizations ('version 0)
	276	(((? string? fingerprints) _ ...) ...)
	277	_ ...)
	278	(map (lambda (fingerprint)
	279	(base16-string->bytevector
	280	(string-downcase (string-filter char-set:graphic fingerprint))))
	281	fingerprints))))
	282
	283	(define* (commit-authorized-keys repository commit
	284	#:optional (default-authorizations '()))
	285	"Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on
	286	authorizations listed in its parent commits. If one of the parent commits
	287	does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
	288	(define (commit-authorizations commit)
	289	(catch 'git-error
	290	(lambda ()
	291	(let* ((tree (commit-tree commit))
	292	(entry (tree-entry-bypath tree ".guix-authorizations"))
	293	(blob (blob-lookup repository (tree-entry-id entry))))
	294	(read-authorizations
	295	(open-bytevector-input-port (blob-content blob)))))
	296	(lambda (key error)
	297	(if (= (git-error-code error) GIT_ENOTFOUND)
	298	default-authorizations
	299	(throw key error)))))
	300
	301	(apply lset-intersection bytevector=?
	302	(map commit-authorizations (commit-parents commit))))
	303
051a45e6	304	(define (authenticate-commit repository commit keyring)
1e43ab2c LC	305	"Authenticate COMMIT from REPOSITORY and return the signing key fingerprint.
	306	Raise an error when authentication fails."
	307	(define id
	308	(commit-id commit))
	309
	310	(define signing-key
051a45e6	311	(commit-signing-key repository id keyring))
1e43ab2c	312
051a45e6	313	(unless (member (openpgp-public-key-fingerprint signing-key)
92db1036 LC	314	(commit-authorized-keys repository commit
92db1036 LC	315	%authorized-signing-keys))
1e43ab2c LC	316	(raise (condition
	317	(&message
	318	(message (format #f (G_ "commit ~a not signed by an authorized \
	319	key: ~a")
051a45e6 LC	320	(oid->string id)
	321	(openpgp-format-fingerprint
	322	(openpgp-public-key-fingerprint
	323	signing-key))))))))
1e43ab2c LC	324
	325	signing-key)
	326
041dc3a9 LC	327	(define (load-keyring-from-blob repository oid keyring)
	328	"Augment KEYRING with the keyring available in the blob at OID, which may or
	329	may not be ASCII-armored."
	330	(let* ((blob (blob-lookup repository oid))
	331	(port (open-bytevector-input-port (blob-content blob))))
	332	(get-openpgp-keyring (if (port-ascii-armored? port)
	333	(open-bytevector-input-port (read-radix-64 port))
	334	port)
	335	keyring)))
	336
	337	(define (load-keyring-from-reference repository reference)
	338	"Load the '.key' files from the tree at REFERENCE in REPOSITORY and return
	339	an OpenPGP keyring."
8d65a71e LC	340	(let* ((reference (branch-lookup repository
	341	(string-append "origin/" reference)
	342	BRANCH-REMOTE))
041dc3a9 LC	343	(target (reference-target reference))
	344	(commit (commit-lookup repository target))
	345	(tree (commit-tree commit)))
	346	(fold (lambda (name keyring)
	347	(if (string-suffix? ".key" name)
	348	(let ((entry (tree-entry-bypath tree name)))
	349	(load-keyring-from-blob repository
	350	(tree-entry-id entry)
	351	keyring))
	352	keyring))
	353	%empty-keyring
	354	(tree-list tree))))
	355
1e43ab2c	356	(define* (authenticate-commits repository commits
041dc3a9	357	#:key
8d65a71e	358	(keyring-reference "keyring")
041dc3a9	359	(report-progress (const #t)))
1e43ab2c	360	"Authenticate COMMITS, a list of commit objects, calling REPORT-PROGRESS for
041dc3a9 LC	361	each of them. Return an alist showing the number of occurrences of each key.
041dc3a9 LC	362	The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY."
051a45e6	363	(define keyring
041dc3a9	364	(load-keyring-from-reference repository keyring-reference))
051a45e6 LC	365
	366	(fold (lambda (commit stats)
	367	(report-progress)
	368	(let ((signer (authenticate-commit repository commit keyring)))
	369	(match (assq signer stats)
	370	(#f (cons `(,signer . 1) stats))
	371	((_ . count) (cons `(,signer . ,(+ count 1))
	372	(alist-delete signer stats))))))
	373	'()
	374	commits))
1e43ab2c LC	375
	376	(define commit-short-id
	377	(compose (cut string-take <> 7) oid->string commit-id))
	378
	379	\f
787766ed LC	380	;;;
	381	;;; Caching.
	382	;;;
	383
	384	(define (authenticated-commit-cache-file)
	385	"Return the name of the file that contains the cache of
	386	previously-authenticated commits."
	387	(string-append (cache-directory) "/authentication/channels/guix"))
	388
	389	(define (previously-authenticated-commits)
	390	"Return the previously-authenticated commits as a list of commit IDs (hex
	391	strings)."
	392	(catch 'system-error
	393	(lambda ()
	394	(call-with-input-file (authenticated-commit-cache-file)
	395	read))
	396	(lambda args
	397	(if (= ENOENT (system-error-errno args))
	398	'()
	399	(apply throw args)))))
	400
	401	(define (cache-authenticated-commit commit-id)
	402	"Record in ~/.cache COMMIT-ID and its closure as authenticated (only
	403	COMMIT-ID is written to cache, though)."
	404	(define %max-cache-length
	405	;; Maximum number of commits in cache.
	406	200)
	407
	408	(let ((lst (delete-duplicates
	409	(cons commit-id (previously-authenticated-commits))))
	410	(file (authenticated-commit-cache-file)))
	411	(mkdir-p (dirname file))
	412	(with-atomic-file-output file
	413	(lambda (port)
	414	(let ((lst (if (> (length lst) %max-cache-length)
	415	(take lst %max-cache-length) ;truncate
	416	lst)))
	417	(chmod port #o600)
	418	(display ";; List of previously-authenticated commits.\n\n"
	419	port)
	420	(pretty-print lst port))))))
	421
	422	\f
1e43ab2c LC	423	;;;
	424	;;; Entry point.
	425	;;;
	426
	427	(define (git-authenticate args)
	428	(define repository
	429	(repository-open "."))
	430
	431	(let loop ((args args))
	432	(match args
	433	((_ start end)
	434	(define start-commit
	435	(commit-lookup repository (string->oid start)))
	436	(define end-commit
	437	(commit-lookup repository (string->oid end)))
	438
787766ed LC	439	(define authenticated-commits
	440	;; Previously-authenticated commits that don't need to be checked
	441	;; again.
	442	(filter-map (lambda (id)
	443	(false-if-exception
	444	(commit-lookup repository (string->oid id))))
	445	(previously-authenticated-commits)))
	446
1e43ab2c	447	(define commits
787766ed LC	448	;; Commits to authenticate, excluding the closure of
	449	;; AUTHENTICATED-COMMITS.
	450	(commit-difference end-commit start-commit
	451	authenticated-commits))
1e43ab2c LC	452
	453	(define reporter
	454	(progress-reporter/bar (length commits)))
	455
	456	(format #t (G_ "Authenticating ~a to ~a (~a commits)...~%")
	457	(commit-short-id start-commit)
	458	(commit-short-id end-commit)
	459	(length commits))
	460
	461	(let ((stats (call-with-progress-reporter reporter
	462	(lambda (report)
	463	(authenticate-commits repository commits
	464	#:report-progress report)))))
787766ed LC	465	(cache-authenticated-commit (oid->string (commit-id end-commit)))
	466
	467	(unless (null? stats)
	468	(format #t (G_ "Signing statistics:~%"))
	469	(for-each (match-lambda
	470	((signer . count)
051a45e6 LC	471	(format #t " ~a ~10d~%"
	472	(openpgp-format-fingerprint
	473	(openpgp-public-key-fingerprint signer))
	474	count)))
787766ed LC	475	(sort stats
	476	(match-lambda*
	477	(((_ . count1) (_ . count2))
	478	(> count1 count2))))))))
1e43ab2c LC	479	((command start)
	480	(let* ((head (repository-head repository))
	481	(end (reference-target head)))
	482	(loop (list command start (oid->string end)))))
	483	(_
	484	(format (current-error-port)
	485	(G_ "Usage: git-authenticate START [END]
	486
	487	Authenticate commits START to END or the current head.\n"))))))