code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 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 serialization)
  #:use-module (guix combinators)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 binary-ports)
  #:use-module ((ice-9 rdelim) #:prefix rdelim:)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (system foreign)
  #:export (write-int read-int
            write-long-long read-long-long
            write-padding
            write-bytevector write-string
            read-string read-latin1-string read-maybe-utf8-string
            write-string-list read-string-list
            write-string-pairs
            write-store-path read-store-path
            write-store-path-list read-store-path-list
            (dump . dump-port*)

            &nar-error
            nar-error?
            nar-error-port
            nar-error-file

            &nar-read-error
            nar-read-error?
            nar-read-error-token

            write-file
            write-file-tree
            fold-archive
            restore-file))

;;; Comment:
;;;
;;; Serialization procedures used by the RPCs and the Nar format.  This module
;;; is for internal consumption.
;;;
;;; Code:

;; Similar to serialize.cc in Nix.

(define-condition-type &nar-error &error      ; XXX: inherit from &store-error ?
  nar-error?
  (file  nar-error-file)                       ; file we were restoring, or #f
  (port  nar-error-port))                      ; port from which we read

(define currently-restored-file
  ;; Name of the file being restored.  Used internally for error reporting.
  (make-parameter #f))

(define (get-bytevector-n* port count)
  (let ((bv (get-bytevector-n port count)))
    (when (or (eof-object? bv)
              (< (bytevector-length bv) count))
      (raise (condition (&nar-error
                         (file (currently-restored-file))
                         (port port)))))
    bv))

(define (sub-bytevector bv len)
  "Return a bytevector that aliases the first LEN bytes of BV."
  (define max (bytevector-length bv))
  (cond ((= len max) bv)
        ((< len max)
         ;; Yes, this is safe because the result of each conversion procedure
         ;; has its life cycle synchronized with that of its argument.
         (pointer->bytevector (bytevector->pointer bv) len))
        (else
         (error "sub-bytevector called to get a super bytevector"))))

(define (write-int n p)
  (let ((b (make-bytevector 8 0)))
    (bytevector-u32-set! b 0 n (endianness little))
    (put-bytevector p b)))

(define (read-int p)
  (let ((b (get-bytevector-n* p 8)))
    (bytevector-u32-ref b 0 (endianness little))))

(define (write-long-long n p)
  (let ((b (make-bytevector 8 0)))
    (bytevector-u64-set! b 0 n (endianness little))
    (put-bytevector p b)))

(define (read-long-long p)
  (let ((b (get-bytevector-n* p 8)))
    (bytevector-u64-ref b 0 (endianness little))))

(define write-padding
  (let ((zero (make-bytevector 8 0)))
    (lambda (n p)
      (let ((m (modulo n 8)))
        (or (zero? m)
            (put-bytevector p zero 0 (- 8 m)))))))

(define* (write-bytevector s p
                           #:optional (l (bytevector-length s)))
  (let* ((m (modulo l 8))
         (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
    (bytevector-u32-set! b 0 l (endianness little))
    (bytevector-copy! s 0 b 8 l)
    (put-bytevector p b)))

(define (write-string s p)
  (write-bytevector (string->utf8 s) p))

(define (read-byte-string p)
  (let* ((len (read-int p))
         (m   (modulo len 8))
         (pad (if (zero? m) 0 (- 8 m)))
         (bv  (get-bytevector-n* p (+ len pad))))
    (sub-bytevector bv len)))

(define (read-string p)
  (utf8->string (read-byte-string p)))

(define (read-latin1-string p)
  "Read an ISO-8859-1 string from P."
  ;; Note: do not use 'get-string-n' to work around Guile bug
  ;; <http://bugs.gnu.org/19621>.  See <http://bugs.gnu.org/19610> for
  ;; a discussion.
  (let ((bv (read-byte-string p)))
    ;; XXX: Rewrite using (ice-9 iconv).
    (list->string (map integer->char (bytevector->u8-list bv)))))

(define (read-maybe-utf8-string p)
  "Read a serialized string from port P.  Attempt to decode it as UTF-8 and
substitute invalid byte sequences with question marks.  This is a
\"permissive\" UTF-8 decoder."
  ;; XXX: We rely on the port's decoding mechanism to do permissive decoding
  ;; and substitute invalid byte sequences with question marks, but this is
  ;; not very efficient.  Eventually Guile may provide a lightweight
  ;; permissive UTF-8 decoder.
  (let* ((bv   (read-byte-string p))
         (port (open-bytevector-input-port bv)))
    (set-port-encoding! port "UTF-8")
    (set-port-conversion-strategy! port 'substitute)
    (rdelim:read-string port)))

(define (write-string-list l p)
  (write-int (length l) p)
  (for-each (cut write-string <> p) l))

(define (write-string-pairs l p)
  (write-int (length l) p)
  (for-each (match-lambda
             ((first . second)
              (write-string first p)
              (write-string second p)))
            l))

(define (read-string-list p)
  (let ((len (read-int p)))
    (unfold (cut >= <> len)
            (lambda (i)
              (read-string p))
            1+
            0)))

(define (write-store-path f p)
  (write-string f p))                             ; TODO: assert path

(define (read-store-path p)
  (read-string p))                                ; TODO: assert path

(define write-store-path-list write-string-list)
(define read-store-path-list read-string-list)

(define-condition-type &nar-read-error &nar-error
  nar-read-error?
  (token nar-read-error-token))                 ; faulty token, or #f

(define (dump in out size)
  "Copy SIZE bytes from IN to OUT."
  (define buf-size 65536)
  (define buf (make-bytevector buf-size))

  (let loop ((left size))
    (if (<= left 0)
        0
        (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
          (if (eof-object? read)
              left
              (begin
                (put-bytevector out buf 0 read)
                (loop (- left read))))))))

(define (write-contents-from-port input output size)
  "Write SIZE bytes from port INPUT to port OUTPUT."
  (write-string "contents" output)
  (write-long-long size output)
  ;; Use 'sendfile' when both OUTPUT and INPUT are file ports.
  (if (and (file-port? output) (file-port? input))
      (sendfile output input size 0)
      (dump input output size))
  (write-padding size output))

(define (read-file-type port)
  "Read the file type tag from PORT, and return either 'regular or
'executable."
  (match (read-string port)
    ("contents"
     'regular)
    ("executable"
     (match (list (read-string port) (read-string port))
       (("" "contents") 'executable)
       (x (raise
           (condition (&message
                       (message "unexpected executable file marker"))
                      (&nar-read-error (port port)
                                       (file #f)
                                       (token x)))))))
    (x
     (raise
      (condition (&message (message "unsupported nar file type"))
                 (&nar-read-error (port port) (file #f) (token x)))))))

(define %archive-version-1
  ;; Magic cookie for Nix archives.
  "nix-archive-1")

(define* (write-file file port
                     #:key (select? (const #t)))
  "Write the contents of FILE to PORT in Nar format, recursing into
sub-directories of FILE as needed.  For each directory entry, call (SELECT?
FILE STAT), where FILE is the entry's absolute file name and STAT is the
result of 'lstat'; exclude entries for which SELECT? does not return true."
  (write-file-tree file port
                   #:file-type+size
                   (lambda (file)
                     (let* ((stat (lstat file))
                            (size (stat:size stat)))
                       (case (stat:type stat)
                         ((directory)
                          (values 'directory size))
                         ((regular)
                          (values (if (zero? (logand (stat:mode stat)
                                                     #o100))
                                      'regular
                                      'executable)
                                  size))
                         (else
                          (values (stat:type stat) size))))) ;bah!
                   #:file-port (cut open-file <> "r0b")
                   #:symlink-target readlink

                   #:directory-entries
                   (lambda (directory)
                     ;; 'scandir' defaults to 'string-locale<?' to sort files,
                     ;; but this happens to be case-insensitive (at least in
                     ;; 'en_US' locale on libc 2.18.)  Conversely, we want
                     ;; files to be sorted in a case-sensitive fashion.
                     (define basenames
                       (scandir directory (negate (cut member <> '("." "..")))
                                string<?))

                     (filter-map (lambda (base)
                                   (let ((file (string-append directory
                                                              "/" base)))
                                     (and (select? file (lstat file))
                                          base)))
                                 basenames))

                   ;; The 'scandir' call above gives us filtered and sorted
                   ;; entries, so no post-processing is needed.
                   #:postprocess-entries identity))

(define (filter/sort-directory-entries lst)
  "Remove dot and dot-dot entries from LST, and sort it in lexicographical
order."
  (delete-duplicates
   (sort (remove (cute member <> '("." "..")) lst)
         string<?)
   string=?))

(define* (write-file-tree file port
                          #:key
                          file-type+size
                          file-port
                          symlink-target
                          directory-entries
                          (postprocess-entries filter/sort-directory-entries))
  "Write the contents of FILE to PORT in Nar format, recursing into
sub-directories of FILE as needed.

This procedure does not make any file-system I/O calls.  Instead, it calls the
user-provided FILE-TYPE+SIZE, FILE-PORT, SYMLINK-TARGET, and DIRECTORY-ENTRIES
procedures, which roughly correspond to 'lstat', 'readlink', and 'scandir'.
POSTPROCESS-ENTRIES ensures that directory entries are valid; leave it as-is
unless you know that DIRECTORY-ENTRIES provide filtered and sorted entries, in
which case you can use 'identity'."
  (define p port)

  (write-string %archive-version-1 p)

  (let dump ((f file))
    (define-values (type size)
      (file-type+size f))

    (write-string "(" p)
    (case type
      ((regular executable)
       (write-string "type" p)
       (write-string "regular" p)
       (when (eq? 'executable type)
         (write-string "executable" p)
         (write-string "" p))
       (let ((input (file-port f)))
         (dynamic-wind
           (const #t)
           (lambda ()
             (write-contents-from-port input p size))
           (lambda ()
             (close-port input)))))
      ((directory)
       (write-string "type" p)
       (write-string "directory" p)
       (let ((entries (postprocess-entries (directory-entries f))))
         (for-each (lambda (e)
                     (let* ((f (string-append f "/" e)))
                       (write-string "entry" p)
                       (write-string "(" p)
                       (write-string "name" p)
                       (write-string e p)
                       (write-string "node" p)
                       (dump f)
                       (write-string ")" p)))
                   entries)))
      ((symlink)
       (write-string "type" p)
       (write-string "symlink" p)
       (write-string "target" p)
       (write-string (symlink-target f) p))
      (else
       (raise (condition (&message (message "unsupported file type"))
                         (&nar-error (file f) (port port))))))
    (write-string ")" p)))

(define port-conversion-strategy
  (fluid->parameter %default-port-conversion-strategy))

(define (fold-archive proc seed port file)
  "Read a file (possibly a directory structure) in Nar format from PORT.  Call
PROC on each file or directory read from PORT using:

  (PROC FILE TYPE CONTENTS RESULT)

using SEED as the first RESULT.  TYPE is a symbol like 'regular, and CONTENTS
depends on TYPE."
  (parameterize ((currently-restored-file file)

                 ;; Error out if we can convert file names to the current
                 ;; locale.  (XXX: We'd prefer UTF-8 encoding for file names
                 ;; regardless of the locale, but that's what Guile gives us
                 ;; so far.)
                 (port-conversion-strategy 'error))
    (let ((signature (read-string port)))
      (unless (equal? signature %archive-version-1)
        (raise
         (condition (&message (message "invalid nar signature"))
                    (&nar-read-error (port port)
                                     (token signature)
                                     (file #f))))))

    (let read ((file file)
               (result seed))
      (define (read-eof-marker)
        (match (read-string port)
          (")" #t)
          (x (raise
              (condition
               (&message (message "invalid nar end-of-file marker"))
               (&nar-read-error (port port) (file file) (token x)))))))

      (currently-restored-file file)

      (match (list (read-string port) (read-string port) (read-string port))
        (("(" "type" "regular")
         (let* ((type   (read-file-type port))
                (size   (read-long-long port))

                ;; The caller must read exactly SIZE bytes from PORT.
                (result (proc file type `(,port . ,size) result)))
           (let ((m (modulo size 8)))
             (unless (zero? m)
               (get-bytevector-n* port (- 8 m))))
           (read-eof-marker)
           result))
        (("(" "type" "symlink")
         (match (list (read-string port) (read-string port))
           (("target" target)
            (let ((result (proc file 'symlink target result)))
              (read-eof-marker)
              result))
           (x (raise
               (condition
                (&message (message "invalid symlink tokens"))
                (&nar-read-error (port port) (file file) (token x)))))))
        (("(" "type" "directory")
         (let ((dir file))
           (let loop ((prefix (read-string port))
                      (result (proc file 'directory #f result)))
             (match prefix
               ("entry"
                (match (list (read-string port)
                             (read-string port) (read-string port)
                             (read-string port))
                  (("(" "name" file "node")
                   (let ((result (read (string-append dir "/" file) result)))
                     (match (read-string port)
                       (")" #f)
                       (x
                        (raise
                         (condition
                          (&message
                           (message "unexpected directory entry termination"))
                          (&nar-read-error (port port)
                                           (file file)
                                           (token x))))))
                     (loop (read-string port) result)))))
               (")" result)                       ;done with DIR
               (x
                (raise
                 (condition
                  (&message (message "unexpected directory inter-entry marker"))
                  (&nar-read-error (port port) (file file) (token x)))))))))
        (x
         (raise
          (condition
           (&message (message "unsupported nar entry type"))
           (&nar-read-error (port port) (file file) (token x)))))))))

(define (restore-file port file)
  "Read a file (possibly a directory structure) in Nar format from PORT.
Restore it as FILE."
  (fold-archive (lambda (file type content result)
                  (match type
                    ('directory
                     (mkdir file))
                    ('symlink
                     (symlink content file))
                    ((or 'regular 'executable)
                     (match content
                       ((input . size)
                        (call-with-output-file file
                          (lambda (output)
                            (dump input output size)
                            (when (eq? type 'executable)
                              (chmod output #o755)))))))))
                #t
                port
                file))

;;; Local Variables:
;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
;;; End:

;;; serialization.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 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 sets)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:export (set
            setq
            set?
            set-insert
            set-union
            set-contains?
            set->list
            list->set
            list->setq))

;;; Commentary:
;;;
;;; A simple (simplistic?) implementation of unordered persistent sets based
;;; on vhashes that seems to be good enough so far.
;;;
;;; Another option would be to use "bounded balance trees" (Adams 1992) as
;;; implemented by Ian Price in 'pfds', which has faster union etc. but needs
;;; an order on the objects of the set.
;;;
;;; Code:

(define-record-type <set>
  (%make-set vhash insert ref)
  set?
  (vhash  set-vhash)
  (insert set-insert-proc)
  (ref    set-ref))

(define %insert
  (cut vhash-cons <> #t <>))
(define %insertq
  (cut vhash-consq <> #t <>))

(define (set . args)
  "Return a set containing the ARGS, compared as per 'equal?'."
  (list->set args))

(define (setq . args)
  "Return a set containing the ARGS, compared as per 'eq?'."
  (list->setq args))

(define (list->set lst)
  "Return a set with the elements taken from LST.  Elements of the set will be
compared with 'equal?'."
  (%make-set (fold %insert vlist-null lst)
             %insert
             vhash-assoc))

(define (list->setq lst)
  "Return a set with the elements taken from LST.  Elements of the set will be
compared with 'eq?'."
  (%make-set (fold %insertq vlist-null lst)
             %insertq
             vhash-assq))

(define-inlinable (set-contains? set value)
  "Return #t if VALUE is a member of SET."
  (->bool ((set-ref set) value (set-vhash set))))

(define (set-insert value set)
  "Insert VALUE into SET."
  (if (set-contains? set value)
      set
      (let ((vhash ((set-insert-proc set) value (set-vhash set))))
        (%make-set vhash (set-insert-proc set) (set-ref set)))))

(define-inlinable (set-size set)
  "Return the number of elements in SET."
  (vlist-length (set-vhash set)))

(define (set-union set1 set2)
  "Return the union of SET1 and SET2.  Warning: this is linear in the number
of elements of the smallest."
  (unless (eq? (set-insert-proc set1) (set-insert-proc set2))
    (error "set-union: incompatible sets"))

  (let* ((small (if (> (set-size set1) (set-size set2))
                    set2 set1))
         (large (if (eq? small set1) set2 set1)))
    (vlist-fold (match-lambda*
                 (((item . _) result)
                  (set-insert item result)))
                large
                (set-vhash small))))

(define (set->list set)
  "Return the list of elements of SET."
  (map (match-lambda
        ((key . _) key))
       (vlist->list (set-vhash set))))

;;; sets.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 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 ssh)
  #:use-module (guix store)
  #:use-module (guix inferior)
  #:use-module (guix i18n)
  #:use-module ((guix diagnostics)
                #:select (info &fix-hint formatted-message))
  #:use-module ((guix progress)
                #:select (progress-bar
                          erase-current-line current-terminal-columns))
  #:use-module (gcrypt pk-crypto)
  #:use-module (ssh session)
  #:use-module (ssh auth)
  #:use-module (ssh key)
  #:use-module (ssh channel)
  #:use-module (ssh popen)
  #:use-module (ssh session)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 vlist)
  #:export (open-ssh-session
            authenticate-server*

            remote-inferior
            remote-daemon-channel
            connect-to-remote-daemon
            remote-system
            remote-authorize-signing-key
            send-files
            retrieve-files
            retrieve-files*
            remote-store-host

            report-guile-error
            report-module-error))

;;; Commentary:
;;;
;;; This module provides tools to support communication with remote stores
;;; over SSH, using Guile-SSH.
;;;
;;; Code:

(define %compression
  "zlib@openssh.com,zlib")

(define (host-key->type+key host-key)
  "Destructure HOST-KEY, an OpenSSH host key string, and return two values:
its key type as a symbol, and the actual base64-encoded string."
  (define (type->symbol type)
    (and (string-prefix? "ssh-" type)
         (string->symbol (string-drop type 4))))

  (match (string-tokenize host-key)
    ((type key x)
     (values (type->symbol type) key))
    ((type key)
     (values (type->symbol type) key))))

(define (authenticate-server* session key)
  "Make sure the server for SESSION has the given KEY, where KEY is a string
such as \"ssh-ed25519 AAAAC3Nz… root@example.org\".  Raise an exception if the
actual key does not match."
  (let-values (((server)   (get-server-public-key session))
               ((type key) (host-key->type+key key)))
    (unless (and (or (not (get-key-type server))
                     (eq? (get-key-type server) type))
                 (string=? (public-key->string server) key))
      ;; Key mismatch: something's wrong.  XXX: It could be that the server
      ;; provided its Ed25519 key when we where expecting its RSA key.  XXX:
      ;; Guile-SSH 0.10.1 doesn't know about ed25519 keys and 'get-key-type'
      ;; returns #f in that case.
      (raise (formatted-message (G_ "server at '~a' returned host key \
'~a' of type '~a' instead of '~a' of type '~a'~%")
                                (session-get session 'host)
                                (public-key->string server)
                                (get-key-type server)
                                key type)))))

(define* (open-ssh-session host #:key user port identity
                           host-key
                           (compression %compression)
                           (timeout 3600))
  "Open an SSH session for HOST and return it.  IDENTITY specifies the file
name of a private key to use for authenticating with the host.  When USER,
PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
specifies; otherwise use them.

When HOST-KEY is true, it must be a string like \"ssh-ed25519 AAAAC3Nz…
root@example.org\"; the server is authenticated and an error is raised if its
host key is different from HOST-KEY.

Install TIMEOUT as the maximum time in seconds after which a read or write
operation on a channel of the returned session is considered as failing.

Throw an error on failure."
  (let ((session (make-session #:user user
                               #:identity identity
                               #:host host
                               #:port port
                               #:timeout 10       ;seconds
                               ;; #:log-verbosity 'protocol

                               ;; Prevent libssh from reading
                               ;; ~/.ssh/known_hosts when the caller provides
                               ;; a HOST-KEY to match against.
                               #:knownhosts (and host-key "/dev/null")

                               ;; We need lightweight compression when
                               ;; exchanging full archives.
                               #:compression compression
                               #:compression-level 3

                               ;; Speed up RPCs by creating sockets with
                               ;; TCP_NODELAY.
                               #:nodelay #t)))

    ;; Honor ~/.ssh/config.
    (session-parse-config! session)

    (match (connect! session)
      ('ok
       (if host-key
           ;; Make sure the server's key is what we expect.
           (authenticate-server* session host-key)

           ;; Authenticate against ~/.ssh/known_hosts.
           (match (authenticate-server session)
             ('ok #f)
             (reason
              (raise (formatted-message (G_ "failed to authenticate \
server at '~a': ~a")
                                        (session-get session 'host)
                                        reason)))))

       ;; Use public key authentication, via the SSH agent if it's available.
       (match (userauth-public-key/auto! session)
         ('success
          (session-set! session 'timeout timeout)
          session)
         (x
          (match (userauth-gssapi! session)
            ('success
             (session-set! session 'timeout timeout)
             session)
            (x
             (disconnect! session)
             (raise (condition
                     (&message
                      (message (format #f (G_ "SSH authentication failed for '~a': ~a~%")
                                       host (get-error session)))))))))))
      (x
       ;; Connection failed or timeout expired.
       (raise (formatted-message (G_ "SSH connection to '~a' failed: ~a~%")
                                 host (get-error session)))))))

(define* (remote-inferior session #:optional become-command)
  "Return a remote inferior for the given SESSION.  If BECOME-COMMAND is
given, use that to invoke the remote Guile REPL."
  (let* ((repl-command (append (or become-command '())
                               '("guix" "repl" "-t" "machine")))
         (pipe (apply open-remote-pipe* session OPEN_BOTH 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))))
    (port->inferior pipe)))

(define* (inferior-remote-eval exp session #:optional become-command)
  "Evaluate EXP in a new inferior running in SESSION, and close the inferior
right away.  If BECOME-COMMAND is given, use that to invoke the remote Guile
REPL."
  (let ((inferior (remote-inferior session become-command)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (inferior-eval exp inferior))
      (lambda ()
        ;; Close INFERIOR right away to prevent finalization from happening in
        ;; another thread at the wrong time (see
        ;; <https://bugs.gnu.org/26976>.)
        (close-inferior inferior)))))

(define* (remote-daemon-channel session
                                #:optional
                                (socket-name
                                 "/var/guix/daemon-socket/socket"))
  "Return an input/output port (an SSH channel) to the daemon at SESSION."
  (define redirect
    ;; Code run in SESSION to redirect the remote process' stdin/stdout to the
    ;; daemon's socket, à la socat.  The SSH protocol supports forwarding to
    ;; Unix-domain sockets but libssh doesn't have an API for that, hence this
    ;; hack.
    `(begin
       (use-modules (ice-9 match) (rnrs io ports)
                    (rnrs bytevectors))

       (let ((sock    (socket AF_UNIX SOCK_STREAM 0))
             (stdin   (current-input-port))
             (stdout  (current-output-port))
             (select* (lambda (read write except)
                        ;; This is a workaround for
                        ;; <https://bugs.gnu.org/30365> in Guile < 2.2.4:
                        ;; since 'select' sometimes returns non-empty sets for
                        ;; no good reason, call 'select' a second time with a
                        ;; zero timeout to filter out incorrect replies.
                        (match (select read write except)
                          ((read write except)
                           (select read write except 0))))))
         (setvbuf stdout 'none)

         ;; Use buffered ports so that 'get-bytevector-some' returns up to the
         ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
         (setvbuf stdin 'block 65536)
         (setvbuf sock 'block 65536)

         (connect sock AF_UNIX ,socket-name)

         (let loop ()
           (match (select* (list stdin sock) '() '())
             ((reads () ())
              (when (memq stdin reads)
                (match (get-bytevector-some stdin)
                  ((? eof-object?)
                   (primitive-exit 0))
                  (bv
                   (put-bytevector sock bv)
                   (force-output sock))))
              (when (memq sock reads)
                (match (get-bytevector-some sock)
                  ((? eof-object?)
                   (primitive-exit 0))
                  (bv
                   (put-bytevector stdout bv))))
              (loop))
             (_
              (primitive-exit 1)))))))

  (open-remote-pipe* session OPEN_BOTH
                     ;; Sort-of shell-quote REDIRECT.
                     "guile" "-c"
                     (object->string
                      (object->string redirect))))

(define* (connect-to-remote-daemon session
                                   #:optional
                                   (socket-name
                                    "/var/guix/daemon-socket/socket"))
  "Connect to the remote build daemon listening on SOCKET-NAME over SESSION,
an SSH session.  Return a <store-connection> object."
  (open-connection #:port (remote-daemon-channel session socket-name)))

(define (store-import-channel session)
  "Return an output port to which archives to be exported to SESSION's store
can be written."
  ;; Using the 'import-paths' RPC on a remote store would be slow because it
  ;; makes a round trip every time 32 KiB have been transferred.  This
  ;; procedure instead opens a separate channel to use the remote
  ;; 'import-paths' procedure, which consumes all the data in a single round
  ;; trip.  This optimizes the successful case at the expense of error
  ;; conditions: errors can only be reported once all the input has been
  ;; consumed.
  (define import
    `(begin
       (eval-when (load expand eval)
         (unless (resolve-module '(guix) #:ensure #f)
           (write `(module-error))
           (exit 7)))

       (use-modules (guix) (srfi srfi-34)
                    (rnrs io ports) (rnrs bytevectors))

       (define (consume-input port)
         (let ((bv (make-bytevector 32768)))
           (let loop ()
             (let ((n (get-bytevector-n! port bv 0
                                         (bytevector-length bv))))
               (unless (eof-object? n)
                 (loop))))))

       ;; Upon completion, write an sexp that denotes the status.
       (write
        (catch #t
          (lambda ()
            (guard (c ((nix-protocol-error? c)
                       ;; Consume all the input since the only time we can
                       ;; report the error is after everything has been
                       ;; consumed.
                       (consume-input (current-input-port))
                       (list 'protocol-error (nix-protocol-error-message c))))
              (with-store store
                (write '(importing))              ;we're ready
                (force-output)

                (setvbuf (current-input-port) 'none)
                (import-paths store (current-input-port))
                '(success))))
          (lambda args
            (cons 'error args))))))

  (open-remote-pipe session
                    (string-join
                     `("guile" "-c"
                       ,(object->string (object->string import))))
                    OPEN_BOTH))

(define* (store-export-channel session files
                               #:key recursive?)
  "Return an input port from which an export of FILES from SESSION's store can
be read.  When RECURSIVE? is true, the closure of FILES is exported."
  ;; Same as above: this is more efficient than calling 'export-paths' on a
  ;; remote store.
  (define export
    `(begin
       (eval-when (load expand eval)
         (unless (resolve-module '(guix) #:ensure #f)
           (write `(module-error))
           (exit 7)))

       (use-modules (guix) (srfi srfi-1)
                    (srfi srfi-26) (srfi srfi-34))

       (guard (c ((nix-connection-error? c)
                  (write `(connection-error ,(nix-connection-error-file c)
                                            ,(nix-connection-error-code c))))
                 ((nix-protocol-error? c)
                  (write `(protocol-error ,(nix-protocol-error-status c)
                                          ,(nix-protocol-error-message c))))
                 (else
                  (write `(exception))))
         (with-store store
           (let* ((files ',files)
                  (invalid (remove (cut valid-path? store <>)
                                   files)))
             (unless (null? invalid)
               (write `(invalid-items ,invalid))
               (exit 1))

             ;; TODO: When RECURSIVE? is true, we could send the list of store
             ;; items in the closure so that the other end can filter out
             ;; those it already has.

             (write '(exporting))                 ;we're ready
             (force-output)

             (setvbuf (current-output-port) 'none)
             (export-paths store files (current-output-port)
                           #:recursive? ,recursive?))))))

  (open-remote-input-pipe session
                          (string-join
                           `("guile" "-c"
                             ,(object->string
                               (object->string export))))))

(define (remote-system session)
  "Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of
the machine on the other end of SESSION."
  (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system))
                        session))

(define* (remote-authorize-signing-key key session #:optional become-command)
  "Send KEY, a canonical sexp containing a public key, over SESSION and add it
to the system ACL file if it has not yet been authorized."
  (inferior-remote-eval
   `(begin
      (use-modules (guix build utils)
                   (guix pki)
                   (guix utils)
                   (gcrypt pk-crypto)
                   (srfi srfi-26))

      (define acl (current-acl))
      (define key (string->canonical-sexp ,(canonical-sexp->string key)))

      (unless (authorized-key? key)
        (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 <>)))))
   session
   become-command))

(define (prepare-to-send store host log-port items)
  "Notify the user that we're about to send ITEMS to HOST.  Return three
values allowing 'notify-send-progress' to track the state of this transfer."
  (let* ((count (length items))
         (sizes (fold (lambda (item result)
                        (vhash-cons item
                                    (path-info-nar-size
                                     (query-path-info store item))
                                    result))
                      vlist-null
                      items))
         (total  (vlist-fold (lambda (pair result)
                               (match pair
                                 ((_ . size) (+ size result))))
                             0
                             sizes)))
    (info (N_ "sending ~a store item (~h MiB) to '~a'...~%"
              "sending ~a store items (~h MiB) to '~a'...~%" count)
          count
          (inexact->exact (round (/ total (expt 2. 20))))
          host)

    (values log-port sizes total 0)))

(define (notify-transfer-progress item port sizes total sent)
  "Notify the user that we've already transferred SENT bytes out of TOTAL.
Use SIZES to determine the size of ITEM, which is about to be sent."
  (define (display-bar %)
    (erase-current-line port)
    (format port "~3@a% ~a"
            (inexact->exact (round (* 100. (/ sent total))))
            (progress-bar % (- (max (current-terminal-columns) 5) 5)))
    (force-output port))

  (unless (zero? total)
    (let ((% (* 100. (/ sent total))))
      (match (vhash-assoc item sizes)
        (#f
         (display-bar %)
         (values port sizes total sent))
        ((_ . size)
         (display-bar %)
         (values port sizes total (+ sent size)))))))

(define (notify-transfer-completion port . args)
  "Notify the user that the transfer has completed."
  (apply notify-transfer-progress "" port args) ;display the 100% progress bar
  (erase-current-line port)
  (force-output port))

(define* (send-files local files remote
                     #:key
                     recursive?
                     (log-port (current-error-port)))
  "Send the subset of FILES from LOCAL (a local store) that's missing to
REMOTE, a remote store.  When RECURSIVE? is true, send the closure of FILES.
Return the list of store items actually sent."
  ;; Compute the subset of FILES missing on SESSION and send them.
  (let* ((files   (if recursive? (requisites local files) files))
         (session (channel-get-session (store-connection-socket remote)))
         (missing (inferior-remote-eval
                   `(begin
                      (use-modules (guix)
                                   (srfi srfi-1) (srfi srfi-26))

                      (with-store store
                        (remove (cut valid-path? store <>)
                                ',files)))
                   session))
         (port    (store-import-channel session))
         (host    (session-get session 'host)))
    ;; Make sure everything alright on the remote side.
    (match (read port)
      (('importing)
       #t)
      (sexp
       (handle-import/export-channel-error sexp remote)))

    ;; Send MISSING in topological order.
    (let ((tty? (isatty? log-port)))
      (export-paths local missing port
                    #:start (cut prepare-to-send local host log-port <>)
                    #:progress (if tty? notify-transfer-progress (const #f))
                    #:finish (if tty? notify-transfer-completion (const #f))))

    ;; Tell the remote process that we're done.  (In theory the end-of-archive
    ;; mark of 'export-paths' would be enough, but in practice it's not.)
    (channel-send-eof port)

    ;; Wait for completion of the remote process and read the status sexp from
    ;; PORT.  Wait for the exit status only when 'read' completed; otherwise,
    ;; we might wait forever if the other end is stuck.
    (let* ((result (false-if-exception (read port)))
           (status (and result
                        (zero? (channel-get-exit-status port)))))
      (close-port port)
      (match result
        (('success . _)
         missing)
        (('protocol-error message)
         (raise (condition
                 (&store-protocol-error (message message) (status 42)))))
        (('error key args ...)
         (raise (condition
                 (&store-protocol-error
                  (message (call-with-output-string
                             (lambda (port)
                               (print-exception port #f key args))))
                  (status 43)))))
        (_
         (raise (condition
                 (&store-protocol-error
                  (message "unknown error while sending files over SSH")
                  (status 44)))))))))

(define (remote-store-session remote)
  "Return the SSH channel beneath REMOTE, a remote store as returned by
'connect-to-remote-daemon', or #f."
  (channel-get-session (store-connection-socket remote)))

(define (remote-store-host remote)
  "Return the name of the host REMOTE is connected to, where REMOTE is a
remote store as returned by 'connect-to-remote-daemon'."
  (match (remote-store-session remote)
    (#f #f)
    ((? session? session)
     (session-get session 'host))))

(define* (file-retrieval-port files remote
                              #:key recursive?)
  "Return an input port from which to retrieve FILES (a list of store items)
from REMOTE, along with the number of items to retrieve (lower than or equal
to the length of FILES.)"
  (values (store-export-channel (remote-store-session remote) files
                                #:recursive? recursive?)
          (length files)))            ;XXX: inaccurate when RECURSIVE? is true

(define-syntax raise-error
  (syntax-rules (=>)
    ((_ fmt args ... (=> hint-fmt hint-args ...))
     (raise (condition
             (&message
              (message (format #f fmt args ...)))
             (&fix-hint
              (hint (format #f hint-fmt hint-args ...))))))
    ((_ fmt args ...)
     (raise (condition
             (&message
              (message (format #f fmt args ...))))))))

(define (handle-import/export-channel-error sexp remote)
  "Report an error corresponding to SEXP, the EOF object or an sexp read from
REMOTE."
  (match sexp
    ((? eof-object?)
     (report-guile-error (remote-store-host remote)))
    (('module-error . _)
     (report-module-error (remote-store-host remote)))
    (('connection-error file code . _)
     (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a")
                  file (remote-store-host remote) (strerror code)))
    (('invalid-items items . _)
     (raise-error (N_ "no such item on remote host '~A':~{ ~a~}"
                      "no such items on remote host '~A':~{ ~a~}"
                      (length items))
                  (remote-store-host remote) items))
    (('protocol-error status message . _)
     (raise-error (G_ "protocol error on remote host '~A': ~a")
                  (remote-store-host remote) message))
    (_
     (raise-error (G_ "failed to retrieve store items from '~a'")
                  (remote-store-host remote)))))

(define* (retrieve-files* files remote
                          #:key recursive? (log-port (current-error-port))
                          (import (const #f)))
  "Pass IMPORT an input port from which to read the sequence of FILES coming
from REMOTE.  When RECURSIVE? is true, retrieve the closure of FILES."
  (let-values (((port count)
                (file-retrieval-port files remote
                                     #:recursive? recursive?)))
    (match (read port)                            ;read the initial status
      (('exporting)
       (format #t (N_ "retrieving ~a store item from '~a'...~%"
                      "retrieving ~a store items from '~a'...~%" count)
               count (remote-store-host remote))

       (dynamic-wind
         (const #t)
         (lambda ()
           (import port))
         (lambda ()
           (close-port port))))
      (sexp
       (handle-import/export-channel-error sexp remote)))))

(define* (retrieve-files local files remote
                         #:key recursive? (log-port (current-error-port)))
  "Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on
LOCAL.  When RECURSIVE? is true, retrieve the closure of FILES."
  (retrieve-files* (remove (cut valid-path? local <>) files)
                   remote
                   #:recursive? recursive?
                   #:log-port log-port
                   #:import (lambda (port)
                              (import-paths local port))))

;;;
;;; Error reporting.
;;;

(define (report-guile-error host)
  (raise-error (G_ "failed to start Guile on remote host '~A'") host
               (=> (G_ "Make sure @command{guile} can be found in
@code{$PATH} on the remote host.  Run @command{ssh ~A guile --version} to
check.")
                   host)))

(define (report-module-error host)
  "Report an error about missing Guix modules on HOST."
  ;; TRANSLATORS: Leave "Guile" untranslated.
  (raise-error (G_ "Guile modules not found on remote host '~A'") host
               (=> (G_ "Make sure @code{GUILE_LOAD_PATH} includes Guix'
own module directory.  Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to
check.")
                   host)))

(define (report-inferior-exception exception host)
  "Report EXCEPTION, an &inferior-exception that occurred on HOST."
  (raise-error (G_ "exception occurred on remote host '~A': ~s")
               host (inferior-exception-arguments exception)))

;;; ssh.scm ends here


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

(define-module (guix status)
  #:use-module (guix records)
  #:use-module (guix i18n)
  #:use-module (guix colors)
  #:use-module (guix progress)
  #:autoload   (guix build syscalls) (terminal-columns)
  #:use-module ((guix build download)
                #:select (nar-uri-abbreviation))
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix memoization)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 binary-ports)
  #:autoload   (ice-9 rdelim) (read-string)
  #:use-module (rnrs bytevectors)
  #:use-module ((system foreign)
                #:select (bytevector->pointer pointer->bytevector))
  #:export (build-event-output-port
            compute-status

            build-status
            build-status?
            build-status-building
            build-status-downloading
            build-status-builds-completed
            build-status-downloads-completed

            build?
            build
            build-derivation
            build-system
            build-log-file
            build-phase
            build-completion

            download?
            download
            download-item
            download-uri
            download-size
            download-start
            download-end
            download-transferred

            build-status-updater
            print-build-event
            print-build-event/quiet
            print-build-status

            with-status-report
            with-status-verbosity))

;;; Commentary:
;;;
;;; This module provides facilities to track the status of ongoing builds and
;;; downloads in a given session, as well as tools to report about the current
;;; status to user interfaces.  It does so by analyzing the output of
;;; 'current-build-output-port'.  The build status is maintained in a
;;; <build-status> record.
;;;
;;; Code:

;;;
;;; Build status tracking.
;;;

;; Builds and substitutions performed by the daemon.
(define-record-type* <build-status> build-status make-build-status
  build-status?
  (building     build-status-building             ;list of <build>
                (default '()))
  (downloading  build-status-downloading          ;list of <download>
                (default '()))
  (builds-completed build-status-builds-completed ;list of <build>
                    (default '()))
  (downloads-completed build-status-downloads-completed ;list of <download>
                       (default '())))

;; On-going or completed build.
(define-immutable-record-type <build>
  (%build derivation id system log-file phase completion)
  build?
  (derivation  build-derivation)                ;string (.drv file name)
  (id          build-id)                        ;#f | integer
  (system      build-system)                    ;string
  (log-file    build-log-file)                  ;#f | string
  (phase       build-phase                      ;#f | symbol
               set-build-phase)
  (completion  build-completion                 ;#f | integer (percentage)
               set-build-completion))

(define* (build derivation system #:key id log-file phase completion)
  "Return a new build."
  (%build derivation id system log-file phase completion))

;; On-going or completed downloads.  Downloads can be stem from substitutes
;; and from "builtin:download" fixed-output derivations.
(define-record-type <download>
  (%download item uri size start end transferred)
  download?
  (item         download-item)            ;store item
  (uri          download-uri)             ;string | #f
  (size         download-size)            ;integer | #f
  (start        download-start)           ;<time>
  (end          download-end)             ;#f | <time>
  (transferred  download-transferred))    ;integer

(define* (download item uri
                   #:key size
                   (start (current-time time-monotonic)) end
                   (transferred 0))
  "Return a new download."
  (%download item uri size start end transferred))

(define (matching-build drv)
  "Return a predicate that matches builds of DRV."
  (lambda (build)
    (string=? drv (build-derivation build))))

(define (matching-download item)
  "Return a predicate that matches downloads of ITEM."
  (lambda (download)
    (string=? item (download-item download))))

(define %phase-start-rx
  ;; Match the "starting phase" message emitted by 'gnu-build-system'.
  (make-regexp "^starting phase [`']([^']+)'"))

(define %percentage-line-rx
  ;; Things like CMake write lines like "[ 10%] gcc -c …".  This regexp
  ;; matches them.
  (make-regexp "^[[:space:]]*\\[ *([0-9]+)%\\]"))

(define %fraction-line-rx
  ;; The 'compiled-modules' derivations and Ninja produce reports like
  ;; "[ 1/32]" at the beginning of each line, while GHC prints "[ 6 of 45]".
  ;; This regexp matches these.
  (make-regexp "^[[:space:]]*\\[ *([0-9]+) *(/|of) *([0-9]+)\\]"))

(define (update-build status id line)
  "Update STATUS based on LINE, a build output line for ID that might contain
a completion indication."
  (define (find-build)
    (find (lambda (build)
            (and (build-id build)
                 (= (build-id build) id)))
          (build-status-building status)))

  (define (update %)
    (let ((build (find-build)))
      (build-status
       (inherit status)
       (building (cons (set-build-completion build %)
                       (delq build (build-status-building status)))))))

  (cond ((string-any #\nul line)
         ;; Don't try to match a regexp here.
         status)
        ((regexp-exec %percentage-line-rx line)
         =>
         (lambda (match)
           (let ((% (string->number (match:substring match 1))))
             (update %))))
        ((regexp-exec %fraction-line-rx line)
         =>
         (lambda (match)
           (let ((done  (string->number (match:substring match 1)))
                 (total (string->number (match:substring match 3))))
             (update (* 100. (/ done total))))))
        ((regexp-exec %phase-start-rx line)
         =>
         (lambda (match)
           (let ((phase (match:substring match 1))
                 (build (find-build)))
             (if build
                 (build-status
                  (inherit status)
                  (building
                   (cons (set-build-phase (set-build-completion build #f)
                                          (string->symbol phase))
                         (delq build (build-status-building status)))))
                 status))))
        (else
         status)))

(define* (compute-status event status
                         #:key
                         (current-time current-time)
                         (derivation-path->output-path
                          derivation-path->output-path))
  "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...),
compute a new status based on STATUS."
  (match event
    (('build-started drv "-" system log-file . rest)
     (let ((build (build drv system
                         #:id (match rest
                                ((pid . _) (string->number pid))
                                (_ #f))
                         #:log-file (if (string-null? log-file)
                                        #f
                                        log-file))))
       (build-status
        (inherit status)
        (building (cons build (build-status-building status))))))
    (((or 'build-succeeded 'build-failed) drv _ ...)
     (let ((build (find (matching-build drv)
                        (build-status-building status))))
       ;; If BUILD is #f, this may be because DRV corresponds to a
       ;; fixed-output derivation that is listed as a download.
       (if build
           (build-status
            (inherit status)
            (building (delq build (build-status-building status)))
            (builds-completed
             (cons build (build-status-builds-completed status))))
           status)))

    ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because
    ;; they're not as informative as 'download-started' and
    ;; 'download-succeeded'.

    (('download-started item uri (= string->number size))
     ;; This is presumably a fixed-output derivation so move it from
     ;; 'building' to 'downloading'.  XXX: This doesn't work in 'check' mode
     ;; because ITEM is different from DRV's output.
     (build-status
      (inherit status)
      (building (remove (lambda (build)
                          (let ((drv (build-derivation build)))
                            (equal? (false-if-exception
                                     (derivation-path->output-path drv))
                                    item)))
                        (build-status-building status)))
      (downloading (cons (download item uri #:size size
                                   #:start (current-time time-monotonic))
                         (build-status-downloading status)))))
    (('download-succeeded item uri (= string->number size))
     (let ((current (find (matching-download item)
                          (build-status-downloading status))))
       (build-status
        (inherit status)
        (downloading (delq current (build-status-downloading status)))
        (downloads-completed
         (cons (download item uri
                         #:size size
                         #:start (download-start current)
                         #:transferred size
                         #:end (current-time time-monotonic))
               (build-status-downloads-completed status))))))
    (('substituter-succeeded item _ ...)
     (match (find (matching-download item)
                  (build-status-downloading status))
       (#f
        ;; Presumably we already got a 'download-succeeded' event for ITEM,
        ;; everything is fine.
        status)
       (current
        ;; Maybe the build process didn't emit a 'download-succeeded' event
        ;; for ITEM, so remove CURRENT from the queue now.
        (build-status
         (inherit status)
         (downloading (delq current (build-status-downloading status)))
         (downloads-completed
          (cons (download item (download-uri current)
                          #:size (download-size current)
                          #:start (download-start current)
                          #:transferred (download-size current)
                          #:end (current-time time-monotonic))
                (build-status-downloads-completed status)))))))
    (('download-progress item uri
                         (= string->number size)
                         (= string->number transferred))
     (let ((downloads (remove (matching-download item)
                              (build-status-downloading status)))
           (current   (find (matching-download item)
                            (build-status-downloading status))))
       (build-status
        (inherit status)
        (downloading (cons (download item uri
                                     #:size size
                                     #:start
                                     (or (and current
                                              (download-start current))
                                         (current-time time-monotonic))
                                     #:transferred transferred)
                           downloads)))))
    (('build-log (? integer? pid) line)
     (update-build status pid line))
    (_
     status)))

(define (simultaneous-jobs status)
  "Return the number of on-going builds and downloads for STATUS."
  (+ (length (build-status-building status))
     (length (build-status-downloading status))))

;;;
;;; Rendering.
;;;

(define (extended-build-trace-supported?)
  "Return true if the currently used store is known to support \"extended
build traces\" such as \"@ download-progress\" traces."
  ;; Support for extended build traces was added in protocol version #x162.
  (and (current-store-protocol-version)
       (>= (current-store-protocol-version) #x162)))

(define (multiplexed-output-supported?)
  "Return true if the daemon supports \"multiplexed output\"--i.e., \"@
build-log\" traces."
  (and (current-store-protocol-version)
       (>= (current-store-protocol-version) #x163)))

(define spin!
  (let ((steps (circular-list "\\" "|" "/" "-")))
    (lambda (phase port)
      "Display a spinner on PORT.  If PHASE is true, display it as a hint of
the current build phase."
      (when (isatty?* port)
        (match steps
          ((first . rest)
           (set! steps rest)
           (display "\r\x1b[K" port)
           (display first port)
           (when phase
             (display " " port)
             ;; TRANSLATORS: The word "phase" here denotes a "build phase";
             ;; "~a" is a placeholder for the untranslated name of the current
             ;; build phase--e.g., 'configure' or 'build'.
             (format port (G_ "'~a' phase") phase))
           (force-output port)))))))

(define colorize-log-line
  ;; Take a string and return a possibly colorized string according to the
  ;; rules below.
  (color-rules
   ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
    GREEN    BOLD GREEN          RESET  GREEN  BLUE)
   ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
    RED BLUE RED BLUE RED BLUE)
   ("^(.*)(error|fail|failed|\\<FAIL|FAILED)([[:blank:]]*)(:)(.*)"
    RESET  RED                           BOLD         BOLD BOLD)
   ("^(.*)(warning)([[:blank:]]*)(:)(.*)"
    RESET  MAGENTA   BOLD        BOLD BOLD)))

(define (hook-message hook-type)
  "Return a human-readable string for the profile hook type HOOK-TYPE."
  (match hook-type
    ('info-dir
     (G_ "building directory of Info manuals..."))
    ('ghc-package-cache
     (G_ "building GHC package cache..."))
    ('ca-certificate-bundle
     (G_ "building CA certificate bundle..."))
    ('glib-schemas
     (G_ "generating GLib schema cache..."))
    ('gtk-icon-themes
     (G_ "creating GTK+ icon theme cache..."))
    ('gtk-im-modules
     (G_ "building cache files for GTK+ input methods..."))
    ('xdg-desktop-database
     (G_ "building XDG desktop file cache..."))
    ('xdg-mime-database
     (G_ "building XDG MIME database..."))
    ('fonts-dir
     (G_ "building fonts directory..."))
    ('texlive-configuration
     (G_ "building TeX Live configuration..."))
    ('manual-database
     (G_ "building database for manual pages..."))
    ('package-cache                    ;package cache generated by 'guix pull'
     (G_ "building package cache..."))
    (_ #f)))

(define* (print-build-event event old-status status
                            #:optional (port (current-error-port))
                            #:key
                            (colorize? (color-output? port))
                            (print-log? #t))
  "Print information about EVENT and STATUS to PORT.  When COLORIZE? is true,
produce colorful output.  When PRINT-LOG? is true, display the build log in
addition to build events."
  (define info
    (if colorize?
        (cute colorize-string <> (color BOLD))
        identity))

  (define success
    (if colorize?
        (cute colorize-string <> (color GREEN BOLD))
        identity))

  (define failure
    (if colorize?
        (cute colorize-string <> (color RED BOLD))
        identity))

  (define (report-build-progress phase %)
    (let ((% (min (max % 0) 100)))                ;sanitize
      (erase-current-line port)
      (let* ((prefix (format #f "~3d% ~@['~a' ~]"
                            (inexact->exact (round %))
                            (case phase
                              ((build) #f)        ;not useful to display it
                              (else phase))))
             (length (string-length prefix)))
        (display prefix port)
        (display (progress-bar % (- (current-terminal-columns) length))
                 port))
      (force-output port)))

  (define print-log-line
    (if print-log?
        (if colorize?
            (lambda (id line)
              (display (colorize-log-line line) port))
            (lambda (id line)
              (display line port)))
        (lambda (id line)
          (match (build-status-building status)
            ((build)                              ;single job
             (match (build-completion build)
               ((? number? %)
                (report-build-progress (build-phase build) %))
               (_
                (spin! (build-phase build) port))))
            (_
             (spin! #f port))))))

  (define erase-current-line*
    (if (and (not print-log?) (isatty?* port))
        (lambda ()
          (erase-current-line port)
          (force-output port))
        (const #t)))

  (match event
    (('build-started drv . _)
     (erase-current-line*)
     (let ((properties (derivation-properties
                        (read-derivation-from-file drv))))
       (match (assq-ref properties 'type)
         ('graft
           (let ((count (match (assq-ref properties 'graft)
                          (#f  0)
                          (lst (or (assq-ref lst 'count) 0)))))
             (format port (info (N_ "applying ~a graft for ~a ..."
                                    "applying ~a grafts for ~a ..."
                                    count))
                     count drv)))
         ('profile
          (let ((count (match (assq-ref properties 'profile)
                         (#f  0)
                         (lst (or (assq-ref lst 'count) 0)))))
            (format port (info (N_ "building profile with ~a package..."
                                   "building profile with ~a packages..."
                                   count))
                    count)))
         ('profile-hook
          (let ((hook-type (assq-ref properties 'hook)))
            (or (and=> (hook-message hook-type)
                       (lambda (msg)
                         (format port (info msg))))
                (format port (info (G_ "running profile hook of type '~a'..."))
                        hook-type))))
         (_
          (format port (info (G_ "building ~a...")) drv))))
     (newline port))
    (('build-succeeded drv . _)
     (erase-current-line*)                      ;erase spinner or progress bar
     (when (or print-log? (not (extended-build-trace-supported?)))
       (format port (success (G_ "successfully built ~a")) drv)
       (newline port))
     (match (build-status-building status)
       (() #t)
       (ongoing                                   ;when max-jobs > 1
        (format port
                (N_ "The following build is still in progress:~%~{  ~a~%~}~%"
                    "The following builds are still in progress:~%~{  ~a~%~}~%"
                    (length ongoing))
                (map build-derivation ongoing)))))
    (('build-failed drv . _)
     (erase-current-line*)                      ;erase spinner or progress bar
     (format port (failure (G_ "build of ~a failed")) drv)
     (newline port)
     (match (derivation-log-file drv)
       (#f
        (format port (failure (G_ "Could not find build log for '~a'."))
                drv))
       (log
        (format port (info (G_ "View build log at '~a'.")) log)))
     (newline port))
    (('substituter-started item _ ...)
     (erase-current-line*)
     (when (or print-log? (not (extended-build-trace-supported?)))
       (format port (info (G_ "substituting ~a...")) item)
       (newline port)))
    (('download-started item uri _ ...)
     (erase-current-line*)
     (format port (info (G_ "downloading from ~a ...")) uri)
     (newline port))
    (('download-progress item uri
                         (= string->number size)
                         (= string->number transferred))
     ;; Print a progress bar, but only if there's only one on-going
     ;; job--otherwise the output would be intermingled.
     (when (= 1 (simultaneous-jobs status))
       (match (find (matching-download item)
                    (build-status-downloading status))
         (#f #f)                                  ;shouldn't happen!
         (download
          ;; XXX: It would be nice to memoize the abbreviation.
          (let ((uri (if (string-contains uri "/nar/")
                         (nar-uri-abbreviation uri)
                         (basename uri))))
            (display-download-progress uri size
                                       #:start-time
                                       (download-start download)
                                       #:transferred transferred))))))
    (('substituter-succeeded item _ ...)
     ;; If there are no jobs running, we already reported download completion
     ;; so there's nothing left to do.
     (unless (and (zero? (simultaneous-jobs status))
                  (extended-build-trace-supported?))
       (format port (success (G_ "substitution of ~a complete")) item)
       (newline port)))
    (('substituter-failed item _ ...)
     (format port (failure (G_ "substitution of ~a failed")) item)
     (newline port))
    (('hash-mismatch item algo expected actual _ ...)
     ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for
     ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm.
     (format port (failure (G_ "~a hash mismatch for ~a:")) algo item)
     (newline port)
     (format port (info (G_ "\
  expected hash: ~a
  actual hash:   ~a~%"))
             expected actual))
    (('build-remote drv host _ ...)
     (format port (info (G_ "offloading build of ~a to '~a'")) drv host)
     (newline port))
    (('build-log pid line)
     (if (multiplexed-output-supported?)
         (if (not pid)
             (begin
               ;; LINE comes from the daemon, not from builders.  Let it
               ;; through.
               (display line port)
               (force-output port))
             (print-log-line pid line))
         (cond ((string-prefix? "substitute: " line)
                ;; The daemon prefixes early messages coming with 'guix
                ;; substitute' with "substitute:".  These are useful ("updating
                ;; substitutes from URL"), so let them through.
                (display line port)
                (force-output port))
               ((string-prefix? "waiting for locks" line)
                ;; This is when a derivation is already being built and we're just
                ;; waiting for the build to complete.
                (display (info (string-trim-right line)) port)
                (newline))
               (else
                (print-log-line pid line)))))
    (_
     event)))

(define* (print-build-event/quiet event old-status status
                                  #:optional
                                  (port (current-error-port))
                                  #:key
                                  (colorize? (color-output? port)))
  (print-build-event event old-status status port
                     #:colorize? colorize?
                     #:print-log? #f))

(define* (build-status-updater #:optional (on-change (const #t)))
  "Return a procedure that can be passed to 'build-event-output-port'.  That
procedure computes the new build status upon each event and calls ON-CHANGE:

  (ON-CHANGE event status new-status)

ON-CHANGE can display the build status, build events, etc."
  (lambda (event status)
    (let ((new (compute-status event status)))
      (on-change event status new)
      new)))

;;;
;;; Build port.
;;;

(define (maybe-utf8->string bv)
  "Attempt to decode BV as UTF-8 string and return it.  Gracefully handle the
case where BV does not contain only valid UTF-8."
  (catch 'decoding-error
    (lambda ()
      (utf8->string bv))
    (lambda _
      ;; This is the sledgehammer but it's the only safe way we have to
      ;; properly handle this.  It's expensive but it's rarely needed.
      (let ((port (open-bytevector-input-port bv)))
        (set-port-encoding! port "UTF-8")
        (set-port-conversion-strategy! port 'substitute)
        (let ((str (read-string port)))
          (close-port port)
          str)))))

(define (bytevector-index bv number offset count)
  "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes;
return the offset where NUMBER first occurs or #f if it could not be found."
  (let loop ((offset offset)
             (count count))
    (cond ((zero? count) #f)
          ((= (bytevector-u8-ref bv offset) number) offset)
          (else (loop (+ 1 offset) (- count 1))))))

(define (split-lines str)
  "Split STR into lines in a way that preserves newline characters."
  (let loop ((str str)
             (result '()))
    (if (string-null? str)
        (reverse result)
        (match (string-index str #\newline)
          (#f
           (loop "" (cons str result)))
          (index
           (loop (string-drop str (+ index 1))
                 (cons (string-take str (+ index 1)) result)))))))

(define* (build-event-output-port proc #:optional (seed (build-status)))
  "Return an output port for use as 'current-build-output-port' that calls
PROC with its current state value, initialized with SEED, on every build
event.  Build events passed to PROC are tuples corresponding to the \"build
traces\" produced by the daemon:

  (build-started \"/gnu/store/...-foo.drv\" ...)
  (substituter-started \"/gnu/store/...-foo\" ...)

and so on.

The second return value is a thunk to retrieve the current state."
  (define %fragments
    ;; Line fragments received so far.
    '())

  (define %state
    ;; Current state for PROC.
    seed)

  ;; When true, this represents the current state while reading a
  ;; "@ build-log" trace: the current builder PID, the previously-read
  ;; bytevectors, and the number of bytes that remain to be read.
  (define %build-output-pid #f)
  (define %build-output '())
  (define %build-output-left #f)

  (define (process-line line)
    (cond ((string-prefix? "@ " line)
           ;; Note: Drop the trailing \n, and use 'string-split' to preserve
           ;; spaces (the log file part of 'build-started' events can be the
           ;; empty string.)
           (match (string-split (string-drop (string-drop-right line 1) 2)
                                #\space)
             (("build-log" (= string->number pid) (= string->number len))
              (set! %build-output-pid pid)
              (set! %build-output '())
              (set! %build-output-left len))
             (((= string->symbol event-name) args ...)
              (set! %state
                (proc (cons event-name args)
                      %state)))))
          (else
           (set! %state (proc (list 'build-log #f line)
                              %state)))))

  (define (process-build-output pid output)
    ;; Transform OUTPUT in 'build-log' events or download events as generated
    ;; by extended build traces.
    (define (line->event line)
      (match (and (string-prefix? "@ " line)
                  (string-tokenize (string-drop line 2)))
        ((type . args)
         (if (or (string-prefix? "download-" type)
                 (string=? "build-remote" type))
             (cons (string->symbol type) args)
             `(build-log ,pid ,line)))
        (_
         `(build-log ,pid ,line))))

    (let* ((lines  (split-lines output))
           (events (map line->event lines)))
      (set! %state (fold proc %state events))))

  (define (bytevector-range bv offset count)
    (let ((ptr (bytevector->pointer bv offset)))
      (pointer->bytevector ptr count)))

  (define (write! bv offset count)
    (if %build-output-pid
        (let ((keep (min count %build-output-left)))
          (set! %build-output
            (let ((bv* (make-bytevector keep)))
              (bytevector-copy! bv offset bv* 0 keep)
              (cons bv* %build-output)))
          (set! %build-output-left
            (- %build-output-left keep))

          (when (zero? %build-output-left)
            (process-build-output %build-output-pid
                                  (string-concatenate-reverse
                                   (map maybe-utf8->string %build-output))) ;XXX
            (set! %build-output '())
            (set! %build-output-pid #f))
          keep)
        (match (bytevector-index bv (char->integer #\newline)
                                 offset count)
          ((? integer? cr)
           (let* ((tail (maybe-utf8->string
                         (bytevector-range bv offset (- cr -1 offset))))
                  (line (string-concatenate-reverse
                         (cons tail %fragments))))
             (process-line line)
             (set! %fragments '())
             (- cr -1 offset)))
          (#f
           (unless (zero? count)
             (let ((str (maybe-utf8->string
                         (bytevector-range bv offset count))))
               (set! %fragments (cons str %fragments))))
           count))))

  (define port
    (make-custom-binary-output-port "filtering-input-port"
                                    write!
                                    #f #f
                                    #f))

  ;; The build port actually receives Unicode strings.
  (set-port-encoding! port "UTF-8")
  (setvbuf port 'line)
  (values port (lambda () %state)))

(define (call-with-status-report on-event thunk)
  (parameterize ((current-terminal-columns (terminal-columns))
                 (current-build-output-port
                  (build-event-output-port (build-status-updater on-event))))
    (thunk)))

(define-syntax-rule (with-status-report on-event exp ...)
  "Set up build status reporting to the user using the ON-EVENT procedure;
evaluate EXP... in that context."
  (call-with-status-report on-event (lambda () exp ...)))

(define (logger-for-level level)
  "Return the logging procedure that corresponds to LEVEL."
  (cond ((<= level 0) (const #t))
        ((= level 1)  print-build-event/quiet)
        (else         print-build-event)))

(define (call-with-status-verbosity level thunk)
  (call-with-status-report (logger-for-level level) thunk))

(define-syntax-rule (with-status-verbosity level exp ...)
  "Set up build status reporting to the user at the given LEVEL: 0 means
silent, 1 means quiet, 2 means verbose.  Evaluate EXP... in that context."
  (call-with-status-verbosity level (lambda () exp ...)))