code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;; Copyright © 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; 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 store database)
  #:use-module (sqlite3)
  #:use-module (guix config)
  #:use-module (guix serialization)
  #:use-module (guix store deduplication)
  #:use-module (guix base16)
  #:use-module (guix progress)
  #:use-module (guix build syscalls)
  #:use-module ((guix build utils)
                #:select (mkdir-p executable-file?))
  #:use-module (guix build store-copy)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:use-module (system foreign)
  #:export (sql-schema
            %default-database-file
            store-database-file
            call-with-database
            with-database
            path-id
            sqlite-register
            register-items
            %epoch
            reset-timestamps))

;;; Code for working with the store database directly.

(define sql-schema
  ;; Name of the file containing the SQL scheme or #f.
  (make-parameter #f))

(define* (store-database-directory #:key prefix state-directory)
  "Return the store database directory, taking PREFIX and STATE-DIRECTORY into
account when provided."
  ;; Priority for options: first what is given, then environment variables,
  ;; then defaults. %state-directory, %store-directory, and
  ;; %store-database-directory already handle the "environment variables /
  ;; defaults" question, so we only need to choose between what is given and
  ;; those.
  (cond (state-directory
         (string-append state-directory "/db"))
        (prefix
         (string-append prefix %localstatedir "/guix/db"))
        (else
         %store-database-directory)))

(define* (store-database-file #:key prefix state-directory)
  "Return the store database file name, taking PREFIX and STATE-DIRECTORY into
account when provided."
  (string-append (store-database-directory #:prefix prefix
                                           #:state-directory state-directory)
                 "/db.sqlite"))

(define (initialize-database db)
  "Initializing DB, an empty database, by creating all the tables and indexes
as specified by SQL-SCHEMA."
  (define schema
    (or (sql-schema)
        (search-path %load-path "guix/store/schema.sql")))

  (sqlite-exec db (call-with-input-file schema get-string-all)))

(define* (call-with-database file proc #:key (wal-mode? #t))
  "Pass PROC a database record corresponding to FILE.  If FILE doesn't exist,
create it and initialize it as a new database.  Unless WAL-MODE? is set to #f,
set journal_mode=WAL."
  (let ((new? (and (not (file-exists? file))
                   (begin
                     (mkdir-p (dirname file))
                     #t)))
        (db   (sqlite-open file)))
    ;; Using WAL breaks for the Hurd <https://bugs.gnu.org/42151>.
    (when wal-mode?
      ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED
      ;; errors when we have several readers: <https://www.sqlite.org/wal.html>.
      (sqlite-exec db "PRAGMA journal_mode=WAL;"))

    ;; Install a busy handler such that, when the database is locked, sqlite
    ;; retries until 30 seconds have passed, at which point it gives up and
    ;; throws SQLITE_BUSY.
    (sqlite-exec db "PRAGMA busy_timeout = 30000;")

    (dynamic-wind noop
                  (lambda ()
                    (when new?
                      (initialize-database db))
                    (proc db))
                  (lambda ()
                    (sqlite-close db)))))

;; XXX: missing in guile-sqlite3@0.1.2
(define SQLITE_BUSY 5)

(define (call-with-SQLITE_BUSY-retrying thunk)
  "Call THUNK, retrying as long as it exits abnormally due to SQLITE_BUSY
errors."
  (catch 'sqlite-error
    thunk
    (lambda (key who code errmsg)
      (if (= code SQLITE_BUSY)
          (call-with-SQLITE_BUSY-retrying thunk)
          (throw key who code errmsg)))))

(define* (call-with-transaction db proc #:key restartable?)
  "Start a transaction with DB and run PROC.  If PROC exits abnormally, abort
the transaction, otherwise commit the transaction after it finishes.
RESTARTABLE? may be set to a non-#f value when it is safe to run PROC multiple
times.  This may reduce contention for the database somewhat."
  (define (exec sql)
    (with-statement db sql stmt
      (sqlite-fold cons '() stmt)))
  ;; We might use begin immediate here so that if we need to retry, we figure
  ;; that out immediately rather than because some SQLITE_BUSY exception gets
  ;; thrown partway through PROC - in which case the part already executed
  ;; (which may contain side-effects!) might have to be executed again for
  ;; every retry.
  (exec (if restartable? "begin;" "begin immediate;"))
  (catch #t
    (lambda ()
      (let-values ((result (proc)))
        (exec "commit;")
        (apply values result)))
    (lambda args
      ;; The roll back may or may not have occurred automatically when the
      ;; error was generated. If it has occurred, this does nothing but signal
      ;; an error. If it hasn't occurred, this needs to be done.
      (false-if-exception (exec "rollback;"))
      (apply throw args))))

(define* (call-with-savepoint db proc
                              #:optional (savepoint-name "SomeSavepoint"))
  "Call PROC after creating a savepoint named SAVEPOINT-NAME.  If PROC exits
abnormally, rollback to that savepoint.  In all cases, remove the savepoint
prior to returning."
  (define (exec sql)
    (with-statement db sql stmt
      (sqlite-fold cons '() stmt)))

  (dynamic-wind
    (lambda ()
      (exec (string-append "SAVEPOINT " savepoint-name ";")))
    (lambda ()
      (catch #t
        proc
        (lambda args
          (exec (string-append "ROLLBACK TO " savepoint-name ";"))
          (apply throw args))))
    (lambda ()
      (exec (string-append "RELEASE " savepoint-name ";")))))

(define* (call-with-retrying-transaction db proc #:key restartable?)
  (call-with-SQLITE_BUSY-retrying
   (lambda ()
     (call-with-transaction db proc #:restartable? restartable?))))

(define* (call-with-retrying-savepoint db proc
                                       #:optional (savepoint-name
                                                   "SomeSavepoint"))
  (call-with-SQLITE_BUSY-retrying
   (lambda ()
     (call-with-savepoint db proc savepoint-name))))

(define %default-database-file
  ;; Default location of the store database.
  (string-append %store-database-directory "/db.sqlite"))

(define-syntax with-database
  (syntax-rules ()
    "Open DB from FILE and close it when the dynamic extent of EXP... is left.
If FILE doesn't exist, create it and initialize it as a new database.  Pass
#:wal-mode? to call-with-database."
    ((_ file db #:wal-mode? wal-mode? exp ...)
     (call-with-database file (lambda (db) exp ...) #:wal-mode? wal-mode?))
    ((_ file db exp ...)
     (call-with-database file (lambda (db) exp ...)))))

(define (call-with-statement db sql proc)
  (let ((stmt (sqlite-prepare db sql #:cache? #t)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (proc stmt))
      (lambda ()
        (sqlite-finalize stmt)))))

(define-syntax-rule (with-statement db sql stmt exp ...)
  "Run EXP... with STMT bound to a prepared statement corresponding to the sql
string SQL for DB."
  (call-with-statement db sql
                       (lambda (stmt) exp ...)))

(define (last-insert-row-id db)
  ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
  ;; Work around that.
  (with-statement db "SELECT last_insert_rowid();" stmt
    (match (sqlite-fold cons '() stmt)
      ((#(id)) id)
      (_ #f))))

(define path-id-sql
  "SELECT id FROM ValidPaths WHERE path = :path")

(define* (path-id db path)
  "If PATH exists in the 'ValidPaths' table, return its numerical
identifier.  Otherwise, return #f."
  (with-statement db path-id-sql stmt
    (sqlite-bind-arguments stmt #:path path)
    (match (sqlite-fold cons '() stmt)
      ((#(id) . _) id)
      (_ #f))))

(define update-sql
  "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver =
:deriver, narSize = :size WHERE id = :id")

(define insert-sql
  "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
VALUES (:path, :hash, :time, :deriver, :size)")

(define-inlinable (assert-integer proc in-range? key number)
  (unless (integer? number)
    (throw 'wrong-type-arg proc
           "Wrong type argument ~A: ~S" (list key number)
           (list number)))
  (unless (in-range? number)
    (throw 'out-of-range proc
           "Integer ~A out of range: ~S" (list key number)
           (list number))))

(define* (update-or-insert db #:key path deriver hash nar-size time)
  "The classic update-if-exists and insert-if-doesn't feature that sqlite
doesn't exactly have... they've got something close, but it involves deleting
and re-inserting instead of updating, which causes problems with foreign keys,
of course. Returns the row id of the row that was modified or inserted."

  ;; Make sure NAR-SIZE is valid.
  (assert-integer "update-or-insert" positive? #:nar-size nar-size)
  (assert-integer "update-or-insert" (cut >= <> 0) #:time time)

  ;; It's important that querying the path-id and the insert/update operation
  ;; take place in the same transaction, as otherwise some other
  ;; process/thread/fiber could register the same path between when we check
  ;; whether it's already registered and when we register it, resulting in
  ;; duplicate paths (which, due to a 'unique' constraint, would cause an
  ;; exception to be thrown). With the default journaling mode this will
  ;; prevent writes from occurring during that sensitive time, but with WAL
  ;; mode it will instead arrange to return SQLITE_BUSY when a write occurs
  ;; between the start of a read transaction and its upgrading to a write
  ;; transaction (see https://sqlite.org/rescode.html#busy_snapshot).
  ;; Experimentally, it seems this SQLITE_BUSY will ignore a busy_timeout and
  ;; immediately return (makes sense, since waiting won't change anything).

  ;; Note that when that kind of SQLITE_BUSY error is returned, it will keep
  ;; being returned every time we try to upgrade the same outermost
  ;; transaction to a write transaction.  So when retrying, we have to restart
  ;; the *outermost* write transaction.  We can't inherently tell whether
  ;; we're the outermost write transaction, so we leave the retry-handling to
  ;; the caller.
  (call-with-savepoint db
    (lambda ()
      (let ((id (path-id db path)))
        (if id
            (with-statement db update-sql stmt
              (sqlite-bind-arguments stmt #:id id
                                     #:deriver deriver
                                     #:hash hash #:size nar-size #:time time)
              (sqlite-fold cons '() stmt))
            (with-statement db insert-sql stmt
              (sqlite-bind-arguments stmt
                                     #:path path #:deriver deriver
                                     #:hash hash #:size nar-size #:time time)
              (sqlite-fold cons '() stmt)))
        (last-insert-row-id db)))))

(define add-reference-sql
  "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);")

(define (add-references db referrer references)
  "REFERRER is the id of the referring store item, REFERENCES is a list
ids of items referred to."
  (with-statement db add-reference-sql stmt
    (for-each (lambda (reference)
                (sqlite-reset stmt)
                (sqlite-bind-arguments stmt #:referrer referrer
                                       #:reference reference)
                (sqlite-fold cons '() stmt))
              references)))

(define (timestamp)
  "Return a timestamp, either the current time of SOURCE_DATE_EPOCH."
  (match (getenv "SOURCE_DATE_EPOCH")
    (#f
     (current-time time-utc))
    ((= string->number seconds)
     (if seconds
         (make-time time-utc 0 seconds)
         (current-time time-utc)))))

(define* (sqlite-register db #:key path (references '())
                          deriver hash nar-size
                          (time (timestamp)))
  "Registers this stuff in DB.  PATH is the store item to register and
REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv'
that produced PATH, HASH is the base16-encoded Nix sha256 hash of
PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after
being converted to nar form.  TIME is the registration time to be recorded in
the database or #f, meaning \"right now\".

Every store item in REFERENCES must already be registered."
  (let ((id (update-or-insert db #:path path
                              #:deriver deriver
                              #:hash hash
                              #:nar-size nar-size
                              #:time (time-second time))))
    ;; Call 'path-id' on each of REFERENCES.  This ensures we get a
    ;; "non-NULL constraint" failure if one of REFERENCES is unregistered.
    (add-references db id
                    (map (cut path-id db <>) references))))

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

(define* (reset-timestamps file #:key preserve-permissions?)
  "Reset the modification time on FILE and on all the files it contains, if
it's a directory.  Canonicalize file permissions unless PRESERVE-PERMISSIONS?
is true."
  ;; Note: We're resetting to one second after the Epoch like 'guix-daemon'
  ;; has always done.
  (let loop ((file file)
             (type (stat:type (lstat file))))
    (case type
      ((directory)
       (unless preserve-permissions?
         (chmod file #o555))
       (utime file 1 1 0 0)
       (let ((parent file))
         (for-each (match-lambda
                     (("." . _) #f)
                     ((".." . _) #f)
                     ((file . properties)
                      (let ((file (string-append parent "/" file)))
                        (loop file
                              (match (assoc-ref properties 'type)
                                ((or 'unknown #f)
                                 (stat:type (lstat file)))
                                (type type))))))
                   (scandir* parent))))
      ((symlink)
       (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW))
      (else
       (unless preserve-permissions?
         (chmod file (if (executable-file? file) #o555 #o444)))
       (utime file 1 1 0 0)))))

(define %epoch
  ;; When it all began.
  (make-time time-utc 0 1))

(define* (register-items db items
                         #:key prefix
                         (registration-time (timestamp))
                         (log-port (current-error-port)))
  "Register all of ITEMS, a list of <store-info> records as returned by
'read-reference-graph', in DB.  ITEMS must be in topological order (with
leaves first.)  REGISTRATION-TIME must be the registration time to be recorded
in the database; #f means \"now\".  Write a progress report to LOG-PORT.  All
of ITEMS must be protected from GC and locked during execution of this,
typically by adding them as temp-roots."
  (define store-dir
    (if prefix
        (string-append prefix %storedir)
        %store-directory))

  (define (register db item)
    (define to-register
      (if prefix
          (string-append %storedir "/" (basename (store-info-item item)))
          ;; note: we assume here that if path is, for example,
          ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an
          ;; environment variable has been used to change the store directory
          ;; to /foo/bar/gnu/store, since otherwise real-path would end up
          ;; being /gnu/store/thing.txt, which is probably not the right file
          ;; in this case.
          (store-info-item item)))

    (define real-file-name
      (string-append store-dir "/" (basename (store-info-item item))))

    ;; When TO-REGISTER is already registered, skip it.  This makes a
    ;; significant differences when 'register-closures' is called
    ;; consecutively for overlapping closures such as 'system' and 'bootcfg'.
    (unless (path-id db to-register)
      (let-values (((hash nar-size) (nar-sha256 real-file-name)))
        (call-with-retrying-transaction db
          (lambda ()
            (sqlite-register db #:path to-register
                             #:references (store-info-references item)
                             #:deriver (store-info-deriver item)
                             #:hash (string-append
                                     "sha256:"
                                     (bytevector->base16-string hash))
                             #:nar-size nar-size
                             #:time registration-time))))))

  (let* ((prefix   (format #f "registering ~a items" (length items)))
         (progress (progress-reporter/bar (length items)
                                          prefix log-port)))
    (call-with-progress-reporter progress
      (lambda (report)
        (for-each (lambda (item)
                    (register db item)
                    (report))
                  items)))))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;; 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/>.

;;; This houses stuff we do to files when they arrive at the store - resetting
;;; timestamps, deduplicating, etc.

(define-module (guix store deduplication)
  #:use-module (gcrypt hash)
  #:use-module (guix build utils)
  #:use-module (guix build syscalls)
  #:use-module (guix base32)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (guix serialization)
  #:export (nar-sha256
            deduplicate
            dump-file/deduplicate
            copy-file/deduplicate))

(define (nar-sha256 file)
  "Gives the sha256 hash of a file and the size of the file in nar form."
  (let-values (((port get-hash) (open-sha256-port)))
    (write-file file port)
    (force-output port)
    (let ((hash (get-hash))
          (size (port-position port)))
      (close-port port)
      (values hash size))))

(define (tempname-in directory)
  "Gives an unused temporary name under DIRECTORY. Not guaranteed to still be
unused by the time you create anything with that name, but a good shot."
  (let ((const-part (string-append directory "/.tmp-link-"
                                   (number->string (getpid)))))
    (let try ((guess-part
               (number->string (random most-positive-fixnum) 16)))
      (if (file-exists? (string-append const-part "-" guess-part))
          (try (number->string (random most-positive-fixnum) 16))
          (string-append const-part "-" guess-part)))))

(define* (get-temp-link target #:optional (link-prefix (dirname target)))
  "Like mkstemp!, but instead of creating a new file and giving you the name,
it creates a new hardlink to TARGET and gives you the name. Since
cross-file-system hardlinks don't work, the temp link must be created on the
same file system - where in that file system it is can be controlled by
LINK-PREFIX."
  (let try ((tempname (tempname-in link-prefix)))
    (catch 'system-error
      (lambda ()
        (link target tempname)
        tempname)
      (lambda args
        (if (= (system-error-errno args) EEXIST)
            (try (tempname-in link-prefix))
            (apply throw args))))))

(define (call-with-writable-file file store thunk)
  (if (string=? file store)
      (thunk)                       ;don't meddle with the store's permissions
      (let ((stat (lstat file)))
        (dynamic-wind
          (lambda ()
            (make-file-writable file))
          thunk
          (lambda ()
            (set-file-time file stat)
            (chmod file (stat:mode stat)))))))

(define-syntax-rule (with-writable-file file store exp ...)
  "Make FILE writable for the dynamic extent of EXP..., except if FILE is the
store."
  (call-with-writable-file file store (lambda () exp ...)))

;; There are 3 main kinds of errors we can get from hardlinking: "Too many
;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
;; "can't fit more stuff in this directory" (ENOSPC).

(define* (replace-with-link target to-replace
                            #:key (swap-directory (dirname target))
                            (store (%store-directory)))
  "Atomically replace the file TO-REPLACE with a link to TARGET.  Use
SWAP-DIRECTORY as the directory to store temporary hard links.  Upon ENOSPC
and EMLINK, TO-REPLACE is left unchanged.

Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
  (define temp-link
    (catch 'system-error
      (lambda ()
        (get-temp-link target swap-directory))
      (lambda args
        ;; We get ENOSPC when we can't fit an additional entry in
        ;; SWAP-DIRECTORY.  If it's EMLINK, then TARGET has reached its
        ;; maximum number of links.
        (if (memv (system-error-errno args) `(,ENOSPC ,EMLINK))
            #f
            (apply throw args)))))

  ;; If we couldn't create TEMP-LINK, that's OK: just don't do the
  ;; replacement, which means TO-REPLACE won't be deduplicated.
  (when temp-link
    (with-writable-file (dirname to-replace) store
      (catch 'system-error
        (lambda ()
          (rename-file temp-link to-replace))
        (lambda args
          (delete-file temp-link)
          (unless (= EMLINK (system-error-errno args))
            (apply throw args)))))))

(define* (deduplicate path hash #:key (store (%store-directory)))
  "Check if a store item with sha256 hash HASH already exists.  If so,
replace PATH with a hardlink to the already-existing one.  If not, register
PATH so that future duplicates can hardlink to it.  PATH is assumed to be
under STORE."
  (define links-directory
    (string-append store "/.links"))

  (let loop ((path path)
             (type (stat:type (lstat path)))
             (hash hash))
    (if (eq? 'directory type)
        ;; Can't hardlink directories, so hardlink their atoms.
        (for-each (match-lambda
                    ((file . properties)
                     (unless (member file '("." ".."))
                       (let* ((file (string-append path "/" file))
                              (type (match (assoc-ref properties 'type)
                                      ((or 'unknown #f)
                                       (stat:type (lstat file)))
                                      (type type))))
                         (loop file type
                               (and (not (eq? 'directory type))
                                    (nar-sha256 file)))))))
                  (scandir* path))
        (let ((link-file (string-append links-directory "/"
                                        (bytevector->nix-base32-string hash))))
          (if (file-exists? link-file)
              (replace-with-link link-file path
                                 #:swap-directory links-directory
                                 #:store store)
              (catch 'system-error
                (lambda ()
                  (link path link-file))
                (lambda args
                  (let ((errno (system-error-errno args)))
                    (cond ((= errno EEXIST)
                           ;; Someone else put an entry for PATH in
                           ;; LINKS-DIRECTORY before we could.  Let's use it.
                           (replace-with-link path link-file
                                              #:swap-directory
                                              links-directory
                                              #:store store))
                          ((= errno ENOENT)
                           ;; This most likely means that LINKS-DIRECTORY does
                           ;; not exist.  Attempt to create it and try again.
                           (mkdir-p links-directory)
                           (loop path type hash))
                          ((= errno ENOSPC)
                           ;; There's not enough room in the directory index for
                           ;; more entries in .links, but that's fine: we can
                           ;; just stop.
                           #f)
                          ((= errno EMLINK)
                           ;; PATH has reached the maximum number of links, but
                           ;; that's OK: we just can't deduplicate it more.
                           #f)
                          (else (apply throw args)))))))))))

(define (tee input len output)
  "Return a port that reads up to LEN bytes from INPUT and writes them to
OUTPUT as it goes."
  (define bytes-read 0)

  (define (fail)
    ;; Reached EOF before we had read LEN bytes from INPUT.
    (raise (condition
            (&nar-error (port input)
                        (file (port-filename output))))))

  (define (read! bv start count)
    ;; Read at most LEN bytes in total.
    (let ((count (min count (- len bytes-read))))
      (let loop ((ret (get-bytevector-n! input bv start count)))
        (cond ((eof-object? ret)
               (if (= bytes-read len)
                   0                              ; EOF
                   (fail)))
              ((and (zero? ret) (> count 0))
               ;; Do not return zero since zero means EOF, so try again.
               (loop (get-bytevector-n! input bv start count)))
              (else
               (put-bytevector output bv start ret)
               (set! bytes-read (+ bytes-read ret))
               ret)))))

  (make-custom-binary-input-port "tee input port" read! #f #f #f))

(define* (dump-file/deduplicate file input size type
                                #:key (store (%store-directory)))
  "Write SIZE bytes read from INPUT to FILE.  TYPE is a symbol, either
'regular or 'executable.

This procedure is suitable as a #:dump-file argument to 'restore-file'.  When
used that way, it deduplicates files on the fly as they are restored, thereby
removing the need to a deduplication pass that would re-read all the files
down the road."
  (define hash
    (call-with-output-file file
      (lambda (output)
        (let-values (((hash-port get-hash)
                      (open-hash-port (hash-algorithm sha256))))
          (write-file-tree file hash-port
                           #:file-type+size (lambda (_) (values type size))
                           #:file-port
                           (const (tee input size output)))
          (close-port hash-port)
          (get-hash)))))

  (deduplicate file hash #:store store))

(define* (copy-file/deduplicate source target
                                #:key (store (%store-directory)))
  "Like 'copy-file', but additionally deduplicate TARGET in STORE."
  (call-with-input-file source
    (lambda (input)
      (let ((stat (stat input)))
        (dump-file/deduplicate target input (stat:size stat)
                               (if (zero? (logand (stat:mode stat)
                                                  #o100))
                                   'regular
                                   'executable)
                               #:store store)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2017, 2019 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 store roots)
  #:use-module (guix config)
  #:use-module ((guix store) #:select (store-path? %gc-roots-directory))
  #:use-module (guix sets)
  #:use-module (guix build syscalls)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 ftw)
  #:use-module (rnrs io ports)
  #:re-export (%gc-roots-directory)
  #:export (gc-roots
            user-owned?
            busy-store-items))

;;; Commentary:
;;;
;;; This module provides tools to list and access garbage collector roots ("GC
;;; roots").
;;;
;;; Code:

(define %profile-directory
  ;; Directory where user profiles are stored.
  ;; XXX: This is redundant with the definition in (guix profiles) and not
  ;; entirely needed since in practice /var/guix/gcroots/profiles links to
  ;; it.
  (string-append %state-directory "/profiles"))

(define (gc-roots)
  "Return the list of garbage collector roots (\"GC roots\").  This includes
\"regular\" roots fount in %GC-ROOTS-DIRECTORY as well as indirect roots that
are user-controlled symlinks stored anywhere on the file system."
  (define (regular? file)
    (match file
      (((or "." "..") . _) #f)
      (_ #t)))

  (define (file-type=? type)
    (match-lambda
      ((file . properties)
       (match (assq-ref properties 'type)
         ('unknown
          (let ((stat (lstat file)))
            (eq? type (stat:type stat))))
         (actual-type
          (eq? type actual-type))))))

  (define directory?
    (file-type=? 'directory))

  (define symlink?
    (file-type=? 'symlink))

  (define canonical-root
    (match-lambda
      ((file . properties)
       (let ((target (readlink file)))
         (cond ((store-path? target)
                ;; Regular root: FILE points to the store.
                file)

               ;; Indirect root: FILE points to a user-controlled file outside
               ;; the store.
               ((string-prefix? "/" target)
                target)
               (else
                (string-append (dirname file) "/" target)))))))

  (let loop ((directories (list %gc-roots-directory
                                %profile-directory))
             (roots       '())
             (visited     (set)))
    (match directories
      (()
       roots)
      ((directory . rest)
       (if (set-contains? visited directory)
           (loop rest roots visited)
           (let*-values (((scope)
                          (cut string-append directory "/" <>))
                         ((sub-directories files)
                          (partition directory?
                                     (map (match-lambda
                                            ((file . properties)
                                             (cons (scope file) properties)))
                                          (scandir* directory regular?)))))
             (loop (append rest (map first sub-directories))
                   (append (map canonical-root (filter symlink? files))
                           roots)
                   (set-insert directory visited))))))))

(define* (user-owned? root #:optional (uid (getuid)))
  "Return true if ROOT exists and is owned by UID, false otherwise."
  ;; If ROOT is an indirect root, then perhaps it no longer exists.  Thus,
  ;; catch 'system-error' exceptions.
  (catch 'system-error
    (lambda ()
      (define stat
        (lstat root))

      (= (stat:uid stat) uid))
    (const #f)))

;;;
;;; Listing "busy" store items: those referenced by currently running
;;; processes.
;;;

(define %proc-directory
  ;; Mount point of Linuxish /proc file system.
  "/proc")

(define (proc-file-roots dir file)
  "Return a one-element list containing the file pointed to by DIR/FILE,
or the empty list."
  (or (and=> (false-if-exception (readlink (string-append dir "/" file)))
             list)
      '()))

(define proc-exe-roots (cut proc-file-roots <> "exe"))
(define proc-cwd-roots (cut proc-file-roots <> "cwd"))

(define (proc-fd-roots dir)
  "Return the list of store files referenced by DIR, which is a
/proc/XYZ directory."
  (let ((dir (string-append dir "/fd")))
    (filter-map (lambda (file)
                  (let ((target (false-if-exception
                                 (readlink (string-append dir "/" file)))))
                    (and target
                         (string-prefix? "/" target)
                         target)))
                (or (scandir dir string->number) '()))))

(define (proc-maps-roots dir)
  "Return the list of store files referenced by DIR, which is a
/proc/XYZ directory."
  (define %file-mapping-line
    (make-regexp "^.*[[:blank:]]+/([^ ]+)$"))

  (call-with-input-file (string-append dir "/maps")
    (lambda (maps)
      (let loop ((line  (read-line maps))
                 (roots '()))
        (cond ((eof-object? line)
               roots)
              ((regexp-exec %file-mapping-line line)
               =>
               (lambda (match)
                 (let ((file (string-append "/"
                                            (match:substring match 1))))
                   (loop (read-line maps)
                         (cons file roots)))))
              (else
               (loop (read-line maps) roots)))))))

(define (proc-environ-roots dir)
  "Return the list of store files referenced by DIR/environ, where DIR is a
/proc/XYZ directory."
  (define split-on-nul
    (cute string-tokenize <>
          (char-set-complement (char-set #\nul))))

  (define (rhs-file-names str)
    (let ((equal (string-index str #\=)))
      (if equal
          (let* ((str (substring str (+ 1 equal)))
                 (rx  (string-append (regexp-quote %store-directory)
                                     "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+")))
            (map match:substring (list-matches rx str)))
          '())))

  (define environ
    (string-append dir "/environ"))

  (append-map rhs-file-names
              (split-on-nul
               (call-with-input-file environ
                 get-string-all))))

(define (referenced-files)
  "Return the list of referenced store items."
  (append-map (lambda (pid)
                (let ((proc (string-append %proc-directory "/" pid)))
                  (catch 'system-error
                    (lambda ()
                      (append (proc-exe-roots proc)
                              (proc-cwd-roots proc)
                              (proc-fd-roots proc)
                              (proc-maps-roots proc)
                              (proc-environ-roots proc)))
                    (lambda args
                      (let ((err (system-error-errno args)))
                        (if (or (= ENOENT err)    ;TOCTTOU race
                                (= ESRCH err)     ;ditto
                                (= EACCES err))   ;not running as root
                            '()
                            (apply throw args)))))))
              (scandir %proc-directory string->number
                       (lambda (a b)
                         (< (string->number a) (string->number b))))))

(define canonicalize-store-item
  (let* ((store  (string-append %store-directory "/"))
         (prefix (string-length store)))
    (lambda (file)
      "Return #f if FILE is not a store item; otherwise, return the store file
name without any sub-directory components."
      (and (string-prefix? store file)
           (string-append store
                          (let ((base (string-drop file prefix)))
                            (match (string-index base #\/)
                              (#f    base)
                              (slash (string-take base slash)))))))))

(define (busy-store-items)
  "Return the list of store items used by the currently running processes.

This code should typically run as root; it allows the garbage collector to
determine which store items must not be deleted."
  (delete-duplicates
   (filter-map canonicalize-store-item (referenced-files))))


code:
create table if not exists ValidPaths (
    id               integer primary key autoincrement not null,
    path             text unique not null,
    hash             text not null,
    registrationTime integer not null,
    deriver          text,
    narSize          integer
);

create table if not exists Refs (
    referrer  integer not null,
    reference integer not null,
    primary key (referrer, reference),
    foreign key (referrer) references ValidPaths(id) on delete cascade,
    foreign key (reference) references ValidPaths(id) on delete restrict
);

create index if not exists IndexReferrer on Refs(referrer);
create index if not exists IndexReference on Refs(reference);

-- Paths can refer to themselves, causing a tuple (N, N) in the Refs
-- table.  This causes a deletion of the corresponding row in
-- ValidPaths to cause a foreign key constraint violation (due to `on
-- delete restrict' on the `reference' column).  Therefore, explicitly
-- get rid of self-references.
create trigger if not exists DeleteSelfRefs before delete on ValidPaths
  begin
    delete from Refs where referrer = old.id and reference = old.id;
  end;

create table if not exists DerivationOutputs (
    drv  integer not null,
    id   text not null, -- symbolic output id, usually "out"
    path text not null,
    primary key (drv, id),
    foreign key (drv) references ValidPaths(id) on delete cascade
);

create index if not exists IndexDerivationOutputs on DerivationOutputs(path);

create table if not exists FailedPaths (
    path text primary key not null,
    time integer not null
);


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 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 store ssh)
  #:use-module (guix ssh)
  #:use-module (web uri)
  #:export (connect-to-daemon))

;;; Commentary:
;;;
;;; This modules provides the entry point for 'open-connection' in (guix
;;; store).  Passing an 'ssh://' URI to 'open-connection' triggers the use of
;;; the code in this module.
;;;
;;; End:

(define (connect-to-daemon uri)
  "Connect to the SSH daemon at URI, a URI object with the 'ssh' scheme."
  (remote-daemon-channel
   (open-ssh-session (uri-host uri)
                     #:port (or (uri-port uri) 22)
                     #:user (uri-userinfo uri))))

;;; ssh.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2020 Christopher Baines <mail@cbaines.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 substitutes)
  #:use-module (guix narinfo)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix combinators)
  #:use-module (guix config)
  #:use-module (guix records)
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix base64)
  #:use-module (guix cache)
  #:use-module (gcrypt pk-crypto)
  #:use-module (guix pki)
  #:use-module ((guix build utils) #:select (mkdir-p dump-port))
  #:use-module ((guix build download)
                #:select ((open-connection-for-uri
                           . guix:open-connection-for-uri)
                          resolve-uri-reference))
  #:use-module (guix progress)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 vlist)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (guix http-client)
  #:export (%narinfo-cache-directory

            call-with-connection-error-handling

            lookup-narinfos
            lookup-narinfos/diverse))

(define %narinfo-ttl
  ;; Number of seconds during which cached narinfo lookups are considered
  ;; valid for substitute servers that do not advertise a TTL via the
  ;; 'Cache-Control' response header.
  (* 36 3600))

(define %narinfo-negative-ttl
  ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
  (* 10 60))

(define %narinfo-transient-error-ttl
  ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
  (* 5 60))

(define %narinfo-cache-directory
  ;; A local cache of narinfos, to avoid going to the network.  Most of the
  ;; time, 'guix substitute' is called by guix-daemon as root and stores its
  ;; cached data in /var/guix/….  However, when invoked from 'guix challenge'
  ;; as a user, it stores its cache in ~/.cache.
  (if (zero? (getuid))
      (or (and=> (getenv "XDG_CACHE_HOME")
                 (cut string-append <> "/guix/substitute"))
          (string-append %state-directory "/substitute/cache"))
      (string-append (cache-directory #:ensure? #f) "/substitute")))

(define (narinfo-cache-file cache-url path)
  "Return the name of the local file that contains an entry for PATH.  The
entry is stored in a sub-directory specific to CACHE-URL."
  ;; The daemon does not sanitize its input, so PATH could be something like
  ;; "/gnu/store/foo".  Gracefully handle that.
  (match (store-path-hash-part path)
    (#f
     (leave (G_ "'~a' does not name a store item~%") path))
    ((? string? hash-part)
     (string-append %narinfo-cache-directory "/"
                    (bytevector->base32-string (sha256 (string->utf8 cache-url)))
                    "/" hash-part))))

(define (cache-narinfo! cache-url path narinfo ttl)
  "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
given TTL (a number of seconds or #f).  NARINFO may be #f, in which case it
indicates that PATH is unavailable at CACHE-URL."
  (define now
    (current-time time-monotonic))

  (define (cache-entry cache-uri narinfo)
    `(narinfo (version 2)
              (cache-uri ,cache-uri)
              (date ,(time-second now))
              (ttl ,(or ttl
                        (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
              (value ,(and=> narinfo narinfo->string))))

  (let ((file (narinfo-cache-file cache-url path)))
    (mkdir-p (dirname file))
    (with-atomic-file-output file
      (lambda (out)
        (write (cache-entry cache-url narinfo) out))))

  narinfo)

(define %unreachable-hosts
  ;; Set of names of unreachable hosts.
  (make-hash-table))

(define* (call-with-connection-error-handling uri proc)
  "Call PROC, and catch if a connection fails, print a warning and return #f."
  (define host
    (uri-host uri))

  (catch #t
    proc
    (match-lambda*
      (('getaddrinfo-error error)
       (unless (hash-ref %unreachable-hosts host)
         (hash-set! %unreachable-hosts host #t)   ;warn only once
         (warning (G_ "~a: host not found: ~a~%")
                  host (gai-strerror error)))
       #f)
      (('system-error . args)
       (unless (hash-ref %unreachable-hosts host)
         (hash-set! %unreachable-hosts host #t)
         (warning (G_ "~a: connection failed: ~a~%") host
                  (strerror
                   (system-error-errno `(system-error ,@args)))))
       #f)
      (args
       (apply throw args)))))

(define (narinfo-request cache-url path)
  "Return an HTTP request for the narinfo of PATH at CACHE-URL."
  (let* ((base (string->uri cache-url))
         (ref (build-relative-ref
               #:path (string-append (store-path-hash-part path) ".narinfo")))
         (url (resolve-uri-reference ref base))
         (headers '((User-Agent . "GNU Guile"))))
    (build-request url #:method 'GET #:headers headers)))

(define (narinfo-from-file file url)
  "Attempt to read a narinfo from FILE, using URL as the cache URL.  Return #f
if file doesn't exist, and the narinfo otherwise."
  (catch 'system-error
    (lambda ()
      (call-with-input-file file
        (cut read-narinfo <> url)))
    (lambda args
      (if (= ENOENT (system-error-errno args))
          #f
          (apply throw args)))))

(define* (fetch-narinfos url paths
                         #:key
                         (open-connection guix:open-connection-for-uri)
                         (make-progress-reporter
                          (const progress-reporter/silent)))
  "Retrieve all the narinfos for PATHS from the cache at URL and return them."
  (define progress-reporter
    (make-progress-reporter (length paths)
                            #:url url))

  (define hash-part->path
    (let ((mapping (fold (lambda (path result)
                           (vhash-cons (store-path-hash-part path) path
                                       result))
                         vlist-null
                         paths)))
      (lambda (hash)
        (match (vhash-assoc hash mapping)
          (#f #f)
          ((_ . path) path)))))

  (define (read-to-eof port)
    "Read from PORT until EOF is reached.  The data are discarded."
    (dump-port port (%make-void-port "w")))

  (define (handle-narinfo-response request response port result)
    (let* ((code   (response-code response))
           (len    (response-content-length response))
           (cache  (response-cache-control response))
           (ttl    (and cache (assoc-ref cache 'max-age))))
      (progress-reporter-report! progress-reporter)

      ;; Make sure to read no more than LEN bytes since subsequent bytes may
      ;; belong to the next response.
      (if (= code 200)                            ; hit
          (let ((narinfo (read-narinfo port url #:size len)))
            (if (string=? (dirname (narinfo-path narinfo))
                          (%store-prefix))
                (begin
                  (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
                  (cons narinfo result))
                result))
          (let* ((path      (uri-path (request-uri request)))
                 (hash-part (basename
                             (string-drop-right path 8)))) ;drop ".narinfo"
            (if len
                (get-bytevector-n port len)
                (read-to-eof port))
            (cache-narinfo! url (hash-part->path hash-part) #f
                            (if (or (= 404 code) (= 202 code))
                                ttl
                                %narinfo-transient-error-ttl))
            result))))

  (define (do-fetch uri)
    (case (and=> uri uri-scheme)
      ((http https)
       ;; Note: Do not check HTTPS server certificates to avoid depending
       ;; on the X.509 PKI.  We can do it because we authenticate
       ;; narinfos, which provides a much stronger guarantee.
       (let* ((requests (map (cut narinfo-request url <>) paths))
              (result   (begin
                          (start-progress-reporter! progress-reporter)
                          (call-with-connection-error-handling
                           uri
                           (lambda ()
                             (http-multiple-get uri
                                                handle-narinfo-response '()
                                                requests
                                                #:open-connection open-connection
                                                #:verify-certificate? #f))))))
         (stop-progress-reporter! progress-reporter)
         result))
      ((file #f)
       (let* ((base  (string-append (uri-path uri) "/"))
              (files (map (compose (cut string-append base <> ".narinfo")
                                   store-path-hash-part)
                          paths)))
         (filter-map (cut narinfo-from-file <> url) files)))
      (else
       (leave (G_ "~s: unsupported server URI scheme~%")
              (if uri (uri-scheme uri) url)))))

  (do-fetch (string->uri url)))

(define (cached-narinfo cache-url path)
  "Check locally if we have valid info about PATH coming from CACHE-URL.
Return two values: a Boolean indicating whether we have valid cached info, and
that info, which may be either #f (when PATH is unavailable) or the narinfo
for PATH."
  (define now
    (current-time time-monotonic))

  (define cache-file
    (narinfo-cache-file cache-url path))

  (catch 'system-error
    (lambda ()
      (call-with-input-file cache-file
        (lambda (p)
          (match (read p)
            (('narinfo ('version 2)
                       ('cache-uri cache-uri)
                       ('date date) ('ttl ttl) ('value #f))
             ;; A cached negative lookup.
             (if (obsolete? date now ttl)
                 (values #f #f)
                 (values #t #f)))
            (('narinfo ('version 2)
                       ('cache-uri cache-uri)
                       ('date date) ('ttl ttl) ('value value))
             ;; A cached positive lookup
             (if (obsolete? date now ttl)
                 (values #f #f)
                 (values #t (string->narinfo value cache-uri))))
            (('narinfo ('version v) _ ...)
             (values #f #f))))))
    (lambda _
      (values #f #f))))

(define* (lookup-narinfos cache paths
                          #:key (open-connection guix:open-connection-for-uri)
                          (make-progress-reporter
                           (const progress-reporter/silent)))
  "Return the narinfos for PATHS, invoking the server at CACHE when no
information is available locally."
  (let-values (((cached missing)
                (fold2 (lambda (path cached missing)
                         (let-values (((valid? value)
                                       (cached-narinfo cache path)))
                           (if valid?
                               (if value
                                   (values (cons value cached) missing)
                                   (values cached missing))
                               (values cached (cons path missing)))))
                       '()
                       '()
                       paths)))
    (values (if (null? missing)
                cached
                (let ((missing (fetch-narinfos cache missing
                                               #:open-connection open-connection
                                               #:make-progress-reporter
                                               make-progress-reporter)))
                  (append cached (or missing '()))))
            (length missing))))

(define* (lookup-narinfos/diverse caches paths authorized?
                                  #:key (open-connection
                                         guix:open-connection-for-uri)
                                  (make-progress-reporter
                                   (const progress-reporter/silent)))
  "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
cache, and so on.

Return a list of narinfos for PATHS or a subset thereof.  The returned
narinfos are either AUTHORIZED?, or they claim a hash that matches an
AUTHORIZED? narinfo."
  (define (select-hit result)
    (lambda (path)
      (match (vhash-fold* cons '() path result)
        ((one)
         one)
        ((several ..1)
         (let ((authorized (find authorized? (reverse several))))
           (and authorized
                (find (cut equivalent-narinfo? <> authorized)
                      several)))))))

  (let loop ((caches caches)
             (paths  paths)
             (result vlist-null)                  ;path->narinfo vhash
             (hits   '()))                        ;paths
    (match paths
      (()                                         ;we're done
       ;; Now iterate on all the HITS, and return exactly one match for each
       ;; hit: the first narinfo that is authorized, or that has the same hash
       ;; as an authorized narinfo, in the order of CACHES.
       (filter-map (select-hit result) hits))
      (_
       (match caches
         ((cache rest ...)
          (let* ((narinfos (lookup-narinfos cache paths
                                            #:open-connection open-connection
                                            #:make-progress-reporter
                                            make-progress-reporter))
                 (definite (map narinfo-path (filter authorized? narinfos)))
                 (missing  (lset-difference string=? paths definite))) ;XXX: perf
            (loop rest missing
                  (fold vhash-cons result
                        (map narinfo-path narinfos) narinfos)
                  (append definite hits))))
         (()                                      ;that's it
          (filter-map (select-hit result) hits)))))))

;;; substitutes.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2017, 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 svn-download)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module ((guix build svn) #:prefix build:)
  #:use-module (ice-9 match)
  #:export (svn-reference
            svn-reference?
            svn-reference-url
            svn-reference-revision
            svn-reference-recursive?
            svn-fetch
            download-svn-to-store

            svn-multi-reference
            svn-multi-reference?
            svn-multi-reference-url
            svn-multi-reference-revision
            svn-multi-reference-locations
            svn-multi-reference-recursive?
            svn-multi-fetch))

;;; Commentary:
;;;
;;; An <origin> method that fetches a specific revision from a Subversion
;;; repository.  The repository URL and REVISION are specified with a
;;; <svn-reference> object.  REVISION should be specified as a number.
;;;
;;; Code:

(define-record-type* <svn-reference>
  svn-reference make-svn-reference
  svn-reference?
  (url        svn-reference-url)                    ; string
  (revision   svn-reference-revision)               ; number
  (recursive? svn-reference-recursive? (default #t))
  (user-name  svn-reference-user-name (default #f))
  (password   svn-reference-password (default #f)))

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

(define* (svn-fetch ref hash-algo hash
                    #:optional name
                    #:key (system (%current-system)) (guile (default-guile))
                    (svn (subversion-package)))
  "Return a fixed-output derivation that fetches REF, a <svn-reference>
object.  The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
  (define build
    (with-imported-modules '((guix build svn)
                             (guix build utils))
      #~(begin
          (use-modules (guix build svn))
          (svn-fetch '#$(svn-reference-url ref)
                     '#$(svn-reference-revision ref)
                     #$output
                     #:svn-command (string-append #+svn "/bin/svn")
                     #:recursive? #$(svn-reference-recursive? ref)
                     #:user-name #$(svn-reference-user-name ref)
                     #:password #$(svn-reference-password ref)))))

  (mlet %store-monad ((guile (package->derivation guile system)))
    (gexp->derivation (or name "svn-checkout") build
                      #:system system
                      #:hash-algo hash-algo
                      #:hash hash
                      #:recursive? #t
                      #:guile-for-build guile
                      #:local-build? #t)))

(define-record-type* <svn-multi-reference>
  svn-multi-reference make-svn-multi-reference
  svn-multi-reference?
  (url        svn-multi-reference-url)                 ; string
  (revision   svn-multi-reference-revision)            ; number
  (locations  svn-multi-reference-locations)           ; list of strings
  (recursive? svn-multi-reference-recursive? (default #t))
  (user-name  svn-multi-reference-user-name (default #f))
  (password   svn-multi-reference-password (default #f)))

(define* (svn-multi-fetch ref hash-algo hash
                          #:optional name
                          #:key (system (%current-system)) (guile (default-guile))
                          (svn (subversion-package)))
  "Return a fixed-output derivation that fetches REF, a <svn-multi-reference>
object.  The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
  (define build
    (with-imported-modules '((guix build svn)
                             (guix build utils))
      #~(begin
          (use-modules (guix build svn)
                       (guix build utils)
                       (srfi srfi-1))
          (every (lambda (location)
                   ;; The directory must exist if we are to fetch only a
                   ;; single file.
                   (unless (string-suffix? "/" location)
                     (mkdir-p (string-append #$output "/" (dirname location))))
                   (svn-fetch (string-append '#$(svn-multi-reference-url ref)
                                             "/" location)
                              '#$(svn-multi-reference-revision ref)
                              (if (string-suffix? "/" location)
                                  (string-append #$output "/" location)
                                  (string-append #$output "/" (dirname location)))
                              #:svn-command (string-append #+svn "/bin/svn")
                              #:recursive?
                              #$(svn-multi-reference-recursive? ref)
                              #:user-name #$(svn-multi-reference-user-name ref)
                              #:password #$(svn-multi-reference-password ref)))
                 '#$(svn-multi-reference-locations ref)))))

  (mlet %store-monad ((guile (package->derivation guile system)))
    (gexp->derivation (or name "svn-checkout") build
                      #:leaked-env-vars '("http_proxy" "https_proxy"
                                          "LC_ALL" "LC_MESSAGES" "LANG"
                                          "COLUMNS")
                      #:system system
                      #:hash-algo hash-algo
                      #:hash hash
                      #:recursive? #t
                      #:guile-for-build guile
                      #:local-build? #t)))

(define* (download-svn-to-store store ref
                                #:optional (name (basename (svn-reference-url ref)))
                                #:key (log (current-error-port)))
  "Download from REF, a <svn-reference> object to STORE.  Write progress
reports to LOG."
  (call-with-temporary-directory
   (lambda (temp)
     (let ((result
            (parameterize ((current-output-port log))
              (build:svn-fetch (svn-reference-url ref)
                               (svn-reference-revision ref)
                               (string-append temp "/svn")
                               #:user-name (svn-reference-user-name ref)
                               #:password (svn-reference-password ref)))))
       (and result
            (add-to-store store name #t "sha256"
                          (string-append temp "/svn")))))))

;;; svn-download.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; 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 swh)
  #:use-module (guix base16)
  #:use-module (guix build utils)
  #:use-module ((guix build syscalls) #:select (mkdtemp!))
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 popen)
  #:use-module ((ice-9 ftw) #:select (scandir))
  #:export (%swh-base-url
            %verify-swh-certificate?
            %allow-request?

            request-rate-limit-reached?

            origin?
            origin-type
            origin-url
            origin-visits
            lookup-origin

            visit?
            visit-date
            visit-origin
            visit-url
            visit-snapshot-url
            visit-status
            visit-number
            visit-snapshot

            branch?
            branch-name
            branch-target

            release?
            release-id
            release-name
            release-message
            release-target

            revision?
            revision-id
            revision-date
            revision-directory
            lookup-revision
            lookup-origin-revision

            content?
            content-checksums
            content-data-url
            content-length
            lookup-content

            directory-entry?
            directory-entry-name
            directory-entry-type
            directory-entry-checksums
            directory-entry-length
            directory-entry-permissions
            lookup-directory
            directory-entry-target

            save-reply?
            save-reply-origin-url
            save-reply-origin-type
            save-reply-request-date
            save-reply-request-status
            save-reply-task-status
            save-origin
            save-origin-status

            vault-reply?
            vault-reply-id
            vault-reply-fetch-url
            vault-reply-object-id
            vault-reply-object-type
            vault-reply-progress-message
            vault-reply-status
            query-vault
            request-cooking
            vault-fetch

            commit-id?

            swh-download-directory
            swh-download))

;;; Commentary:
;;;
;;; This module provides bindings to the HTTP interface of Software Heritage.
;;; It allows you to browse the archive, look up revisions (such as SHA1
;;; commit IDs), "origins" (code hosting URLs), content (files), etc.  See
;;; <https://archive.softwareheritage.org/api/> for more information.
;;;
;;; The high-level 'swh-download' procedure allows you to download a Git
;;; revision from Software Heritage, provided it is available.
;;;
;;; Code:

(define %swh-base-url
  ;; Presumably we won't need to change it.
  (make-parameter "https://archive.softwareheritage.org"))

(define %verify-swh-certificate?
  ;; Whether to verify the X.509 HTTPS certificate for %SWH-BASE-URL.
  (make-parameter #t))

(define (swh-url path . rest)
  ;; URLs returned by the API may be relative or absolute. This has changed
  ;; without notice before. Handle both cases by detecting whether the path
  ;; starts with a domain.
  (define root
    (if (string-prefix? "/" path)
      (string-append (%swh-base-url) path)
      path))

  (define url
    (string-append root (string-join rest "/" 'prefix)))

  ;; Ensure there's a trailing slash or we get a redirect.
  (if (string-suffix? "/" url)
      url
      (string-append url "/")))

;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would
;; be ignored (<https://bugs.gnu.org/40486>).
(define* (http-get* uri #:rest rest)
  (apply http-request uri #:method 'GET rest))
(define* (http-post* uri #:rest rest)
  (apply http-request uri #:method 'POST rest))

(define %date-regexp
  ;; Match strings like "2014-11-17T22:09:38+01:00" or
  ;; "2018-09-30T23:20:07.815449+00:00"".
  (make-regexp "^([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})((\\.[0-9]+)?)([+-][0-9]{2}):([0-9]{2})$"))

(define (string->date* str)
  "Return a SRFI-19 date parsed from STR, a date string as returned by
Software Heritage."
  ;; We can't use 'string->date' because of the timezone format: SWH returns
  ;; "+01:00" when the '~z' template expects "+0100".  So we roll our own!
  (or (and=> (regexp-exec %date-regexp str)
             (lambda (match)
               (define (ref n)
                 (string->number (match:substring match n)))

               (make-date (let ((ns (match:substring match 8)))
                            (if ns
                                (string->number (string-drop ns 1))
                                0))
                          (ref 6) (ref 5) (ref 4)
                          (ref 3) (ref 2) (ref 1)
                          (+ (* 3600 (ref 9))     ;time zone
                             (if (< (ref 9) 0)
                                 (- (ref 10))
                                 (ref 10))))))
      str))                                       ;oops!

(define string*
  ;; Converts "string or #nil" coming from JSON to "string or #f".
  (match-lambda
    ((? string? str) str)
    ((? null?) #f)                                ;Guile-JSON 3.x
    ('null #f)))                                  ;Guile-JSON 4.x

(define %allow-request?
  ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true
  ;; to keep going.  This can be used to disallow requests when
  ;; 'request-rate-limit-reached?' returns true, for instance.
  (make-parameter (const #t)))

;; The time when the rate limit for "/origin/save" POST requests and that of
;; other requests will be reset.
;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
(define %save-rate-limit-reset-time 0)
(define %general-rate-limit-reset-time 0)

(define (request-rate-limit-reached? url method)
  "Return true if the rate limit has been reached for URI."
  (define uri
    (string->uri url))

  (define reset-time
    (if (and (eq? method http-post*)
             (string-prefix? "/api/1/origin/save/" (uri-path uri)))
        %save-rate-limit-reset-time
        %general-rate-limit-reset-time))

  (< (car (gettimeofday)) reset-time))

(define (update-rate-limit-reset-time! url method response)
  "Update the rate limit reset time for URL and METHOD based on the headers in
RESPONSE."
  (let ((uri (string->uri url)))
    (match (assq-ref (response-headers response) 'x-ratelimit-reset)
      ((= string->number (? number? reset))
       (if (and (eq? method http-post*)
                (string-prefix? "/api/1/origin/save/" (uri-path uri)))
           (set! %save-rate-limit-reset-time reset)
           (set! %general-rate-limit-reset-time reset)))
      (_
       #f))))

(define* (call url decode #:optional (method http-get*)
               #:key (false-if-404? #t))
  "Invoke the endpoint at URL using METHOD.  Decode the resulting JSON body
using DECODE, a one-argument procedure that takes an input port.  When
FALSE-IF-404? is true, return #f upon 404 responses."
  (and ((%allow-request?) url method)
       (let*-values (((response port)
                      (method url #:streaming? #t
                              #:verify-certificate?
                              (%verify-swh-certificate?))))
         ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
         (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
           (#f #t)
           ((? (compose zero? string->number))
            (update-rate-limit-reset-time! url method response)
            (throw 'swh-error url method response))
           (_ #t))

         (cond ((= 200 (response-code response))
                (let ((result (decode port)))
                  (close-port port)
                  result))
               ((and false-if-404?
                     (= 404 (response-code response)))
                (close-port port)
                #f)
               (else
                (close-port port)
                (throw 'swh-error url method response))))))

(define-syntax define-query
  (syntax-rules (path)
    "Define a procedure that performs a Software Heritage query."
    ((_ (name args ...) docstring (path components ...)
        json->value)
     (define (name args ...)
       docstring
       (call (swh-url components ...) json->value)))))

;; <https://archive.softwareheritage.org/api/1/origin/https://github.com/guix-mirror/guix/get>
(define-json-mapping <origin> make-origin origin?
  json->origin
  (visits-url origin-visits-url "origin_visits_url")
  (type origin-type)
  (url origin-url))

;; <https://archive.softwareheritage.org/api/1/origin/52181937/visits/>
(define-json-mapping <visit> make-visit visit?
  json->visit
  (date visit-date "date" string->date*)
  (origin visit-origin)
  (url visit-url "origin_visit_url")
  (snapshot-url visit-snapshot-url "snapshot_url" string*) ;string | #f
  (status visit-status "status" string->symbol)   ;'full | 'partial | 'ongoing
  (number visit-number "visit"))

;; <https://archive.softwareheritage.org/api/1/snapshot/4334c3ed4bb208604ed780d8687fe523837f1bd1/>
(define-json-mapping <snapshot> make-snapshot snapshot?
  json->snapshot
  (branches snapshot-branches "branches" json->branches))

;; This is used for the "branches" field of snapshots.
(define-record-type <branch>
  (make-branch name target-type target-url)
  branch?
  (name         branch-name)
  (target-type  branch-target-type)               ;release | revision
  (target-url   branch-target-url))

(define (json->branches branches)
  (map (match-lambda
         ((key . value)
          (make-branch key
                       (string->symbol
                        (assoc-ref value "target_type"))
                       (assoc-ref value "target_url"))))
       branches))

;; <https://archive.softwareheritage.org/api/1/release/1f44934fb6e2cefccbecd4fa347025349fa9ff76/>
(define-json-mapping <release> make-release release?
  json->release
  (id          release-id)
  (name        release-name)
  (message     release-message)
  (target-type release-target-type "target_type" string->symbol)
  (target-url  release-target-url "target_url"))

;; <https://archive.softwareheritage.org/api/1/revision/359fdda40f754bbf1b5dc261e7427b75463b59be/>
(define-json-mapping <revision> make-revision revision?
  json->revision
  (id            revision-id)
  (date          revision-date "date" string->date*)
  (directory     revision-directory)
  (directory-url revision-directory-url "directory_url"))

;; <https://archive.softwareheritage.org/api/1/content/>
(define-json-mapping <content> make-content content?
  json->content
  (checksums     content-checksums "checksums" json->checksums)
  (data-url      content-data-url "data_url")
  (file-type-url content-file-type-url "filetype_url")
  (language-url  content-language-url "language_url")
  (length        content-length)
  (license-url   content-license-url "license_url"))

(define (json->checksums checksums)
  (map (match-lambda
         ((key . value)
          (cons key (base16-string->bytevector value))))
       checksums))

;; <https://archive.softwareheritage.org/api/1/directory/27c69c5d298a43096a53affbf881e7b13f17bdcd/>
(define-json-mapping <directory-entry> make-directory-entry directory-entry?
  json->directory-entry
  (name          directory-entry-name)
  (type          directory-entry-type "type"
                 (match-lambda
                   ("dir" 'directory)
                   (str   (string->symbol str))))
  (checksums     directory-entry-checksums "checksums"
                 (match-lambda
                   (#f  #f)
                   ((? unspecified?) #f)
                   (lst (json->checksums lst))))
  (id            directory-entry-id "dir_id")
  (length        directory-entry-length)
  (permissions   directory-entry-permissions "perms")
  (target-url    directory-entry-target-url "target_url"))

;; <https://archive.softwareheritage.org/api/1/origin/save/>
(define-json-mapping <save-reply> make-save-reply save-reply?
  json->save-reply
  (origin-url     save-reply-origin-url "origin_url")
  (origin-type    save-reply-origin-type "origin_type")
  (request-date   save-reply-request-date "save_request_date"
                  string->date*)
  (request-status save-reply-request-status "save_request_status"
                  string->symbol)
  (task-status    save-reply-task-status "save_task_status"
                  (match-lambda
                    ("not created" 'not-created)
                    ((? string? str) (string->symbol str)))))

;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref>
(define-json-mapping <vault-reply> make-vault-reply vault-reply?
  json->vault-reply
  (id             vault-reply-id)
  (fetch-url      vault-reply-fetch-url "fetch_url")
  (object-id      vault-reply-object-id "obj_id")
  (object-type    vault-reply-object-type "obj_type" string->symbol)
  (progress-message vault-reply-progress-message "progress_message")
  (status         vault-reply-status "status" string->symbol))

;;;
;;; RPCs.
;;;

(define-query (lookup-origin url)
  "Return an origin for URL."
  (path "/api/1/origin" url "get")
  json->origin)

(define-query (lookup-content hash type)
  "Return a content for HASH, of the given TYPE--e.g., \"sha256\"."
  (path "/api/1/content"
        (string-append type ":"
                       (bytevector->base16-string hash)))
  json->content)

(define-query (lookup-revision id)
  "Return the revision with the given ID, typically a Git commit SHA1."
  (path "/api/1/revision" id)
  json->revision)

(define-query (lookup-directory id)
  "Return the directory with the given ID."
  (path "/api/1/directory" id)
  json->directory-entries)

(define (json->directory-entries port)
  (map json->directory-entry
       (vector->list (json->scm port))))

(define (origin-visits origin)
  "Return the list of visits of ORIGIN, a record as returned by
'lookup-origin'."
  (call (swh-url (origin-visits-url origin))
        (lambda (port)
          (map json->visit (vector->list (json->scm port))))))

(define (visit-snapshot visit)
  "Return the snapshot corresponding to VISIT or #f if no snapshot is
available."
  (and (visit-snapshot-url visit)
       (call (swh-url (visit-snapshot-url visit))
             json->snapshot)))

(define (branch-target branch)
  "Return the target of BRANCH, either a <revision> or a <release>."
  (match (branch-target-type branch)
    ('release
     (call (swh-url (branch-target-url branch))
           json->release))
    ('revision
     (call (swh-url (branch-target-url branch))
           json->revision))))

(define (lookup-origin-revision url tag)
  "Return a <revision> corresponding to the given TAG for the repository
coming from URL.  Example:

  (lookup-origin-revision \"https://github.com/guix-mirror/guix/\" \"v0.8\")
  => #<<revision> id: \"44941…\" …>

The information is based on the latest visit of URL available.  Return #f if
URL could not be found."
  (match (lookup-origin url)
    (#f #f)
    (origin
      (match (filter (lambda (visit)
                       ;; Return #f if (visit-snapshot VISIT) would return #f.
                       (and (visit-snapshot-url visit)
                            (eq? 'full (visit-status visit))))
                     (origin-visits origin))
        ((visit . _)
         (let ((snapshot (visit-snapshot visit)))
           (match (and=> (find (lambda (branch)
                                 (or
                                  ;; Git specific.
                                  (string=? (string-append "refs/tags/" tag)
                                            (branch-name branch))
                                  ;; Hg specific.
                                  (string=? tag
                                            (branch-name branch))))
                               (snapshot-branches snapshot))
                         branch-target)
             ((? release? release)
              (release-target release))
             ((? revision? revision)
              revision)
             (#f                                  ;tag not found
              #f))))
        (()
         #f)))))

(define (release-target release)
  "Return the revision that is the target of RELEASE."
  (match (release-target-type release)
    ('revision
     (call (swh-url (release-target-url release))
           json->revision))))

(define (directory-entry-target entry)
  "If ENTRY, a directory entry, has type 'directory, return its list of
directory entries; if it has type 'file, return its <content> object."
  (call (swh-url (directory-entry-target-url entry))
        (match (directory-entry-type entry)
          ('file json->content)
          ('directory json->directory-entries))))

(define* (save-origin url #:optional (type "git"))
  "Request URL to be saved."
  (call (swh-url "/api/1/origin/save" type "url" url) json->save-reply
        http-post*))

(define-query (save-origin-status url type)
  "Return the status of a /save request for URL and TYPE (e.g., \"git\")."
  (path "/api/1/origin/save" type "url" url)
  json->save-reply)

(define-query (query-vault id kind)
  "Ask the availability of object ID and KIND to the vault, where KIND is
'directory or 'revision.  Return #f if it could not be found, or a
<vault-reply> on success."
  ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref>
  ;; There's a single format supported for directories and revisions and for
  ;; now, the "/format" bit of the URL *must* be omitted.
  (path "/api/1/vault" (symbol->string kind) id)
  json->vault-reply)

(define (request-cooking id kind)
  "Request the cooking of object ID and KIND (one of 'directory or 'revision)
to the vault.  Return a <vault-reply>."
  (call (swh-url "/api/1/vault" (symbol->string kind) id)
        json->vault-reply
        http-post*))

(define* (vault-fetch id kind
                      #:key (log-port (current-error-port)))
  "Return an input port from which a bundle of the object with the given ID
and KIND (one of 'directory or 'revision) can be retrieved, or #f if the
object could not be found.

For a directory, the returned stream is a gzip-compressed tarball.  For a
revision, it is a gzip-compressed stream for 'git fast-import'."
  (let loop ((reply (query-vault id kind)))
    (match reply
      (#f
       (and=> (request-cooking id kind) loop))
      (_
       (match (vault-reply-status reply)
         ('done
          ;; Fetch the bundle.
          (let-values (((response port)
                        (http-get* (swh-url (vault-reply-fetch-url reply))
                                   #:streaming? #t
                                   #:verify-certificate?
                                   (%verify-swh-certificate?))))
            (if (= (response-code response) 200)
                port
                (begin                            ;shouldn't happen
                  (close-port port)
                  #f))))
         ('failed
          ;; Upon failure, we're supposed to try again.
          (format log-port "SWH vault: failure: ~a~%"
                  (vault-reply-progress-message reply))
          (format log-port "SWH vault: retrying...~%")
          (loop (request-cooking id kind)))
         ((and (or 'new 'pending) status)
          ;; Wait until the bundle shows up.
          (let ((message (vault-reply-progress-message reply)))
            (when (eq? 'new status)
              (format log-port "SWH vault: \
requested bundle cooking, waiting for completion...~%"))
            (when (string? message)
              (format log-port "SWH vault: ~a~%" message))

            ;; Wait long enough so we don't exhaust our maximum number of
            ;; requests per hour too fast (as of this writing, the limit is 60
            ;; requests per hour per IP address.)
            (sleep (if (eq? status 'new) 60 30))

            (loop (query-vault id kind)))))))))

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

(define (call-with-temporary-directory proc)      ;FIXME: factorize
  "Call PROC with a name of a temporary directory; close the directory and
delete it when leaving the dynamic extent of this call."
  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
         (template  (string-append directory "/guix-directory.XXXXXX"))
         (tmp-dir   (mkdtemp! template)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (proc tmp-dir))
      (lambda ()
        (false-if-exception (delete-file-recursively tmp-dir))))))

(define* (swh-download-directory id output
                                 #:key (log-port (current-error-port)))
  "Download from Software Heritage the directory with the given ID, and
unpack it to OUTPUT.  Return #t on success and #f on failure"
  (call-with-temporary-directory
   (lambda (directory)
     (match (vault-fetch id 'directory #:log-port log-port)
       (#f
        (format log-port
                "SWH: directory ~a could not be fetched from the vault~%"
                id)
        #f)
       ((? port? input)
        (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
          (dump-port input tar)
          (close-port input)
          (let ((status (close-pipe tar)))
            (unless (zero? status)
              (error "tar extraction failure" status)))

          (match (scandir directory)
            (("." ".." sub-directory)
             (copy-recursively (string-append directory "/" sub-directory)
                               output
                               #:log (%make-void-port "w"))
             #t))))))))

(define (commit-id? reference)
  "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
it is a tag name.  This is based on a simple heuristic so use with care!"
  (and (= (string-length reference) 40)
       (string-every char-set:hex-digit reference)))

(define* (swh-download url reference output
                       #:key (log-port (current-error-port)))
  "Download from Software Heritage a checkout of the Git tag or commit
REFERENCE originating from URL, and unpack it in OUTPUT.  Return #t on success
and #f on failure.

This procedure uses the \"vault\", which contains \"cooked\" directories in
the form of tarballs.  If the requested directory is not cooked yet, it will
wait until it becomes available, which could take several minutes."
  (match (if (commit-id? reference)
             (lookup-revision reference)
             (lookup-origin-revision url reference))
    ((? revision? revision)
     (format log-port "SWH: found revision ~a with directory at '~a'~%"
             (revision-id revision)
             (swh-url (revision-directory-url revision)))
     (swh-download-directory (revision-directory revision) output
                             #:log-port log-port))
    (#f
     #f)))