code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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/>.

(define-module (guix git-authenticate)
  #:use-module (git)
  #:autoload   (gcrypt hash) (sha256)
  #:use-module (guix base16)
  #:autoload   (guix base64) (base64-encode)
  #:use-module ((guix git)
                #:select (commit-difference false-if-git-not-found))
  #:use-module (guix i18n)
  #:use-module ((guix diagnostics) #:select (formatted-message))
  #:use-module (guix openpgp)
  #:use-module ((guix utils)
                #:select (cache-directory with-atomic-file-output))
  #:use-module ((guix build utils)
                #:select (mkdir-p))
  #:use-module (guix progress)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:export (read-authorizations
            commit-signing-key
            commit-authorized-keys
            authenticate-commit
            authenticate-commits
            load-keyring-from-reference
            previously-authenticated-commits
            cache-authenticated-commit

            repository-cache-key
            authenticate-repository

            git-authentication-error?
            git-authentication-error-commit
            unsigned-commit-error?
            unauthorized-commit-error?
            unauthorized-commit-error-signing-key
            signature-verification-error?
            signature-verification-error-keyring
            signature-verification-error-signature
            missing-key-error?
            missing-key-error-signature))

;;; Commentary:
;;;
;;; This module provides tools to authenticate a range of Git commits.  A
;;; commit is considered "authentic" if and only if it is signed by an
;;; authorized party.  Parties authorized to sign a commit are listed in the
;;; '.guix-authorizations' file of the parent commit.
;;;
;;; Code:

(define-condition-type &git-authentication-error &error
  git-authentication-error?
  (commit  git-authentication-error-commit))

(define-condition-type &unsigned-commit-error &git-authentication-error
  unsigned-commit-error?)

(define-condition-type &unauthorized-commit-error &git-authentication-error
  unauthorized-commit-error?
  (signing-key unauthorized-commit-error-signing-key))

(define-condition-type &signature-verification-error &git-authentication-error
  signature-verification-error?
  (signature signature-verification-error-signature)
  (keyring   signature-verification-error-keyring))

(define-condition-type &missing-key-error &git-authentication-error
  missing-key-error?
  (signature missing-key-error-signature))

