code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;; Copyright © 2018, 2020 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 gexp)
  #: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 utils)
  #: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
            with-database
            path-id
            sqlite-register
            register-path
            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 sqlite-exec
  ;; XXX: This is was missing from guile-sqlite3 until
  ;; <https://notabug.org/guile-sqlite3/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>.
  (let ((exec (pointer->procedure
               int
               (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3))
               '(* * * * *))))
    (lambda (db text)
      (let ((ret (exec ((@@ (sqlite3) db-pointer) db)
                       (string->pointer text)
                       %null-pointer %null-pointer %null-pointer)))
        (unless (zero? ret)
          ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret))))))

(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.0
(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 (sqlite-finalize stmt)
  ;; As of guile-sqlite3 0.1.0, cached statements aren't reset when
  ;; sqlite-finalize is invoked on them (see
  ;; https://notabug.org/guile-sqlite3/guile-sqlite3/issues/12).  This can
  ;; cause problems with automatically-started transactions, so we work around
  ;; it by wrapping sqlite-finalize so that sqlite-reset is always called.
  ;; This always works, because resetting a statement twice has no adverse
  ;; effects.  We can remove this once the fixed guile-sqlite3 is widespread.
  (sqlite-reset stmt)
  ((@ (sqlite3) sqlite-finalize) stmt))

(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* (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."

  ;; 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* (sqlite-register db #:key path (references '())
                          deriver hash nar-size time)
  "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
                                      (or time
                                          (current-time time-utc))))))
    ;; 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* (register-path path
                        #:key (references '()) deriver prefix
                        state-directory (deduplicate? #t)
                        (reset-timestamps? #t)
                        (schema (sql-schema)))
  "Register PATH as a valid store file, with REFERENCES as its list of
references, and DERIVER as its deriver (.drv that led to it.)  If PREFIX is
given, it must be the name of the directory containing the new store to
initialize; if STATE-DIRECTORY is given, it must be a string containing the
absolute file name to the state directory of the store being initialized.
Return #t on success.

Use with care as it directly modifies the store!  This is primarily meant to
be used internally by the daemon's build hook.

PATH must be protected from GC and locked during execution of this, typically
by adding it as a temp-root."
  (define db-file
    (store-database-file #:prefix prefix
                         #:state-directory state-directory))

  (parameterize ((sql-schema schema))
    (with-database db-file db
      (register-items db (list (store-info path deriver references))
                      #:prefix prefix
                      #:deduplicate? deduplicate?
                      #:reset-timestamps? reset-timestamps?
                      #:log-port (%make-void-port "w")))))

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

(define* (register-items db items
                         #:key prefix
                         (deduplicate? #t)
                         (reset-timestamps? #t)
                         registration-time
                         (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)
      (when reset-timestamps?
        (reset-timestamps real-file-name))
      (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)))
        (when deduplicate?
          (deduplicate real-file-name hash #:store store-dir)))))

  (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)))))

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 (rnrs io ports)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (guix serialization)
  #:export (nar-sha256
            deduplicate))

;; XXX: This port is used as a workaround on Guile <= 2.2.4 where
;; 'port-position' throws to 'out-of-range' when the offset is great than or
;; equal to 2^32: <https://bugs.gnu.org/32161>.
(define (counting-wrapper-port output-port)
  "Return two values: an output port that wraps OUTPUT-PORT, and a thunk to
retrieve the number of bytes written to OUTPUT-PORT."
  (let ((byte-count 0))
    (values (make-custom-binary-output-port "counting-wrapper"
                                            (lambda (bytes offset count)
                                              (put-bytevector output-port bytes
                                                              offset count)
                                              (set! byte-count
                                                (+ byte-count count))
                                              count)
                                            (lambda ()
                                              byte-count)
                                            #f
                                            (lambda ()
                                              (close-port output-port)))
            (lambda ()
              byte-count))))

(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))
                ((wrapper get-size) (counting-wrapper-port port)))
    (write-file file wrapper)
    (force-output wrapper)
    (force-output port)
    (let ((hash (get-hash))
          (size (get-size)))
      (close-port wrapper)
      (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"))

    (mkdir-p links-directory)
    (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 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)))))))))))


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 © 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 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.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 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))

