code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.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 progress)
  #:use-module (guix records)
  #:use-module (srfi srfi-19)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (<progress-reporter>
            progress-reporter
            make-progress-reporter
            progress-reporter?
            call-with-progress-reporter

            start-progress-reporter!
            stop-progress-reporter!
            progress-reporter-report!

            progress-reporter/silent
            progress-reporter/file
            progress-reporter/bar
            progress-reporter/trace
            progress-report-port

            display-download-progress
            erase-current-line
            progress-bar
            byte-count->string
            current-terminal-columns

            dump-port*))

;;; Commentary:
;;;
;;; Helper to write progress report code for downloads, etc.
;;;
;;; Code:

(define-record-type* <progress-reporter>
  progress-reporter make-progress-reporter progress-reporter?
  (start   progress-reporter-start)     ; thunk
  (report  progress-reporter-report)    ; procedure
  (stop    progress-reporter-stop))     ; thunk

(define (call-with-progress-reporter reporter proc)
  "Start REPORTER for progress reporting, and call @code{(@var{proc} report)}
with the resulting report procedure.  When @var{proc} returns, the REPORTER is
stopped."
  (match reporter
    (($ <progress-reporter> start report stop)
     (dynamic-wind start (lambda () (proc report)) stop))))

(define (start-progress-reporter! reporter)
  "Low-level procedure to start REPORTER."
  (match reporter
    (($ <progress-reporter> start report stop)
     (start))))

(define (progress-reporter-report! reporter . args)
  "Low-level procedure to lead REPORTER to emit a report."
  (match reporter
    (($ <progress-reporter> start report stop)
     (apply report args))))

(define (stop-progress-reporter! reporter)
  "Low-level procedure to stop REPORTER."
  (match reporter
    (($ <progress-reporter> start report stop)
     (stop))))

(define progress-reporter/silent
  (make-progress-reporter noop noop noop))

;;;
;;; File download progress report.
;;;

(define (nearest-exact-integer x)
  "Given a real number X, return the nearest exact integer, with ties going to
the nearest exact even integer."
  (inexact->exact (round x)))

(define (duration->seconds duration)
  "Return the number of seconds represented by DURATION, a 'time-duration'
object, as an inexact number."
  (+ (time-second duration)
     (/ (time-nanosecond duration) 1e9)))