(define* (commit-signing-key repo commit-id keyring
                             #:key (disallowed-hash-algorithms '(sha1)))
  "Return the OpenPGP key that signed COMMIT-ID (an OID).  Raise an exception
if the commit is unsigned, has an invalid signature, has a signature using one
of the hash algorithms in DISALLOWED-HASH-ALGORITHMS, 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 (make-compound-condition
              (condition (&unsigned-commit-error (commit commit-id)))
              (formatted-message (G_ "commit ~a lacks a signature")
                                 (oid->string commit-id)))))

    (let ((signature (string->openpgp-packet signature)))
      (when (memq (openpgp-signature-hash-algorithm signature)
                  `(,@disallowed-hash-algorithms md5))
        (raise (make-compound-condition
                (condition (&unsigned-commit-error (commit commit-id)))
                (formatted-message (G_ "commit ~a has a ~a signature, \
which is not permitted")
                                   (oid->string commit-id)
                                   (openpgp-signature-hash-algorithm
                                    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 (make-compound-condition
                     (condition
                      (&signature-verification-error (commit commit-id)
                                                     (signature signature)
                                                     (keyring keyring)))
                     (formatted-message (G_ "signature verification failed \
for commit ~a")
                                        (oid->string commit-id)))))
            ('missing-key
             (raise (make-compound-condition
                     (condition (&missing-key-error (commit commit-id)
                                                    (signature signature)))
                     (formatted-message (G_ "could not authenticate \
commit ~a: key ~a is missing")
                                        (oid->string commit-id)
                                        (openpgp-format-fingerprint 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 (parents-have-authorizations-file? commit)
    ;; Return true if at least one of the parents of COMMIT has the
    ;; '.guix-authorizations' file.
    (find (lambda (commit)
            (false-if-git-not-found
             (tree-entry-bypath (commit-tree commit)
                                ".guix-authorizations")))
          (commit-parents commit)))

  (define (assert-parents-lack-authorizations commit)
    ;; If COMMIT removes the '.guix-authorizations' file found in one of its
    ;; parents, raise an error.
    (when (parents-have-authorizations-file? commit)
      (raise (make-compound-condition
              (condition
               (&unauthorized-commit-error (commit (commit-id commit))
                                           (signing-key #f)))
              (formatted-message (G_ "commit ~a attempts \
to remove '.guix-authorizations' file")
                                 (oid->string (commit-id commit)))))))

  (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)
            (begin
              ;; Prevent removal of '.guix-authorizations' since it would make
              ;; it trivial to force a fallback to DEFAULT-AUTHORIZATIONS.
              (assert-parents-lack-authorizations commit)
              default-authorizations)
            (throw key error)))))

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

(define* (authenticate-commit repository commit keyring
                              #:key (default-authorizations '()))
  "Authenticate COMMIT from REPOSITORY and return the signing key fingerprint.
Raise an error when authentication fails.  If one of the parent commits does
not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
  (define id
    (commit-id commit))

  (define recent-commit?
    (false-if-git-not-found
     (tree-entry-bypath (commit-tree commit) ".guix-authorizations")))

  (define signing-key
    (commit-signing-key repository id keyring
                        ;; Reject SHA1 signatures unconditionally as suggested
                        ;; by the authors of "SHA-1 is a Shambles" (2019).
                        ;; Accept it for "historical" commits (there are such
                        ;; signatures from April 2020 in the repository).
                        #:disallowed-hash-algorithms
                        (if recent-commit? '(sha1) '())))

  (unless (member (openpgp-public-key-fingerprint signing-key)
                  (commit-authorized-keys repository commit
                                          default-authorizations))
    (raise (make-compound-condition
            (condition
             (&unauthorized-commit-error (commit id)
                                         (signing-key signing-key)))
            (formatted-message (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 reference BRANCH-ALL))
         (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
                               (default-authorizations '())
                               (keyring-reference "keyring")
                               (keyring (load-keyring-from-reference
                                         repository keyring-reference))
                               (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.
If KEYRING is omitted, the OpenPGP keyring is loaded from KEYRING-REFERENCE in
REPOSITORY."
  (fold (lambda (commit stats)
          (report-progress)
          (let ((signer (authenticate-commit repository commit keyring
                                             #:default-authorizations
                                             default-authorizations)))
            (match (assq signer stats)
              (#f          (cons `(,signer . 1) stats))
              ((_ . count) (cons `(,signer . ,(+ count 1))
                                 (alist-delete signer stats))))))
        '()
        commits))

;;;
;;; Caching.
;;;

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

(define (previously-authenticated-commits key)
  "Return the previously-authenticated commits under KEY as a list of commit
IDs (hex strings)."
  (catch 'system-error
    (lambda ()
      (call-with-input-file (authenticated-commit-cache-file key)
        (lambda (port)
          ;; If PORT has the wrong permissions, it might have been tampered
          ;; with by another user so ignore its contents.
          (if (= #o600 (stat:perms (stat port)))
              (read port)
              (begin
                (chmod port #o600)
                '())))))
    (lambda args
      (if (= ENOENT (system-error-errno args))
          '()
          (apply throw args)))))

(define (cache-authenticated-commit key commit-id)
  "Record in ~/.cache, under KEY, 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 key))))
        (file (authenticated-commit-cache-file key)))
    (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))))))

;;;
;;; High-level interface.
;;;

(define (repository-cache-key repository)
  "Return a unique key to store the authenticate commit cache for REPOSITORY."
  (string-append "checkouts/"
                 (base64-encode
                  (sha256 (string->utf8 (repository-directory repository))))))

(define (verify-introductory-commit repository keyring commit expected-signer)
  "Look up COMMIT in REPOSITORY, and raise an exception if it is not signed by
EXPECTED-SIGNER."
  (define actual-signer
    (openpgp-public-key-fingerprint
     (commit-signing-key repository (commit-id commit) keyring)))

  (unless (bytevector=? expected-signer actual-signer)
    (raise (formatted-message (G_ "initial commit ~a is signed by '~a' \
instead of '~a'")
                              (oid->string (commit-id commit))
                              (openpgp-format-fingerprint actual-signer)
                              (openpgp-format-fingerprint expected-signer)))))

(define* (authenticate-repository repository start signer
                                  #:key
                                  (keyring-reference "keyring")
                                  (cache-key (repository-cache-key repository))
                                  (end (reference-target
                                        (repository-head repository)))
                                  (historical-authorizations '())
                                  (make-reporter
                                   (const progress-reporter/silent)))
  "Authenticate REPOSITORY up to commit END, an OID.  Authentication starts
with commit START, an OID, which must be signed by SIGNER; an exception is
raised if that is not the case.  Return an alist mapping OpenPGP public keys
to the number of commits signed by that key that have been traversed.

The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY, where
KEYRING-REFERENCE is the name of a branch.  The list of authenticated commits
is cached in the authentication cache under CACHE-KEY.

HISTORICAL-AUTHORIZATIONS must be a list of OpenPGP fingerprints (bytevectors)
denoting the authorized keys for commits whose parent lack the
'.guix-authorizations' file."
  (define start-commit
    (commit-lookup repository start))
  (define end-commit
    (commit-lookup repository end))

  (define keyring
    (load-keyring-from-reference repository keyring-reference))

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

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

  ;; When COMMITS is empty, it's because END-COMMIT is in the closure of
  ;; START-COMMIT and/or AUTHENTICATED-COMMITS, in which case it's known to
  ;; be authentic already.
  (if (null? commits)
      '()
      (let ((reporter (make-reporter start-commit end-commit commits)))
        ;; If it's our first time, verify START-COMMIT's signature.
        (when (null? authenticated-commits)
          (verify-introductory-commit repository keyring
                                      start-commit signer))

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

          stats))))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;;
;;; 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/>.

(define-module (guix git-download)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix modules)
  #:autoload   (guix build-system gnu) (standard-packages)
  #:use-module (git)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (git-reference
            git-reference?
            git-reference-url
            git-reference-commit
            git-reference-recursive?

            git-fetch
            git-version
            git-file-name
            git-predicate))

;;; Commentary:
;;;
;;; An <origin> method that fetches a specific commit from a Git repository.
;;; The repository URL and commit hash are specified with a <git-reference>
;;; object.
;;;
;;; Code:

(define-record-type* <git-reference>
  git-reference make-git-reference
  git-reference?
  (url        git-reference-url)
  (commit     git-reference-commit)
  (recursive? git-reference-recursive?   ; whether to recurse into sub-modules
              (default #f)))

(define (git-package)
  "Return the default Git package."
  (let ((distro (resolve-interface '(gnu packages version-control))))
    (module-ref distro 'git-minimal)))

(define* (git-fetch ref hash-algo hash
                    #:optional name
                    #:key (system (%current-system)) (guile (default-guile))
                    (git (git-package)))
  "Return a fixed-output derivation that fetches REF, a <git-reference>
object.  The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
  (define inputs
    ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
    ;; available so that 'git submodule' works.
    (if (git-reference-recursive? ref)
        (standard-packages)

        ;; The 'swh-download' procedure requires tar and gzip.
        `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression))
                               'gzip))
          ("tar" ,(module-ref (resolve-interface '(gnu packages base))
                              'tar)))))

  (define guile-json
    (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))

  (define guile-zlib
    (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))

  (define gnutls
    (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))

  (define modules
    (delete '(guix config)
            (source-module-closure '((guix build git)
                                     (guix build utils)
                                     (guix build download-nar)
                                     (guix swh)))))

  (define build
    (with-imported-modules modules
      (with-extensions (list guile-json gnutls   ;for (guix swh)
                             guile-zlib)
        #~(begin
            (use-modules (guix build git)
                         (guix build utils)
                         (guix build download-nar)
                         (guix swh)
                         (ice-9 match))

            (define recursive?
              (call-with-input-string (getenv "git recursive?") read))

            ;; The 'git submodule' commands expects Coreutils, sed,
            ;; grep, etc. to be in $PATH.
            (set-path-environment-variable "PATH" '("bin")
                                           (match '#+inputs
                                             (((names dirs outputs ...) ...)
                                              dirs)))

            (setvbuf (current-output-port) 'line)
            (setvbuf (current-error-port) 'line)

            (or (git-fetch (getenv "git url") (getenv "git commit")
                           #$output
                           #:recursive? recursive?
                           #:git-command (string-append #+git "/bin/git"))
                (download-nar #$output)

                ;; As a last resort, attempt to download from Software Heritage.
                ;; Disable X.509 certificate verification to avoid depending
                ;; on nss-certs--we're authenticating the checkout anyway.
                ;; XXX: Currently recursive checkouts are not supported.
                (and (not recursive?)
                     (parameterize ((%verify-swh-certificate? #f))
                       (format (current-error-port)
                               "Trying to download from Software Heritage...~%")
                       (swh-download (getenv "git url") (getenv "git commit")
                                     #$output))))))))

  (mlet %store-monad ((guile (package->derivation guile system)))
    (gexp->derivation (or name "git-checkout") build

                      ;; Use environment variables and a fixed script name so
                      ;; there's only one script in store for all the
                      ;; downloads.
                      #:script-name "git-download"
                      #:env-vars
                      `(("git url" . ,(git-reference-url ref))
                        ("git commit" . ,(git-reference-commit ref))
                        ("git recursive?" . ,(object->string
                                              (git-reference-recursive? ref))))
                      #:leaked-env-vars '("http_proxy" "https_proxy"
                                          "LC_ALL" "LC_MESSAGES" "LANG"
                                          "COLUMNS")

                      #:system system
                      #:local-build? #t           ;don't offload repo cloning
                      #:hash-algo hash-algo
                      #:hash hash
                      #:recursive? #t
                      #:guile-for-build guile)))

(define (git-version version revision commit)
  "Return the version string for packages using git-download."
  ;; git-version is almost exclusively executed while modules are being loaded.
  ;; This makes any errors hide their backtrace. Avoid the mysterious error
  ;; "Value out of range 0 to N: 7" when the commit ID is too short, which
  ;; can happen, for example, when the user swapped the revision and commit
  ;; arguments by mistake.
  (when (< (string-length commit) 7)
    (raise
      (condition
        (&message (message "git-version: commit ID unexpectedly short")))))
  (string-append version "-" revision "." (string-take commit 7)))

(define (git-file-name name version)
  "Return the file-name for packages using git-download."
  (string-append name "-" version "-checkout"))

;;;
;;; 'git-predicate'.
;;;

(define (git-file-list directory)
  "Return the list of files checked in in the Git repository at DIRECTORY.
The result is similar to that of the 'git ls-files' command, except that it
also includes directories, not just regular files.  The returned file names
are relative to DIRECTORY, which is not necessarily the root of the checkout."
  (let* (;; 'repository-working-directory' always returns a trailing "/",
         ;; so add one here to ease the comparisons below.
         (directory  (string-append (canonicalize-path directory) "/"))
         (dot-git    (repository-discover directory))
         (repository (repository-open dot-git))
         (workdir    (repository-working-directory repository))
         (head       (repository-head repository))
         (oid        (reference-target head))
         (commit     (commit-lookup repository oid))
         (tree       (commit-tree commit))
         (files      (tree-list tree)))
    (repository-close! repository)
    (if (string=? workdir directory)
        files
        (let ((relative (string-drop directory (string-length workdir))))
          (filter-map (lambda (file)
                        (and (string-prefix? relative file)
                             (string-drop file (string-length relative))))
                      files)))))

(define (git-predicate directory)
  "Return a predicate that returns true if a file is part of the Git checkout
living at DIRECTORY.  If DIRECTORY does not lie within a Git checkout, and
upon Git errors, return #f instead of a predicate.

The returned predicate takes two arguments FILE and STAT where FILE is an
absolute file name and STAT is the result of 'lstat'."
  (catch 'git-error
    (lambda ()
      (let* ((files  (git-file-list directory))
             (inodes (fold (lambda (file result)
                             (let ((stat
                                    (lstat (string-append directory "/"
                                                          file))))
                               (vhash-consv (stat:ino stat) (stat:dev stat)
                                            result)))
                           vlist-null
                           files)))
        (lambda (file stat)
          ;; Comparing file names is always tricky business so we rely on inode
          ;; numbers instead.
          (match (vhash-assv (stat:ino stat) inodes)
            ((_ . dev) (= dev (stat:dev stat)))
            (#f        #f)))))
    (const #f)))

;;; git-download.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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/>.

(define-module (guix git)
  #:use-module (git)
  #:use-module (git object)
  #:use-module (guix i18n)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix sets)
  #:use-module ((guix diagnostics) #:select (leave))
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (%repository-cache-directory
            honor-system-x509-certificates!

            url-cache-directory
            with-repository
            with-git-error-handling
            false-if-git-not-found
            update-cached-checkout
            url+commit->name
            latest-repository-commit
            commit-difference
            commit-relation

            git-checkout
            git-checkout?
            git-checkout-url
            git-checkout-branch
            git-checkout-commit
            git-checkout-recursive?))

(define %repository-cache-directory
  (make-parameter (string-append (cache-directory #:ensure? #f)
                                 "/checkouts")))

(define (honor-system-x509-certificates!)
  "Use the system's X.509 certificates for Git checkouts over HTTPS.  Honor
the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
  ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
  ;; files (instead of all the certificates) among which "ca-bundle.crt".  On
  ;; other distros /etc/ssl/certs usually contains the whole set of
  ;; certificates along with "ca-certificates.crt".  Try to choose the right
  ;; one.
  (let ((file      (letrec-syntax ((choose
                                    (syntax-rules ()
                                      ((_ file rest ...)
                                       (let ((f file))
                                         (if (and f (file-exists? f))
                                             f
                                             (choose rest ...))))
                                      ((_)
                                       #f))))
                     (choose (getenv "SSL_CERT_FILE")
                             "/etc/ssl/certs/ca-certificates.crt"
                             "/etc/ssl/certs/ca-bundle.crt")))
        (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
    (and (or file
             (and=> (stat directory #f)
                    (lambda (st)
                      (> (stat:nlink st) 2))))
         (begin
           (set-tls-certificate-locations! directory file)
           #t))))

(define %certificates-initialized?
  ;; Whether 'honor-system-x509-certificates!' has already been called.
  #f)

(define-syntax-rule (with-libgit2 thunk ...)
  (begin
    ;; XXX: The right thing to do would be to call (libgit2-shutdown) here,
    ;; but pointer finalizers used in guile-git may be called after shutdown,
    ;; resulting in a segfault. Hence, let's skip shutdown call for now.
    (libgit2-init!)
    (unless %certificates-initialized?
      (honor-system-x509-certificates!)
      (set! %certificates-initialized? #t))
    thunk ...))

(define* (url-cache-directory url
                              #:optional (cache-directory
                                          (%repository-cache-directory))
                              #:key recursive?)
  "Return the directory associated to URL in %repository-cache-directory."
  (string-append
   cache-directory "/"
   (bytevector->base32-string
    (sha256 (string->utf8 (if recursive?
                              (string-append "R:" url)
                              url))))))

;; Authentication appeared in Guile-Git 0.3.0, check if it is available.
(define auth-supported?
  (false-if-exception (resolve-interface '(git auth))))

(define (clone* url directory)
  "Clone git repository at URL into DIRECTORY.  Upon failure,
make sure no empty directory is left behind."
  (with-throw-handler #t
    (lambda ()
      (mkdir-p directory)

      ;; Note: Explicitly pass options to work around the invalid default
      ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
      (if (module-defined? (resolve-interface '(git))
                           'clone-init-options)
          (let ((auth-method (and auth-supported?
                                  (%make-auth-ssh-agent))))
            (clone url directory
                   (if auth-supported?
                       (make-clone-options
                        #:fetch-options (make-fetch-options auth-method))
                       (clone-init-options))))
          (clone url directory)))
    (lambda _
      (false-if-exception (rmdir directory)))))

(define (url+commit->name url sha1)
  "Return the string \"<REPO-NAME>-<SHA1:7>\" where REPO-NAME is the name of
the git repository, extracted from URL and SHA1:7 the seven first digits
of SHA1 string."
  (string-append
   (string-replace-substring
    (last (string-split url #\/)) ".git" "")
   "-" (string-take sha1 7)))

(define (resolve-reference repository ref)
  "Resolve the branch, commit or tag specified by REF, and return the
corresponding Git object."
  (let resolve ((ref ref))
    (match ref
      (('branch . branch)
       (let ((oid (reference-target
                   (branch-lookup repository branch BRANCH-REMOTE))))
         (object-lookup repository oid)))
      (('commit . commit)
       (let ((len (string-length commit)))
         ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
         ;; can't be sure it's available.  Furthermore, 'string->oid' used to
         ;; read out-of-bounds when passed a string shorter than 40 chars,
         ;; which is why we delay calls to it below.
         (if (< len 40)
             (if (module-defined? (resolve-interface '(git object))
                                  'object-lookup-prefix)
                 (object-lookup-prefix repository (string->oid commit) len)
                 (raise (condition
                         (&message
                          (message "long Git object ID is required")))))
             (object-lookup repository (string->oid commit)))))
      (('tag-or-commit . str)
       (if (or (> (string-length str) 40)
               (not (string-every char-set:hex-digit str)))
           (resolve `(tag . ,str))              ;definitely a tag
           (catch 'git-error
             (lambda ()
               (resolve `(tag . ,str)))
             (lambda _
               ;; There's no such tag, so it must be a commit ID.
               (resolve `(commit . ,str))))))
      (('tag    . tag)
       (let ((oid (reference-name->oid repository
                                       (string-append "refs/tags/" tag))))
         ;; OID may point to a "tag" object, but it can also point directly
         ;; to a "commit" object, as surprising as it may seem.  Return that
         ;; object, whatever that is.
         (object-lookup repository oid))))))

(define (switch-to-ref repository ref)
  "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
OID (roughly the commit hash) corresponding to REF."
  (define obj
    (resolve-reference repository ref))

  (reset repository obj RESET_HARD)
  (object-id obj))

(define (call-with-repository directory proc)
  (let ((repository #f))
   (dynamic-wind
     (lambda ()
       (set! repository (repository-open directory)))
     (lambda ()
       (proc repository))
     (lambda ()
       (repository-close! repository)))))

(define-syntax-rule (with-repository directory repository exp ...)
  "Open the repository at DIRECTORY and bind REPOSITORY to it within the
dynamic extent of EXP."
  (call-with-repository directory
                        (lambda (repository) exp ...)))

(define (report-git-error error)
  "Report the given Guile-Git error."
  ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
  ;; errors would be represented by integers.
  (match error
    ((? integer? error)                           ;old Guile-Git
     (leave (G_ "Git error ~a~%") error))
    ((? git-error? error)                         ;new Guile-Git
     (leave (G_ "Git error: ~a~%") (git-error-message error)))))

(define-syntax-rule (with-git-error-handling body ...)
  (catch 'git-error
    (lambda ()
      body ...)
    (lambda (key err)
      (report-git-error err))))

(define (load-git-submodules)
  "Attempt to load (git submodules), which was missing until Guile-Git 0.2.0.
Return true on success, false on failure."
  (match (false-if-exception (resolve-interface '(git submodule)))
    (#f
     (set! load-git-submodules (const #f))
     #f)
    (iface
     (module-use! (resolve-module '(guix git)) iface)
     (set! load-git-submodules (const #t))
     #t)))

(define* (update-submodules repository
                            #:key (log-port (current-error-port)))
  "Update the submodules of REPOSITORY, a Git repository object."
  ;; Guile-Git < 0.2.0 did not have (git submodule).
  (if (load-git-submodules)
      (for-each (lambda (name)
                  (let ((submodule (submodule-lookup repository name)))
                    (format log-port (G_ "updating submodule '~a'...~%")
                            name)
                    (submodule-update submodule)

                    ;; Recurse in SUBMODULE.
                    (let ((directory (string-append
                                      (repository-working-directory repository)
                                      "/" (submodule-path submodule))))
                      (with-repository directory repository
                        (update-submodules repository
                                           #:log-port log-port)))))
                (repository-submodules repository))
      (format (current-error-port)
              (G_ "Support for submodules is missing; \
please upgrade Guile-Git.~%"))))

(define-syntax-rule (false-if-git-not-found exp)
  "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
  (catch 'git-error
    (lambda ()
      exp)
    (lambda (key error . rest)
      (if (= GIT_ENOTFOUND (git-error-code error))
          #f
          (apply throw key error rest)))))

(define (reference-available? repository ref)
  "Return true if REF, a reference such as '(commit . \"cabba9e\"), is
definitely available in REPOSITORY, false otherwise."
  (match ref
    (('commit . commit)
     (false-if-git-not-found
      (->bool (commit-lookup repository (string->oid commit)))))
    (_
     #f)))

(define* (update-cached-checkout url
                                 #:key
                                 (ref '(branch . "master"))
                                 recursive?
                                 (check-out? #t)
                                 starting-commit
                                 (log-port (%make-void-port "w"))
                                 (cache-directory
                                  (url-cache-directory
                                   url (%repository-cache-directory)
                                   #:recursive? recursive?)))
  "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return three
values: the cache directory name, and the SHA1 commit (a string) corresponding
to REF, and the relation of the new commit relative to STARTING-COMMIT (if
provided) as returned by 'commit-relation'.

REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
the associated data: [<branch name> | <sha1> | <tag name> | <string>].

When RECURSIVE? is true, check out submodules as well, if any.

When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave
it unchanged."
  (define canonical-ref
    ;; We used to require callers to specify "origin/" for each branch, which
    ;; made little sense since the cache should be transparent to them.  So
    ;; here we append "origin/" if it's missing and otherwise keep it.
    (match ref
      (('branch . branch)
       `(branch . ,(if (string-prefix? "origin/" branch)
                       branch
                       (string-append "origin/" branch))))
      (_ ref)))

  (with-libgit2
   (let* ((cache-exists? (openable-repository? cache-directory))
          (repository    (if cache-exists?
                             (repository-open cache-directory)
                             (clone* url cache-directory))))
     ;; Only fetch remote if it has not been cloned just before.
     (when (and cache-exists?
                (not (reference-available? repository ref)))
       (if auth-supported?
           (let ((auth-method (and auth-supported?
                                   (%make-auth-ssh-agent))))
             (remote-fetch (remote-lookup repository "origin")
                           #:fetch-options (make-fetch-options auth-method)))
           (remote-fetch (remote-lookup repository "origin"))))
     (when recursive?
       (update-submodules repository #:log-port log-port))

     ;; Note: call 'commit-relation' from here because it's more efficient
     ;; than letting users re-open the checkout later on.
     (let* ((oid      (if check-out?
                          (switch-to-ref repository canonical-ref)
                          (object-id
                           (resolve-reference repository canonical-ref))))
            (new      (and starting-commit
                           (commit-lookup repository oid)))
            (old      (and starting-commit
                           (false-if-git-not-found
                            (commit-lookup repository
                                           (string->oid starting-commit)))))
            (relation (and starting-commit
                           (if old
                               (commit-relation old new)
                               'unrelated))))

       ;; Reclaim file descriptors and memory mappings associated with
       ;; REPOSITORY as soon as possible.
       (when (module-defined? (resolve-interface '(git repository))
                              'repository-close!)
         (repository-close! repository))

       (values cache-directory (oid->string oid) relation)))))

(define* (latest-repository-commit store url
                                   #:key
                                   recursive?
                                   (log-port (%make-void-port "w"))
                                   (cache-directory
                                    (%repository-cache-directory))
                                   (ref '(branch . "master")))
  "Return two values: the content of the git repository at URL copied into a
store directory and the sha1 of the top level commit in this directory.  The
reference to be checkout, once the repository is fetched, is specified by REF.
REF is pair whose key is [branch | commit | tag] and value the associated
data, respectively [<branch name> | <sha1> | <tag name>].

When RECURSIVE? is true, check out submodules as well, if any.

Git repositories are kept in the cache directory specified by
%repository-cache-directory parameter.

Log progress and checkout info to LOG-PORT."
  (define (dot-git? file stat)
    (and (string=? (basename file) ".git")
         (or (eq? 'directory (stat:type stat))

             ;; Submodule checkouts end up with a '.git' regular file that
             ;; contains metadata about where their actual '.git' directory
             ;; lives.
             (and recursive?
                  (eq? 'regular (stat:type stat))))))

  (format log-port "updating checkout of '~a'...~%" url)
  (let*-values
      (((checkout commit _)
        (update-cached-checkout url
                                #:recursive? recursive?
                                #:ref ref
                                #:cache-directory
                                (url-cache-directory url cache-directory
                                                     #:recursive?
                                                     recursive?)
                                #:log-port log-port))
       ((name)
        (url+commit->name url commit)))
    (format log-port "retrieved commit ~a~%" commit)
    (values (add-to-store store name #t "sha256" checkout
                          #:select? (negate dot-git?))
            commit)))

(define (print-git-error port key args default-printer)
  (match args
    (((? git-error? error) . _)
     (format port (G_ "Git error: ~a~%")
             (git-error-message error)))))

(set-exception-printer! 'git-error print-git-error)

;;;
;;; Commit difference.
;;;

(define* (commit-closure commit #:optional (visited (setq)))
  "Return the closure of COMMIT as a set.  Skip commits contained in VISITED,
a set, and adjoin VISITED to the result."
  (let loop ((commits (list commit))
             (visited visited))
    (match commits
      (()
       visited)
      ((head . tail)
       (if (set-contains? visited head)
           (loop tail visited)
           (loop (append (commit-parents head) tail)
                 (set-insert head visited)))))))

(define* (commit-difference new old #:optional (excluded '()))
  "Return the list of commits between NEW and OLD, where OLD is assumed to be
an ancestor of NEW.  Exclude all the commits listed in EXCLUDED along with
their ancestors.

Essentially, this computes the set difference between the closure of NEW and
that of OLD."
  (let loop ((commits (list new))
             (result '())
             (visited (fold commit-closure
                            (setq)
                            (cons old excluded))))
    (match commits
      (()
       (reverse result))
      ((head . tail)
       (if (set-contains? visited head)
           (loop tail result visited)
           (loop (append (commit-parents head) tail)
                 (cons head result)
                 (set-insert head visited)))))))

(define (commit-relation old new)
  "Return a symbol denoting the relation between OLD and NEW, two commit
objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
'unrelated, or 'self (OLD and NEW are the same commit)."
  (if (eq? old new)
      'self
      (let ((newest (commit-closure new)))
        (if (set-contains? newest old)
            'ancestor
            (let* ((seen   (list->setq (commit-parents new)))
                   (oldest (commit-closure old seen)))
              (if (set-contains? oldest new)
                  'descendant
                  'unrelated))))))

;;;
;;; Checkouts.
;;;

;; Representation of the "latest" checkout of a branch or a specific commit.
(define-record-type* <git-checkout>
  git-checkout make-git-checkout
  git-checkout?
  (url     git-checkout-url)
  (branch  git-checkout-branch (default "master"))
  (commit  git-checkout-commit (default #f))      ;#f | tag | commit
  (recursive? git-checkout-recursive? (default #f)))

(define* (latest-repository-commit* url #:key ref recursive? log-port)
  ;; Monadic variant of 'latest-repository-commit'.
  (lambda (store)
    ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so
    ;; translate it into '&message' conditions that we know will be properly
    ;; handled.
    (catch 'git-error
      (lambda ()
        (values (latest-repository-commit store url
                                          #:ref ref
                                          #:recursive? recursive?
                                          #:log-port log-port)
                store))
      (lambda (key error . _)
        (raise (condition
                (&message
                 (message
                  (match ref
                    (('commit . commit)
                     (format #f (G_ "cannot fetch commit ~a from ~a: ~a")
                             commit url (git-error-message error)))
                    (('branch . branch)
                     (format #f (G_ "cannot fetch branch '~a' from ~a: ~a")
                             branch url (git-error-message error)))
                    (_
                     (format #f (G_ "Git failure while fetching ~a: ~a")
                             url (git-error-message error))))))))))))

(define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>)
                                             system target)
  ;; "Compile" CHECKOUT by updating the local checkout and adding it to the
  ;; store.
  (match checkout
    (($ <git-checkout> url branch commit recursive?)
     (latest-repository-commit* url
                                #:ref (if commit
                                          `(tag-or-commit . ,commit)
                                          `(branch . ,branch))
                                #:recursive? recursive?
                                #:log-port (current-error-port)))))

;; Local Variables:
;; eval: (put 'with-repository 'scheme-indent-function 2)
;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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/>.

(define-module (guix glob)
  #:use-module (ice-9 match)
  #:export (string->sglob
            compile-sglob
            string->compiled-sglob
            glob-match?))

;;; Commentary:
;;;
;;; This is a minimal implementation of "glob patterns" (info "(libc)
;;; Globbbing").  It is currently limited to simple patterns and does not
;;; support braces, for instance.
;;;
;;; Code:

(define (parse-bracket chars)
  "Parse CHARS, a list of characters that extracted from a '[...]' sequence."
  (match chars
    ((start #\- end)
     `(range ,start ,end))
    (lst
     `(set ,@lst))))

(define (string->sglob str)
  "Return an sexp, called an \"sglob\", that represents the compiled form of
STR, a glob pattern such as \"foo*\" or \"foo??bar\"."
  (define flatten
    (match-lambda
      (((? string? str)) str)
      (x x)))

  (define (cons-string chars lst)
    (match chars
      (() lst)
      (_ (cons (list->string (reverse chars)) lst))))

  (let loop ((chars   (string->list str))
             (pending '())
             (brackets 0)
             (result '()))
    (match chars
      (()
       (flatten (reverse (if (null? pending)
                             result
                             (cons-string pending result)))))
      (((and chr (or #\? #\*)) . rest)
       (let ((wildcard (match chr
                         (#\? '?)
                         (#\* '*))))
         (if (zero? brackets)
             (loop rest '() 0
                   (cons* wildcard (cons-string pending result)))
             (loop rest (cons chr pending) brackets result))))
      ((#\[ . rest)
       (if (zero? brackets)
           (loop rest '() (+ 1 brackets)
                 (cons-string pending result))
           (loop rest (cons #\[ pending) (+ 1 brackets) result)))
      ((#\] . rest)
       (cond ((zero? brackets)
              (error "unexpected closing bracket" str))
             ((= 1 brackets)
              (loop rest '() 0
                    (cons (parse-bracket (reverse pending)) result)))
             (else
              (loop rest (cons #\] pending) (- brackets 1) result))))
      ((chr . rest)
       (loop rest (cons chr pending) brackets result)))))

(define (compile-sglob sglob)
  "Compile SGLOB into a more efficient representation."
  (if (string? sglob)
      sglob
      (let loop ((sglob sglob)
                 (result '()))
        (match sglob
          (()
           (reverse result))
          (('? . rest)
           (loop rest (cons char-set:full result)))
          ((('range start end) . rest)
           (loop rest (cons (ucs-range->char-set
                             (char->integer start)
                             (+ 1 (char->integer end)))
                            result)))
          ((('set . chars) . rest)
           (loop rest (cons (list->char-set chars) result)))
          ((head . rest)
           (loop rest (cons head result)))))))

(define string->compiled-sglob
  (compose compile-sglob string->sglob))

(define (glob-match? pattern str)
  "Return true if STR matches PATTERN, a compiled glob pattern as returned by
'compile-sglob'."
  (let loop ((pattern pattern)
             (str str))
   (match pattern
     ((? string? literal)
      (string=? literal str))
     (()
      (string-null? str))
     (('*)
      #t)
     (('* suffix . rest)
      (match (string-contains str suffix)
        (#f    #f)
        (index (loop rest
                     (string-drop str
                                  (+ index (string-length suffix)))))))
     (((? char-set? cs) . rest)
      (and (>= (string-length str) 1)
           (let ((chr (string-ref str 0)))
             (and (char-set-contains? cs chr)
                  (loop rest (string-drop str 1))))))
     ((prefix . rest)
      (and (string-prefix? prefix str)
           (loop rest (string-drop str (string-length prefix))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; 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/>.

(define-module (guix gnu-maintenance)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (sxml simple)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs io ports)
  #:use-module (system foreign)
  #:use-module (guix http-client)
  #:use-module (guix ftp-client)
  #:use-module (guix utils)
  #:use-module (guix memoization)
  #:use-module (guix records)
  #:use-module (guix upstream)
  #:use-module (guix packages)
  #:use-module (zlib)
  #:export (gnu-package-name
            gnu-package-mundane-name
            gnu-package-copyright-holder
            gnu-package-savannah
            gnu-package-fsd
            gnu-package-language
            gnu-package-logo
            gnu-package-doc-category
            gnu-package-doc-summary
            gnu-package-doc-description
            gnu-package-doc-urls
            gnu-package-download-url

            official-gnu-packages
            find-package
            gnu-package?

            release-file?
            releases
            latest-release
            gnu-release-archive-types
            gnu-package-name->name+version

            %gnu-updater
            %gnu-ftp-updater
            %savannah-updater
            %xorg-updater
            %kernel.org-updater))

;;; Commentary:
;;;
;;; Code for dealing with the maintenance of GNU packages, such as
;;; auto-updates.
;;;
;;; Code:

;;;
;;; List of GNU packages.
;;;

(define %gnumaint-base-url
  "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")

(define %package-list-url
  (string->uri
   (string-append %gnumaint-base-url "rec/gnupackages.rec")))

(define %package-description-url
  ;; This file contains package descriptions in recutils format.
  ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>
  ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
  (string->uri
   (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))

(define-record-type* <gnu-package-descriptor>
  gnu-package-descriptor
  make-gnu-package-descriptor

  gnu-package-descriptor?

  (name             gnu-package-name)
  (mundane-name     gnu-package-mundane-name)
  (copyright-holder gnu-package-copyright-holder)
  (savannah         gnu-package-savannah)
  (fsd              gnu-package-fsd)
  (language         gnu-package-language)         ; list of strings
  (logo             gnu-package-logo)
  (doc-category     gnu-package-doc-category)
  (doc-summary      gnu-package-doc-summary)
  (doc-description  gnu-package-doc-description)  ; taken from 'pkgdescr.txt'
  (doc-urls         gnu-package-doc-urls)         ; list of strings
  (download-url     gnu-package-download-url))

(define* (official-gnu-packages
          #:optional (fetch http-fetch/cached))
  "Return a list of records, which are GNU packages.  Use FETCH,
to fetch the list of GNU packages over HTTP."
  (define (read-records port)
    ;; Return a list of alists.  Each alist contains fields of a GNU
    ;; package.
    (let loop ((alist  (recutils->alist port))
               (result '()))
      (if (null? alist)
          (reverse result)
          (loop (recutils->alist port)

                ;; Ignore things like "%rec" (info "(recutils) Record
                ;; Descriptors").
                (if (assoc-ref alist "package")
                    (cons alist result)
                    result)))))

  (define official-description
    (let ((db (read-records (fetch %package-description-url #:text? #t))))
      (lambda (name)
        ;; Return the description found upstream for package NAME, or #f.
        (and=> (find (lambda (alist)
                       (equal? name (assoc-ref alist "package")))
                     db)
               (lambda (record)
                 (let ((field (assoc-ref record "blurb")))
                   ;; The upstream description file uses "redirect PACKAGE" as
                   ;; a blurb in cases where the description of the two
                   ;; packages should be considered the same (e.g., GTK+ has
                   ;; "redirect gnome".)  This is usually not acceptable for
                   ;; us because we prefer to have distinct descriptions in
                   ;; such cases.  Thus, ignore the 'blurb' field when that
                   ;; happens.
                   (and field
                        (not (string-prefix? "redirect " field))
                        field)))))))

  (map (lambda (alist)
         (let ((name (assoc-ref alist "package")))
           (alist->record `(("description" . ,(official-description name))
                            ,@alist)
                          make-gnu-package-descriptor
                          (list "package" "mundane_name" "copyright_holder"
                                "savannah" "fsd" "language" "logo"
                                "doc_category" "doc_summary" "description"
                                "doc_url"
                                "download_url")
                          '("doc_url" "language"))))
       (let* ((port (fetch %package-list-url #:text? #t))
              (lst  (read-records port)))
         (close-port port)
         lst)))

(define (find-package name)
  "Find GNU package called NAME and return it.  Return #f if it was not
found."
  (find (lambda (package)
          (string=? name (gnu-package-name package)))
        (official-gnu-packages)))

(define gnu-package?
  (let ((official-gnu-packages (memoize official-gnu-packages)))
    (mlambdaq (package)
      "Return true if PACKAGE is a GNU package.  This procedure may access the
network to check in GNU's database."
      (define (mirror-type url)
        (let ((uri (string->uri url)))
          (and (eq? (uri-scheme uri) 'mirror)
               (cond
                ((member (uri-host uri)
                         '("gnu" "gnupg" "gcc" "gnome"))
                 ;; Definitely GNU.
                 'gnu)
                ((equal? (uri-host uri) "cran")
                 ;; Possibly GNU: mirror://cran could be either GNU R itself
                 ;; or a non-GNU package.
                 #f)
                (else
                 ;; Definitely non-GNU.
                 'non-gnu)))))

      (define (gnu-home-page? package)
        (letrec-syntax ((>> (syntax-rules ()
                              ((_ value proc)
                               (and=> value proc))
                              ((_ value proc rest ...)
                               (and=> value
                                      (lambda (next)
                                        (>> (proc next) rest ...)))))))
          (>> package package-home-page
              string->uri uri-host
              (lambda (host)
                (member host '("www.gnu.org" "gnu.org"))))))

      (or (gnu-home-page? package)
          (match (package-source package)
            ((? origin? origin)
             (let ((url  (origin-uri origin))
                   (name (package-upstream-name package)))
               (case (and (string? url) (mirror-type url))
                 ((gnu) #t)
                 ((non-gnu) #f)
                 (else
                  (and (member name (map gnu-package-name (official-gnu-packages)))
                       #t)))))
            (_ #f))))))

;;;
;;; Latest FTP release.
;;;

(define (ftp-server/directory package)
  "Return the FTP server and directory where PACKAGE's tarball are stored."
  (let ((name (package-upstream-name package)))
    (values (or (assoc-ref (package-properties package) 'ftp-server)
                "ftp.gnu.org")
            (or (assoc-ref (package-properties package) 'ftp-directory)
                (string-append "/gnu/" name)))))

(define %tarball-rx
  ;; The .zip extensions is notably used for freefont-ttf.
  ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
  ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
  (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))

(define %alpha-tarball-rx
  (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))

(define (release-file? project file)
  "Return #f if FILE is not a release tarball of PROJECT, otherwise return
true."
  (and (not (member (file-extension file) '("sig" "sign" "asc")))
       (and=> (regexp-exec %tarball-rx file)
              (lambda (match)
                ;; Filter out unrelated files, like `guile-www-1.1.1'.
                ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
                ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
                (and=> (match:substring match 1)
                       (lambda (name)
                         (or (string-ci=? name project)
                             (string-ci=? name
                                          (string-append project
                                                         "-src")))))))
       (not (regexp-exec %alpha-tarball-rx file))
       (let ((s (tarball-sans-extension file)))
         (regexp-exec %package-name-rx s))))

(define (tarball->version tarball)
  "Return the version TARBALL corresponds to.  TARBALL is a file name like
\"coreutils-8.23.tar.xz\"."
  (let-values (((name version)
                (gnu-package-name->name+version
                 (tarball-sans-extension tarball))))
    version))

(define* (releases project
                   #:key
                   (server "ftp.gnu.org")
                   (directory (string-append "/gnu/" project)))
  "Return the list of <upstream-release> of PROJECT as a list of release
name/directory pairs."
  ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
  (define conn (ftp-open server))

  (let loop ((directories (list directory))
             (result      '()))
    (match directories
      (()
       (ftp-close conn)
       (coalesce-sources result))
      ((directory rest ...)
       (let* ((files   (ftp-list conn directory))
              (subdirs (filter-map (match-lambda
                                     ((name 'directory . _) name)
                                     (_ #f))
                                   files)))
         (define (file->url file)
           (string-append "ftp://" server directory "/" file))

         (define (file->source file)
           (let ((url (file->url file)))
             (upstream-source
              (package project)
              (version (tarball->version file))
              (urls (list url))
              (signature-urls (list (string-append url ".sig"))))))

         (loop (append (map (cut string-append directory "/" <>)
                            subdirs)
                       rest)
               (append
                ;; Filter out signatures, deltas, and files which
                ;; are potentially not releases of PROJECT--e.g.,
                ;; in /gnu/guile, filter out guile-oops and
                ;; guile-www; in mit-scheme, filter out binaries.
                (filter-map (match-lambda
                              ((file 'file . _)
                               (and (release-file? project file)
                                    (file->source file)))
                              (_ #f))
                            files)
                result)))))))

(define* (latest-ftp-release project
                             #:key
                             (server "ftp.gnu.org")
                             (directory (string-append "/gnu/" project))
                             (keep-file? (const #t))
                             (file->signature (cut string-append <> ".sig"))
                             (ftp-open ftp-open) (ftp-close ftp-close))
  "Return an <upstream-source> for the latest release of PROJECT on SERVER
under DIRECTORY, or #f.  Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
connections; this can be useful to reuse connections.

KEEP-FILE? is a predicate to decide whether to enter a directory and to
consider a given file (source tarball) as a valid candidate based on its name.

FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
return the corresponding signature URL, or #f it signatures are unavailable."
  (define (latest a b)
    (if (version>? a b) a b))

  (define (latest-release a b)
    (if (version>? (upstream-source-version a) (upstream-source-version b))
        a b))

  (define patch-directory-name?
    ;; Return #t for patch directory names such as 'bash-4.2-patches'.
    (cut string-suffix? "patches" <>))

  (define conn (ftp-open server))

  (define (file->url directory file)
    (string-append "ftp://" server directory "/" file))

  (define (file->source directory file)
    (let ((url (file->url directory file)))
      (upstream-source
       (package project)
       (version (tarball->version file))
       (urls (list url))
       (signature-urls (match (file->signature url)
                         (#f #f)
                         (sig (list sig)))))))

  (let loop ((directory directory)
             (result    #f))
    (let* ((entries (ftp-list conn directory))

           ;; Filter out things like /gnupg/patches.  Filter out "w32"
           ;; directories as found on ftp.gnutls.org.
           (subdirs (filter-map (match-lambda
                                  (((? patch-directory-name? dir)
                                    'directory . _)
                                   #f)
                                  (("w32" 'directory . _)
                                   #f)
                                  (("unstable" 'directory . _)
                                   ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
                                   #f)
                                  ((directory 'directory . _)
                                   directory)
                                  (_ #f))
                                entries))

           ;; Whether or not SUBDIRS is empty, compute the latest releases
           ;; for the current directory.  This is necessary for packages
           ;; such as 'sharutils' that have a sub-directory that contains
           ;; only an older release.
           (releases (filter-map (match-lambda
                                   ((file 'file . _)
                                    (and (release-file? project file)
                                         (keep-file? file)
                                         (file->source directory file)))
                                   (_ #f))
                                 entries)))

      ;; Assume that SUBDIRS correspond to versions, and jump into the
      ;; one with the highest version number.
      (let* ((release  (reduce latest-release #f
                               (coalesce-sources releases)))
             (result   (if (and result release)
                           (latest-release release result)
                           (or release result)))
             (target   (reduce latest #f subdirs)))
        (if target
            (loop (string-append directory "/" target)
                  result)
            (begin
              (ftp-close conn)
              result))))))

(define* (latest-release package
                         #:key
                         (server "ftp.gnu.org")
                         (directory (string-append "/gnu/" package)))
  "Return the <upstream-source> for the latest version of PACKAGE or #f.
PACKAGE must be the canonical name of a GNU package."
  (latest-ftp-release package
                      #:server server
                      #:directory directory))

(define-syntax-rule (false-if-ftp-error exp)
  "Return #f if an FTP error is raise while evaluating EXP; return the result
of EXP otherwise."
  (catch 'ftp-error
    (lambda ()
      exp)
    (lambda (key port . rest)
      (if (ftp-connection? port)
          (ftp-close port)
          (close-port port))
      #f)))

(define (latest-release* package)
  "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
errors that might occur when PACKAGE is not actually a GNU package, or not
hosted on ftp.gnu.org, or not under that name (this is the case for
\"emacs-auctex\", for instance.)"
  (let-values (((server directory)
                (ftp-server/directory package)))
    (false-if-ftp-error (latest-release (package-upstream-name package)
                                        #:server server
                                        #:directory directory))))

;;;
;;; Latest HTTP release.
;;;

(define (html->sxml port)
  "Read HTML from PORT and return the corresponding SXML tree."
  (let ((str (get-string-all port)))
    (catch #t
      (lambda ()
        ;; XXX: This is the poor developer's HTML-to-XML converter.  It's good
        ;; enough for directory listings at <https://kernel.org/pub> but if
        ;; needed we could resort to (htmlprag) from Guile-Lib.
        (call-with-input-string (string-replace-substring str "
" "
")
          xml->sxml))
      (const '(html)))))                          ;parse error

(define (html-links sxml)
  "Return the list of links found in SXML, the SXML tree of an HTML page."
  (let loop ((sxml sxml)
             (links '()))
    (match sxml
      (('a ('@ attributes ...) body ...)
       (match (assq 'href attributes)
         (#f          (fold loop links body))
         (('href url) (fold loop (cons url links) body))))
      ((tag ('@ _ ...) body ...)
       (fold loop links body))
      ((tag body ...)
       (fold loop links body))
      (_
       links))))

(define* (latest-html-release package
                              #:key
                              (base-url "https://kernel.org/pub")
                              (directory (string-append "/" package))
                              (file->signature (cut string-append <> ".sig")))
  "Return an <upstream-source> for the latest release of PACKAGE (a string) on
SERVER under DIRECTORY, or #f.  BASE-URL should be the URL of an HTML page,
typically a directory listing as found on 'https://kernel.org/pub'.

FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
return the corresponding signature URL, or #f it signatures are unavailable."
  (let* ((uri  (string->uri (string-append base-url directory "/")))
         (port (http-fetch/cached uri #:ttl 3600))
         (sxml (html->sxml port)))
    (define (url->release url)
      (and (string=? url (basename url))          ;relative reference?
           (release-file? package url)
           (let-values (((name version)
                         (package-name->name+version
                          (tarball-sans-extension url)
                          #\-)))
             (upstream-source
              (package name)
              (version version)
              (urls (list (string-append base-url directory "/" url)))
              (signature-urls
               (list (file->signature
                      (string-append base-url directory "/" url))))))))

    (define candidates
      (filter-map url->release (html-links sxml)))

    (close-port port)
    (match candidates
      (() #f)
      ((first . _)
       ;; Select the most recent release and return it.
       (reduce (lambda (r1 r2)
                 (if (version>? (upstream-source-version r1)
                                (upstream-source-version r2))
                     r1 r2))
               first
               (coalesce-sources candidates))))))

;;;
;;; Updaters.
;;;

(define %gnu-file-list-uri
  ;; URI of the file list for ftp.gnu.org.
  (string->uri "https://ftp.gnu.org/find.txt.gz"))

(define ftp.gnu.org-files
  (mlambda ()
    "Return the list of files available at ftp.gnu.org."

    ;; XXX: Memoize the whole procedure to work around the fact that
    ;; 'http-fetch/cached' caches the gzipped version.

    (define (trim-leading-components str)
      ;; Trim the leading ".", if any, in "./gnu/foo".
      (string-trim str (char-set #\.)))

    (define (string->lines str)
      (string-tokenize str (char-set-complement (char-set #\newline))))

    ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
    ;; TTL can be relatively short.
    (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
      (map trim-leading-components
           (call-with-gzip-input-port port
             (compose string->lines get-string-all))))))

(define (latest-gnu-release package)
  "Return the latest release of PACKAGE, a GNU package available via
ftp.gnu.org.

This method does not rely on FTP access at all; instead, it browses the file
list available from %GNU-FILE-LIST-URI over HTTP(S)."
  (let-values (((server directory)
                (ftp-server/directory package))
               ((name)
                (package-upstream-name package)))
    (let* ((files    (ftp.gnu.org-files))
           (relevant (filter (lambda (file)
                               (and (string-prefix? "/gnu" file)
                                    (string-contains file directory)
                                    (release-file? name (basename file))))
                             files)))
      (match (sort relevant (lambda (file1 file2)
                              (version>? (tarball-sans-extension
                                          (basename file1))
                                         (tarball-sans-extension
                                          (basename file2)))))
        ((and tarballs (reference _ ...))
         (let* ((version  (tarball->version reference))
                (tarballs (filter (lambda (file)
                                    (string=? (tarball-sans-extension
                                               (basename file))
                                              (tarball-sans-extension
                                               (basename reference))))
                                  tarballs)))
           (upstream-source
            (package name)
            (version version)
            (urls (map (lambda (file)
                         (string-append "mirror://gnu/"
                                        (string-drop file
                                                     (string-length "/gnu/"))))
                       tarballs))
            (signature-urls (map (cut string-append <> ".sig") urls)))))
        (()
         #f)))))

(define %package-name-rx
  ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
  ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
  (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))

(define (gnu-package-name->name+version name+version)
  "Return the package name and version number extracted from NAME+VERSION."
  (let ((match (regexp-exec %package-name-rx name+version)))
    (if (not match)
        (values name+version #f)
        (values (match:substring match 1) (match:substring match 2)))))

(define gnome-package?
  (url-prefix-predicate "mirror://gnome/"))

(define (pure-gnu-package? package)
  "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package.  This
excludes AucTeX, for instance, whose releases are now uploaded to
elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
releases are on gnu.org."
  (and (or (not (string-prefix? "emacs-" (package-name package)))
           (gnu-hosted? package))
       (not (gnome-package? package))
       (gnu-package? package)))

(define gnu-hosted?
  (url-prefix-predicate "mirror://gnu/"))

(define (url-prefix-rewrite old new)
  "Return a one-argument procedure that rewrites URL prefix OLD to NEW."
  (lambda (url)
    (if (string-prefix? old url)
        (string-append new (string-drop url (string-length old)))
        url)))

(define (adjusted-upstream-source source rewrite-url)
  "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
  (upstream-source
   (inherit source)
   (urls (map rewrite-url (upstream-source-urls source)))
   (signature-urls (and=> (upstream-source-signature-urls source)
                          (lambda (urls)
                            (map rewrite-url urls))))))

(define savannah-package?
  (url-prefix-predicate "mirror://savannah/"))

(define %savannah-base
  ;; One of the Savannah mirrors listed at
  ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid
  ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.)
  "https://nongnu.freemirror.org/nongnu")

(define (latest-savannah-release package)
  "Return the latest release of PACKAGE."
  (let* ((uri       (string->uri
                     (match (origin-uri (package-source package))
                       ((? string? uri) uri)
                       ((uri mirrors ...) uri))))
         (package   (package-upstream-name package))
         (directory (dirname (uri-path uri)))
         (rewrite   (url-prefix-rewrite %savannah-base
                                        "mirror://savannah")))
    ;; Note: We use the default 'file->signature', which adds ".sig", but not
    ;; all projects on Savannah follow that convention: some use ".asc" and
    ;; perhaps some lack signatures altogether.
    (and=> (latest-html-release package
                                #:base-url %savannah-base
                                #:directory directory)
           (cut adjusted-upstream-source <> rewrite))))

(define (latest-xorg-release package)
  "Return the latest release of PACKAGE."
  (let ((uri (string->uri (origin-uri (package-source package)))))
    (false-if-ftp-error
     (latest-ftp-release
      (package-name package)
      #:server "ftp.freedesktop.org"
      #:directory
      (string-append "/pub/xorg/" (dirname (uri-path uri)))))))

(define (latest-kernel.org-release package)
  "Return the latest release of PACKAGE, the name of a kernel.org package."
  (define %kernel.org-base
    ;; This URL and sub-directories thereof are nginx-generated directory
    ;; listings suitable for 'latest-html-release'.
    "https://mirrors.edge.kernel.org/pub")

  (define (file->signature file)
    (string-append (file-sans-extension file) ".sign"))

  (let* ((uri       (string->uri
                     (match (origin-uri (package-source package))
                       ((? string? uri) uri)
                       ((uri mirrors ...) uri))))
         (package   (package-upstream-name package))
         (directory (dirname (uri-path uri)))
         (rewrite   (url-prefix-rewrite %kernel.org-base
                                        "mirror://kernel.org")))
    (and=> (latest-html-release package
                                #:base-url %kernel.org-base
                                #:directory directory
                                #:file->signature file->signature)
           (cut adjusted-upstream-source <> rewrite))))

(define %gnu-updater
  ;; This is for everything at ftp.gnu.org.
  (upstream-updater
   (name 'gnu)
   (description "Updater for GNU packages")
   (pred gnu-hosted?)
   (latest latest-gnu-release)))

(define %gnu-ftp-updater
  ;; This is for GNU packages taken from alternate locations, such as
  ;; alpha.gnu.org, ftp.gnupg.org, etc.  It is obsolescent.
  (upstream-updater
   (name 'gnu-ftp)
   (description "Updater for GNU packages only available via FTP")
   (pred (lambda (package)
           (and (not (gnu-hosted? package))
                (pure-gnu-package? package))))
   (latest latest-release*)))

(define %savannah-updater
  (upstream-updater
   (name 'savannah)
   (description "Updater for packages hosted on savannah.gnu.org")
   (pred (url-prefix-predicate "mirror://savannah/"))
   (latest latest-savannah-release)))

(define %xorg-updater
  (upstream-updater
   (name 'xorg)
   (description "Updater for X.org packages")
   (pred (url-prefix-predicate "mirror://xorg/"))
   (latest latest-xorg-release)))

(define %kernel.org-updater
  (upstream-updater
   (name 'kernel.org)
   (description "Updater for packages hosted on kernel.org")
   (pred (url-prefix-predicate "mirror://kernel.org/"))
   (latest latest-kernel.org-release)))

;;; gnu-maintenance.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.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/>.

(define-module (guix gnupg)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 i18n)
  #:use-module (srfi srfi-1)
  #:use-module (guix i18n)
  #:use-module ((guix utils) #:select (config-directory))
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:export (%gpg-command
            %openpgp-key-server
            current-keyring
            gnupg-verify
            gnupg-verify*
            gnupg-status-good-signature?
            gnupg-status-missing-key?))

;;; Commentary:
;;;
;;; GnuPG interface.
;;;
;;; Code:

(define %gpg-command
  ;; The GnuPG 2.x command-line program name.
  (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))

(define %gpgv-command
  ;; The 'gpgv' program.
  (make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv")))

(define current-keyring
  ;; The default keyring of "trusted keys".
  (make-parameter (string-append (config-directory #:ensure? #f)
                                 "/gpg/trustedkeys.kbx")))

(define %openpgp-key-server
  ;; The default key server.  Note that keys.gnupg.net appears to be
  ;; unreliable.
  (make-parameter "pool.sks-keyservers.net"))

;; Regexps for status lines.  See file `doc/DETAILS' in GnuPG.

(define sigid-rx
  (make-regexp
   "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
(define goodsig-rx
  (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
(define validsig-rx
  (make-regexp
   "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
(define expkeysig-rx                    ; good signature, but expired key
  (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
(define revkeysig-rx                    ; good signature, but revoked key
  (make-regexp "^\\[GNUPG:\\] REVKEYSIG ([[:xdigit:]]+) (.*)$"))
(define errsig-rx
  ;; Note: The fingeprint part (the last element of the line) appeared in
  ;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing.
  (make-regexp
   "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)"))

(define* (gnupg-verify sig file
                       #:optional (keyring (current-keyring)))
  "Verify signature SIG for FILE against the keys in KEYRING.  All the keys in
KEYRING as assumed to be \"trusted\", whether or not they expired or were
revoked.  Return a status s-exp if GnuPG failed."

  (define (maybe-fingerprint str)
    (match (string-trim-both str)
      ((or "-" "") #f)
      (fpr         fpr)))

  (define (status-line->sexp line)
    (cond ((regexp-exec sigid-rx line)
           =>
           (lambda (match)
             `(signature-id ,(match:substring match 1) ; sig id
                            ,(match:substring match 2) ; date
                            ,(string->number           ; timestamp
                              (match:substring match 3)))))
          ((regexp-exec goodsig-rx line)
           =>
           (lambda (match)
             `(good-signature ,(match:substring match 1)    ; key id
                              ,(match:substring match 2)))) ; user name
          ((regexp-exec validsig-rx line)
           =>
           (lambda (match)
             `(valid-signature ,(match:substring match 1) ; fingerprint
                               ,(match:substring match 2) ; sig creation date
                               ,(string->number           ; timestamp
                                 (match:substring match 3)))))
          ((regexp-exec expkeysig-rx line)
           =>
           (lambda (match)
             `(expired-key-signature ,(match:substring match 1) ; fingerprint
                                     ,(match:substring match 2)))) ; user name
          ((regexp-exec revkeysig-rx line)
           =>
           (lambda (match)
             `(revoked-key-signature ,(match:substring match 1) ; fingerprint
                                     ,(match:substring match 2)))) ; user name
          ((regexp-exec errsig-rx line)
           =>
           (lambda (match)
             `(signature-error ,(match:substring match 1) ; key id
                               ,(match:substring match 2) ; pubkey algo
                               ,(match:substring match 3) ; hash algo
                               ,(match:substring match 4) ; sig class
                               ,(string->number           ; timestamp
                                 (match:substring match 5))
                               ,(let ((rc
                                       (string->number ; return code
                                        (match:substring match 6))))
                                  (case rc
                                    ((9) 'missing-key)
                                    ((4) 'unknown-algorithm)
                                    (else rc)))
                               ,(maybe-fingerprint ; fingerprint or #f
                                 (match:substring match 7)))))
          (else
           `(unparsed-line ,line))))

  (define (parse-status input)
    (let loop ((line   (read-line input))
               (result '()))
      (if (eof-object? line)
          (reverse result)
          (loop (read-line input)
                (cons (status-line->sexp line) result)))))

  (let* ((pipe   (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
                             "--keyring" keyring sig file))
         (status (parse-status pipe)))
    ;; Ignore PIPE's exit status since STATUS above should contain all the
    ;; info we need.
    (close-pipe pipe)
    status))

(define (gnupg-status-good-signature? status)
  "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
a fingerprint/user pair; return #f otherwise."
  (match (assq 'valid-signature status)
    (('valid-signature fingerprint date timestamp)
     (match (or (assq 'good-signature status)
                (assq 'expired-key-signature status)
                (assq 'revoked-key-signature status))
       ((_ key-id user) (cons fingerprint user))
       (_ #f)))
    (_
     #f)))

(define (gnupg-status-missing-key? status)
  "If STATUS denotes a missing-key error, then return the fingerprint of the
missing key or its key id if the fingerprint is unavailable."
  (any (lambda (sexp)
         (match sexp
           (('signature-error key-id _ ... 'missing-key fingerprint)
            (or fingerprint key-id))
           (_ #f)))
       status))

(define* (gnupg-receive-keys fingerprint/key-id server
                             #:optional (keyring (current-keyring)))
  "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to
KEYRING."
  (unless (file-exists? keyring)
    (mkdir-p (dirname keyring))
    (call-with-output-file keyring (const #t)))   ;create an empty keybox

  (zero? (system* (%gpg-command) "--keyserver" server
                  "--no-default-keyring" "--keyring" keyring
                  "--recv-keys" fingerprint/key-id)))

(define* (gnupg-verify* sig file
                        #:key
                        (key-download 'interactive)
                        (server (%openpgp-key-server))
                        (keyring (current-keyring)))
  "Like `gnupg-verify', but try downloading the public key if it's missing.
Return two values: 'valid-signature and a fingerprint/name pair upon success,
'missing-key and a fingerprint if the key could not be found, and
'invalid-signature with a fingerprint if the signature is invalid.

KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
values: 'always', 'never', and 'interactive' (default).  Return a
fingerprint/user name pair on success and #f otherwise."
  (let ((status (gnupg-verify sig file)))
    (match (gnupg-status-good-signature? status)
      ((fingerprint . user)
       (values 'valid-signature (cons fingerprint user)))
      (#f
       (let ((missing (gnupg-status-missing-key? status)))
         (define (download-and-try-again)
           ;; Download the missing key and try again.
           (if (gnupg-receive-keys missing server keyring)
               (match (gnupg-status-good-signature?
                       (gnupg-verify sig file keyring))
                 (#f
                  (values 'invalid-signature missing))
                 ((fingerprint . user)
                  (values 'valid-signature
                          (cons fingerprint user))))
               (values 'missing-key missing)))

         (define (receive?)
           (let ((answer
                  (begin
                    (format #t (G_ "Would you like to add this key \
to keyring '~a'?~%")
                            keyring)
                    (read-line))))
             (string-match (locale-yes-regexp) answer)))

         (case key-download
           ((never)
            (values 'missing-key missing))
           ((always)
            (download-and-try-again))
           (else
            (if (receive?)
                (download-and-try-again)
                (values 'missing-key missing)))))))))

;;; gnupg.scm ends here