;;; 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)
                   (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 visit-snapshot-url (origin-visits origin))
        ((visit . _)
         (let ((snapshot (visit-snapshot visit)))
           (match (and=> (find (lambda (branch)
                                 (string=? (string-append "refs/tags/" 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 (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 (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 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)))
     (call-with-temporary-directory
      (lambda (directory)
        (match (vault-fetch (revision-directory revision) 'directory
                            #:log-port log-port)
          (#f
           (format log-port
                   "SWH: directory ~a could not be fetched from the vault~%"
                   (revision-directory revision))
           #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))))))))
    (#f
     #f)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 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 tests)
  #:use-module ((guix config) #:select (%storedir %localstatedir))
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix base32)
  #:use-module (guix serialization)
  #:use-module (guix monads)
  #:use-module ((guix utils) #:select (substitute-keyword-arguments))
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:use-module ((gcrypt hash) #:hide (sha256))
  #:use-module (guix build-system gnu)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bootstrap)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (ice-9 binary-ports)
  #:use-module (web uri)
  #:export (open-connection-for-tests
            with-external-store
            %seed
            random-text
            random-bytevector
            file=?
            canonical-file?
            network-reachable?
            shebang-too-long?
            with-environment-variable

            search-bootstrap-binary

            mock
            %test-substitute-urls
            test-assertm
            test-equalm
            %substitute-directory
            with-derivation-narinfo
            with-derivation-substitute
            dummy-package
            dummy-origin

            gnu-make-for-tests))

;;; Commentary:
;;;
;;; This module provide shared infrastructure for the test suite.  For
;;; internal use only.
;;;
;;; Code:

(define %test-substitute-urls
  ;; URLs where to look for substitutes during tests.
  (make-parameter
   (or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list)
       '())))

(define* (open-connection-for-tests #:optional (uri (%daemon-socket-uri)))
  "Open a connection to the build daemon for tests purposes and return it."
  (guard (c ((store-error? c)
             (format (current-error-port)
                     "warning: build daemon error: ~s~%" c)
             #f))
    (let ((store (open-connection uri)))
      ;; Make sure we build everything by ourselves.
      (set-build-options store
                         #:use-substitutes? #f
                         #:substitute-urls (%test-substitute-urls))

      ;; Use the bootstrap Guile when running tests, so we don't end up
      ;; building everything in the temporary test store.
      (%guile-for-build (package-derivation store %bootstrap-guile))

      store)))

(define (bootstrap-binary-file program system)
  "Return the absolute file name where bootstrap binary PROGRAM for SYSTEM is
stored."
  (string-append (dirname (search-path %load-path
                                       "gnu/packages/bootstrap.scm"))
                 "/bootstrap/" system "/" program))

(define (search-bootstrap-binary file-name system)
  "Search the bootstrap binary FILE-NAME for SYSTEM.  Raise an error if not
found."
  ;; Note: Keep bootstrap binaries on the local file system so that the 'guix'
  ;; package can provide them as inputs and copy them to the right place.
  (let* ((system (match system
                   ("x86_64-linux" "i686-linux")
                   (_ system)))
         (file   (bootstrap-binary-file file-name system)))
    (if (file-exists? file)
        file
        (with-store store
          (run-with-store store
            (mlet %store-monad ((drv (origin->derivation
                                      (bootstrap-executable file-name system))))
              (mbegin %store-monad
                (built-derivations (list drv))
                (begin
                  (mkdir-p (dirname file))
                  (copy-file (derivation->output-path drv) file)
                  (return file)))))))))

(define (call-with-external-store proc)
  "Call PROC with an open connection to the external store or #f it there is
no external store to talk to."
  (parameterize ((%daemon-socket-uri
                  (string-append %localstatedir
                                 "/guix/daemon-socket/socket"))
                 (%store-prefix %storedir))
    (define store
      (catch #t
        (lambda ()
          (open-connection))
        (const #f)))

    (dynamic-wind
      (const #t)
      (lambda ()
        ;; Since we're using a different store we must clear the
        ;; package-derivation cache.
        (hash-clear! (@@ (guix packages) %derivation-cache))

        (proc store))
      (lambda ()
        (when store
          (close-connection store))))))

(define-syntax-rule (with-external-store store exp ...)
  "Evaluate EXP with STORE bound to the external store rather than the
temporary test store, or #f if there is no external store to talk to.

This is meant to be used for tests that need to build packages that would be
too expensive to build entirely in the test store."
  (call-with-external-store (lambda (store) exp ...)))

(define (random-seed)
  (or (and=> (getenv "GUIX_TESTS_RANDOM_SEED")
             number->string)
      (logxor (getpid) (car (gettimeofday)))))

(define %seed
  (let ((seed (random-seed)))
    (format (current-error-port) "random seed for tests: ~a~%"
            seed)
    (seed->random-state seed)))

(define (random-text)
  "Return the hexadecimal representation of a random number."
  (number->string (random (expt 2 256) %seed) 16))

(define (random-bytevector n)
  "Return a random bytevector of N bytes."
  (let ((bv (make-bytevector n)))
    (let loop ((i 0))
      (if (< i n)
          (begin
            (bytevector-u8-set! bv i (random 256 %seed))
            (loop (1+ i)))
          bv))))

(define (file=? a b)
  "Return true if files A and B have the same type and same content."
  (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
       (case (stat:type (lstat a))
         ((regular)
          (equal?
           (call-with-input-file a get-bytevector-all)
           (call-with-input-file b get-bytevector-all)))
         ((symlink)
          (string=? (readlink a) (readlink b)))
         (else
          (error "what?" (lstat a))))))

(define (canonical-file? file)
  "Return #t if FILE is in the store, is read-only, and its mtime is 1."
  (let ((st (lstat file)))
    (or (not (string-prefix? (%store-prefix) file))
        (eq? 'symlink (stat:type st))
        (and (= 1 (stat:mtime st))
             (zero? (logand #o222 (stat:mode st)))))))

(define (network-reachable?)
  "Return true if we can reach the Internet."
  (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))

(define-syntax-rule (mock (module proc replacement) body ...)
  "Within BODY, replace the definition of PROC from MODULE with the definition
given by REPLACEMENT."
  (let* ((m (resolve-module 'module))
         (original (module-ref m 'proc)))
    (dynamic-wind
      (lambda () (module-set! m 'proc replacement))
      (lambda () body ...)
      (lambda () (module-set! m 'proc original)))))

(define-syntax-rule (test-assertm name exp)
  "Like 'test-assert', but EXP is a monadic value.  A new connection to the
store is opened."
  (test-assert name
    (let ((store (open-connection-for-tests)))
      (dynamic-wind
        (const #t)
        (lambda ()
          (run-with-store store exp
                          #:guile-for-build (%guile-for-build)))
        (lambda ()
          (close-connection store))))))

(define-syntax-rule (test-equalm name value exp)
  "Like 'test-equal', but EXP is a monadic value.  A new connection to the
store is opened."
  (test-equal name
    value
    (with-store store
      (run-with-store store exp
                      #:guile-for-build (%guile-for-build)))))

(define-syntax-rule (with-environment-variable variable value body ...)
  "Run BODY with VARIABLE set to VALUE."
  (let ((orig (getenv variable)))
    (dynamic-wind
      (lambda ()
        (setenv variable value))
      (lambda ()
        body ...)
      (lambda ()
        (if orig
            (setenv variable orig)
            (unsetenv variable))))))

;;;
;;; Narinfo files, as used by the substituter.
;;;

(define* (derivation-narinfo drv #:key (nar "example.nar")
                             (sha256 (make-bytevector 32 0))
                             (references '()))
  "Return the contents of the narinfo corresponding to DRV, with the specified
REFERENCES (a list of store items); NAR should be the file name of the archive
containing the substitute for DRV, and SHA256 is the expected hash."
  (format #f "StorePath: ~a
URL: ~a
Compression: none
NarSize: 1234
NarHash: sha256:~a
References: ~a
System: ~a
Deriver: ~a~%"
          (derivation->output-path drv)       ; StorePath
          nar                                 ; URL
          (bytevector->nix-base32-string sha256)  ; NarHash
          (string-join (map basename references)) ; References
          (derivation-system drv)             ; System
          (basename
           (derivation-file-name drv))))      ; Deriver

(define %substitute-directory
  (make-parameter
   (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
          (compose uri-path string->uri))))

(define* (call-with-derivation-narinfo drv thunk
                                       #:key
                                       (sha256 (make-bytevector 32 0))
                                       (references '()))
  "Call THUNK in a context where fake substituter data, as read by 'guix
substitute', has been installed for DRV.  SHA256 is the hash of the
expected output of DRV."
  (let* ((output  (derivation->output-path drv))
         (dir     (%substitute-directory))
         (info    (string-append dir "/nix-cache-info"))
         (narinfo (string-append dir "/" (store-path-hash-part output)
                                 ".narinfo")))
    (dynamic-wind
      (lambda ()
        (call-with-output-file info
          (lambda (p)
            (format p "StoreDir: ~a\nWantMassQuery: 0\n"
                    (%store-prefix))))
        (call-with-output-file narinfo
          (lambda (p)
            (display (derivation-narinfo drv #:sha256 sha256
                                         #:references references)
                     p))))
      thunk
      (lambda ()
        (delete-file narinfo)
        (delete-file info)))))

(define-syntax with-derivation-narinfo
  (syntax-rules (sha256 references =>)
    "Evaluate BODY in a context where DRV looks substitutable from the
substituter's viewpoint."
    ((_ drv (sha256 => hash) (references => refs) body ...)
     (call-with-derivation-narinfo drv
       (lambda () body ...)
       #:sha256 hash
       #:references refs))
    ((_ drv (sha256 => hash) body ...)
     (with-derivation-narinfo drv
       (sha256 => hash) (references => '())
       body ...))
    ((_ drv body ...)
     (call-with-derivation-narinfo drv
       (lambda ()
         body ...)))))

(define* (call-with-derivation-substitute drv contents thunk
                                          #:key
                                          sha256
                                          (references '()))
  "Call THUNK in a context where a substitute for DRV has been installed,
using CONTENTS, a string, as its contents.  If SHA256 is true, use it as the
expected hash of the substitute; otherwise use the hash of the nar containing
CONTENTS."
  (define dir (%substitute-directory))
  (dynamic-wind
    (lambda ()
      (call-with-output-file (string-append dir "/example.out")
        (lambda (port)
          (display contents port)))
      (call-with-output-file (string-append dir "/example.nar")
        (lambda (p)
          (write-file (string-append dir "/example.out") p))))
    (lambda ()
      (let ((hash (call-with-input-file (string-append dir "/example.nar")
                    port-sha256)))
        ;; Create fake substituter data, to be read by 'guix substitute'.
        (call-with-derivation-narinfo drv
          thunk
          #:sha256 (or sha256 hash)
          #:references references)))
    (lambda ()
      (delete-file (string-append dir "/example.out"))
      (delete-file (string-append dir "/example.nar")))))

(define (shebang-too-long?)
  "Return true if the typical shebang in the current store would exceed
Linux's static limit---the BINPRM_BUF_SIZE constant, normally 128 characters
all included."
  (define shebang
    (string-append "#!" (%store-prefix) "/"
                   (make-string 32 #\a)
                   "-bootstrap-binaries-0/bin/bash\0"))

  (> (string-length shebang) 128))

(define-syntax with-derivation-substitute
  (syntax-rules (sha256 references =>)
    "Evaluate BODY in a context where DRV is substitutable with the given
CONTENTS."
    ((_ drv contents (sha256 => hash) (references => refs) body ...)
     (call-with-derivation-substitute drv contents
       (lambda () body ...)
       #:sha256 hash
       #:references refs))
    ((_ drv contents (sha256 => hash) body ...)
     (with-derivation-substitute drv contents
       (sha256 => hash) (references => '())
       body ...))
    ((_ drv contents body ...)
     (call-with-derivation-substitute drv contents
       (lambda ()
         body ...)))))

(define-syntax-rule (dummy-package name* extra-fields ...)
  "Return a \"dummy\" package called NAME*, with all its compulsory fields
initialized with default values, and with EXTRA-FIELDS set as specified."
  (let ((p (package
             (name name*) (version "0") (source #f)
             (build-system gnu-build-system)
             (synopsis #f) (description #f)
             (home-page #f) (license #f))))
    (package (inherit p) extra-fields ...)))

(define-syntax-rule (dummy-origin extra-fields ...)
  "Return a \"dummy\" origin, with all its compulsory fields initialized with
default values, and with EXTRA-FIELDS set as specified."
  (let ((o (origin (method #f) (uri "http://www.example.com")
                   (sha256 (base32 (make-string 52 #\x))))))
    (origin (inherit o) extra-fields ...)))

(define gnu-make-for-tests
  ;; This is a variant of 'gnu-make-boot0' that can be built with minimal
  ;; resources.
  (package-with-bootstrap-guile
   (package
     (inherit gnu-make)
     (name "make-test-boot0")
     (arguments
      `(#:guile ,%bootstrap-guile
        #:implicit-inputs? #f
        #:tests? #f                               ;cannot run "make check"
        ,@(substitute-keyword-arguments (package-arguments gnu-make)
            ((#:configure-flags flags ''())
             ;; As in 'gnu-make-boot0', work around a 'config.status' defect.
             `(cons "--disable-dependency-tracking" ,flags))
            ((#:phases phases)
             `(modify-phases ,phases
                (replace 'build
                  (lambda _
                    (invoke "./build.sh")
                    #t))
                (replace 'install
                  (lambda* (#:key outputs #:allow-other-keys)
                    (let* ((out (assoc-ref outputs "out"))
                           (bin (string-append out "/bin")))
                      (install-file "make" bin)
                      #t))))))))
     (native-inputs '())                          ;no need for 'pkg-config'
     (inputs %bootstrap-inputs-for-tests))))

;; Local Variables:
;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
;; End:

;;; tests.scm ends here


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

(define-module (guix tests git)
  #:use-module (git)
  #:use-module ((guix git) #:select (with-repository))
  #:use-module (guix utils)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 control)
  #:export (git-command
            with-temporary-git-repository
            find-commit))

(define git-command
  (make-parameter "git"))

(define (populate-git-repository directory directives)
  "Initialize a new Git checkout and repository in DIRECTORY and apply
DIRECTIVES.  Each element of DIRECTIVES is an sexp like:

  (add \"foo.txt\" \"hi!\")

Return DIRECTORY on success."

  ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do
  ;; all this, so resort to the "git" command.
  (define (git command . args)
    ;; Make sure Git doesn't rely on the user's config.
    (call-with-temporary-directory
     (lambda (home)
       (call-with-output-file (string-append home "/.gitconfig")
         (lambda (port)
           (display "[user]
  email = charlie@example.org\n  name = Charlie Guix\n"
                    port)))

       (with-environment-variables
        `(("GIT_CONFIG_NOSYSTEM" "1")
          ("GIT_ATTR_NOSYSTEM" "1")
          ("HOME" ,home))
        (apply invoke (git-command) "-C" directory
               command args)))))

  (mkdir-p directory)
  (git "init")

  (let loop ((directives directives))
    (match directives
      (()
       directory)
      ((('add file contents) rest ...)
       (let ((file (string-append directory "/" file)))
         (mkdir-p (dirname file))
         (call-with-output-file file
           (lambda (port)
             (display (if (string? contents)
                          contents
                          (with-repository directory repository
                            (contents repository)))
                      port)))
         (git "add" file)
         (loop rest)))
      ((('remove file) rest ...)
       (git "rm" "-f" file)
       (loop rest))
      ((('commit text) rest ...)
       (git "commit" "-m" text)
       (loop rest))
      ((('commit text ('signer fingerprint)) rest ...)
       (git "commit" "-m" text (string-append "--gpg-sign=" fingerprint))
       (loop rest))
      ((('tag name) rest ...)
       (git "tag" name)
       (loop rest))
      ((('branch name) rest ...)
       (git "branch" name)
       (loop rest))
      ((('checkout branch) rest ...)
       (git "checkout" branch)
       (loop rest))
      ((('merge branch message) rest ...)
       (git "merge" branch "-m" message)
       (loop rest))
      ((('merge branch message ('signer fingerprint)) rest ...)
       (git "merge" branch "-m" message
            (string-append "--gpg-sign=" fingerprint))
       (loop rest)))))

(define (call-with-temporary-git-repository directives proc)
  (call-with-temporary-directory
   (lambda (directory)
     (populate-git-repository directory directives)
     (proc directory))))

(define-syntax-rule (with-temporary-git-repository directory
                                                   directives exp ...)
  "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
per DIRECTIVES."
  (call-with-temporary-git-repository directives
                                      (lambda (directory)
                                        exp ...)))

(define (find-commit repository message)
  "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
  (let/ec return
    (fold-commits (lambda (commit _)
                    (and (string-contains (commit-message commit)
                                          message)
                         (return commit)))
                  #f
                  repository)
    (error "commit not found" message)))


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

(define-module (guix tests gnupg)
  #:use-module (guix openpgp)
  #:use-module (guix utils)
  #:use-module (guix build utils)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:export (gpg-command
            gpgconf-command
            with-fresh-gnupg-setup

            %ed25519-public-key-file
            %ed25519-secret-key-file
            %ed25519bis-public-key-file
            %ed25519bis-secret-key-file

            read-openpgp-packet
            key-fingerprint
            key-id))

(define gpg-command
  (make-parameter "gpg"))

(define gpgconf-command
  (make-parameter "gpgconf"))

(define (call-with-fresh-gnupg-setup imported thunk)
  (call-with-temporary-directory
   (lambda (home)
     (with-environment-variables `(("GNUPGHOME" ,home))
       (dynamic-wind
         (lambda ()
           (for-each (lambda (file)
                       (invoke (gpg-command) "--import" file))
                     imported))
         thunk
         (lambda ()
           ;; Terminate 'gpg-agent' & co.
           (invoke (gpgconf-command) "--kill" "all")))))))

(define-syntax-rule (with-fresh-gnupg-setup imported exp ...)
  "Evaluate EXP in the context of a fresh GnuPG setup where all the files
listed in IMPORTED, and only them, have been imported.  This sets 'GNUPGHOME'
such that the user's real GnuPG files are left untouched.  The 'gpg-agent'
process is terminated afterwards."
  (call-with-fresh-gnupg-setup imported (lambda () exp ...)))

(define %ed25519-public-key-file
  (search-path %load-path "tests/ed25519.key"))
(define %ed25519-secret-key-file
  (search-path %load-path "tests/ed25519.sec"))
(define %ed25519bis-public-key-file
  (search-path %load-path "tests/ed25519bis.key"))
(define %ed25519bis-secret-key-file
  (search-path %load-path "tests/ed25519bis.sec"))

(define (read-openpgp-packet file)
  (get-openpgp-packet
   (open-bytevector-input-port
    (call-with-input-file file read-radix-64))))

(define key-fingerprint
  (compose openpgp-format-fingerprint
           openpgp-public-key-fingerprint
           read-openpgp-packet))