;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2024, 2025 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 scripts git authenticate)
  #:use-module (git)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix git-authenticate)
  #:autoload   (guix openpgp) (openpgp-format-fingerprint
                               openpgp-public-key-fingerprint)
  #:use-module ((guix channels) #:select (openpgp-fingerprint))
  #:use-module ((guix git) #:select (with-git-error-handling))
  #:use-module (guix progress)
  #:autoload   (guix base16) (base16-string->bytevector)
  #:use-module (guix base64)
  #:autoload   (rnrs bytevectors) (bytevector=? bytevector-length)
  #:autoload   (gcrypt hash) (port-hash hash-algorithm sha1)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (guix-git-authenticate))

;;; Commentary:
;;;
;;; Authenticate a Git checkout by reading '.guix-authorizations' files and
;;; following the "authorizations invariant" also used by (guix channels).
;;;
;;; Code:

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix git authenticate")))

        (option '(#\r "repository") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'directory arg result)))
        (option '(#\e "end") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'end-commit (string->oid arg) result)))
        (option '(#\k "keyring") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'keyring-reference arg result)))
        (option '("cache-key") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'cache-key arg result)))
        (option '("historical-authorizations") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'historical-authorizations arg
                              result)))
        (option '("stats") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'show-stats? #t result)))))

(define %default-options
  '())

(define (current-branch repository)
  "Return the name of the checked out branch of REPOSITORY or #f if it could
not be determined."
  (and (not (repository-head-detached? repository))
       (let* ((head (repository-head repository))
              (name (reference-name head)))
         (and (string-prefix? "refs/heads/" name)
              (string-drop name (string-length "refs/heads/"))))))

(define (config-value repository key)
  "Return the config value associated with KEY in the 'guix.authentication' or
'guix.authentication-BRANCH' name space in REPOSITORY, or #f if no such config
was found."
  (let-syntax ((false-if-git-error
                (syntax-rules ()
                  ((_ exp)
                   (catch 'git-error (lambda () exp) (const #f))))))
    (let* ((config (repository-config repository))
           (branch (current-branch repository)))
      ;; First try the BRANCH-specific value, then the generic one.`
      (or (and branch
               (false-if-git-error
                (config-entry-value
                 (config-get-entry config
                                   (string-append "guix.authentication-"
                                                  branch "." key)))))
          (false-if-git-error
           (config-entry-value
            (config-get-entry config
                              (string-append "guix.authentication."
                                             key))))))))

(define (configured-introduction repository)
  "Return two values: the commit and signer fingerprint (strings) as
configured in REPOSITORY.  Error out if one or both were missing."
  (let* ((commit (config-value repository "introduction-commit"))
         (signer (config-value repository "introduction-signer")))
    (unless (and commit signer)
      (leave (G_ "unknown introductory commit and signer~%")))
    (values commit signer)))

(define (configured-keyring-reference repository)
  "Return the keyring reference configured in REPOSITORY or #f if missing."
  (config-value repository "keyring"))

(define (configured? repository)
  "Return true if REPOSITORY already container introduction info in its
'config' file."
  (and (config-value repository "introduction-commit")
       (config-value repository "introduction-signer")))

(define* (record-configuration repository
                               #:key commit signer keyring-reference)
  "Record COMMIT, SIGNER, and KEYRING-REFERENCE in the 'config' file of
REPOSITORY."
  (define config
    (repository-config repository))

  (set-config-string config "guix.authentication.introduction-commit"
                     commit)
  (set-config-string config "guix.authentication.introduction-signer"
                     signer)
  (set-config-string config "guix.authentication.keyring"
                     keyring-reference)
  (info (G_ "introduction and keyring recorded \
in repository configuration file~%")))

(define %pre-push-hook
  ;; Contents of the pre-push hook that gets installed.
  "\
#!/bin/sh
# Installed by 'guix git authenticate'.
set -e

# The \"empty hash\" used by Git when pushing a branch deletion.
z40=0000000000000000000000000000000000000000

while read local_ref local_oid remote_ref remote_oid
do
  if [ \"$local_oid\" != \"$z40\" ]
  then
      guix git authenticate --end=\"$local_oid\"
  fi
done\n")

(define (install-hooks repository)
  "Attempt to install in REPOSITORY hooks that invoke 'guix git authenticate'.
Bail out if one of these already exists."
  (define directory
    (repository-common-directory repository))

  (define pre-push-hook
    (in-vicinity directory "hooks/pre-push"))

  (define post-merge-hook
    (in-vicinity directory "hooks/post-merge"))

  (if (or (file-exists? pre-push-hook)
          (file-exists? post-merge-hook))
      (begin
        (warning (G_ "not overriding pre-existing hooks '~a' and '~a'~%")
                 pre-push-hook post-merge-hook)
        (display-hint (G_ "Consider running @command{guix git authenticate}
from your pre-push and post-merge hooks so your repository is automatically
authenticated before you push and when you pull updates.")))
      (begin
        (call-with-output-file pre-push-hook
          (lambda (port)
            (display %pre-push-hook port)
            (chmod port #o755)))
        (call-with-output-file post-merge-hook
          (lambda (port)
            (format port "#!/bin/sh
# Installed by 'guix git authenticate'.
exec guix git authenticate\n")
            (chmod port #o755)))
        (info (G_ "installed hooks '~a' and '~a'~%")
              pre-push-hook post-merge-hook))))

(define (broken-pre-push-hook? file)
  "Return true if FILE corresponds to a missing or known-broken pre-push hook
that needs to be replaced."
  (define broken-pre-push-hooks
    ;; Size and SHA1 hash of pre-push hooks that were automatically installed
    ;; but are known to be broken.
    `((161 "a9916155b71894014144fcafad7700f89da26c83")))

  (match (stat file #f)
    (#f #t)
    (st
     (find (match-lambda
             ((size bad-sha1)
              (and (= size (stat:size st))
                   (bytevector=? (call-with-input-file file
                                   (lambda (port)
                                     (port-hash (hash-algorithm sha1) port)))
                                 (base16-string->bytevector bad-sha1)))))
           broken-pre-push-hooks))))

(define (maybe-upgrade-hooks repository)
  "Update pre-push or post-merge hooks in REPOSITORY if it is missing or a
known-broken version is installed."
  (define directory
    (repository-common-directory repository))

  (define pre-push-hook
    (in-vicinity directory "hooks/pre-push"))

  (when (broken-pre-push-hook? pre-push-hook)
    (info (G_ "upgrading hook '~a'~%") pre-push-hook)
    (call-with-output-file pre-push-hook
      (lambda (port)
        (display %pre-push-hook port)
        (chmod port #o755)))))

(define (ensure-commit-id repository oid)
  "If OID refers to an annotated tag, return its target commit; otherwise
return OID."
  (let ((obj (object-lookup repository oid)))
    (if (= OBJ-TAG (object-type obj))
        (tag-target-id (tag-lookup repository oid))
        oid)))

(define (show-stats stats)
  "Display STATS, an alist containing commit signing stats as returned by
'authenticate-repository'."
  (format #t (G_ "Signing statistics:~%"))
  (for-each (match-lambda
              ((signer . count)
               (format #t "  ~a ~10d~%"
                       (openpgp-format-fingerprint
                        (openpgp-public-key-fingerprint signer))
                       count)))
            (sort stats
                  (match-lambda*
                    (((_ . count1) (_ . count2))
                     (> count1 count2))))))

(define (show-help)
  (display (G_ "Usage: guix git authenticate COMMIT SIGNER [OPTIONS...]
Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n"))
  (display (G_ "
  -r, --repository=DIRECTORY
                         open the Git repository at DIRECTORY"))
  (display (G_ "
  -k, --keyring=REFERENCE
                         load keyring from REFERENCE, a Git branch"))
  (display (G_ "
      --end=COMMIT       authenticate revisions up to COMMIT"))
  (display (G_ "
      --stats            display commit signing statistics upon completion"))
  (display (G_ "
      --cache-key=KEY    cache authenticated commits under KEY"))
  (display (G_ "
      --historical-authorizations=FILE
                         read historical authorizations from FILE"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))


;;;
;;; Entry point.
;;;

(define (guix-git-authenticate . args)
  (define options
    (parse-command-line args %options (list %default-options)
                        #:build-options? #f))

  (define (command-line-arguments lst)
    (reverse (filter-map (match-lambda
                           (('argument . arg) arg)
                           (_ #f))
                         lst)))

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

  (define (openpgp-fingerprint* str)
    (unless (string-every (char-set-union char-set:hex-digit
                                          char-set:whitespace)
                          str)
      (leave (G_ "~a: invalid OpenPGP fingerprint~%") str))
    (let ((fingerprint (openpgp-fingerprint str)))
      (unless (= 20 (bytevector-length fingerprint))
        (leave (G_ "~a: wrong length for OpenPGP fingerprint~%") str))
      fingerprint))

  (define (make-reporter start-commit end-commit commits)
    (format (current-error-port)
            (G_ "Authenticating commits ~a to ~a (~h new \
commits)...~%")
            (commit-short-id start-commit)
            (commit-short-id end-commit)
            (length commits))

    (if (isatty? (current-error-port))
        (progress-reporter/bar (length commits))
        progress-reporter/silent))

  (define (missing-arguments)
    (leave (G_ "wrong number of arguments; \
expected COMMIT and SIGNER~%")))

  (with-error-handling
    (with-git-error-handling
     (let* ((show-stats? (assoc-ref options 'show-stats?))
            (repository  (repository-open (or (assoc-ref options 'directory)
                                              (repository-discover "."))))
            (commit signer (match (command-line-arguments options)
                             ((commit signer)
                              (values commit signer))
                             (()
                              (configured-introduction repository))
                             (_
                              (missing-arguments))))
            (keyring     (or (assoc-ref options 'keyring-reference)
                             (configured-keyring-reference repository)
                             "keyring"))
            (end         (match (assoc-ref options 'end-commit)
                           (#f  (reference-target
                                 (repository-head repository)))
                           (oid (ensure-commit-id repository oid))))
            (history     (match (assoc-ref options 'historical-authorizations)
                           (#f '())
                           (file (call-with-input-file file
                                   read-authorizations))))
            (cache-key   (or (assoc-ref options 'cache-key)
                             (repository-cache-key repository)))
            (branch      (current-branch repository)))
       ;; Since the keyring branch is not authenticated, exit successfully
       ;; when invoked on it.  This exit status is what the 'post-merge' hook
       ;; expects when running 'git pull' on that branch, and what the
       ;; 'pre-push' hook expects when running 'git push' on that branch.
       (if (and branch (string=? branch keyring))
           (info (G_ "current branch '~a' is the keyring branch; \
doing nothing~%")
                 branch)
           (let ((stats
                  (authenticate-repository repository (string->oid commit)
                                           (openpgp-fingerprint* signer)
                                           #:end end
                                           #:keyring-reference keyring
                                           #:historical-authorizations history
                                           #:cache-key cache-key
                                           #:make-reporter make-reporter)))

             (if (configured? repository)
                 (maybe-upgrade-hooks repository)
                 (begin
                   (record-configuration repository
                                         #:commit commit #:signer signer
                                         #:keyring-reference keyring)
                   (install-hooks repository)))

             (when (and show-stats? (not (null? stats)))
               (show-stats stats))

             (info (G_ "successfully authenticated commit ~a~%")
                   (oid->string end))))))))
