code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.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 scripts build)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix import json)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix grafts)

  #:use-module (guix utils)

  ;; Use the procedure that destructures "NAME-VERSION" forms.
  #:use-module ((guix build utils)
                #:select ((package-name->name+version
                           . hyphen-package-name->name+version)))

  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix profiles)
  #:autoload   (guix http-client) (http-fetch http-get-error?)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:use-module (gnu packages)
  #:autoload   (guix download) (download-to-store)
  #:autoload   (guix git-download) (git-reference? git-reference-url)
  #:autoload   (guix git) (git-checkout git-checkout? git-checkout-url)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module ((guix progress) #:select (current-terminal-columns))
  #:use-module ((guix build syscalls) #:select (terminal-columns))
  #:export (%standard-build-options
            set-build-options-from-command-line
            set-build-options-from-command-line*
            show-build-options-help

            %transformation-options
            options->transformation
            show-transformation-options-help

            guix-build
            register-root
            register-root*))

(define %default-log-urls
  ;; Default base URLs for build logs.
  '("http://ci.guix.gnu.org/log"))

;; XXX: The following procedure cannot be in (guix store) because of the
;; dependency on (guix derivations).
(define* (log-url store file #:key (base-urls %default-log-urls))
  "Return a URL under one of the BASE-URLS where a build log for FILE can be
found.  Return #f if no build log was found."
  (define (valid-url? url)
    ;; Probe URL and return #t if it is accessible.
    (catch #t
      (lambda ()
        (guard (c ((http-get-error? c) #f))
          (close-port (http-fetch url #:buffered? #f))
          #t))
      (match-lambda*
        (('getaddrinfo-error . _)
         #f)
        (('tls-certificate-error args ...)
         (report-error (G_ "cannot access build log at '~a':~%") url)
         (print-exception (current-error-port) #f
                          'tls-certificate-error args)
         (exit 1))
        ((key . args)
         (apply throw key args)))))

  (define (find-url file)
    (let ((base (basename file)))
      (any (lambda (base-url)
             (let ((url (string-append base-url "/" base)))
               (and (valid-url? url) url)))
           base-urls)))

  (cond ((derivation-path? file)
         (catch 'system-error
           (lambda ()
             ;; Usually we'll have more luck with the output file name since
             ;; the deriver that was used by the server could be different, so
             ;; try one of the output file names.
             (let ((drv (read-derivation-from-file file)))
               (or (find-url (derivation->output-path drv))
                   (find-url file))))
           (lambda args
             ;; As a last resort, try the .drv.
             (if (= ENOENT (system-error-errno args))
                 (find-url file)
                 (apply throw args)))))
        (else
         (find-url file))))

(define (register-root store paths root)
  "Register ROOT as an indirect GC root for all of PATHS."
  (let* ((root (if (string-prefix? "/" root)
                   root
                   (string-append (canonicalize-path (dirname root))
                                  "/" (basename root)))))
    (catch 'system-error
      (lambda ()
        (match paths
          ((path)
           (symlink path root)
           (add-indirect-root store root))
          ((paths ...)
           (fold (lambda (path count)
                   (let ((root (string-append root
                                              "-"
                                              (number->string count))))
                     (symlink path root)
                     (add-indirect-root store root))
                   (+ 1 count))
                 0
                 paths))))
      (lambda args
        (leave (G_ "failed to create GC root `~a': ~a~%")
               root (strerror (system-error-errno args)))))))

(define register-root*
  (store-lift register-root))

(define (numeric-extension? file-name)
  "Return true if FILE-NAME ends with digits."
  (string-every char-set:hex-digit (file-extension file-name)))

(define (tarball-base-name file-name)
  "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar
extensions."
  ;; TODO: Factorize.
  (cond ((not (file-extension file-name))
         file-name)
        ((numeric-extension? file-name)
         file-name)
        ((string=? (file-extension file-name) "tar")
         (file-sans-extension file-name))
        ((file-extension file-name)
         =>
         (match-lambda
           ("scm" file-name)
           (else  (tarball-base-name (file-sans-extension file-name)))))
        (else
         file-name)))

(define* (package-with-source store p uri #:optional version)
  "Return a package based on P but with its source taken from URI.  Extract
the new package's version number from URI."
  (let ((base (tarball-base-name (basename uri))))
    (let-values (((_ version*)
                  (hyphen-package-name->name+version base)))
      (package (inherit p)
               (version (or version version*
                            (package-version p)))

               ;; Use #:recursive? #t to allow for directories.
               (source (download-to-store store uri
                                          #:recursive? #t))

               ;; Override the replacement, otherwise '--with-source' would
               ;; have no effect.
               (replacement #f)))))

;;;
;;; Transformations.
;;;

(define (transform-package-source sources)
  "Return a transformation procedure that replaces package sources with the
matching URIs given in SOURCES."
  (define new-sources
    (map (lambda (uri)
           (match (string-index uri #\=)
             (#f
              ;; Determine the package name and version from URI.
              (call-with-values
                  (lambda ()
                    (hyphen-package-name->name+version
                     (tarball-base-name (basename uri))))
                (lambda (name version)
                  (list name version uri))))
             (index
              ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
              (call-with-values
                  (lambda ()
                    (package-name->name+version (string-take uri index)))
                (lambda (name version)
                  (list name version
                        (string-drop uri (+ 1 index))))))))
         sources))

  (lambda (store obj)
    (let loop ((sources  new-sources)
               (result   '()))
      (match obj
        ((? package? p)
         (match (assoc-ref sources (package-name p))
           ((version source)
            (package-with-source store p source version))
           (#f
            p)))
        (_
         obj)))))

(define (evaluate-replacement-specs specs proc)
  "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list
of package spec/procedure pairs as expected by 'package-input-rewriting/spec'.
PROC is called with the package to be replaced and its replacement according
to SPECS.  Raise an error if an element of SPECS uses invalid syntax, or if a
package it refers to could not be found."
  (define not-equal
    (char-set-complement (char-set #\=)))

  (map (lambda (spec)
         (match (string-tokenize spec not-equal)
           ((spec new)
            (cons spec
                  (let ((new (specification->package new)))
                    (lambda (old)
                      (proc old new)))))
           (x
            (leave (G_ "invalid replacement specification: ~s~%") spec))))
       specs))

(define (transform-package-inputs replacement-specs)
  "Return a procedure that, when passed a package, replaces its direct
dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
strings like \"guile=guile@2.1\" meaning that, any dependency on a package
called \"guile\" must be replaced with a dependency on a version 2.1 of
\"guile\"."
  (let* ((replacements (evaluate-replacement-specs replacement-specs
                                                   (lambda (old new)
                                                     new)))
         (rewrite      (package-input-rewriting/spec replacements)))
    (lambda (store obj)
      (if (package? obj)
          (rewrite obj)
          obj))))

(define (transform-package-inputs/graft replacement-specs)
  "Return a procedure that, when passed a package, replaces its direct
dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
current 'gnutls' package, after which version 3.5.4 is grafted onto them."
  (define (set-replacement old new)
    (package (inherit old) (replacement new)))

  (let* ((replacements (evaluate-replacement-specs replacement-specs
                                                   set-replacement))
         (rewrite      (package-input-rewriting/spec replacements)))
    (lambda (store obj)
      (if (package? obj)
          (rewrite obj)
          obj))))

(define %not-equal
  (char-set-complement (char-set #\=)))

(define (package-git-url package)
  "Return the URL of the Git repository for package, or raise an error if
the source of PACKAGE is not fetched from a Git repository."
  (let ((source (package-source package)))
    (cond ((and (origin? source)
                (git-reference? (origin-uri source)))
           (git-reference-url (origin-uri source)))
          ((git-checkout? source)
           (git-checkout-url source))
          (else
           (leave (G_ "the source of ~a is not a Git reference~%")
                  (package-full-name package))))))

(define (evaluate-git-replacement-specs specs proc)
  "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the
replacement package.  Raise an error if an element of SPECS uses invalid
syntax, or if a package it refers to could not be found."
  (map (lambda (spec)
         (match (string-tokenize spec %not-equal)
           ((spec branch-or-commit)
            (define (replace old)
              (let* ((source (package-source old))
                     (url    (package-git-url old)))
                (proc old url branch-or-commit)))

            (cons spec replace))
           (x
            (leave (G_ "invalid replacement specification: ~s~%") spec))))
       specs))

(define (transform-package-source-branch replacement-specs)
  "Return a procedure that, when passed a package, replaces its direct
dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
strings like \"guile-next=stable-3.0\" meaning that packages are built using
'guile-next' from the latest commit on its 'stable-3.0' branch."
  (define (replace old url branch)
    (package
      (inherit old)
      (version (string-append "git." (string-map (match-lambda
                                                   (#\/ #\-)
                                                   (chr chr))
                                                 branch)))
      (source (git-checkout (url url) (branch branch)
                            (recursive? #t)))))

  (let* ((replacements (evaluate-git-replacement-specs replacement-specs
                                                       replace))
         (rewrite      (package-input-rewriting/spec replacements)))
    (lambda (store obj)
      (if (package? obj)
          (rewrite obj)
          obj))))

(define (transform-package-source-commit replacement-specs)
  "Return a procedure that, when passed a package, replaces its direct
dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
strings like \"guile-next=cabba9e\" meaning that packages are built using
'guile-next' from commit 'cabba9e'."
  (define (replace old url commit)
    (package
      (inherit old)
      (version (if (and (> (string-length commit) 1)
                        (string-prefix? "v" commit)
                        (char-set-contains? char-set:digit
                                            (string-ref commit 1)))
                   (string-drop commit 1)        ;looks like a tag like "v1.0"
                   (string-append "git."
                                  (if (< (string-length commit) 7)
                                      commit
                                      (string-take commit 7)))))
      (source (git-checkout (url url) (commit commit)
                            (recursive? #t)))))

  (let* ((replacements (evaluate-git-replacement-specs replacement-specs
                                                       replace))
         (rewrite      (package-input-rewriting/spec replacements)))
    (lambda (store obj)
      (if (package? obj)
          (rewrite obj)
          obj))))

(define (transform-package-source-git-url replacement-specs)
  "Return a procedure that, when passed a package, replaces its dependencies
according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of strings like
\"guile-json=https://gitthing.com/…\" meaning that packages are built using
a checkout of the Git repository at the given URL."
  (define replacements
    (map (lambda (spec)
           (match (string-tokenize spec %not-equal)
             ((spec url)
              (cons spec
                    (lambda (old)
                      (package
                        (inherit old)
                        (source (git-checkout (url url)
                                              (recursive? #t)))))))
             (_
              (leave (G_ "~a: invalid Git URL replacement specification~%")
                     spec))))
         replacement-specs))

  (define rewrite
    (package-input-rewriting/spec replacements))

  (lambda (store obj)
    (if (package? obj)
        (rewrite obj)
        obj)))

(define %transformations
  ;; Transformations that can be applied to things to build.  The car is the
  ;; key used in the option alist, and the cdr is the transformation
  ;; procedure; it is called with two arguments: the store, and a list of
  ;; things to build.
  `((with-source . ,transform-package-source)
    (with-input  . ,transform-package-inputs)
    (with-graft  . ,transform-package-inputs/graft)
    (with-branch . ,transform-package-source-branch)
    (with-commit . ,transform-package-source-commit)
    (with-git-url . ,transform-package-source-git-url)))

(define %transformation-options
  ;; The command-line interface to the above transformations.
  (let ((parser (lambda (symbol)
                  (lambda (opt name arg result . rest)
                    (apply values
                           (alist-cons symbol arg result)
                           rest)))))
    (list (option '("with-source") #t #f
                  (parser 'with-source))
          (option '("with-input") #t #f
                  (parser 'with-input))
          (option '("with-graft") #t #f
                  (parser 'with-graft))
          (option '("with-branch") #t #f
                  (parser 'with-branch))
          (option '("with-commit") #t #f
                  (parser 'with-commit))
          (option '("with-git-url") #t #f
                  (parser 'with-git-url)))))

(define (show-transformation-options-help)
  (display (G_ "
      --with-source=SOURCE
                         use SOURCE when building the corresponding package"))
  (display (G_ "
      --with-input=PACKAGE=REPLACEMENT
                         replace dependency PACKAGE by REPLACEMENT"))
  (display (G_ "
      --with-graft=PACKAGE=REPLACEMENT
                         graft REPLACEMENT on packages that refer to PACKAGE"))
  (display (G_ "
      --with-branch=PACKAGE=BRANCH
                         build PACKAGE from the latest commit of BRANCH"))
  (display (G_ "
      --with-commit=PACKAGE=COMMIT
                         build PACKAGE from COMMIT"))
  (display (G_ "
      --with-git-url=PACKAGE=URL
                         build PACKAGE from the repository at URL")))

(define (options->transformation opts)
  "Return a procedure that, when passed an object to build (package,
derivation, etc.), applies the transformations specified by OPTS."
  (define applicable
    ;; List of applicable transformations as symbol/procedure pairs in the
    ;; order in which they appear on the command line.
    (filter-map (match-lambda
                  ((key . value)
                   (match (any (match-lambda
                                 ((k . proc)
                                  (and (eq? k key) proc)))
                               %transformations)
                     (#f
                      #f)
                     (transform
                      ;; XXX: We used to pass TRANSFORM a list of several
                      ;; arguments, but we now pass only one, assuming that
                      ;; transform composes well.
                      (cons key (transform (list value)))))))
                (reverse opts)))

  (lambda (store obj)
    (fold (match-lambda*
            (((name . transform) obj)
             (let ((new (transform store obj)))
               (when (eq? new obj)
                 (warning (G_ "transformation '~a' had no effect on ~a~%")
                          name
                          (if (package? obj)
                              (package-full-name obj)
                              obj)))
               new)))
          obj
          applicable)))

;;;
;;; Standard command-line build options.
;;;

(define (show-build-options-help)
  "Display on the current output port help about the standard command-line
options handled by 'set-build-options-from-command-line', and listed in
'%standard-build-options'."
  (display (G_ "
  -L, --load-path=DIR    prepend DIR to the package module search path"))
  (display (G_ "
  -K, --keep-failed      keep build tree of failed builds"))
  (display (G_ "
  -k, --keep-going       keep going when some of the derivations fail"))
  (display (G_ "
  -n, --dry-run          do not build the derivations"))
  (display (G_ "
      --fallback         fall back to building when the substituter fails"))
  (display (G_ "
      --no-substitutes   build instead of resorting to pre-built substitutes"))
  (display (G_ "
      --substitute-urls=URLS
                         fetch substitute from URLS if they are authorized"))
  (display (G_ "
      --no-grafts        do not graft packages"))
  (display (G_ "
      --no-offload       do not attempt to offload builds"))
  (display (G_ "
      --max-silent-time=SECONDS
                         mark the build as failed after SECONDS of silence"))
  (display (G_ "
      --timeout=SECONDS  mark the build as failed after SECONDS of activity"))
  (display (G_ "
      --rounds=N         build N times in a row to detect non-determinism"))
  (display (G_ "
  -c, --cores=N          allow the use of up to N CPU cores for the build"))
  (display (G_ "
  -M, --max-jobs=N       allow at most N build jobs"))
  (display (G_ "
      --debug=LEVEL      produce debugging output at LEVEL")))

(define (set-build-options-from-command-line store opts)
  "Given OPTS, an alist as returned by 'args-fold' given
'%standard-build-options', set the corresponding build options on STORE."

  ;; '--keep-failed' has no effect when talking to a remote daemon.  Catch the
  ;; case where GUIX_DAEMON_SOCKET=guix://….
  (when (and (assoc-ref opts 'keep-failed?)
             (let* ((socket (store-connection-socket store))
                    (peer   (catch 'system-error
                              (lambda ()
                                (and (file-port? socket)
                                     (getpeername socket)))
                              (const #f))))
               (and peer (not (= AF_UNIX (sockaddr:fam peer))))))
    (warning (G_ "'--keep-failed' ignored since you are \
talking to a remote daemon\n")))

  (set-build-options store
                     #:keep-failed? (assoc-ref opts 'keep-failed?)
                     #:keep-going? (assoc-ref opts 'keep-going?)
                     #:rounds (assoc-ref opts 'rounds)
                     #:build-cores (assoc-ref opts 'cores)
                     #:max-build-jobs (assoc-ref opts 'max-jobs)
                     #:fallback? (assoc-ref opts 'fallback?)
                     #:use-substitutes? (assoc-ref opts 'substitutes?)
                     #:substitute-urls (assoc-ref opts 'substitute-urls)
                     #:offload? (and (assoc-ref opts 'offload?)
                                     (not (assoc-ref opts 'keep-failed?)))
                     #:max-silent-time (assoc-ref opts 'max-silent-time)
                     #:timeout (assoc-ref opts 'timeout)
                     #:print-build-trace (assoc-ref opts 'print-build-trace?)
                     #:print-extended-build-trace?
                     (assoc-ref opts 'print-extended-build-trace?)
                     #:multiplexed-build-output?
                     (assoc-ref opts 'multiplexed-build-output?)
                     #:verbosity (assoc-ref opts 'debug)))

(define set-build-options-from-command-line*
  (store-lift set-build-options-from-command-line))

(define %standard-build-options
  ;; List of standard command-line options for tools that build something.
  (list (option '(#\L "load-path") #t #f
                (lambda (opt name arg result . rest)
                  ;; XXX: Imperatively modify the search paths.
                  (%package-module-path (cons arg (%package-module-path)))
                  (%patch-path (cons arg (%patch-path)))
                  (set! %load-path (cons arg %load-path))
                  (set! %load-compiled-path (cons arg %load-compiled-path))

                  (apply values (cons result rest))))
        (option '(#\K "keep-failed") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'keep-failed? #t result)
                         rest)))
        (option '(#\k "keep-going") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'keep-going? #t result)
                         rest)))
        (option '("rounds") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'rounds (string->number* arg)
                                     result)
                         rest)))
        (option '("fallback") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'fallback? #t
                                     (alist-delete 'fallback? result))
                         rest)))
        (option '("no-substitutes") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'substitutes? #f
                                     (alist-delete 'substitutes? result))
                         rest)))
        (option '("substitute-urls") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'substitute-urls
                                     (string-tokenize arg)
                                     (alist-delete 'substitute-urls result))
                         rest)))
        (option '("no-grafts") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'graft? #f
                                     (alist-delete 'graft? result eq?))
                         rest)))
        (option '("no-offload" "no-build-hook") #f #f
                (lambda (opt name arg result . rest)
                  (when (string=? name "no-build-hook")
                    (warning (G_ "'--no-build-hook' is deprecated; \
use '--no-offload' instead~%")))

                  (apply values
                         (alist-cons 'offload? #f
                                     (alist-delete 'offload? result))
                         rest)))
        (option '("max-silent-time") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'max-silent-time (string->number* arg)
                                     result)
                         rest)))
        (option '("timeout") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'timeout (string->number* arg) result)
                         rest)))
        (option '("debug") #t #f
                (lambda (opt name arg result . rest)
                  (let ((level (string->number* arg)))
                    (apply values
                           (alist-cons 'debug level
                                       (alist-delete 'debug result))
                           rest))))
        (option '(#\c "cores") #t #f
                (lambda (opt name arg result . rest)
                  (let ((c (false-if-exception (string->number arg))))
                    (if c
                        (apply values (alist-cons 'cores c result) rest)
                        (leave (G_ "not a number: '~a' option argument: ~a~%")
                               name arg)))))
        (option '(#\M "max-jobs") #t #f
                (lambda (opt name arg result . rest)
                  (let ((c (false-if-exception (string->number arg))))
                    (if c
                        (apply values (alist-cons 'max-jobs c result) rest)
                        (leave (G_ "not a number: '~a' option argument: ~a~%")
                               name arg)))))))

;;;
;;; Command-line options.
;;;

(define %default-options
  ;; Alist of default option values.
  `((build-mode . ,(build-mode normal))
    (graft? . #t)
    (substitutes? . #t)
    (offload? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)
    (verbosity . 2)
    (debug . 0)))

(define (show-help)
  (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION...
Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
  (display (G_ "
  -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
  (display (G_ "
  -f, --file=FILE        build the package or derivation that the code within
                         FILE evaluates to"))
  (display (G_ "
  -m, --manifest=FILE    build the packages that the manifest given in FILE
                         evaluates to"))
  (display (G_ "
  -S, --source           build the packages' source derivations"))
  (display (G_ "
      --sources[=TYPE]   build source derivations; TYPE may optionally be one
                         of \"package\", \"all\" (default), or \"transitive\""))
  (display (G_ "
  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
  (display (G_ "
      --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
  (display (G_ "
  -d, --derivations      return the derivation paths of the given packages"))
  (display (G_ "
      --check            rebuild items to check for non-determinism issues"))
  (display (G_ "
      --repair           repair the specified items"))
  (display (G_ "
  -r, --root=FILE        make FILE a symlink to the result, and register it
                         as a garbage collector root"))
  (display (G_ "
  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  (display (G_ "
  -q, --quiet            do not show the build log"))
  (display (G_ "
      --log-file         return the log file names for the given derivations"))
  (newline)
  (show-build-options-help)
  (newline)
  (show-transformation-options-help)
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  ;; Specifications of the command-line options.
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix build")))
         (option '(#\S "source") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'source #t result)))
         (option '("sources") #f #t
                 (lambda (opt name arg result)
                   (match arg
                     ("package"
                      (alist-cons 'source #t result))
                     ((or "all" #f)
                      (alist-cons 'source package-direct-sources result))
                     ("transitive"
                      (alist-cons 'source package-transitive-sources result))
                     (else
                      (leave (G_ "invalid argument: '~a' option argument: ~a, ~
must be one of 'package', 'all', or 'transitive'~%")
                             name arg)))))
         (option '("check") #f #f
                 (lambda (opt name arg result . rest)
                   (apply values
                          (alist-cons 'build-mode (build-mode check)
                                      result)
                          rest)))
         (option '("repair") #f #f
                 (lambda (opt name arg result . rest)
                   (apply values
                          (alist-cons 'build-mode (build-mode repair)
                                      result)
                          rest)))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg result)))
         (option '("target") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'target arg
                               (alist-delete 'target result eq?))))
         (option '(#\d "derivations") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'derivations-only? #t result)))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
         (option '(#\f "file") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'file arg result)))
         (option '(#\m "manifest") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'manifest arg result)))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
         (option '(#\r "root") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'gc-root arg result)))
         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result)
                   (let ((level (string->number* arg)))
                     (alist-cons 'verbosity level
                                 (alist-delete 'verbosity result)))))
         (option '(#\q "quiet") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'verbosity 0
                               (alist-delete 'verbosity result))))
         (option '("log-file") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'log-file? #t result)))

         (append %transformation-options
                 %standard-build-options)))

(define (options->things-to-build opts)
  "Read the arguments from OPTS and return a list of high-level objects to
build---packages, gexps, derivations, and so on."
  (define (validate-type x)
    (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x))
      (leave (G_ "~s: not something we can build~%") x)))

  (define (ensure-list x)
    (let ((lst (match x
                 ((x ...) x)
                 (x       (list x)))))
      (for-each validate-type lst)
      lst))

  (append-map (match-lambda
                (('argument . (? string? spec))
                 (cond ((derivation-path? spec)
                        (catch 'system-error
                          (lambda ()
                            ;; Ask for absolute file names so that .drv file
                            ;; names passed from the user to 'read-derivation'
                            ;; are absolute when it returns.
                            (let ((spec (canonicalize-path spec)))
                              (list (read-derivation-from-file spec))))
                          (lambda args
                            ;; Non-existent .drv files can be substituted down
                            ;; the road, so don't error out.
                            (if (= ENOENT (system-error-errno args))
                                '()
                                (apply throw args)))))
                       ((store-path? spec)
                        ;; Nothing to do; maybe for --log-file.
                        '())
                       (else
                        (list (specification->package spec)))))
                (('file . file)
                 (let ((file (or (and (string-suffix? ".json" file)
                                      (json->scheme-file file))
                                 file)))
                   (ensure-list (load* file (make-user-module '())))))
                (('manifest . manifest)
                 (map manifest-entry-item
                      (manifest-entries
                       (load* manifest
                              (make-user-module '((guix profiles) (gnu)))))))
                (('expression . str)
                 (ensure-list (read/eval str)))
                (('argument . (? derivation? drv))
                 drv)
                (_ '()))
              opts))

(define (options->derivations store opts)
  "Given OPTS, the result of 'args-fold', return a list of derivations to
build."
  (define transform
    (options->transformation opts))

  (define package->derivation
    (match (assoc-ref opts 'target)
      (#f package-derivation)
      (triplet
       (cut package-cross-derivation <> <> triplet <>))))

  (define src    (assoc-ref opts 'source))
  (define graft? (assoc-ref opts 'graft?))
  (define systems
    (match (filter-map (match-lambda
                         (('system . system) system)
                         (_ #f))
                       opts)
      (()      (list (%current-system)))
      (systems systems)))

  (define things-to-build
    (map (cut transform store <>)
         (options->things-to-build opts)))

  (define (compute-derivation obj system)
    ;; Compute the derivation of OBJ for SYSTEM.
    (match obj
      ((? package? p)
       (let ((p (or (and graft? (package-replacement p)) p)))
         (match src
           (#f
            (list (package->derivation store p system)))
           (#t
            (match (package-source p)
              (#f
               (warning (package-location p)
                        (G_ "package '~a' has no source~%")
                        (package-name p))
               '())
              (s
               (list (package-source-derivation store s)))))
           (proc
            (map (cut package-source-derivation store <>)
                 (proc p))))))
      ((? derivation? drv)
       (list drv))
      ((? procedure? proc)
       (list (run-with-store store
               (mbegin %store-monad
                 (set-guile-for-build (default-guile))
                 (proc))
               #:system system)))
      ((? file-like? obj)
       (list (run-with-store store
               (lower-object obj system
                             #:target (assoc-ref opts 'target))
               #:system system)))
      ((? gexp? gexp)
       (list (run-with-store store
               (mbegin %store-monad
                 (set-guile-for-build (default-guile))
                 (gexp->derivation "gexp" gexp
                                   #:system system))
               #:system system)))))

  ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
  ;; of user packages.  Since 'guix build' is the primary tool for people
  ;; testing new packages, report such errors gracefully.
  (with-unbound-variable-handling
   (parameterize ((%graft? graft?))
     (append-map (lambda (system)
                   (concatenate
                    (map/accumulate-builds store
                                           (cut compute-derivation <> system)
                                           things-to-build)))
                 systems))))

(define (show-build-log store file urls)
  "Show the build log for FILE, falling back to remote logs from URLS if
needed."
  (let ((log (or (log-file store file)
                 (log-url store file #:base-urls urls))))
    (if log
        (format #t "~a~%" log)
        (leave (G_ "no build log for '~a'~%") file))))

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

(define-command (guix-build . args)
  (category packaging)
  (synopsis "build packages or derivations without installing them")

  (define opts
    (parse-command-line args %options
                        (list %default-options)))

  (define graft?
    (assoc-ref opts 'graft?))

  (with-error-handling
    (with-status-verbosity (assoc-ref opts 'verbosity)
      (with-store store
        ;; Set the build options before we do anything else.
        (set-build-options-from-command-line store opts)

        (with-build-handler (build-notifier #:use-substitutes?
                                            (assoc-ref opts 'substitutes?)
                                            #:verbosity
                                            (assoc-ref opts 'verbosity)
                                            #:dry-run?
                                            (assoc-ref opts 'dry-run?))
          (parameterize ((current-terminal-columns (terminal-columns))

                         ;; Set grafting upfront in case the user's input
                         ;; depends on it (e.g., a manifest or code snippet that
                         ;; calls 'gexp->derivation').
                         (%graft?                  graft?))
            (let* ((mode  (assoc-ref opts 'build-mode))
                   (drv   (options->derivations store opts))
                   (urls  (map (cut string-append <> "/log")
                               (if (assoc-ref opts 'substitutes?)
                                   (or (assoc-ref opts 'substitute-urls)
                                       ;; XXX: This does not necessarily match the
                                       ;; daemon's substitute URLs.
                                       %default-substitute-urls)
                                   '())))
                   (items (filter-map (match-lambda
                                        (('argument . (? store-path? file))
                                         ;; If FILE is a .drv that's not in
                                         ;; store, keep it so that it can be
                                         ;; substituted.
                                         (and (or (not (derivation-path? file))
                                                  (not (file-exists? file)))
                                              file))
                                        (_ #f))
                                      opts))
                   (roots (filter-map (match-lambda
                                        (('gc-root . root) root)
                                        (_ #f))
                                      opts)))

              (cond ((assoc-ref opts 'log-file?)
                     ;; Pass 'show-build-log' the output file names, not the
                     ;; derivation file names, because there can be several
                     ;; derivations leading to the same output.
                     (for-each (cut show-build-log store <> urls)
                               (delete-duplicates
                                (append (map derivation->output-path drv)
                                        items))))
                    ((assoc-ref opts 'derivations-only?)
                     (format #t "~{~a~%~}" (map derivation-file-name drv))
                     (for-each (cut register-root store <> <>)
                               (map (compose list derivation-file-name) drv)
                               roots))
                    (else
                     (and (build-derivations store (append drv items)
                                             mode)
                          (for-each show-derivation-outputs drv)
                          (for-each (cut register-root store <> <>)
                                    (map (lambda (drv)
                                           (map cdr
                                                (derivation->output-paths drv)))
                                         drv)
                                    roots)))))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 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 scripts challenge)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix grafts)
  #:use-module (guix monads)
  #:use-module (guix base32)
  #:use-module (guix packages)
  #:use-module ((guix progress) #:hide (dump-port*))
  #:use-module (guix serialization)
  #:use-module (guix scripts substitute)
  #:use-module (rnrs bytevectors)
  #:autoload   (guix http-client) (http-fetch)
  #:use-module ((guix build syscalls) #:select (terminal-columns))
  #:use-module (gcrypt hash)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:use-module (web uri)
  #:export (compare-contents

            comparison-report?
            comparison-report-item
            comparison-report-result
            comparison-report-local-sha256
            comparison-report-narinfos

            comparison-report-match?
            comparison-report-mismatch?
            comparison-report-inconclusive?

            differing-files
            call-with-mismatches

            guix-challenge))

;;; Commentary:
;;;
;;; Challenge substitute servers, checking whether they provide the same
;;; binaries as those built locally.
;;;
;;; Here we completely bypass the daemon to access substitutes.  This is
;;; because we want to be able to report fine-grain information about
;;; discrepancies: We need to show the URL of the offending nar, its hash, and
;;; so on.
;;;
;;; Code:

(define ensure-store-item                         ;XXX: move to (guix ui)?
  (@@ (guix scripts size) ensure-store-item))

;; Representation of a comparison report for ITEM.
(define-record-type <comparison-report>
  (%comparison-report item result local-sha256 narinfos)
  comparison-report?
  (item         comparison-report-item)    ;string, /gnu/store/… item
  (result       comparison-report-result)  ;'match | 'mismatch | 'inconclusive
  (local-sha256 comparison-report-local-sha256)   ;bytevector | #f
  (narinfos     comparison-report-narinfos))      ;list of <narinfo>

(define-syntax comparison-report
  ;; Some sort of a an enum to make sure 'result' is correct.
  (syntax-rules (match mismatch inconclusive)
    ((_ item 'match rest ...)
     (%comparison-report item 'match rest ...))
    ((_ item 'mismatch rest ...)
     (%comparison-report item 'mismatch rest ...))
    ((_ item 'inconclusive rest ...)
     (%comparison-report item 'inconclusive rest ...))))

(define (comparison-report-predicate result)
  "Return a predicate that returns true when pass a REPORT that has RESULT."
  (lambda (report)
    (eq? (comparison-report-result report) result)))

(define comparison-report-mismatch?
  (comparison-report-predicate 'mismatch))

(define comparison-report-match?
  (comparison-report-predicate 'match))

(define comparison-report-inconclusive?
  (comparison-report-predicate 'inconclusive))

(define (locally-built? store item)
  "Return true if ITEM was built locally."
  ;; XXX: For now approximate it by checking whether there's a build log for
  ;; ITEM.  There could be false negatives, if logs have been removed.
  (->bool (log-file store item)))

(define (query-locally-built-hash item)
  "Return the hash of ITEM, a store item, if ITEM was built locally.
Otherwise return #f."
  (lambda (store)
    (guard (c ((store-protocol-error? c)
               (values #f store)))
      (if (locally-built? store item)
          (values (query-path-hash store item) store)
          (values #f store)))))

(define-syntax-rule (report args ...)
  (format (current-error-port) args ...))

(define (compare-contents items servers)
  "Challenge the substitute servers whose URLs are listed in SERVERS by
comparing the hash of the substitutes of ITEMS that they serve.  Return the
list of <comparison-report> objects.

This procedure does not authenticate narinfos from SERVERS, nor does it verify
that they are signed by an authorized public keys.  The reason is that, by
definition, we may want to target unknown servers.  Furthermore, no risk is
taken since we do not import the archives."
  (define (compare item reference)
    ;; Return a procedure to compare the hash of ITEM with REFERENCE.
    (lambda (narinfo url)
      (or (not narinfo)
          (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
            (bytevector=? reference value)))))

  (define (select-reference item narinfos urls)
    ;; Return a "reference" narinfo among NARINFOS.
    (match narinfos
      ((first narinfos ...)
       (match servers
         ((url urls ...)
          (if (not first)
              (select-reference item narinfos urls)
              (narinfo-hash->sha256 (narinfo-hash first))))))))

  (mlet* %store-monad ((local     (mapm %store-monad
                                        query-locally-built-hash items))
                       (remote -> (append-map (cut lookup-narinfos <> items)
                                              servers))
                       ;; No 'assert-valid-narinfo' on purpose.
                       (narinfos -> (fold (lambda (narinfo vhash)
                                            (vhash-cons (narinfo-path narinfo) narinfo
                                                        vhash))
                                          vlist-null
                                          remote)))
    (return (map (lambda (item local)
                   (match (vhash-fold* cons '() item narinfos)
                     (()                          ;no substitutes
                      (comparison-report item 'inconclusive local '()))
                     ((narinfo)
                      (if local
                          (if ((compare item local) narinfo (first servers))
                              (comparison-report item 'match
                                                 local (list narinfo))
                              (comparison-report item 'mismatch
                                                 local (list narinfo)))
                          (comparison-report item 'inconclusive
                                             local (list narinfo))))
                     ((narinfos ...)
                      (let ((reference
                             (or local (select-reference item narinfos
                                                         servers))))
                        (if (every (compare item reference) narinfos servers)
                            (comparison-report item 'match
                                               local narinfos)
                            (comparison-report item 'mismatch
                                               local narinfos))))))
                 items
                 local))))

;;;
;;; Reporting.
;;;

(define (port-sha256* port size)
  ;; Like 'port-sha256', but limited to SIZE bytes.
  (let-values (((out get) (open-sha256-port)))
    (dump-port* port out size)
    (close-port out)
    (get)))

(define (archive-contents port)
  "Return a list representing the files contained in the nar read from PORT."
  (fold-archive (lambda (file type contents result)
                  (match type
                    ((or 'regular 'executable)
                     (match contents
                       ((port . size)
                        (cons `(,file ,type ,(port-sha256* port size))
                              result))))
                    ('directory result)
                    ('symlink
                     (cons `(,file ,type ,contents) result))))
                '()
                port
                ""))

(define (store-item-contents item)
  "Return a list of files and contents for ITEM in the same format as
'archive-contents'."
  (file-system-fold (const #t)                    ;enter?
                    (lambda (file stat result)    ;leaf
                      (define short
                        (string-drop file (string-length item)))

                      (match (stat:type stat)
                        ('regular
                         (let ((size (stat:size stat))
                               (type (if (zero? (logand (stat:mode stat)
                                                        #o100))
                                         'regular
                                         'executable)))
                           (cons `(,short ,type
                                          ,(call-with-input-file file
                                             (cut port-sha256* <> size)))
                                 result)))
                        ('symlink
                         (cons `(,short symlink ,(readlink file))
                               result))))
                    (lambda (directory stat result) result)  ;down
                    (lambda (directory stat result) result)  ;up
                    (lambda (file stat result) result)       ;skip
                    (lambda (file stat errno result) result) ;error
                    '()
                    item
                    lstat))

(define (call-with-nar narinfo proc)
  "Call PROC with an input port from which it can read the nar pointed to by
NARINFO."
  (let*-values (((uri compression size)
                 (narinfo-best-uri narinfo))
                ((port response)
                 (http-fetch uri)))
    (define reporter
      (progress-reporter/file (narinfo-path narinfo) size
                              #:abbreviation (const (uri-host uri))))

    (define result
      (call-with-decompressed-port (string->symbol compression)
          (progress-report-port reporter port)
        proc))

    (close-port port)
    (erase-current-line (current-output-port))
    result))

(define (narinfo-contents narinfo)
  "Fetch the nar described by NARINFO and return a list representing the file
it contains."
  (call-with-nar narinfo archive-contents))

(define (differing-files comparison-report)
  "Return a list of files that differ among the nars and possibly the local
store item specified in COMPARISON-REPORT."
  (define contents
    (map narinfo-contents
         (comparison-report-narinfos comparison-report)))

  (define local-contents
    (and (comparison-report-local-sha256 comparison-report)
         (store-item-contents (comparison-report-item comparison-report))))

  (match (apply lset-difference equal?
                (take (delete-duplicates
                       (if local-contents
                           (cons local-contents contents)
                           contents))
                      2))
    (((files _ ...) ...)
     files)))

(define (report-differing-files comparison-report)
  "Report differences among the nars and possibly the local store item
specified in COMPARISON-REPORT."
  (match (differing-files comparison-report)
    (()
     #t)
    ((files ...)
     (format #t (N_ "  differing file:~%"
                    "  differing files:~%"
                    (length files)))
     (format #t     "~{    ~a~%~}" files))))

(define (call-with-mismatches comparison-report proc)
  "Call PROC with two directories containing the mismatching store items."
  (define local-hash
    (comparison-report-local-sha256 comparison-report))

  (define narinfos
    (comparison-report-narinfos comparison-report))

  (call-with-temporary-directory
   (lambda (directory1)
     (call-with-temporary-directory
      (lambda (directory2)
        (define narinfo1
          (if local-hash
              (find (lambda (narinfo)
                      (not (bytevector=? (narinfo-hash->sha256
                                          (narinfo-hash narinfo))
                                         local-hash)))
                    narinfos)
              (first (comparison-report-narinfos comparison-report))))

        (define narinfo2
          (and (not local-hash)
               (find (lambda (narinfo)
                       (not (eq? narinfo narinfo1)))
                     narinfos)))

        (rmdir directory1)
        (call-with-nar narinfo1 (cut restore-file <> directory1))
        (when narinfo2
          (rmdir directory2)
          (call-with-nar narinfo2 (cut restore-file <> directory2)))
        (proc directory1
              (if local-hash
                  (comparison-report-item comparison-report)
                  directory2)))))))

(define %diffoscope-command
  ;; Default external diff command.  Pass "--exclude-directory-metadata" so
  ;; that the mtime/ctime differences are ignored.
  '("diffoscope" "--exclude-directory-metadata=yes"))

(define* (report-differing-files/external comparison-report
                                          #:optional
                                          (command %diffoscope-command))
  "Run COMMAND to show the file-level differences for the mismatches in
COMPARISON-REPORT."
  (call-with-mismatches comparison-report
                        (lambda (directory1 directory2)
                          (apply system*
                                 (append command
                                         (list directory1 directory2))))))

(define* (summarize-report comparison-report
                           #:key
                           (report-differences (const #f))
                           (hash->string bytevector->nix-base32-string)
                           verbose?)
  "Write to the current error port a summary of COMPARISON-REPORT, a
<comparison-report> object.  When VERBOSE?, display matches in addition to
mismatches and inconclusive reports.  Upon mismatch, call REPORT-DIFFERENCES
with COMPARISON-REPORT."
  (define (report-hashes item local narinfos)
    (if local
        (report (G_ "  local hash: ~a~%") (hash->string local))
        (report (G_ "  no local build for '~a'~%") item))
    (for-each (lambda (narinfo)
                (report (G_ "  ~50a: ~a~%")
                        (uri->string (narinfo-best-uri narinfo))
                        (hash->string
                         (narinfo-hash->sha256 (narinfo-hash narinfo)))))
              narinfos))

  (match comparison-report
    (($ <comparison-report> item 'mismatch local (narinfos ...))
     (report (G_ "~a contents differ:~%") item)
     (report-hashes item local narinfos)
     (report-differences comparison-report))
    (($ <comparison-report> item 'inconclusive #f narinfos)
     (warning (G_ "could not challenge '~a': no local build~%") item))
    (($ <comparison-report> item 'inconclusive locals ())
     (warning (G_ "could not challenge '~a': no substitutes~%") item))
    (($ <comparison-report> item 'match local (narinfos ...))
     (when verbose?
       (report (G_ "~a contents match:~%") item)
       (report-hashes item local narinfos)))))

(define (summarize-report-list reports)
  "Display the overall summary of REPORTS."
  (let ((total         (length reports))
        (inconclusive  (count comparison-report-inconclusive? reports))
        (matches       (count comparison-report-match? reports))
        (discrepancies (count comparison-report-mismatch? reports)))
    (report (G_ "~h store items were analyzed:~%") total)
    (report (G_ "  - ~h (~,1f%) were identical~%")
            matches (* 100. (/ matches total)))
    (report (G_ "  - ~h (~,1f%) differed~%")
            discrepancies (* 100. (/ discrepancies total)))
    (report (G_ "  - ~h (~,1f%) were inconclusive~%")
            inconclusive (* 100. (/ inconclusive total)))))

;;;
;;; Command-line options.
;;;

(define (show-help)
  (display (G_ "Usage: guix challenge [PACKAGE...]
Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
  (display (G_ "
      --substitute-urls=URLS
                         compare build results with those at URLS"))
  (display (G_ "
  -v, --verbose          show details about successful comparisons"))
  (display (G_ "
      --diff=MODE        show differences according to MODE"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %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 challenge")))

         (option '("diff") #t #f
                 (lambda (opt name arg result . rest)
                   (define mode
                     (match arg
                       ("none" (const #t))
                       ("simple" report-differing-files)
                       ("diffoscope" report-differing-files/external)
                       ((and (? (cut string-prefix? "/" <>)) command)
                        (cute report-differing-files/external <>
                              (string-tokenize command)))
                       (_ (leave (G_ "~a: unknown diff mode~%") arg))))

                   (apply values
                          (alist-cons 'difference-report mode result)
                          rest)))

         (option '("substitute-urls") #t #f
                 (lambda (opt name arg result . rest)
                   (apply values
                          (alist-cons 'substitute-urls
                                      (string-tokenize arg)
                                      (alist-delete 'substitute-urls result))
                          rest)))
         (option '("verbose" #\v) #f #f
                 (lambda (opt name arg result . rest)
                   (apply values
                          (alist-cons 'verbose? #t result)
                          rest)))))

(define %default-options
  `((system . ,(%current-system))
    (substitute-urls . ,%default-substitute-urls)
    (difference-report . ,report-differing-files)))

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

(define-command (guix-challenge . args)
  (category packaging)
  (synopsis "challenge substitute servers, comparing their binaries")

  (with-error-handling
    (let* ((opts     (parse-command-line args %options (list %default-options)
                                         #:build-options? #f))
           (files    (filter-map (match-lambda
                                   (('argument . file) file)
                                   (_ #f))
                                 opts))
           (system   (assoc-ref opts 'system))
           (urls     (assoc-ref opts 'substitute-urls))
           (diff     (assoc-ref opts 'difference-report))
           (verbose? (assoc-ref opts 'verbose?)))
      (leave-on-EPIPE
       (with-store store
         ;; Disable grafts since substitute servers normally provide only
         ;; ungrafted stuff.
         (parameterize ((%graft? #f)
                        (current-terminal-columns (terminal-columns)))
           (let ((files (match files
                          (()
                           (filter (cut locally-built? store <>)
                                   (live-paths store)))
                          (x
                           files))))
             (set-build-options store
                                #:use-substitutes? #f)

             (run-with-store store
               (mlet* %store-monad ((items   (mapm %store-monad
                                                   ensure-store-item files))
                                    (reports (compare-contents items urls)))
                 (for-each (cut summarize-report <> #:verbose? verbose?
                                #:report-differences diff)
                           reports)
                 (report "\n")
                 (summarize-report-list reports)

                 (exit (cond ((any comparison-report-mismatch? reports) 2)
                             ((every comparison-report-match? reports) 0)
                             (else 1))))
               #:system system))))))))

;;; challenge.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;;
;;; 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 container)
  #:use-module (ice-9 match)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:export (guix-container))

(define (show-help)
  (display (G_ "Usage: guix container ACTION ARGS...
Build and manipulate Linux containers.\n"))
  (newline)
  (display (G_ "The valid values for ACTION are:\n"))
  (newline)
  (display (G_ "\
   exec            execute a command inside of an existing container\n"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %actions '("exec"))

(define (resolve-action name)
  (let ((module (resolve-interface
                 `(guix scripts container ,(string->symbol name))))
        (proc (string->symbol (string-append "guix-container-" name))))
    (module-ref module proc)))

(define-command (guix-container . args)
  (category development)
  (synopsis "run code in containers created by 'guix environment -C'")

  (with-error-handling
    (match args
      (()
       (format (current-error-port)
               (G_ "guix container: missing action~%")))
      ((or ("-h") ("--help"))
       (show-help)
       (exit 0))
      ((or ("-V") ("--version"))
       (show-version-and-exit "guix container"))
      ((action args ...)
       (if (member action %actions)
           (apply (resolve-action action) args)
           (format (current-error-port)
                   (G_ "guix container: invalid action~%")))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@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 container exec)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-37)
  #:use-module (guix scripts)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (gnu build linux-container)
  #:export (guix-container-exec))

(define %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 container exec")))))

(define (show-help)
  (display (G_ "Usage: guix container exec PID COMMAND [ARGS...]
Execute COMMAND within the container process PID.\n"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define (partition-args args)
  "Split ARGS into two lists; one containing the arguments for this program,
and the other containing arguments for the command to be executed."
  (define (number-string? str)
    (false-if-exception (string->number str)))

  (let loop ((a '())
             (b args))
    (match b
      (()
       (values (reverse a) '()))
      (((? number-string? head) . tail)
       (values (reverse (cons head a)) tail))
      ((head . tail)
       (loop (cons head a) tail)))))

(define (guix-container-exec . args)
  (define (handle-argument arg result)
    (if (assoc-ref result 'pid)
        (leave (G_ "~a: extraneous argument~%") arg)
        (alist-cons 'pid (string->number* arg) result)))

  (with-error-handling
    (let-values (((args command) (partition-args args)))
      (let* ((opts (parse-command-line args %options '(())
                                       #:argument-handler
                                       handle-argument))
             (pid  (assoc-ref opts 'pid))
             (environment (filter-map (lambda (name)
                                        (let ((value (getenv name)))
                                          (and value (cons name value))))
                                      ;; Pass through the TERM environment
                                      ;; variable to inform processes about
                                      ;; the capabilities of the terminal.
                                      '("TERM"))))

        (unless pid
          (leave (G_ "no pid specified~%")))

        (when (null? command)
          (leave (G_ "no command specified~%")))

        (unless (file-exists? (string-append "/proc/" (number->string pid)))
          (leave (G_ "no such process ~d~%") pid))

        (let ((result (container-excursion pid
                        (lambda ()
                          (match command
                            ((program . program-args)
                             (for-each (match-lambda
                                         ((name . value)
                                          (setenv name value)))
                                       environment)
                             (apply execlp program program program-args)))))))
          (unless (zero? result)
            (leave (G_ "exec failed with status ~d~%") result)))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 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 scripts copy)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix ssh)
  #:use-module ((ssh session) #:select (disconnect!))
  #:use-module (guix store)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix scripts build)
  #:use-module ((guix scripts archive) #:select (options->derivations+files))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (guix-copy))

;;;
;;; Exchanging store items over SSH.
;;;

(define (ssh-spec->user+host+port spec)
  "Parse SPEC, a string like \"user@host:port\" or just \"host\", and return
three values: the user name (or #f), the host name, and the TCP port
number (or #f) corresponding to SPEC."
  (define tokens
    (char-set #\@ #\:))

  (match (string-tokenize spec (char-set-complement tokens))
    ((host)
     (values #f host #f))
    ((left right)
     (if (string-index spec #\@)
         (values left right #f)
         (values #f left (string->number right))))
    ((user host port)
     (match (string->number port)
       ((? integer? port)
        (values user host port))
       (x
        (leave (G_ "~a: invalid TCP port number~%") port))))
    (x
     (leave (G_ "~a: invalid SSH specification~%") spec))))

(define (send-to-remote-host local target opts)
  "Send ITEMS to TARGET.  ITEMS is a list of store items or package names; for ;
package names, build the underlying packages before sending them."
  (let-values (((user host port)
                (ssh-spec->user+host+port target))
               ((drv items)
                (options->derivations+files local opts)))
    (and (build-derivations local drv)
         (let* ((session (open-ssh-session host #:user user
                                           #:port (or port 22)))
                (remote  (connect-to-remote-daemon session))
                (sent    (send-files local items remote
                                     #:recursive? #t)))
           (close-connection remote)
           (format #t "~{~a~%~}" sent)
           sent))))

(define (retrieve-from-remote-host local source opts)
  "Retrieve ITEMS from SOURCE."
  (let*-values (((user host port)
                 (ssh-spec->user+host+port source))
                ((session)
                 (open-ssh-session host #:user user #:port (or port 22)))
                ((remote)
                 (connect-to-remote-daemon session)))
    ;; TODO: Here we could to compute and build the derivations on REMOTE
    ;; rather than on LOCAL (one-off offloading) but that is currently too
    ;; slow due to the many RPC round trips.  So we just assume that REMOTE
    ;; contains ITEMS.
    (let*-values (((drv items)
                   (options->derivations+files local opts))
                  ((retrieved)
                   (retrieve-files local items remote #:recursive? #t)))
      (close-connection remote)
      (disconnect! session)
      (format #t "~{~a~%~}" retrieved)
      retrieved)))

;;;
;;; Options.
;;;

(define (show-help)
  (display (G_ "Usage: guix copy [OPTION]... ITEMS...
Copy ITEMS to or from the specified host over SSH.\n"))
  (display (G_ "
      --to=HOST          send ITEMS to HOST"))
  (display (G_ "
      --from=HOST        receive ITEMS from HOST"))
  (display (G_ "
  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  (newline)
  (show-build-options-help)
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  ;; Specifications of the command-line options.
  (cons* (option '("to") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'destination arg result)))
         (option '("from") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'source arg result)))
         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result)
                   (let ((level (string->number* arg)))
                     (alist-cons 'verbosity level
                                 (alist-delete 'verbosity result)))))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))

         (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix copy")))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg
                               (alist-delete 'system result eq?))))
         %standard-build-options))

(define %default-options
  `((system . ,(%current-system))
    (substitutes? . #t)
    (offload? . #t)
    (graft? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)
    (debug . 0)
    (verbosity . 2)))

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

(define-command (guix-copy . args)
  (category plumbing)
  (synopsis "copy store items remotely over SSH")

  (with-error-handling
    (let* ((opts     (parse-command-line args %options (list %default-options)))
           (source   (assoc-ref opts 'source))
           (target   (assoc-ref opts 'destination)))
      (with-store store
        (set-build-options-from-command-line store opts)
        (with-build-handler (build-notifier #:use-substitutes?
                                            (assoc-ref opts 'substitutes?)
                                            #:verbosity
                                            (assoc-ref opts 'verbosity)
                                            #:dry-run?
                                            (assoc-ref opts 'dry-run?))
          (with-status-verbosity (assoc-ref opts 'verbosity)
            (cond (target (send-to-remote-host store target opts))
                  (source (retrieve-from-remote-host store source opts))
                  (else   (leave (G_ "use '--to' or '--from'~%"))))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 David Thompson <davet@gnu.org>
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;; Copyright © 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 scripts deploy)
  #:use-module (gnu machine)
  #:use-module (guix discovery)
  #:use-module (guix scripts)
  #:use-module (guix scripts build)
  #:use-module (guix store)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix grafts)
  #:use-module (guix status)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-37)
  #:export (guix-deploy))

;;; Commentary:
;;;
;;; This program provides a command-line interface to (gnu machine), allowing
;;; users to perform remote deployments through specification files.
;;;
;;; Code:

(define (show-help)
  (display (G_ "Usage: guix deploy [OPTION] FILE...
Perform the deployment specified by FILE.\n"))
  (show-build-options-help)
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (display (G_ "
  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  (show-bug-report-information))

(define %options
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix deploy")))

         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg
                               (alist-delete 'system result eq?))))
         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result)
                   (let ((level (string->number* arg)))
                     (alist-cons 'verbosity level
                                 (alist-delete 'verbosity result)))))

         %standard-build-options))

(define %default-options
  ;; Alist of default option values.
  `((verbosity . 1)
    (debug . 0)
    (graft? . #t)
    (substitutes? . #t)
    (offload? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)))

(define (load-source-file file)
  "Load FILE as a user module."
  (let* ((guix-path (dirname (search-path %load-path "guix.scm")))
         (environment-modules (scheme-modules* guix-path "gnu/machine"))
         (module (make-user-module (append '((gnu) (gnu machine))
                                           environment-modules))))
    (load* file module)))

(define (show-what-to-deploy machines)
  "Show the list of machines to deploy, MACHINES."
  (let ((count (length machines)))
    (format (current-error-port)
            (N_ "The following ~d machine will be deployed:~%"
                "The following ~d machines will be deployed:~%"
                count)
            count)
    (display (indented-string
              (fill-paragraph (string-join (map machine-display-name machines)
                                           ", ")
                              (- (%text-width) 2) 2)
              2)
             (current-error-port))
    (display "\n\n" (current-error-port))))

(define (deploy-machine* store machine)
  "Deploy MACHINE, taking care of error handling."
  (info (G_ "deploying to ~a...~%")
        (machine-display-name machine))

  (guard (c ((message-condition? c)
             (report-error (G_ "failed to deploy ~a: ~a~%")
                           (machine-display-name machine)
                           (condition-message c)))
            ((deploy-error? c)
             (when (deploy-error-should-roll-back c)
               (info (G_ "rolling back ~a...~%")
                     (machine-display-name machine))
               (run-with-store store (roll-back-machine machine)))
             (apply throw (deploy-error-captured-args c))))
    (run-with-store store (deploy-machine machine))

    (info (G_ "successfully deployed ~a~%")
          (machine-display-name machine))))

(define-command (guix-deploy . args)
  (synopsis "deploy operating systems on a set of machines")
  (define (handle-argument arg result)
    (alist-cons 'file arg result))

  (with-error-handling
    (let* ((opts (parse-command-line args %options (list %default-options)
                                     #:argument-handler handle-argument))
           (file (assq-ref opts 'file))
           (machines (or (and file (load-source-file file)) '())))
      (show-what-to-deploy machines)

      (with-status-verbosity (assoc-ref opts 'verbosity)
        (with-store store
          (set-build-options-from-command-line store opts)
          (with-build-handler (build-notifier #:use-substitutes?
                                              (assoc-ref opts 'substitutes?)
                                              #:verbosity
                                              (assoc-ref opts 'verbosity))
            (parameterize ((%graft? (assq-ref opts 'graft?)))
              (map/accumulate-builds store
                                     (cut deploy-machine* store <>)
                                     machines))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech>
;;;
;;; 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 describe)
  #:use-module ((guix config) #:select (%guix-version))
  #:use-module ((guix ui) #:hide (display-profile-content))
  #:use-module ((guix utils) #:select (string-replace-substring))
  #:use-module (guix channels)
  #:use-module (guix scripts)
  #:use-module (guix describe)
  #:use-module (guix profiles)
  #:autoload   (guix openpgp) (openpgp-format-fingerprint)
  #:use-module (git)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:use-module (web uri)
  #:export (display-profile-content
            channel-commit-hyperlink

            guix-describe))

;;;
;;; Command-line options.
;;;
(define %available-formats
  '("human" "channels" "channels-sans-intro" "json" "recutils"))

(define (list-formats)
  (display (G_ "The available formats are:\n"))
  (newline)
  (for-each (lambda (f)
              (format #t "  - ~a~%" f))
            %available-formats))

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\f "format") #t #f
                (lambda (opt name arg result)
                  (unless (member arg %available-formats)
                    (leave (G_ "~a: unsupported output format~%") arg))
                  (alist-cons 'format (string->symbol arg) result)))
        (option '("list-formats") #f #f
                (lambda (opt name arg result)
                  (list-formats)
                  (exit 0)))
        (option '(#\p "profile") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'profile (canonicalize-profile arg)
                              result)))
        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix describe")))))

(define %default-options
  ;; Alist of default option values.
  '((format . human)))

(define (show-help)
  (display (G_ "Usage: guix describe [OPTION]...
Display information about the channels currently in use.\n"))
  (display (G_ "
  -f, --format=FORMAT    display information in the given FORMAT"))
  (display (G_ "
      --list-formats     display available formats"))
  (display (G_ "
  -p, --profile=PROFILE  display information about PROFILE"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define (display-package-search-path fmt)
  "Display GUIX_PACKAGE_PATH, if it is set, according to FMT."
  (match (getenv "GUIX_PACKAGE_PATH")
    (#f #t)
    (string
     (match fmt
       ('human
        (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string))
       ('channels
        (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%")
                string))
       (_
        (warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%")))))))

(define* (channel->sexp channel #:key (include-introduction? #t))
  (let ((intro (and include-introduction?
                    (channel-introduction channel))))
    `(channel
      (name ',(channel-name channel))
      (url ,(channel-url channel))
      (commit ,(channel-commit channel))
      ,@(if intro
            `((introduction (make-channel-introduction
                             ,(channel-introduction-first-signed-commit intro)
                             (openpgp-fingerprint
                              ,(openpgp-format-fingerprint
                                (channel-introduction-first-commit-signer
                                 intro))))))
            '()))))

(define (channel->json channel)
  (scm->json-string
   (let ((intro (channel-introduction channel)))
     `((name . ,(channel-name channel))
       (url . ,(channel-url channel))
       (commit . ,(channel-commit channel))
       ,@(if intro
             `((introduction
                . ((commit . ,(channel-introduction-first-signed-commit
                               intro))
                   (signer . ,(openpgp-format-fingerprint
                               (channel-introduction-first-commit-signer
                                intro))))))
             '())))))

(define (channel->recutils channel port)
  (define intro
    (channel-introduction channel))

  (format port "name: ~a~%" (channel-name channel))
  (format port "url: ~a~%" (channel-url channel))
  (format port "commit: ~a~%" (channel-commit channel))
  (when intro
    (format port "introductioncommit: ~a~%"
            (channel-introduction-first-signed-commit intro))
    (format port "introductionsigner: ~a~%"
            (openpgp-format-fingerprint
             (channel-introduction-first-commit-signer intro)))))

(define (display-checkout-info fmt)
  "Display information about the current checkout according to FMT, a symbol
denoting the requested format.  Exit if the current directory does not lie
within a Git checkout."
  (let* ((program    (car (command-line)))
         (directory  (catch 'git-error
                       (lambda ()
                         (repository-discover (dirname program)))
                       (lambda (key err)
                         (report-error (G_ "failed to determine origin~%"))
                         (display-hint (format #f (G_ "Perhaps this
@command{guix} command was not obtained with @command{guix pull}?  Its version
string is ~a.~%")
                                               %guix-version))
                         (exit 1))))
         (repository (repository-open directory))
         (head       (repository-head repository))
         (commit     (oid->string (reference-target head))))
    (match fmt
      ('human
       (format #t (G_ "Git checkout:~%"))
       (format #t (G_ "  repository: ~a~%") (dirname directory))
       (format #t (G_ "  branch: ~a~%") (reference-shorthand head))
       (format #t (G_ "  commit: ~a~%") commit))
      ('channels
       (pretty-print `(list ,(channel->sexp (channel (name 'guix)
                                                     (url (dirname directory))
                                                     (commit commit))))))
      ('json
       (display (channel->json (channel (name 'guix)
                                        (url (dirname directory))
                                        (commit commit))))
       (newline))
      ('recutils
       (channel->recutils (channel (name 'guix)
                                   (url (dirname directory))
                                   (commit commit))
                          (current-output-port))))
    (display-package-search-path fmt)))

(define (display-profile-info profile fmt)
  "Display information about PROFILE, a profile as created by (guix channels),
in the format specified by FMT."
  (define number
    (generation-number profile))

  (define channels
    (profile-channels (if (zero? number)
                          profile
                          (generation-file-name profile number))))

  (match fmt
    ('human
     (display-profile-content profile number))
    ('channels
     (pretty-print `(list ,@(map channel->sexp channels))))
    ('channels-sans-intro
     (pretty-print `(list ,@(map (cut channel->sexp <>
                                      #:include-introduction? #f)
                                 channels))))
    ('json
     (format #t "[~a]~%" (string-join (map channel->json channels) ",")))
    ('recutils
     (format #t "~{~a~%~}"
             (map (lambda (channel)
                    (with-output-to-string
                      (lambda ()
                        (channel->recutils channel (current-output-port)))))
                  channels))))
  (display-package-search-path fmt))

(define (display-profile-content profile number)
  "Display the packages in PROFILE, generation NUMBER, in a human-readable
way and displaying details about the channel's source code."
  (display-generation profile number)
  (for-each (lambda (entry)
              (format #t "  ~a ~a~%"
                      (manifest-entry-name entry)
                      (manifest-entry-version entry))
              (match (assq 'source (manifest-entry-properties entry))
                (('source ('repository ('version 0)
                                       ('url url)
                                       ('branch branch)
                                       ('commit commit)
                                       _ ...))
                 (let ((channel (channel (name 'nameless)
                                         (url url)
                                         (branch branch)
                                         (commit commit))))
                   (format #t (G_ "    repository URL: ~a~%") url)
                   (when branch
                     (format #t (G_ "    branch: ~a~%") branch))
                   (format #t (G_ "    commit: ~a~%")
                           (if (supports-hyperlinks?)
                               (channel-commit-hyperlink channel commit)
                               commit))))
                (_ #f)))

            ;; Show most recently installed packages last.
            (reverse
             (manifest-entries
              (profile-manifest (if (zero? number)
                                    profile
                                    (generation-file-name profile number)))))))

(define %vcs-web-views
  ;; Hard-coded list of host names and corresponding web view URL templates.
  ;; TODO: Allow '.guix-channel' files to specify a URL template.
  (let ((labhub-url (lambda (repository-url commit)
                      (string-append
                       (if (string-suffix? ".git" repository-url)
                           (string-drop-right repository-url 4)
                           repository-url)
                       "/commit/" commit))))
    `(("git.savannah.gnu.org"
       ,(lambda (repository-url commit)
          (string-append (string-replace-substring repository-url
                                                   "/git/" "/cgit/")
                         "/commit/?id=" commit)))
      ("notabug.org" ,labhub-url)
      ("framagit.org" ,labhub-url)
      ("gitlab.com" ,labhub-url)
      ("gitlab.inria.fr" ,labhub-url)
      ("github.com" ,labhub-url))))

(define* (channel-commit-hyperlink channel
                                   #:optional
                                   (commit (channel-commit channel)))
  "Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's
text.  The hyperlink links to a web view of COMMIT, when available."
  (let* ((url  (channel-url channel))
         (uri  (string->uri url))
         (host (and uri (uri-host uri))))
    (if host
        (match (assoc host %vcs-web-views)
          (#f
           commit)
          ((_ template)
           (hyperlink (template url commit) commit)))
        commit)))

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

(define-command (guix-describe . args)
  (synopsis "describe the channel revisions currently used")
  (let* ((opts    (args-fold* args %options
                              (lambda (opt name arg result)
                                (leave (G_ "~A: unrecognized option~%")
                                       name))
                              cons
                              %default-options))
         (format  (assq-ref opts 'format))
         (profile (or (assq-ref opts 'profile) (current-profile))))
    (with-error-handling
      (match profile
        (#f
         (display-checkout-info format))
        (profile
         (display-profile-info (canonicalize-profile profile) format))))))