(define (seconds->string duration)
  "Given DURATION in seconds, return a string representing it in 'mm:ss' or
'hh:mm:ss' format, as needed."
  (if (not (number? duration))
      "00:00"
      (let* ((total-seconds (nearest-exact-integer duration))
             (extra-seconds (modulo total-seconds 3600))
             (num-hours     (quotient total-seconds 3600))
             (hours         (and (positive? num-hours) num-hours))
             (mins          (quotient extra-seconds 60))
             (secs          (modulo extra-seconds 60)))
        (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))

(define (byte-count->string size)
  "Given SIZE in bytes, return a string representing it in a human-readable
way."
  (let ((KiB 1024.)
        (MiB (expt 1024. 2))
        (GiB (expt 1024. 3))
        (TiB (expt 1024. 4)))
    (cond
     ((< size KiB) (format #f "~dB"     (nearest-exact-integer size)))
     ((< size MiB) (format #f "~dKiB"   (nearest-exact-integer (/ size KiB))))
     ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
     ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
     (else         (format #f "~,3fTiB" (/ size TiB))))))

(define (string-pad-middle left right len)
  "Combine LEFT and RIGHT with enough padding in the middle so that the
resulting string has length at least LEN (it may overflow).  If the string
does not overflow, the last char in RIGHT will be flush with the LEN
column."
  (let* ((total-used (+ (string-length left)
                        (string-length right)))
         (num-spaces (max 1 (- len total-used)))
         (padding    (make-string num-spaces #\space)))
    (string-append left padding right)))

(define (rate-limited proc interval)
  "Return a procedure that will forward the invocation to PROC when the time
elapsed since the previous forwarded invocation is greater or equal to
INTERVAL (a time-duration object), otherwise does nothing and returns #f."
  (let ((previous-at #f))
    (lambda args
      (let* ((now (current-time time-monotonic))
             (forward-invocation (lambda ()
                                   (set! previous-at now)
                                   (apply proc args))))
        (if previous-at
            (let ((elapsed (time-difference now previous-at)))
              (if (time>=? elapsed interval)
                  (forward-invocation)
                  #f))
            (forward-invocation))))))

(define current-terminal-columns
  ;; Number of columns of the terminal.
  (make-parameter 80))

(define* (progress-bar % #:optional (bar-width 20))
  "Return % as a string representing an ASCII-art progress bar.  The total
width of the bar is BAR-WIDTH."
  (let* ((bar-width (max 3 (- bar-width 2)))
         (fraction (/ % 100))
         (filled   (inexact->exact (floor (* fraction bar-width))))
         (empty    (- bar-width filled)))
    (format #f "[~a~a]"
            (make-string filled #\#)
            (make-string empty #\space))))

(define (erase-current-line port)
  "Write an ANSI erase-current-line sequence to PORT to erase the whole line and
move the cursor to the beginning of the line."
  (display "\r\x1b[K" port))

(define* (display-download-progress file size
                                    #:key
                                    start-time (transferred 0)
                                    (log-port (current-error-port)))
  "Write the progress report to LOG-PORT.  Use START-TIME (a SRFI-19 time
object) and TRANSFERRED (a total number of bytes) to determine the
throughput."
  (define elapsed
    (duration->seconds
     (time-difference (current-time (time-type start-time))
                      start-time)))

  (if (and (number? size) (not (zero? size)))
      (let* ((%  (* 100.0 (/ transferred size)))
             (throughput (/ transferred elapsed))
             (left       (format #f " ~a  ~a" file
                                 (byte-count->string size)))
             (right      (format #f "~a/s ~a ~a~6,1f%"
                                 (byte-count->string throughput)
                                 (seconds->string elapsed)
                                 (progress-bar %) %)))
        (erase-current-line log-port)
        (display (string-pad-middle left right
                                    (current-terminal-columns))
                 log-port)
        (force-output log-port))
      ;; If we don't know the total size, the last transfer will have a 0B
      ;; size.  Don't display it.
      (unless (zero? transferred)
        (let* ((throughput (/ transferred elapsed))
               (left       (format #f " ~a" file))
               (right      (format #f "~a/s ~a | ~a transferred"
                                   (byte-count->string throughput)
                                   (seconds->string elapsed)
                                   (byte-count->string transferred))))
          (erase-current-line log-port)
          (display (string-pad-middle left right
                                      (current-terminal-columns))
                   log-port)
          (force-output log-port)))))

(define %progress-interval
  ;; Default interval between subsequent outputs for rate-limited displays.
  (make-time time-duration 200000000 0))

(define* (progress-reporter/file file size
                                 #:optional (log-port (current-output-port))
                                 #:key (abbreviation basename))
  "Return a <progress-reporter> object to show the progress of FILE's download,
which is SIZE bytes long.  The progress report is written to LOG-PORT, with
ABBREVIATION used to shorten FILE for display."
  (let ((start-time (current-time time-monotonic))
        (transferred 0))
    (define (render)
      (display-download-progress (abbreviation file) size
                                 #:start-time start-time
                                 #:transferred transferred
                                 #:log-port log-port))

    (progress-reporter
     (start render)
     ;; Report the progress every 300ms or longer.
     (report
      (let ((rate-limited-render (rate-limited render %progress-interval)))
        (lambda (value)
          (set! transferred value)
          (rate-limited-render))))
     ;; Don't miss the last report.
     (stop render))))

(define* (progress-reporter/bar total
                                #:optional
                                (prefix "")
                                (port (current-error-port)))
  "Return a reporter that shows a progress bar every time one of the TOTAL
tasks is performed.  Write PREFIX at the beginning of the line."
  (define done 0)

  (define (report-progress)
    (set! done (+ 1 done))
    (unless (> done total)
      (let* ((ratio (* 100. (/ done total))))
        (erase-current-line port)
        (if (string-null? prefix)
            (display (progress-bar ratio (current-terminal-columns)) port)
            (let ((width (- (current-terminal-columns)
                            (string-length prefix) 3)))
              (display prefix port)
              (display "  " port)
              (display (progress-bar ratio width) port)))
        (force-output port))))

  (progress-reporter
   (start (lambda ()
            (set! done 0)))
   (report report-progress)
   (stop (lambda ()
           (erase-current-line port)
           (unless (string-null? prefix)
             (display prefix port)
             (newline port))
           (force-output port)))))

(define* (progress-reporter/trace file url size
                                  #:optional (log-port (current-output-port)))
  "Like 'progress-reporter/file', but instead of returning human-readable
progress reports, write \"build trace\" lines to be processed elsewhere."
  (define total 0)                                ;bytes transferred

  (define (report-progress transferred)
    (define message
      (format #f "@ download-progress ~a ~a ~a ~a~%"
              file url (or size "-") transferred))

    (display message log-port)                    ;should be atomic
    (flush-output-port log-port))

  (progress-reporter
   (start (lambda ()
            (set! total 0)
            (display (format #f "@ download-started ~a ~a ~a~%"
                             file url (or size "-"))
                     log-port)))
   (report (let ((report (rate-limited report-progress %progress-interval)))
             (lambda (transferred)
               (set! total transferred)
               (report transferred))))
   (stop (lambda ()
           (let ((size (or size total)))
             (report-progress size)
             (display (format #f "@ download-succeeded ~a ~a ~a~%"
                              file url size)
                      log-port))))))

;; TODO: replace '(@ (guix build utils) dump-port))'.
(define* (dump-port* in out
                     #:key (buffer-size 16384)
                     (reporter progress-reporter/silent))
  "Read as much data as possible from IN and write it to OUT, using chunks of
BUFFER-SIZE bytes.  After each successful transfer of BUFFER-SIZE bytes or
less, report the total number of bytes transferred to the REPORTER, which
should be a <progress-reporter> object."
  (define buffer
    (make-bytevector buffer-size))

  (call-with-progress-reporter reporter
    (lambda (report)
      (let loop ((total 0)
                 (bytes (get-bytevector-n! in buffer 0 buffer-size)))
        (or (eof-object? bytes)
            (let ((total (+ total bytes)))
              (put-bytevector out buffer 0 bytes)
              (report total)
              (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))

(define (progress-report-port reporter port)
  "Return a port that continuously reports the bytes read from PORT using
REPORTER, which should be a <progress-reporter> object."
  (match reporter
    (($ <progress-reporter> start report stop)
     (let* ((total 0)
            (read! (lambda (bv start count)
                     (let ((n (match (get-bytevector-n! port bv start count)
                                ((? eof-object?) 0)
                                (x x))))
                       (set! total (+ total n))
                       (report total)
                       n))))
       (start)
       (make-custom-binary-input-port "progress-port-proc"
                                      read! #f #f
                                      (lambda ()
                                        ;; XXX: Kludge!  When used through
                                        ;; 'decompressed-port', this port ends
                                        ;; up being closed twice: once in a
                                        ;; child process early on, and at the
                                        ;; end in the parent process.  Ignore
                                        ;; the early close so we don't output
                                        ;; a spurious "download-succeeded"
                                        ;; trace.
                                        (unless (zero? total)
                                          (stop))
                                        (close-port port)))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; 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 quirks)
  #:use-module ((guix build utils) #:select (substitute*))
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:export (%quirks

            patch?
            applicable-patch?
            apply-patch

            %patches))

;;; Commentary:
;;;
;;; Time traveling is a challenge!  Sometimes, going back to the past requires
;;; adjusting the old source code so it can be evaluated with our modern day
;;; Guile and against our modern Guix APIs.  This file describes quirks found
;;; in old Guix revisions, along with ways to address them or patch them.
;;;
;;; Code:

(define (syscalls-reexports-local-variables? source)
  "Return true if (guix build syscalls) contains the bug described at
<https://bugs.gnu.org/36723>."
  (catch 'system-error
    (lambda ()
      (define content
        (call-with-input-file (string-append source
                                             "/guix/build/syscalls.scm")
          read-string))

      ;; The faulty code would use the 're-export' macro, causing the
      ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using
      ;; Guile > 2.2.4.
      (string-contains content "(re-export variable)"))
    (lambda args
      (if (= ENOENT (system-error-errno args))
          #f
          (apply throw args)))))

(define (requires-guile-2.2? source)
  "Return true if SOURCE uses Guile 2.2 for the shebang of
'compute-guix-derivation'."
  (define content
    (call-with-input-file (string-append source "/" %self-build-file)
      read-string))

  ;; The 'find-best-packages-by-name' call is inserted by %BUG-41214-PATCH.
  (string-contains content
                   (object->string
                    '(find-best-packages-by-name "guile" "2.2"))))

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

(define %quirks
  ;; List of predicate/package pairs.  This allows us to provide information
  ;; about specific Guile versions that old Guix revisions might need to use
  ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE.  See
  ;; <https://bugs.gnu.org/37506>
  `((,syscalls-reexports-local-variables? . ,guile-2.2.4)
    (,requires-guile-2.2? . ,guile-2.2.4)))

;;;
;;; Patches.
;;;

;; Patch to apply to a source tree.
(define-record-type <patch>
  (patch predicate application)
  patch?
  (predicate    patch-predicate)                  ;procedure
  (application  patch-application))               ;procedure

(define (applicable-patch? patch source commit)
  "Return true if PATCH is applicable to SOURCE, a directory, which
corresponds to the given Guix COMMIT, a SHA1 hexadecimal string."
  ;; The predicate is passed COMMIT so that it can choose to only apply to
  ;; ancestors.
  ((patch-predicate patch) source commit))

(define (apply-patch patch source)
  "Apply PATCH onto SOURCE, directly modifying files beneath it."
  ((patch-application patch) source))

(define %self-build-file
  ;; The file containing code to build Guix.
  "build-aux/build-self.scm")

(define %bug-41028-patch
  ;; Patch for <https://bugs.gnu.org/41028>.  The faulty code is the
  ;; 'compute-guix-derivation' body, which uses 'call-with-new-thread' without
  ;; importing (ice-9 threads).  However, the 'call-with-new-thread' binding
  ;; is no longer available in the default name space on Guile 3.0.
  (let ()
    (define (missing-ice-9-threads-import? source commit)
      ;; Return true if %SELF-BUILD-FILE is missing an (ice-9 threads) import.
      (define content
        (call-with-input-file (string-append source "/" %self-build-file)
          read-string))

      (and (string-contains content "(call-with-new-thread")
           (not (string-contains content "(ice-9 threads)"))))

    (define (add-missing-ice-9-threads-import source)
      ;; Add (ice-9 threads) import in the gexp of 'compute-guix-derivation'.
      (substitute* (string-append source "/" %self-build-file)
        (("^ +\\(use-modules \\(ice-9 match\\)\\)")
         (object->string '(use-modules (ice-9 match) (ice-9 threads))))))

   (patch missing-ice-9-threads-import? add-missing-ice-9-threads-import)))

(define %bug-41214-patch
  ;; Patch for <https://bugs.gnu.org/41214>.  Around v1.0.0, (guix build
  ;; compile) would use Guile 2.2 procedures to access the set of available
  ;; compilation options.  These procedures no longer exist in 3.0.
  (let ()
    (define (accesses-guile-2.2-optimization-options? source commit)
      (catch 'system-error
        (lambda ()
          (call-with-input-file (string-append source
                                               "/guix/build/compile.scm")
            (lambda (port)
              (match (read port)
                (('define-module ('guix 'build 'compile)
                   _ ...
                   #:use-module ('language 'tree-il 'optimize)
                   #:use-module ('language 'cps 'optimize)
                   #:export ('%default-optimizations
                             '%lightweight-optimizations
                             'compile-files))
                 #t)
                (_
                 ;; Before v1.0.0 (ca. Dec. 2018), the 'use-modules' form
                 ;; would show up in a subsequent 'cond-expand' clause.
                 ;; See <https://bugs.gnu.org/42519>.
                 (match (read port)
                   (('cond-expand
                      ('guile-2.2 ('use-modules ('language 'tree-il 'optimize)
                                                _ ...))
                      _ ...)
                    #t)
                   (_
                    #f)))))))
        (const #f)))

    (define (build-with-guile-2.2 source)
      (substitute* (string-append source "/" %self-build-file)
        (("\\(default-guile\\)")
         ;; Note: This goes hand in hand with the 'requires-guile-2.2?' quirk.
         (object->string '(car (find-best-packages-by-name "guile" "2.2"))))
        (("\\(find-best-packages-by-name \"guile-gcrypt\" #f\\)")
         (object->string '(find-best-packages-by-name "guile2.2-gcrypt" #f))))
      #t)

    (patch accesses-guile-2.2-optimization-options?
           build-with-guile-2.2)))

(define %patches
  ;; Bits of past Guix revisions can become incompatible with newer Guix and
  ;; Guile.  This variable lists <patch> records for the Guix source tree that
  ;; apply to the Guix source.
  (list %bug-41028-patch
        %bug-41214-patch))

license: mit


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 © 2018 Mark H Weaver <mhw@netris.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 records)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:autoload (system base target) (target-most-positive-fixnum)
  #:export (define-record-type*
            this-record

            alist->record
            object->fields
            recutils->alist
            match-record))

;;; Commentary:
;;;
;;; Utilities for dealing with Scheme records.
;;;
;;; Code:

(define-syntax record-error
  (syntax-rules ()
    "Report a syntactic error in use of CONSTRUCTOR."
    ((_ constructor form fmt args ...)
     (syntax-violation constructor
                       (format #f fmt args ...)
                       form))))

(eval-when (expand load eval)
  ;; The procedures below are needed both at run time and at expansion time.

  (define (current-abi-identifier type)
    "Return an identifier unhygienically derived from TYPE for use as its
\"current ABI\" variable."
    (let ((type-name (syntax->datum type)))
      (datum->syntax
       type
       (string->symbol
        (string-append "% " (symbol->string type-name)
                       " abi-cookie")))))

  (define (abi-check type cookie)
    "Return syntax that checks that the current \"application binary
interface\" (ABI) for TYPE is equal to COOKIE."
    (with-syntax ((current-abi (current-abi-identifier type)))
      #`(unless (eq? current-abi #,cookie)
          ;; The source file where this exception is thrown must be
          ;; recompiled.
          (throw 'record-abi-mismatch-error 'abi-check
                 "~a: record ABI mismatch; recompilation needed"
                 (list #,type) '()))))

  (define* (report-invalid-field-specifier name bindings
                                           #:optional parent-form)
    "Report the first invalid binding among BINDINGS.  PARENT-FORM is used for
error-reporting purposes."
    (let loop ((bindings bindings))
      (syntax-case bindings ()
        (((field value) rest ...)                   ;good
         (loop #'(rest ...)))
        ((weird _ ...)                              ;weird!
         ;; WEIRD may be an identifier, thus lacking source location info, and
         ;; BINDINGS is a list, also lacking source location info.  Hopefully
         ;; PARENT-FORM provides source location info.
         (apply syntax-violation name "invalid field specifier"
                (if parent-form
                    (list parent-form #'weird)
                    (list #'weird)))))))

  (define (report-duplicate-field-specifier name ctor)
    "Report the first duplicate identifier among the bindings in CTOR."
    (syntax-case ctor ()
      ((_ bindings ...)
       (let loop ((bindings #'(bindings ...))
                  (seen   '()))
         (syntax-case bindings ()
           (((field value) rest ...)
            (not (memq (syntax->datum #'field) seen))
            (loop #'(rest ...) (cons (syntax->datum #'field) seen)))
           ((duplicate rest ...)
            (syntax-violation name "duplicate field initializer"
                              #'duplicate))
           (()
            #t)))))))

(define-syntax-parameter this-record
  (lambda (s)
    "Return the record being defined.  This macro may only be used in the
context of the definition of a thunked field."
    (syntax-case s ()
      (id
       (identifier? #'id)
       (syntax-violation 'this-record
                         "cannot be used outside of a record instantiation"
                         #'id)))))

(define-syntax make-syntactic-constructor
  (syntax-rules ()
    "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
expects all of EXPECTED fields to be initialized.  DEFAULTS is the list of
FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
fields, and DELAYED is the list of identifiers of delayed fields.

ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI
of TYPE matches the expansion-time ABI."
    ((_ type name ctor (expected ...)
        #:abi-cookie abi-cookie
        #:thunked thunked
        #:this-identifier this-identifier
        #:delayed delayed
        #:innate innate
        #:defaults defaults)
     (define-syntax name
       (lambda (s)
         (define (record-inheritance orig-record field+value)
           ;; Produce code that returns a record identical to ORIG-RECORD,
           ;; except that values for the FIELD+VALUE alist prevail.
           (define (field-inherited-value f)
             (and=> (find (lambda (x)
                            (eq? f (car (syntax->datum x))))
                          field+value)
                    car))

           ;; Make sure there are no unknown field names.
           (let* ((fields     (map (compose car syntax->datum) field+value))
                  (unexpected (lset-difference eq? fields '(expected ...))))
             (when (pair? unexpected)
               (record-error 'name s "extraneous field initializers ~a"
                             unexpected)))

           #`(make-struct/no-tail type
                          #,@(map (lambda (field index)
                                    (or (field-inherited-value field)
                                        (if (innate-field? field)
                                            (wrap-field-value
                                             field (field-default-value field))
                                            #`(struct-ref #,orig-record
                                                          #,index))))
                                  '(expected ...)
                                  (iota (length '(expected ...))))))

         (define (thunked-field? f)
           (memq (syntax->datum f) 'thunked))

         (define (delayed-field? f)
           (memq (syntax->datum f) 'delayed))

         (define (innate-field? f)
           (memq (syntax->datum f) 'innate))

         (define (wrap-field-value f value)
           (cond ((thunked-field? f)
                  #`(lambda (x)
                      (syntax-parameterize ((#,this-identifier
                                             (lambda (s)
                                               (syntax-case s ()
                                                 (id
                                                  (identifier? #'id)
                                                  #'x)))))
                        #,value)))
                 ((delayed-field? f)
                  #`(delay #,value))
                 (else value)))

         (define default-values
           ;; List of symbol/value tuples.
           (map (match-lambda
                  ((f v)
                   (list (syntax->datum f) v)))
                #'defaults))

         (define (field-default-value f)
           (car (assoc-ref default-values (syntax->datum f))))

         (define (field-bindings field+value)
           ;; Return field to value bindings, for use in 'let*' below.
           (map (lambda (field+value)
                  (syntax-case field+value ()
                    ((field value)
                     #`(field
                        #,(wrap-field-value #'field #'value)))))
                field+value))

         (syntax-case s (inherit expected ...)
           ((_ (inherit orig-record) (field value) (... ...))
            #`(let* #,(field-bindings #'((field value) (... ...)))
                #,(abi-check #'type abi-cookie)
                #,(record-inheritance #'orig-record
                                      #'((field value) (... ...)))))
           ((_ (field value) (... ...))
            (let ((fields (map syntax->datum #'(field (... ...)))))
              (define (field-value f)
                (or (find (lambda (x)
                            (eq? f (syntax->datum x)))
                          #'(field (... ...)))
                    (wrap-field-value f (field-default-value f))))

              ;; Pass S to make sure source location info is preserved.
              (report-duplicate-field-specifier 'name s)

              (let ((fields (append fields (map car default-values))))
                (cond ((lset= eq? fields '(expected ...))
                       #`(let* #,(field-bindings
                                  #'((field value) (... ...)))
                           #,(abi-check #'type abi-cookie)
                           (ctor #,@(map field-value '(expected ...)))))
                      ((pair? (lset-difference eq? fields
                                               '(expected ...)))
                       (record-error 'name s
                                     "extraneous field initializers ~a"
                                     (lset-difference eq? fields
                                                      '(expected ...))))
                      (else
                       (record-error 'name s
                                     "missing field initializers ~a"
                                     (lset-difference eq?
                                                      '(expected ...)
                                                      fields)))))))
           ((_ bindings (... ...))
            ;; One of BINDINGS doesn't match the (field value) pattern.
            ;; Report precisely which one is faulty, instead of letting the
            ;; "source expression failed to match any pattern" error.
            (report-invalid-field-specifier 'name
                                            #'(bindings (... ...))
                                            s))))))))

(define-syntax-rule (define-field-property-predicate predicate property)
  "Define PREDICATE as a procedure that takes a syntax object and, when passed
a field specification, returns the field name if it has the given PROPERTY."
  (define (predicate s)
    (syntax-case s (property)
      ((field (property values (... ...)) _ (... ...))
       #'field)
      ((field _ properties (... ...))
       (predicate #'(field properties (... ...))))
      (_ #f))))

(define-syntax define-record-type*
  (lambda (s)
    "Define the given record type such that an additional \"syntactic
constructor\" is defined, which allows instances to be constructed with named
field initializers, à la SRFI-35, as well as default values.  An example use
may look like this:

  (define-record-type* <thing> thing make-thing
    thing?
    this-thing
    (name  thing-name (default \"chbouib\"))
    (port  thing-port
           (default (current-output-port)) (thunked))
    (loc   thing-location (innate) (default (current-source-location))))

This example defines a macro 'thing' that can be used to instantiate records
of this type:

  (thing
    (name \"foo\")
    (port (current-error-port)))

The value of 'name' or 'port' could as well be omitted, in which case the
default value specified in the 'define-record-type*' form is used:

  (thing)

The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
actually compute the field's value in the current dynamic extent, which is
useful when referring to fluids in a field's value.  Furthermore, that thunk
can access the record it belongs to via the 'this-thing' identifier.

A field can also be marked as \"delayed\" instead of \"thunked\", in which
case its value is effectively wrapped in a (delay …) form.

It is possible to copy an object 'x' created with 'thing' like this:

  (thing (inherit x) (name \"bar\"))

This expression returns a new object equal to 'x' except for its 'name'
field and its 'loc' field---the latter is marked as \"innate\", so it is not
inherited."

    (define (field-default-value s)
      (syntax-case s (default)
        ((field (default val) _ ...)
         (list #'field #'val))
        ((field _ properties ...)
         (field-default-value #'(field properties ...)))
        (_ #f)))

    (define-field-property-predicate delayed-field? delayed)
    (define-field-property-predicate thunked-field? thunked)
    (define-field-property-predicate innate-field? innate)

    (define (wrapped-field? s)
      (or (thunked-field? s) (delayed-field? s)))

    (define (wrapped-field-accessor-name field)
      ;; Return the name (an unhygienic syntax object) of the "real"
      ;; getter for field, which is assumed to be a wrapped field.
      (syntax-case field ()
        ((field get properties ...)
         (let* ((getter      (syntax->datum #'get))
                (real-getter (symbol-append '% getter '-real)))
           (datum->syntax #'get real-getter)))))

    (define (field-spec->srfi-9 field)
      ;; Convert a field spec of our style to a SRFI-9 field spec of the
      ;; form (field get).
      (syntax-case field ()
        ((name get properties ...)
         #`(name
            #,(if (wrapped-field? field)
                  (wrapped-field-accessor-name field)
                  #'get)))))

    (define (thunked-field-accessor-definition field)
      ;; Return the real accessor for FIELD, which is assumed to be a
      ;; thunked field.
      (syntax-case field ()
        ((name get _ ...)
         (with-syntax ((real-get (wrapped-field-accessor-name field)))
           #'(define-inlinable (get x)
               ;; The real value of that field is a thunk, so call it.
               ((real-get x) x))))))

    (define (delayed-field-accessor-definition field)
      ;; Return the real accessor for FIELD, which is assumed to be a
      ;; delayed field.
      (syntax-case field ()
        ((name get _ ...)
         (with-syntax ((real-get (wrapped-field-accessor-name field)))
           #'(define-inlinable (get x)
               ;; The real value of that field is a promise, so force it.
               (force (real-get x)))))))

    (define (compute-abi-cookie field-specs)
      ;; Compute an "ABI cookie" for the given FIELD-SPECS.  We use
      ;; 'string-hash' because that's a better hash function that 'hash' on a
      ;; list of symbols.
      (syntax-case field-specs ()
        (((field get properties ...) ...)
         (string-hash (object->string
                       (syntax->datum #'((field properties ...) ...)))
                      (cond-expand
                        (guile-3 (target-most-positive-fixnum))
                        (else most-positive-fixnum))))))

    (syntax-case s ()
      ((_ type syntactic-ctor ctor pred
          this-identifier
          (field get properties ...) ...)
       (identifier? #'this-identifier)
       (let* ((field-spec #'((field get properties ...) ...))
              (thunked    (filter-map thunked-field? field-spec))
              (delayed    (filter-map delayed-field? field-spec))
              (innate     (filter-map innate-field? field-spec))
              (defaults   (filter-map field-default-value
                                      #'((field properties ...) ...)))
              (cookie     (compute-abi-cookie field-spec)))
         (with-syntax (((field-spec* ...)
                        (map field-spec->srfi-9 field-spec))
                       ((thunked-field-accessor ...)
                        (filter-map (lambda (field)
                                      (and (thunked-field? field)
                                           (thunked-field-accessor-definition
                                            field)))
                                    field-spec))
                       ((delayed-field-accessor ...)
                        (filter-map (lambda (field)
                                      (and (delayed-field? field)
                                           (delayed-field-accessor-definition
                                            field)))
                                    field-spec)))
           #`(begin
               (define-record-type type
                 (ctor field ...)
                 pred
                 field-spec* ...)
               (define #,(current-abi-identifier #'type)
                 #,cookie)

               #,@(if (free-identifier=? #'this-identifier #'this-record)
                      #'()
                      #'((define-syntax-parameter this-identifier
                           (lambda (s)
                             "Return the record being defined.  This macro may
only be used in the context of the definition of a thunked field."
                             (syntax-case s ()
                               (id
                                (identifier? #'id)
                                (syntax-violation 'this-identifier
                                                  "cannot be used outside \
of a record instantiation"
                                                  #'id)))))))
               thunked-field-accessor ...
               delayed-field-accessor ...
               (make-syntactic-constructor type syntactic-ctor ctor
                                           (field ...)
                                           #:abi-cookie #,cookie
                                           #:thunked #,thunked
                                           #:this-identifier #'this-identifier
                                           #:delayed #,delayed
                                           #:innate #,innate
                                           #:defaults #,defaults)))))
      ((_ type syntactic-ctor ctor pred
          (field get properties ...) ...)
       ;; When no 'this' identifier was specified, use 'this-record'.
       #'(define-record-type* type syntactic-ctor ctor pred
           this-record
           (field get properties ...) ...)))))

(define* (alist->record alist make keys
                        #:optional (multiple-value-keys '()))
  "Apply MAKE to the values associated with KEYS in ALIST.  Items in KEYS that
are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
times in ALIST, and thus their value is a list."
  (let ((args (map (lambda (key)
                     (if (member key multiple-value-keys)
                         (filter-map (match-lambda
                                      ((k . v)
                                       (and (equal? k key) v)))
                                     alist)
                         (assoc-ref alist key)))
                   keys)))
    (apply make args)))

(define (object->fields object fields port)
  "Write OBJECT (typically a record) as a series of recutils-style fields to
PORT, according to FIELDS.  FIELDS must be a list of field name/getter pairs."
  (let loop ((fields fields))
    (match fields
      (()
       object)
      (((field . get) rest ...)
       (format port "~a: ~a~%" field (get object))
       (loop rest)))))

(define %recutils-field-charset
  ;; Valid characters starting a recutils field.
  ;; info "(recutils) Fields"
  (char-set-union char-set:upper-case
                  char-set:lower-case
                  (char-set #\%)))

(define (recutils->alist port)
  "Read a recutils-style record from PORT and return it as a list of key/value
pairs.  Stop upon an empty line (after consuming it) or EOF."
  (let loop ((line   (read-line port))
             (result '()))
    (cond ((eof-object? line)
           (reverse result))
          ((string-null? line)
           (if (null? result)
               (loop (read-line port) result)     ; leading space: ignore it
               (reverse result)))                 ; end-of-record marker
          (else
           ;; Now check the first character of LINE, since that's what the
           ;; recutils manual says is enough.
           (let ((first (string-ref line 0)))
             (cond
              ((char-set-contains? %recutils-field-charset first)
               (let* ((colon (string-index line #\:))
                      (field (string-take line colon))
                      (value (string-trim (string-drop line (+ 1 colon)))))
                 (loop (read-line port)
                       (alist-cons field value result))))
              ((eqv? first #\#)                   ;info "(recutils) Comments"
               (loop (read-line port) result))
              ((eqv? first #\+)                   ;info "(recutils) Fields"
               (let ((new-line (if (string-prefix? "+ " line)
                                   (string-drop line 2)
                                   (string-drop line 1))))
                (match result
                  (((field . value) rest ...)
                   (loop (read-line port)
                         `((,field . ,(string-append value "\n" new-line))
                           ,@rest))))))
              (else
               (error "unmatched line" line))))))))

(define-syntax match-record
  (syntax-rules ()
    "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
The current implementation does not support thunked and delayed fields."
    ((_ record type (field fields ...) body ...)
     (if (eq? (struct-vtable record) type)
         ;; TODO compute indices and report wrong-field-name errors at
         ;;      expansion time
         ;; TODO support thunked and delayed fields
         (let ((field ((record-accessor type 'field) record)))
           (match-record record type (fields ...) body ...))
         (throw 'wrong-type-arg record)))
    ((_ record type () body ...)
     (begin body ...))))

;;; records.scm ends here


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

(define-module (guix remote)
  #:use-module (guix ssh)
  #:use-module (guix gexp)
  #:use-module (guix i18n)
  #:use-module ((guix diagnostics) #:select (formatted-message))
  #:use-module (guix inferior)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module (guix derivations)
  #:use-module (guix utils)
  #:use-module (ssh popen)
  #:use-module (ssh channel)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (remote-eval))

;;; Commentary:
;;;
;;; Note: This API is experimental and subject to change!
;;;
;;; Evaluate a gexp on a remote machine, over SSH, ensuring that all the
;;; elements the gexp refers to are deployed beforehand.  This is useful for
;;; expressions that have side effects; for pure expressions, you would rather
;;; build a derivation remotely or offload it.
;;;
;;; Code:

(define* (remote-pipe-for-gexp lowered session #:optional become-command)
  "Return a remote pipe for the given SESSION to evaluate LOWERED.  If
BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
  (define shell-quote
    (compose object->string object->string))

  (define repl-command
    (append (or become-command '())
            (list
             (string-append (derivation-input-output-path
                             (lowered-gexp-guile lowered))
                            "/bin/guile")
             "--no-auto-compile")
            (append-map (lambda (directory)
                          `("-L" ,directory))
                        (lowered-gexp-load-path lowered))
            (append-map (lambda (directory)
                          `("-C" ,directory))
                        (lowered-gexp-load-path lowered))
            `("-c"
              ,(shell-quote (lowered-gexp-sexp lowered)))))

  (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
    (when (eof-object? (peek-char pipe))
      (let ((status (channel-get-exit-status pipe)))
        (close-port pipe)
        (raise (formatted-message (G_ "remote command '~{~a~^ ~}' failed \
with status ~a")
                                  repl-command status))))
    pipe))

(define* (%remote-eval lowered session #:optional become-command)
  "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
prerequisites of EXP are already available on the host at SESSION.  If
BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
  (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
         (result (read-repl-response pipe)))
    (close-port pipe)
    result))

(define (trampoline exp)
  "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation
result to the current output port using the (guix repl) protocol."
  (define program
    (program-file "remote-exp.scm" exp))

  (with-imported-modules (source-module-closure '((guix repl)))
    #~(begin
        (use-modules (guix repl))

        ;; We use CURRENT-OUTPUT-PORT for REPL messages, so redirect PROGRAM's
        ;; output to CURRENT-ERROR-PORT so that it does not interfere.
        (send-repl-response '(with-output-to-port (current-error-port)
                               (lambda ()
                                 (primitive-load #$program)))
                            (current-output-port))

        (force-output))))

(define* (remote-eval exp session
                      #:key
                      (build-locally? #t)
                      (system (%current-system))
                      (module-path %load-path)
                      (socket-name (%daemon-socket-uri))
                      (become-command #f))
  "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
all the elements EXP refers to are built and deployed to SESSION beforehand.
When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
the remote store afterwards; otherwise, dependencies are built directly on the
remote store."
  (mlet* %store-monad ((lowered (lower-gexp (trampoline exp)
                                            #:system system
                                            #:guile-for-build #f
                                            #:module-path %load-path))
                       (remote -> (connect-to-remote-daemon session
                                                            socket-name)))
    (define inputs
      (cons (lowered-gexp-guile lowered)
            (lowered-gexp-inputs lowered)))

    (define sources
      (lowered-gexp-sources lowered))

    (if build-locally?
        (let ((to-send (append (append-map derivation-input-output-paths
                                           inputs)
                               sources)))
          (mbegin %store-monad
            (built-derivations inputs)
            ((store-lift send-files) to-send remote #:recursive? #t)
            (return (close-connection remote))
            (return (%remote-eval lowered session become-command))))
        (let ((to-send (append (map (compose derivation-file-name
                                             derivation-input-derivation)
                                    inputs)
                               sources)))
          (mbegin %store-monad
            ((store-lift send-files) to-send remote #:recursive? #t)
            (return (build-derivations remote inputs))
            (return (close-connection remote))
            (return (%remote-eval lowered session become-command)))))))


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

(define-module (guix repl)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (send-repl-response
            machine-repl))

;;; Commentary:
;;;
;;; This module implements the "machine-readable" REPL provided by
;;; 'guix repl -t machine'.  It's a lightweight module meant to be
;;; embedded in any Guile process providing REPL functionality.
;;;
;;; Code:

(define (self-quoting? x)
  "Return #t if X is self-quoting."
  (letrec-syntax ((one-of (syntax-rules ()
                            ((_) #f)
                            ((_ pred rest ...)
                             (or (pred x)
                                 (one-of rest ...))))))
    (one-of symbol? string? keyword? pair? null? array?
            number? boolean? char?)))

(define repl-prompt
  ;; Current REPL prompt or #f.
  (make-parameter #f))

(define (stack->frames stack)
  "Return STACK's frames as a list."
  (unfold (cute >= <> (stack-length stack))
          (cut stack-ref stack <>)
          1+
          0))

(define* (send-repl-response exp output
                             #:key (version '(0 0)))
  "Write the response corresponding to the evaluation of EXP to PORT, an
output port.  VERSION is the client's protocol version we are targeting."
  (define (value->sexp value)
    (if (self-quoting? value)
        `(value ,value)
        `(non-self-quoting ,(object-address value)
                           ,(object->string value))))

  (define (frame->sexp frame)
    `(,(frame-procedure-name frame)
      ,(match (frame-source frame)
         ((_ (? string? file) (? integer? line) . (? integer? column))
          (list file line column))
         (_
          '(#f #f #f)))))

  (define (handle-exception key . args)
    (define reply
      (match version
        ((0 1 (? positive?) _ ...)
         ;; Protocol (0 1 1) and later.
         (let ((stack (if (repl-prompt)
                          (make-stack #t handle-exception (repl-prompt))
                          (make-stack #t))))
           `(exception (arguments ,key ,@(map value->sexp args))
                       (stack ,@(map frame->sexp (stack->frames stack))))))
        (_
         ;; Protocol (0 0).
         `(exception ,key ,@(map value->sexp args)))))

    (write reply output)
    (newline output)
    (force-output output))

  (catch #t
    (lambda ()
      (let ((results (call-with-values
                         (lambda ()
                           (primitive-eval exp))
                       list)))
        (write `(values ,@(map value->sexp results))
               output)
        (newline output)
        (force-output output)))
    (const #t)
    handle-exception))

(define* (machine-repl #:optional
                       (input (current-input-port))
                       (output (current-output-port)))
  "Run a machine-usable REPL over ports INPUT and OUTPUT.

The protocol of this REPL is meant to be machine-readable and provides proper
support to represent multiple-value returns, exceptions, objects that lack a
read syntax, and so on.  As such it is more convenient and robust than parsing
Guile's REPL prompt."
  (define tag
    (make-prompt-tag "repl-prompt"))

  (define (loop exp version)
    (match exp
      ((? eof-object?) #t)
      (exp
       (send-repl-response exp output
                           #:version version)
       (loop (read input) version))))

  (write `(repl-version 0 1 1) output)
  (newline output)
  (force-output output)

  ;; In protocol version (0 0), clients would not send their supported
  ;; protocol version.  Thus, the code below checks for two case: (1) a (0 0)
  ;; client that directly sends an expression to evaluate, and (2) a more
  ;; recent client that sends (() repl-version ...).  This form is chosen to
  ;; be unambiguously distinguishable from a regular Scheme expression.

  (call-with-prompt tag
    (lambda ()
      (parameterize ((repl-prompt tag))
        (match (read input)
          ((() 'repl-version version ...)
           (loop (read input) version))
          (exp
           (loop exp '(0 0))))))
    (const #f)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@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)
  #:use-module (guix grafts)
  #:use-module (guix utils)
  #:use-module (guix ui)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module ((guix profiles) #:select (%profile-directory))
  #:autoload   (guix describe) (current-profile-date)
  #:use-module (guix build syscalls)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:export (synopsis
            category
            define-command
            %command-categories

            args-fold*
            parse-command-line
            maybe-build
            build-package
            build-package-source
            %distro-age-warning
            warn-about-old-distro
            %disk-space-warning
            warn-about-disk-space))

;;; Commentary:
;;;
;;; General code for Guix scripts.
;;;
;;; Code:

;; Syntactic keywords.
(define synopsis 'command-synopsis)
(define category 'command-category)

(define-syntax define-command-categories
  (syntax-rules (G_)
    "Define command categories."
    ((_ name assert-valid (identifiers (G_ synopses)) ...)
     (begin
       (define-public identifiers
         ;; Define and export syntactic keywords.
         (list 'syntactic-keyword-for-command-category))
       ...

       (define-syntax assert-valid
         ;; Validate at expansion time that we're passed a valid category.
         (syntax-rules (identifiers ...)
           ((_ identifiers) #t)
           ...))

       (define name
         ;; Alist mapping category name to synopsis.
         `((identifiers . synopses) ...))))))

;; Command categories.
(define-command-categories %command-categories
  assert-valid-command-category
  (main        (G_ "main commands"))
  (development (G_ "software development commands"))
  (packaging   (G_ "packaging commands"))
  (plumbing    (G_ "plumbing commands"))
  (internal    (G_ "internal commands")))

(define-syntax define-command
  (syntax-rules (category synopsis)
    "Define the given command as a procedure along with its synopsis and,
optionally, its category.  The synopsis becomes the docstring of the
procedure, but both the category and synopsis are meant to be read (parsed) by
'guix help'."
    ;; The (synopsis ...) form is here so that xgettext sees those strings as
    ;; translatable.
    ((_ (name . args)
        (synopsis doc) body ...)
     (define (name . args)
       doc
       body ...))
    ((_ (name . args)
        (category cat) (synopsis doc)
        body ...)
     (begin
       (assert-valid-command-category cat)
       (define (name . args)
         doc
         body ...)))))

(define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
  "A wrapper on top of `args-fold' that does proper user-facing error
reporting."
  (catch 'misc-error
    (lambda ()
      (apply args-fold args options unrecognized-option-proc
             operand-proc seeds))
    (lambda (key proc msg args . rest)
      ;; XXX: MSG is not i18n'd.
      (leave (G_ "invalid argument: ~a~%")
             (apply format #f msg args)))))

(define (environment-build-options)
  "Return additional build options passed as environment variables."
  (arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))

(define %default-argument-handler
  ;; The default handler for non-option command-line arguments.
  (lambda (arg result)
    (alist-cons 'argument arg result)))

(define* (parse-command-line args options seeds
                             #:key
                             (build-options? #t)
                             (argument-handler %default-argument-handler))
  "Parse the command-line arguments ARGS according to OPTIONS (a list of
SRFI-37 options) and return the result, seeded by SEEDS.  When BUILD-OPTIONS?
is true, also pass arguments passed via the 'GUIX_BUILD_OPTIONS' environment
variable.  Command-line options take precedence those passed via
'GUIX_BUILD_OPTIONS'.

ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
parameter of 'args-fold'."
  (define (parse-options-from args seeds)
    ;; Actual parsing takes place here.
    (apply args-fold* args options
           (lambda (opt name arg . rest)
             (leave (G_ "~A: unrecognized option~%") name))
           argument-handler
           seeds))

  (call-with-values
      (lambda ()
        (if build-options?
            (parse-options-from (environment-build-options) seeds)
            (apply values seeds)))
    (lambda seeds
      ;; ARGS take precedence over what the environment variable specifies.
      (parse-options-from args seeds))))

(define* (maybe-build drvs
                      #:key dry-run? use-substitutes?)
  "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
true."
  (with-monad %store-monad
    (>>= (show-what-to-build* drvs
                              #:dry-run? dry-run?
                              #:use-substitutes? use-substitutes?)
         (lambda (_)
           (if dry-run?
               (return #f)
               (built-derivations drvs))))))

(define* (build-package package
                        #:key dry-run? (use-substitutes? #t)
                        #:allow-other-keys
                        #:rest build-options)
  "Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
Show what and how will/would be built."
  (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
    (apply set-build-options*
           #:use-substitutes? use-substitutes?
           (strip-keyword-arguments '(#:dry-run?) build-options))
    (mlet %store-monad ((derivation (package->derivation
                                     package #:graft? (and (not dry-run?)
                                                           grafting?))))
      (mbegin %store-monad
        (maybe-build (list derivation)
                     #:use-substitutes? use-substitutes?
                     #:dry-run? dry-run?)
        (return (show-derivation-outputs derivation))))))

(define* (build-package-source package
                               #:key dry-run? (use-substitutes? #t)
                               #:allow-other-keys
                               #:rest build-options)
  "Build PACKAGE source using BUILD-OPTIONS."
  (mbegin %store-monad
    (apply set-build-options*
           #:use-substitutes? use-substitutes?
           (strip-keyword-arguments '(#:dry-run?) build-options))
    (mlet %store-monad ((derivation (origin->derivation
                                     (package-source package))))
      (mbegin %store-monad
        (maybe-build (list derivation)
                     #:use-substitutes? use-substitutes?
                     #:dry-run? dry-run?)
        (return (show-derivation-outputs derivation))))))

(define %distro-age-warning
  ;; The age (in seconds) above which we warn that the distro is too old.
  (make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING")
                                string->duration)
                    (#f  (* 7 24 3600))
                    (age (time-second age)))))

(define* (warn-about-old-distro #:optional (old (%distro-age-warning))
                                #:key (suggested-command
                                       "guix package -u"))
  "Emit a warning if Guix is older than OLD seconds."
  (define (seconds->days seconds)
    (round (/ seconds (* 3600 24))))

  (define age
    (match (current-profile-date)
      (#f    #f)
      (date  (- (time-second (current-time time-utc))
                date))))

  (when (and age (>= age old))
    (warning (N_ "Your Guix installation is ~a day old.\n"
                 "Your Guix installation is ~a days old.\n"
                 (seconds->days age))
             (seconds->days age)))
  (when (and (or (not age) (>= age old))
             (not (getenv "GUIX_UNINSTALLED")))
    (warning (G_ "Consider running 'guix pull' followed by
'~a' to get up-to-date packages and security updates.\n")
             suggested-command)
    (newline (guix-warning-port))))

(define %disk-space-warning
  ;; Return a pair of absolute threshold (number of bytes) and relative
  ;; threshold (fraction between 0 and 1) for the free disk space below which
  ;; a warning is emitted.
  ;; GUIX_DISK_SPACE_WARNING can contain both thresholds.  A value in [0;100)
  ;; is a relative threshold, otherwise it's absolute.  The following
  ;; example values are valid:
  ;; - 1GiB;10%      ;1 GiB absolute, and 10% relative.
  ;; - 15G           ;15 GiB absolute, and default relative.
  ;; - 99%           ;99% relative, and default absolute.
  ;; - 99            ;Same.
  ;; - 100           ;100 absolute, and default relative.
  (let* ((default-absolute-threshold (size->number "5GiB"))
         (default-relative-threshold 0.05)
         (percentage->float (lambda (percentage)
                              (or (and=> (string->number
                                          (car (string-split percentage #\%)))
                                         (lambda (n) (/ n 100.0)))
                                  default-relative-threshold)))
         (size->number* (lambda (size)
                          (or (false-if-exception (size->number size))
                              default-absolute-threshold)))
         (absolute? (lambda (size)
                      (not (or (string-suffix? "%" size)
                               (false-if-exception (< (size->number size) 100)))))))
    (make-parameter
     (match (getenv "GUIX_DISK_SPACE_WARNING")
       (#f (list default-absolute-threshold
                 default-relative-threshold))
       (env-string (match (string-split env-string #\;)
                     ((threshold)
                      (if (absolute? threshold)
                          (list (size->number* threshold)
                                default-relative-threshold)
                          (list default-absolute-threshold
                                (percentage->float threshold))))
                     ((threshold1 threshold2)
                      (if (absolute? threshold1)
                          (list (size->number* threshold1)
                                (percentage->float threshold2))
                          (list (size->number* threshold2)
                                (percentage->float threshold1))))))))))

(define* (warn-about-disk-space #:optional profile
                                #:key
                                (thresholds (%disk-space-warning)))
  "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
available.
THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)."
  (define GiB (expt 2 30))

  (let* ((stats      (statfs (%store-prefix)))
         (block-size (file-system-block-size stats))
         (available  (* block-size (file-system-blocks-available stats)))
         (total      (* block-size (file-system-block-count stats)))
         (relative-threshold-in-bytes (* total (cadr thresholds)))
         (absolute-threshold-in-bytes (car thresholds)))
    (when (< available (min relative-threshold-in-bytes
                            absolute-threshold-in-bytes))
      (warning (G_ "only ~,1f GiB of free space available on ~a~%")
               (/ available 1. GiB) (%store-prefix))
      (display-hint (format #f (G_ "Consider deleting old profile
generations and collecting garbage, along these lines:

@example
guix gc --delete-generations=1m
@end example\n"))))))

;;; scripts.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 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 archive)
  #:use-module (guix config)
  #:use-module (guix utils)
  #:use-module (guix combinators)
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:use-module ((guix serialization)
                #:select (fold-archive restore-file))
  #:use-module (guix store)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module (guix grafts)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix monads)
  #:use-module (guix ui)
  #:use-module (guix pki)
  #:use-module (gcrypt common)
  #:use-module (gcrypt pk-crypto)
  #:use-module (guix scripts)
  #:use-module (guix scripts build)
  #:use-module (gnu packages)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 binary-ports)
  #:use-module (rnrs bytevectors)
  #:export (guix-archive
            options->derivations+files))

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

(define %default-options
  ;; Alist of default option values.
  `((system . ,(%current-system))
    (substitutes? . #t)
    (offload? . #t)
    (graft? . #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 archive [OPTION]... PACKAGE...
Export/import one or more packages from/to the store.\n"))
  (display (G_ "
      --export           export the specified files/packages to stdout"))
  (display (G_ "
  -r, --recursive        combined with '--export', include dependencies"))
  (display (G_ "
      --import           import from the archive passed on stdin"))
  (display (G_ "
      --missing          print the files from stdin that are missing"))
  (display (G_ "
  -x, --extract=DIR      extract the archive on stdin to DIR"))
  (display (G_ "
  -t, --list             list the files in the archive on stdin"))
  (newline)
  (display (G_ "
      --generate-key[=PARAMETERS]
                         generate a key pair with the given parameters"))
  (display (G_ "
      --authorize        authorize imports signed by the public key on stdin"))
  (newline)
  (display (G_ "
  -e, --expression=EXPR  build the package or derivation EXPR evaluates to"))
  (display (G_ "
  -S, --source           build the packages' source derivations"))
  (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_ "
  -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 %key-generation-parameters
  ;; Default key generation parameters.  We prefer Ed25519, but it was
  ;; introduced in libgcrypt 1.6.0.
  (if (version>? (gcrypt-version) "1.6.0")
      "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))"
      "(genkey (rsa (nbits 4:4096)))"))

(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 '("export") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'export #t result)))
         (option '(#\r "recursive") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'export-recursive? #t result)))
         (option '("import") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'import #t result)))
         (option '("missing") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'missing #t result)))
         (option '("extract" #\x) #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'extract arg result)))
         (option '("list" #\t) #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'list #t result)))
         (option '("generate-key") #f #t
                 (lambda (opt name arg result)
                   (catch 'gcry-error
                     (lambda ()
                       ;; XXX: Curve25519 was actually introduced in
                       ;; libgcrypt 1.6.0.
                       (let ((params
                              (string->canonical-sexp
                               (or arg %key-generation-parameters))))
                         (alist-cons 'generate-key params result)))
                     (lambda (key proc err)
                       (leave (G_ "invalid key generation parameters: ~a: ~a~%")
                              (error-source err)
                              (error-string err))))))
         (option '("authorize") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'authorize #t result)))

         (option '(#\S "source") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'source? #t result)))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg
                               (alist-delete 'system result eq?))))
         (option '("target") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'target arg
                               (alist-delete 'target result eq?))))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression 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)))

         %standard-build-options))

(define (derivation-from-expression store str package-derivation
                                    system source?)
  "Read/eval STR and return the corresponding derivation path for SYSTEM.
When SOURCE? is true and STR evaluates to a package, return the derivation of
the package source; otherwise, use PACKAGE-DERIVATION to compute the
derivation of a package."
  (match (read/eval str)
    ((? package? p)
     (if source?
         (let ((source (package-source p)))
           (if source
               (package-source-derivation store source)
               (leave (G_ "package `~a' has no source~%")
                      (package-name p))))
         (package-derivation store p system)))
    ((? procedure? proc)
     (run-with-store store
       (mbegin %store-monad
         (set-guile-for-build (default-guile))
         (proc)) #:system system))))

(define (options->derivations+files store opts)
  "Given OPTS, the result of 'args-fold', return a list of derivations to
build and a list of store files to transfer."
  (define package->derivation
    (match (assoc-ref opts 'target)
      (#f package-derivation)
      (triplet
       (cut package-cross-derivation <> <> triplet <>))))

  (define src? (assoc-ref opts 'source?))
  (define sys  (assoc-ref opts 'system))

  (fold2 (lambda (arg derivations files)
           (match arg
             (('expression . str)
              (let ((drv (derivation-from-expression store str
                                                     package->derivation
                                                     sys src?)))
                (values (cons drv derivations)
                        (cons (derivation->output-path drv) files))))
             (('argument . (? store-path? file))
              (values derivations (cons file files)))
             (('argument . (? string? spec))
              (let-values (((p output)
                            (specification->package+output spec)))
                (if src?
                    (let* ((s   (package-source p))
                           (drv (package-source-derivation store s)))
                      (values (cons drv derivations)
                              (cons (derivation->output-path drv)
                                    files)))
                    (let ((drv (package->derivation store p sys)))
                      (values (cons drv derivations)
                              (cons (derivation->output-path drv output)
                                    files))))))
             (_
              (values derivations files))))
         '()
         '()
         opts))

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

(define (export-from-store store opts)
  "Export the packages or derivations specified in OPTS from STORE.  Write the
resulting archive to the standard output port."
  (let-values (((drv files)
                (options->derivations+files store opts)))
    (if (build-derivations store drv)
        (export-paths store files (current-output-port)
                      #:recursive? (assoc-ref opts 'export-recursive?))
        (leave (G_ "unable to export the given packages~%")))))

(define (generate-key-pair parameters)
  "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the
right place."
  (when (or (file-exists? %public-key-file)
            (file-exists? %private-key-file))
    (leave (G_ "key pair exists under '~a'; remove it first~%")
           (dirname %public-key-file)))

  (format (current-error-port)
          (G_ "Please wait while gathering entropy to generate the key pair;
this may take time...~%"))

  (let* ((pair   (catch 'gcry-error
                   (lambda ()
                     (generate-key parameters))
                   (lambda (key proc err)
                     (leave (G_ "key generation failed: ~a: ~a~%")
                            (error-source err)
                            (error-string err)))))
         (public (find-sexp-token pair 'public-key))
         (secret (find-sexp-token pair 'private-key)))
    ;; Create the following files as #o400.
    (umask #o266)

    (mkdir-p (dirname %public-key-file))
    (with-atomic-file-output %public-key-file
      (lambda (port)
        (display (canonical-sexp->string public) port)))
    (with-atomic-file-output %private-key-file
      (lambda (port)
        (display (canonical-sexp->string secret) port)))

    ;; Make the public key readable by everyone.
    (chmod %public-key-file #o444)))

(define (authorize-key)
  "Authorize imports signed by the public key passed as an advanced sexp on
the input port."
  (define (read-key)
    (catch 'gcry-error
      (lambda ()
        (string->canonical-sexp (read-string (current-input-port))))
      (lambda (key proc err)
        (leave (G_ "failed to read public key: ~a: ~a~%")
               (error-source err) (error-string err)))))

  (let ((key (read-key))
        (acl (current-acl)))
    (unless (eq? 'public-key (canonical-sexp-nth-data key 0))
      (leave (G_ "s-expression does not denote a public key~%")))

    ;; Add KEY to the ACL and write that.
    (let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
      (mkdir-p (dirname %acl-file))
      (with-atomic-file-output %acl-file
        (cut write-acl acl <>)))))

(define (list-contents port)
  "Read a nar from PORT and print the list of files it contains to the current
output port."
  (define (consume-input port size)
    (let ((bv (make-bytevector 32768)))
      (let loop ((total size))
        (unless (zero? total)
          (let ((n (get-bytevector-n! port bv 0
                                      (min total (bytevector-length bv)))))
            (loop (- total n)))))))

  (fold-archive (lambda (file type content result)
                  (match type
                    ('directory
                     (format #t "D ~a~%" file))
                    ('symlink
                     (format #t "S ~a -> ~a~%" file content))
                    ((or 'regular 'executable)
                     (match content
                       ((input . size)
                        (format #t "~a ~60a ~10h B~%"
                                (if (eq? type 'executable)
                                    "x" "r")
                                file size)
                        (consume-input input size))))))
                #t
                port
                ""))

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

(define-command (guix-archive . args)
  (category plumbing)
  (synopsis "manipulate, export, and import normalized archives (nars)")

  (define (lines port)
    ;; Return lines read from PORT.
    (let loop ((line   (read-line port))
               (result '()))
      (if (eof-object? line)
          (reverse result)
          (loop (read-line port)
                (cons line result)))))

  (with-error-handling
    (let ((opts (parse-command-line args %options (list %default-options))))
      (parameterize ((%graft? (assoc-ref opts 'graft?)))
        (cond ((assoc-ref opts 'generate-key)
               =>
               generate-key-pair)
              ((assoc-ref opts 'authorize)
               (authorize-key))
              (else
               (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)
                                       #:dry-run?
                                       (assoc-ref opts 'dry-run?))
                     (cond ((assoc-ref opts 'export)
                            (export-from-store store opts))
                           ((assoc-ref opts 'import)
                            (import-paths store (current-input-port)))
                           ((assoc-ref opts 'missing)
                            (let* ((files   (lines (current-input-port)))
                                   (missing (remove (cut valid-path? store <>)
                                                    files)))
                              (format #t "~{~a~%~}" missing)))
                           ((assoc-ref opts 'list)
                            (list-contents (current-input-port)))
                           ((assoc-ref opts 'extract)
                            =>
                            (lambda (target)
                              (restore-file (current-input-port) target)))
                           (else
                            (leave
                             (G_ "either '--export' or '--import' \
must be specified~%")))))))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 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 authenticate)
  #:use-module (guix scripts)
  #:use-module (guix base16)
  #:use-module (gcrypt pk-crypto)
  #:use-module (guix pki)
  #:use-module (guix ui)
  #:use-module (guix diagnostics)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-71)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (guix-authenticate))

;;; Commentary:
;;;
;;; This program is used internally by the daemon to sign exported archive
;;; (the 'export-paths' RPC), and to authenticate imported archives (the
;;; 'import-paths' RPC.)
;;;
;;; Code:

(define read-canonical-sexp
  ;; Read a gcrypt sexp from a port and return it.
  (compose string->canonical-sexp read-string))

(define (load-key-pair key-file)
  "Load the key pair whose secret key lives at KEY-FILE.  Return a pair of
canonical sexps representing those keys."
  (catch 'system-error
    (lambda ()
      (let* ((secret-key (call-with-input-file key-file read-canonical-sexp))
             (public-key (call-with-input-file
                             (string-append (string-drop-right key-file 4)
                                            ".pub")
                           read-canonical-sexp)))
        (cons public-key secret-key)))
    (lambda args
      (let ((errno (system-error-errno args)))
        (raise
         (formatted-message
          (G_ "failed to load key pair at '~a': ~a~%")
          key-file (strerror errno)))))))

(define (sign-with-key public-key secret-key sha256)
  "Sign the hash SHA256 (a bytevector) with SECRET-KEY (a canonical sexp), and
return the signature as a canonical sexp that includes SHA256, PUBLIC-KEY, and
the actual signature."
  (let ((data (bytevector->hash-data sha256
                                     #:key-type (key-type public-key))))
    (signature-sexp data secret-key public-key)))

(define (validate-signature signature acl)
  "Validate SIGNATURE, a canonical sexp.  Check whether its public key is
authorized in ACL, verify the signature, and return the signed data (a
bytevector) upon success."
  (let* ((subject (signature-subject signature))
         (data    (signature-signed-data signature)))
    (if (and data subject)
        (if (authorized-key? subject acl)
            (if (valid-signature? signature)
                (hash-data->bytevector data)      ; success
                (raise
                 (formatted-message (G_ "invalid signature: ~a")
                                    (canonical-sexp->string signature))))
            (raise
             (formatted-message (G_ "unauthorized public key: ~a")
                                (canonical-sexp->string subject))))
        (raise
         (formatted-message (G_ "corrupt signature data: ~a")
                            (canonical-sexp->string signature))))))

(define (read-command port)
  "Read a command from PORT and return the command and arguments as a list of
strings.  Return the empty list when the end-of-file is reached.

Commands are newline-terminated and must look something like this:

  COMMAND 3:abc 5:abcde 1:x

where COMMAND is an alphanumeric sequence and the remainder is the command
arguments.  Each argument is written as its length (in characters), followed
by colon, followed by the given number of characters."
  (define (consume-whitespace port)
    (let ((chr (lookahead-u8 port)))
      (when (eqv? chr (char->integer #\space))
        (get-u8 port)
        (consume-whitespace port))))

  (match (read-delimited " \t\n\r" port)
    ((? eof-object?)
     '())
    (command
     (let loop ((result (list command)))
       (consume-whitespace port)
       (let ((next (lookahead-u8 port)))
         (cond ((eqv? next (char->integer #\newline))
                (get-u8 port)
                (reverse result))
               ((eof-object? next)
                (reverse result))
               (else
                (let* ((len (string->number (read-delimited ":" port)))
                       (str (utf8->string
                             (get-bytevector-n port len))))
                  (loop (cons str result))))))))))

(define-syntax define-enumerate-type              ;TODO: factorize
  (syntax-rules ()
    ((_ name->int (name id) ...)
     (define-syntax name->int
       (syntax-rules (name ...)
         ((_ name) id) ...)))))

;; Codes used when reply to requests.
(define-enumerate-type reply-code
  (success 0)
  (command-not-found 404)
  (command-failed 500))

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

(define-command (guix-authenticate . args)
  (category internal)
  (synopsis "sign or verify signatures on normalized archives (nars)")

  (define (send-reply code str)
    ;; Send CODE and STR as a reply to our client.
    (let ((bv (string->utf8 str)))
      (format #t "~a ~a:" code (bytevector-length bv))
      (put-bytevector (current-output-port) bv)
      (force-output (current-output-port))))

  (define (call-with-reply thunk)
    ;; Send a reply for the result of THUNK or for any exception raised during
    ;; its execution.
    (guard (c ((formatted-message? c)
               (send-reply (reply-code command-failed)
                           (apply format #f
                                  (G_ (formatted-message-string c))
                                  (formatted-message-arguments c)))))
      (send-reply (reply-code success) (thunk))))

  (define-syntax-rule (with-reply exp ...)
    (call-with-reply (lambda () exp ...)))

  ;; Signature sexps written to stdout may contain binary data, so force
  ;; ISO-8859-1 encoding so that things are not mangled.  See
  ;; <http://bugs.gnu.org/17312> for details.
  (set-port-encoding! (current-output-port) "ISO-8859-1")
  (set-port-conversion-strategy! (current-output-port) 'error)

  ;; Same goes for input ports.
  (with-fluids ((%default-port-encoding "ISO-8859-1")
                (%default-port-conversion-strategy 'error))
    (match args
      (("--help")
       (display (G_ "Usage: guix authenticate OPTION...
Sign data or verify signatures.  This tool is meant to be used internally by
'guix-daemon'.\n")))
      (("--version")
       (show-version-and-exit "guix authenticate"))
      (()
       (let ((acl (current-acl)))
         (let loop ((key-pairs vlist-null))
           ;; Read a request on standard input and reply.
           (match (read-command (current-input-port))
             (("sign" signing-key (= base16-string->bytevector hash))
              (let* ((key-pairs keys
                                (match (vhash-assoc signing-key key-pairs)
                                  ((_ . keys)
                                   (values key-pairs keys))
                                  (#f
                                   (let ((keys (load-key-pair signing-key)))
                                     (values (vhash-cons signing-key keys
                                                         key-pairs)
                                             keys))))))
                (with-reply (canonical-sexp->string
                             (match keys
                               ((public . secret)
                                (sign-with-key public secret hash)))))
                (loop key-pairs)))
             (("verify" signature)
              (with-reply (bytevector->base16-string
                           (validate-signature
                            (string->canonical-sexp signature)
                            acl)))
              (loop key-pairs))
             (()
              (exit 0))
             (commands
              (warning (G_ "~s: invalid command; ignoring~%") commands)
              (send-reply (reply-code command-not-found)
                          "invalid command")
              (loop key-pairs))))))
      (_
       (leave (G_ "wrong arguments~%"))))))

;;; authenticate.scm ends here