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

(define-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-60)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 format)
  #:use-module (ice-9 threads)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:re-export (alist-cons
               alist-delete

               ;; Note: Re-export 'delete' to allow for proper syntax matching
               ;; in 'modify-phases' forms.  See
               ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
               delete)
  #:export (%store-directory
            store-file-name?
            strip-store-file-name
            package-name->name+version
            parallel-job-count

            directory-exists?
            executable-file?
            symbolic-link?
            call-with-ascii-input-file
            elf-file?
            ar-file?
            gzip-file?
            reset-gzip-timestamp
            with-directory-excursion
            mkdir-p
            install-file
            make-file-writable
            copy-recursively
            delete-file-recursively
            file-name-predicate
            find-files
            false-if-file-not-found

            search-path-as-list
            set-path-environment-variable
            search-path-as-string->list
            list->search-path-as-string
            which

            every*
            alist-cons-before
            alist-cons-after
            alist-replace
            modify-phases

            with-atomic-file-replacement
            substitute
            substitute*
            dump-port
            set-file-time
            patch-shebang
            patch-makefile-SHELL
            patch-/usr/bin/file
            fold-port-matches
            remove-store-references
            wrap-program

            invoke
            invoke-error?
            invoke-error-program
            invoke-error-arguments
            invoke-error-exit-status
            invoke-error-term-signal
            invoke-error-stop-signal

            locale-category->string))

;;;
;;; Directories.
;;;

(define (%store-directory)
  "Return the directory name of the store."
  (or (getenv "NIX_STORE")
      "/gnu/store"))

(define (store-file-name? file)
  "Return true if FILE is in the store."
  (string-prefix? (%store-directory) file))

(define (strip-store-file-name file)
  "Strip the '/gnu/store' and hash from FILE, a store file name.  The result
is typically a \"PACKAGE-VERSION\" string."
  (string-drop file
               (+ 34 (string-length (%store-directory)))))

(define (package-name->name+version name)
  "Given NAME, a package name like \"foo-0.9.1b\", return two values:
\"foo\" and \"0.9.1b\".  When the version part is unavailable, NAME and
#f are returned.  The first hyphen followed by a digit is considered to
introduce the version part."
  ;; See also `DrvName' in Nix.

  (define number?
    (cut char-set-contains? char-set:digit <>))

  (let loop ((chars   (string->list name))
             (prefix '()))
    (match chars
      (()
       (values name #f))
      ((#\- (? number? n) rest ...)
       (values (list->string (reverse prefix))
               (list->string (cons n rest))))
      ((head tail ...)
       (loop tail (cons head prefix))))))

(define parallel-job-count
  ;; Number of processes to be passed next to GNU Make's `-j' argument.
  (make-parameter
   (match (getenv "NIX_BUILD_CORES")              ;set by the daemon
     (#f  1)
     ("0" (current-processor-count))
     (x   (or (string->number x) 1)))))

(define (directory-exists? dir)
  "Return #t if DIR exists and is a directory."
  (let ((s (stat dir #f)))
    (and s
         (eq? 'directory (stat:type s)))))

(define (executable-file? file)
  "Return #t if FILE exists and is executable."
  (let ((s (stat file #f)))
    (and s
         (not (zero? (logand (stat:mode s) #o100))))))

(define (symbolic-link? file)
  "Return #t if FILE is a symbolic link (aka. \"symlink\".)"
  (eq? (stat:type (lstat file)) 'symlink))

(define (call-with-ascii-input-file file proc)
  "Open FILE as an ASCII or binary file, and pass the resulting port to
PROC.  FILE is closed when PROC's dynamic extent is left.  Return the
return values of applying PROC to the port."
  (let ((port (with-fluids ((%default-port-encoding #f))
                ;; Use "b" so that `open-file' ignores `coding:' cookies.
                (open-file file "rb"))))
    (dynamic-wind
      (lambda ()
        #t)
      (lambda ()
        (proc port))
      (lambda ()
        (close-input-port port)))))

(define (file-header-match header)
  "Return a procedure that returns true when its argument is a file starting
with the bytes in HEADER, a bytevector."
  (define len
    (bytevector-length header))

  (lambda (file)
    "Return true if FILE starts with the right magic bytes."
    (define (get-header)
      (call-with-input-file file
        (lambda (port)
          (get-bytevector-n port len))
        #:binary #t #:guess-encoding #f))

    (catch 'system-error
      (lambda ()
        (equal? (get-header) header))
      (lambda args
        (if (= EISDIR (system-error-errno args))
            #f                                    ;FILE is a directory
            (apply throw args))))))

(define %elf-magic-bytes
  ;; Magic bytes of ELF files.  See <elf.h>.
  (u8-list->bytevector (map char->integer (string->list "\x7FELF"))))

(define elf-file?
  (file-header-match %elf-magic-bytes))

(define %ar-magic-bytes
  ;; Magic bytes of archives created by 'ar'.  See <ar.h>.
  (u8-list->bytevector (map char->integer (string->list "!<arch>\n"))))

(define ar-file?
  (file-header-match %ar-magic-bytes))

(define %gzip-magic-bytes
  ;; Magic bytes of gzip file.  Beware, it's a small header so there could be
  ;; false positives.
  #vu8(#x1f #x8b))

(define gzip-file?
  (file-header-match %gzip-magic-bytes))

(define* (reset-gzip-timestamp file #:key (keep-mtime? #t))
  "If FILE is a gzip file, reset its embedded timestamp (as with 'gzip
--no-name') and return true.  Otherwise return #f.  When KEEP-MTIME? is true,
preserve FILE's modification time."
  (let ((stat (stat file))
        (port (open file O_RDWR)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (and (= 4 (seek port 4 SEEK_SET))
             (put-bytevector port #vu8(0 0 0 0))))
      (lambda ()
        (close-port port)
        (set-file-time file stat)))))

(define-syntax-rule (with-directory-excursion dir body ...)
  "Run BODY with DIR as the process's current directory."
  (let ((init (getcwd)))
   (dynamic-wind
     (lambda ()
       (chdir dir))
     (lambda ()
       body ...)
     (lambda ()
       (chdir init)))))

(define (mkdir-p dir)
  "Create directory DIR and all its ancestors."
  (define absolute?
    (string-prefix? "/" dir))

  (define not-slash
    (char-set-complement (char-set #\/)))

  (let loop ((components (string-tokenize dir not-slash))
             (root       (if absolute?
                             ""
                             ".")))
    (match components
      ((head tail ...)
       (let ((path (string-append root "/" head)))
         (catch 'system-error
           (lambda ()
             (mkdir path)
             (loop tail path))
           (lambda args
             (if (= EEXIST (system-error-errno args))
                 (loop tail path)
                 (apply throw args))))))
      (() #t))))

(define (install-file file directory)
  "Create DIRECTORY if it does not exist and copy FILE in there under the same
name."
  (mkdir-p directory)
  (copy-file file (string-append directory "/" (basename file))))

(define (make-file-writable file)
  "Make FILE writable for its owner."
  (let ((stat (lstat file)))                      ;XXX: symlinks
    (chmod file (logior #o600 (stat:perms stat)))))

(define* (copy-recursively source destination
                           #:key
                           (log (current-output-port))
                           (follow-symlinks? #f)
                           keep-mtime?)
  "Copy SOURCE directory to DESTINATION.  Follow symlinks if FOLLOW-SYMLINKS?
is true; otherwise, just preserve them.  When KEEP-MTIME? is true, keep the
modification time of the files in SOURCE on those of DESTINATION.  Write
verbose output to the LOG port."
  (define strip-source
    (let ((len (string-length source)))
      (lambda (file)
        (substring file len))))

  (file-system-fold (const #t)                    ; enter?
                    (lambda (file stat result)    ; leaf
                      (let ((dest (string-append destination
                                                 (strip-source file))))
                        (format log "`~a' -> `~a'~%" file dest)
                        (case (stat:type stat)
                          ((symlink)
                           (let ((target (readlink file)))
                             (symlink target dest)))
                          (else
                           (copy-file file dest)
                           (when keep-mtime?
                             (set-file-time dest stat))))))
                    (lambda (dir stat result)     ; down
                      (let ((target (string-append destination
                                                   (strip-source dir))))
                        (mkdir-p target)
                        (when keep-mtime?
                          (set-file-time target stat))))
                    (lambda (dir stat result)     ; up
                      result)
                    (const #t)                    ; skip
                    (lambda (file stat errno result)
                      (format (current-error-port) "i/o error: ~a: ~a~%"
                              file (strerror errno))
                      #f)
                    #t
                    source

                    (if follow-symlinks?
                        stat
                        lstat)))

(define* (delete-file-recursively dir
                                  #:key follow-mounts?)
  "Delete DIR recursively, like `rm -rf', without following symlinks.  Don't
follow mount points either, unless FOLLOW-MOUNTS? is true.  Report but ignore
errors."
  (let ((dev (stat:dev (lstat dir))))
    (file-system-fold (lambda (dir stat result)    ; enter?
                        (or follow-mounts?
                            (= dev (stat:dev stat))))
                      (lambda (file stat result)   ; leaf
                        (delete-file file))
                      (const #t)                   ; down
                      (lambda (dir stat result)    ; up
                        (rmdir dir))
                      (const #t)                   ; skip
                      (lambda (file stat errno result)
                        (format (current-error-port)
                                "warning: failed to delete ~a: ~a~%"
                                file (strerror errno)))
                      #t
                      dir

                      ;; Don't follow symlinks.
                      lstat)))

(define (file-name-predicate regexp)
  "Return a predicate that returns true when passed a file name whose base
name matches REGEXP."
  (let ((file-rx (if (regexp? regexp)
                     regexp
                     (make-regexp regexp))))
    (lambda (file stat)
      (regexp-exec file-rx (basename file)))))

(define* (find-files dir #:optional (pred (const #t))
                     #:key (stat lstat)
                     directories?
                     fail-on-error?)
  "Return the lexicographically sorted list of files under DIR for which PRED
returns true.  PRED is passed two arguments: the absolute file name, and its
stat buffer; the default predicate always returns true.  PRED can also be a
regular expression, in which case it is equivalent to (file-name-predicate
PRED).  STAT is used to obtain file information; using 'lstat' means that
symlinks are not followed.  If DIRECTORIES? is true, then directories will
also be included.  If FAIL-ON-ERROR? is true, raise an exception upon error."
  (let ((pred (if (procedure? pred)
                  pred
                  (file-name-predicate pred))))
    ;; Sort the result to get deterministic results.
    (sort (file-system-fold (const #t)
                            (lambda (file stat result) ; leaf
                              (if (pred file stat)
                                  (cons file result)
                                  result))
                            (lambda (dir stat result) ; down
                              (if (and directories?
                                       (pred dir stat))
                                  (cons dir result)
                                  result))
                            (lambda (dir stat result) ; up
                              result)
                            (lambda (file stat result) ; skip
                              result)
                            (lambda (file stat errno result)
                              (format (current-error-port) "find-files: ~a: ~a~%"
                                      file (strerror errno))
                              (when fail-on-error?
                                (error "find-files failed"))
                              result)
                            '()
                            dir
                            stat)
          string<?)))

(define-syntax-rule (false-if-file-not-found exp)
  "Evaluate EXP but return #f if it raises to 'system-error with ENOENT."
  (catch 'system-error
    (lambda () exp)
    (lambda args
      (if (= ENOENT (system-error-errno args))
          #f
          (apply throw args)))))

;;;
;;; Search paths.
;;;

(define* (search-path-as-list files input-dirs
                              #:key (type 'directory) pattern)
  "Return the list of directories among FILES of the given TYPE (a symbol as
returned by 'stat:type') that exist in INPUT-DIRS.  Example:

  (search-path-as-list '(\"share/emacs/site-lisp\" \"share/emacs/24.1\")
                       (list \"/package1\" \"/package2\" \"/package3\"))
  => (\"/package1/share/emacs/site-lisp\"
      \"/package3/share/emacs/site-lisp\")

When PATTERN is true, it is a regular expression denoting file names to look
for under the directories designated by FILES.  For example:

  (search-path-as-list '(\"xml\") (list docbook-xml docbook-xsl)
                       #:type 'regular
                       #:pattern \"^catalog\\\\.xml$\")
  => (\"/…/xml/dtd/docbook/catalog.xml\"
      \"/…/xml/xsl/docbook-xsl-1.78.1/catalog.xml\")
"
  (append-map (lambda (input)
                (append-map (lambda (file)
                              (let ((file (string-append input "/" file)))
                                (if pattern
                                    (find-files file (lambda (file stat)
                                                       (and stat
                                                            (eq? type (stat:type stat))
                                                            ((file-name-predicate pattern) file stat)))
                                                #:stat stat
                                                #:directories? #t)
                                    (let ((stat (stat file #f)))
                                      (if (and stat (eq? type (stat:type stat)))
                                          (list file)
                                          '())))))
                            files))
              (delete-duplicates input-dirs)))

(define (list->search-path-as-string lst separator)
  (if separator
      (string-join lst separator)
      (match lst
        ((head rest ...) head)
        (() ""))))

(define* (search-path-as-string->list path #:optional (separator #\:))
  (if separator
      (string-tokenize path
                       (char-set-complement (char-set separator)))
      (list path)))

(define* (set-path-environment-variable env-var files input-dirs
                                        #:key
                                        (separator ":")
                                        (type 'directory)
                                        pattern)
  "Look for each of FILES of the given TYPE (a symbol as returned by
'stat:type') in INPUT-DIRS.  Set ENV-VAR to a SEPARATOR-separated path
accordingly.  Example:

  (set-path-environment-variable \"PKG_CONFIG\"
                                 '(\"lib/pkgconfig\")
                                 (list package1 package2))

When PATTERN is not #f, it must be a regular expression (really a string)
denoting file names to look for under the directories designated by FILES:

  (set-path-environment-variable \"XML_CATALOG_FILES\"
                                 '(\"xml\")
                                 (list docbook-xml docbook-xsl)
                                 #:type 'regular
                                 #:pattern \"^catalog\\\\.xml$\")
"
  (let* ((path  (search-path-as-list files input-dirs
                                     #:type type
                                     #:pattern pattern))
         (value (list->search-path-as-string path separator)))
    (if (string-null? value)
        (begin
          ;; Never set ENV-VAR to an empty string because often, the empty
          ;; string is equivalent to ".".  This is the case for
          ;; GUILE_LOAD_PATH in Guile 2.0, for instance.
          (unsetenv env-var)
          (format #t "environment variable `~a' unset~%" env-var))
        (begin
          (setenv env-var value)
          (format #t "environment variable `~a' set to `~a'~%"
                  env-var value)))))

(define (which program)
  "Return the complete file name for PROGRAM as found in $PATH, or #f if
PROGRAM could not be found."
  (search-path (search-path-as-string->list (getenv "PATH"))
               program))

;;;
;;; Phases.
;;;
;;; In (guix build gnu-build-system), there are separate phases (configure,
;;; build, test, install).  They are represented as a list of name/procedure
;;; pairs.  The following procedures make it easy to change the list of
;;; phases.
;;;

(define (every* pred lst)
  "This is like 'every', but process all the elements of LST instead of
stopping as soon as PRED returns false.  This is useful when PRED has side
effects, such as displaying warnings or error messages."
  (let loop ((lst    lst)
             (result #t))
    (match lst
      (()
       result)
      ((head . tail)
       (loop tail (and (pred head) result))))))

(define* (alist-cons-before reference key value alist
                            #:optional (key=? equal?))
  "Insert the KEY/VALUE pair before the first occurrence of a pair whose key
is REFERENCE in ALIST.  Use KEY=? to compare keys."
  (let-values (((before after)
                (break (match-lambda
                        ((k . _)
                         (key=? k reference)))
                       alist)))
    (append before (alist-cons key value after))))

(define* (alist-cons-after reference key value alist
                           #:optional (key=? equal?))
  "Insert the KEY/VALUE pair after the first occurrence of a pair whose key
is REFERENCE in ALIST.  Use KEY=? to compare keys."
  (let-values (((before after)
                (break (match-lambda
                        ((k . _)
                         (key=? k reference)))
                       alist)))
    (match after
      ((reference after ...)
       (append before (cons* reference `(,key . ,value) after)))
      (()
       (append before `((,key . ,value)))))))

(define* (alist-replace key value alist #:optional (key=? equal?))
  "Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair.
An error is raised when no such pair exists."
  (let-values (((before after)
                (break (match-lambda
                        ((k . _)
                         (key=? k key)))
                       alist)))
    (match after
      ((_ after ...)
       (append before (alist-cons key value after))))))

(define-syntax-rule (modify-phases phases mod-spec ...)
  "Modify PHASES sequentially as per each MOD-SPEC, which may have one of the
following forms:

  (delete <old-phase-name>)
  (replace <old-phase-name> <new-phase>)
  (add-before <old-phase-name> <new-phase-name> <new-phase>)
  (add-after <old-phase-name> <new-phase-name> <new-phase>)

Where every <*-phase-name> is an expression evaluating to a symbol, and
<new-phase> an expression evaluating to a procedure."
  (let* ((phases* phases)
         (phases* (%modify-phases phases* mod-spec))
         ...)
    phases*))

(define-syntax %modify-phases
  (syntax-rules (delete replace add-before add-after)
    ((_ phases (delete old-phase-name))
     (alist-delete old-phase-name phases))
    ((_ phases (replace old-phase-name new-phase))
     (alist-replace old-phase-name new-phase phases))
    ((_ phases (add-before old-phase-name new-phase-name new-phase))
     (alist-cons-before old-phase-name new-phase-name new-phase phases))
    ((_ phases (add-after old-phase-name new-phase-name new-phase))
     (alist-cons-after old-phase-name new-phase-name new-phase phases))))

(define-condition-type &invoke-error &error
  invoke-error?
  (program      invoke-error-program)
  (arguments    invoke-error-arguments)
  (exit-status  invoke-error-exit-status)
  (term-signal  invoke-error-term-signal)
  (stop-signal  invoke-error-stop-signal))

(define (invoke program . args)
  "Invoke PROGRAM with the given ARGS.  Raise an exception
if the exit code is non-zero; otherwise return #t."
  (let ((code (apply system* program args)))
    (unless (zero? code)
      (raise (condition (&invoke-error
                         (program program)
                         (arguments args)
                         (exit-status (status:exit-val code))
                         (term-signal (status:term-sig code))
                         (stop-signal (status:stop-sig code))))))
    #t))

;;;
;;; Text substitution (aka. sed).
;;;

(define (with-atomic-file-replacement file proc)
  "Call PROC with two arguments: an input port for FILE, and an output
port for the file that is going to replace FILE.  Upon success, FILE is
atomically replaced by what has been written to the output port, and
PROC's result is returned."
  (let* ((template (string-append file ".XXXXXX"))
         (out      (mkstemp! template))
         (mode     (stat:mode (stat file))))
    (with-throw-handler #t
      (lambda ()
        (call-with-input-file file
          (lambda (in)
            (let ((result (proc in out)))
              (close out)
              (chmod template mode)
              (rename-file template file)
              result))))
      (lambda (key . args)
        (false-if-exception (delete-file template))))))

(define (substitute file pattern+procs)
  "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs.  For each
line of FILE, and for each PATTERN that it matches, call the corresponding
PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
a substitution of the original line.  Be careful about using '$' to match the
end of a line; by itself it won't match the terminating newline of a line."
  (let ((rx+proc  (map (match-lambda
                        (((? regexp? pattern) . proc)
                         (cons pattern proc))
                        ((pattern . proc)
                         (cons (make-regexp pattern regexp/extended)
                               proc)))
                       pattern+procs)))
    (with-atomic-file-replacement file
      (lambda (in out)
        (let loop ((line (read-line in 'concat)))
          (if (eof-object? line)
              #t
              (let ((line (fold (lambda (r+p line)
                                  (match r+p
                                    ((regexp . proc)
                                     (match (list-matches regexp line)
                                       ((and m+ (_ _ ...))
                                        (proc line m+))
                                       (_ line)))))
                                line
                                rx+proc)))
                (display line out)
                (loop (read-line in 'concat)))))))))

(define-syntax let-matches
  ;; Helper macro for `substitute*'.
  (syntax-rules (_)
    ((let-matches index match (_ vars ...) body ...)
     (let-matches (+ 1 index) match (vars ...)
                  body ...))
    ((let-matches index match (var vars ...) body ...)
     (let ((var (match:substring match index)))
       (let-matches (+ 1 index) match (vars ...)
                    body ...)))
    ((let-matches index match () body ...)
     (begin body ...))))

(define-syntax substitute*
  (syntax-rules ()
    "Substitute REGEXP in FILE by the string returned by BODY.  BODY is
evaluated with each MATCH-VAR bound to the corresponding positional regexp
sub-expression.  For example:

  (substitute* file
     ((\"hello\")
      \"good morning\\n\")
     ((\"foo([a-z]+)bar(.*)$\" all letters end)
      (string-append \"baz\" letter end)))

Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
morning\".  Anytime a line of FILE matches the second regexp, ALL is bound to
the complete match, LETTERS is bound to the first sub-expression, and END is
bound to the last one.

When one of the MATCH-VAR is `_', no variable is bound to the corresponding
match substring.

Alternatively, FILE may be a list of file names, in which case they are
all subject to the substitutions.

Be careful about using '$' to match the end of a line; by itself it won't
match the terminating newline of a line."
    ((substitute* file ((regexp match-var ...) body ...) ...)
     (let ()
       (define (substitute-one-file file-name)
         (substitute
          file-name
          (list (cons regexp
                      (lambda (l m+)
                        ;; Iterate over matches M+ and return the
                        ;; modified line based on L.
                        (let loop ((m* m+)  ; matches
                                   (o  0)   ; offset in L
                                   (r  '())) ; result
                          (match m*
                            (()
                             (let ((r (cons (substring l o) r)))
                               (string-concatenate-reverse r)))
                            ((m . rest)
                             (let-matches 0 m (match-var ...)
                               (loop rest
                                     (match:end m)
                                     (cons*
                                      (begin body ...)
                                      (substring l o (match:start m))
                                      r))))))))
                ...)))

       (match file
         ((files (... ...))
          (for-each substitute-one-file files))
         ((? string? f)
          (substitute-one-file f)))))))

;;;
;;; Patching shebangs---e.g., /bin/sh -> /gnu/store/xyz...-bash/bin/sh.
;;;

(define* (dump-port in out
                    #:key (buffer-size 16384)
                    (progress (lambda (t k) (k))))
  "Read as much data as possible from IN and write it to OUT, using chunks of
BUFFER-SIZE bytes.  Call PROGRESS at the beginning and after each successful
transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
transferred and the continuation of the transfer as a thunk."
  (define buffer
    (make-bytevector buffer-size))

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

  ;; Make sure PROGRESS is called when we start so that it can measure
  ;; throughput.
  (progress 0
            (lambda ()
              (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))

(define (set-file-time file stat)
  "Set the atime/mtime of FILE to that specified by STAT."
  (utime file
         (stat:atime stat)
         (stat:mtime stat)
         (stat:atimensec stat)
         (stat:mtimensec stat)))

(define (get-char* p)
  ;; We call it `get-char', but that's really a binary version
  ;; thereof.  (The real `get-char' cannot be used here because our
  ;; bootstrap Guile is hacked to always use UTF-8.)
  (match (get-u8 p)
    ((? integer? x) (integer->char x))
    (x x)))

(define patch-shebang
  (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
    (lambda* (file
              #:optional
              (path (search-path-as-string->list (getenv "PATH")))
              #:key (keep-mtime? #t))
      "Replace the #! interpreter file name in FILE by a valid one found in
PATH, when FILE actually starts with a shebang.  Return #t when FILE was
patched, #f otherwise.  When KEEP-MTIME? is true, the atime/mtime of
FILE are kept unchanged."
      (define (patch p interpreter rest-of-line)
        (let* ((template (string-append file ".XXXXXX"))
               (out      (mkstemp! template))
               (st       (stat file))
               (mode     (stat:mode st)))
          (with-throw-handler #t
            (lambda ()
              (format out "#!~a~a~%"
                      interpreter rest-of-line)
              (dump-port p out)
              (close out)
              (chmod template mode)
              (rename-file template file)
              (when keep-mtime?
                (set-file-time file st))
              #t)
            (lambda (key . args)
              (format (current-error-port)
                      "patch-shebang: ~a: error: ~a ~s~%"
                      file key args)
              (false-if-exception (delete-file template))
              #f))))

      (call-with-ascii-input-file file
        (lambda (p)
          (and (eq? #\# (get-char* p))
               (eq? #\! (get-char* p))
               (let ((line (false-if-exception (read-line p))))
                 (and=> (and line (regexp-exec shebang-rx line))
                        (lambda (m)
                          (let* ((interp (match:substring m 1))
                                 (arg1 (match:substring m 2))
                                 (rest (match:substring m 3))
                                 (has-env (string-suffix? "/env" interp))
                                 (cmd (if has-env arg1 (basename interp)))
                                 (bin (search-path path cmd)))
                            (if bin
                                (if (string=? bin interp)
                                    #f            ; nothing to do
                                    (if has-env
                                        (begin
                                          (format (current-error-port)
                                                  "patch-shebang: ~a: changing `~a' to `~a'~%"
                                                  file (string-append interp " " arg1) bin)
                                          (patch p bin rest))
                                      (begin
                                        (format (current-error-port)
                                                "patch-shebang: ~a: changing `~a' to `~a'~%"
                                                file interp bin)
                                        (patch p bin
                                               (if (string-null? arg1)
                                                   ""
                                                   (string-append " " arg1 rest))))))
                                (begin
                                  (format (current-error-port)
                                          "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
                                          file (basename cmd))
                                  #f))))))))))))

(define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
  "Patch the `SHELL' variable in FILE, which is supposedly a makefile.
When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."

  ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.

  ;; XXX: Unlike with `patch-shebang', FILE is always touched.

  (define (find-shell name)
    (let ((shell (which name)))
      (unless shell
        (format (current-error-port)
                "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
                name))
      shell))

  (let ((st (stat file)))
    ;; Consider FILE is using an 8-bit encoding to avoid errors.
    (with-fluids ((%default-port-encoding #f))
      (substitute* file
        (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
          _ dir shell args)
         (let* ((old (string-append dir shell))
                (new (or (find-shell shell) old)))
           (unless (string=? new old)
             (format (current-error-port)
                     "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
                     file old new))
           (string-append "SHELL = " new args)))))

   (when keep-mtime?
     (set-file-time file st))))

(define* (patch-/usr/bin/file file
                              #:key
                              (file-command (which "file"))
                              (keep-mtime? #t))
  "Patch occurrences of \"/usr/bin/file\" in FILE, replacing them with
FILE-COMMAND.  When KEEP-MTIME? is true, keep FILE's modification time
unchanged."
  (if (not file-command)
      (format (current-error-port)
              "patch-/usr/bin/file: warning: \
no replacement 'file' command, doing nothing~%")
      (let ((st (stat file)))
        ;; Consider FILE is using an 8-bit encoding to avoid errors.
        (with-fluids ((%default-port-encoding #f))
          (substitute* file
            (("/usr/bin/file")
             (begin
               (format (current-error-port)
                       "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
                       file "/usr/bin/file" file-command)
               file-command))))

        (when keep-mtime?
          (set-file-time file st)))))

(define* (fold-port-matches proc init pattern port
                            #:optional (unmatched (lambda (_ r) r)))
  "Read from PORT character-by-character; for each match against
PATTERN, call (PROC MATCH RESULT), where RESULT is seeded with INIT.
PATTERN is a list of SRFI-14 char-sets.  Call (UNMATCHED CHAR RESULT)
for each unmatched character."
  (define initial-pattern
    ;; The poor developer's regexp.
    (if (string? pattern)
        (map char-set (string->list pattern))
        pattern))

  ;; Note: we're not really striving for performance here...
  (let loop ((chars   '())
             (pattern initial-pattern)
             (matched '())
             (result  init))
    (cond ((null? chars)
           (loop (list (get-char* port))
                 pattern
                 matched
                 result))
          ((null? pattern)
           (loop chars
                 initial-pattern
                 '()
                 (proc (list->string (reverse matched)) result)))
          ((eof-object? (car chars))
           (fold-right unmatched result matched))
          ((char-set-contains? (car pattern) (car chars))
           (loop (cdr chars)
                 (cdr pattern)
                 (cons (car chars) matched)
                 result))
          ((null? matched)                        ; common case
           (loop (cdr chars)
                 pattern
                 matched
                 (unmatched (car chars) result)))
          (else
           (let ((matched (reverse matched)))
             (loop (append (cdr matched) chars)
                   initial-pattern
                   '()
                   (unmatched (car matched) result)))))))

(define* (remove-store-references file
                                  #:optional (store (%store-directory)))
  "Remove from FILE occurrences of file names in STORE; return #t when
store paths were encountered in FILE, #f otherwise.  This procedure is
known as `nuke-refs' in Nixpkgs."
  (define pattern
    (let ((nix-base32-chars
           '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
             #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
             #\p #\q #\r #\s #\v #\w #\x #\y #\z)))
      `(,@(map char-set (string->list store))
        ,(char-set #\/)
        ,@(make-list 32 (list->char-set nix-base32-chars))
        ,(char-set #\-))))

  (with-fluids ((%default-port-encoding #f))
    (with-atomic-file-replacement file
      (lambda (in out)
        ;; We cannot use `regexp-exec' here because it cannot deal with
        ;; strings containing NUL characters.
        (format #t "removing store references from `~a'...~%" file)
        (setvbuf in _IOFBF 65536)
        (setvbuf out _IOFBF 65536)
        (fold-port-matches (lambda (match result)
                             (put-bytevector out (string->utf8 store))
                             (put-u8 out (char->integer #\/))
                             (put-bytevector out
                                             (string->utf8
                                              "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
                             #t)
                           #f
                           pattern
                           in
                           (lambda (char result)
                             (put-u8 out (char->integer char))
                             result))))))

(define* (wrap-program prog #:rest vars)
  "Make a wrapper for PROG.  VARS should look like this:

  '(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES)

where DELIMITER is optional.  ':' will be used if DELIMITER is not given.

For example, this command:

  (wrap-program \"foo\"
                '(\"PATH\" \":\" = (\"/gnu/.../bar/bin\"))
                '(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\"
                                        \"/qux/certs\")))

will copy 'foo' to '.foo-real' and create the file 'foo' with the following
contents:

  #!location/of/bin/bash
  export PATH=\"/gnu/.../bar/bin\"
  export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\"
  exec -a $0 location/of/.foo-real \"$@\"

This is useful for scripts that expect particular programs to be in $PATH, for
programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
modules in $GUILE_LOAD_PATH, etc.

If PROG has previously been wrapped by 'wrap-program', the wrapper is extended
with definitions for VARS."
  (define wrapped-file
    (string-append (dirname prog) "/." (basename prog) "-real"))

  (define already-wrapped?
    (file-exists? wrapped-file))

  (define (last-line port)
    ;; Return the last line read from PORT and leave PORT's cursor right
    ;; before it.
    (let loop ((previous-line-offset 0)
               (previous-line "")
               (position (seek port 0 SEEK_CUR)))
      (match (read-line port 'concat)
        ((? eof-object?)
         (seek port previous-line-offset SEEK_SET)
         previous-line)
        ((? string? line)
         (loop position line (+ (string-length line) position))))))

  (define (export-variable lst)
    ;; Return a string that exports an environment variable.
    (match lst
      ((var sep '= rest)
       (format #f "export ~a=\"~a\""
               var (string-join rest sep)))
      ((var sep 'prefix rest)
       (format #f "export ~a=\"~a${~a~a+~a}$~a\""
               var (string-join rest sep) var sep sep var))
      ((var sep 'suffix rest)
       (format #f "export ~a=\"$~a${~a~a+~a}~a\""
               var var var sep sep (string-join rest sep)))
      ((var '= rest)
       (format #f "export ~a=\"~a\""
               var (string-join rest ":")))
      ((var 'prefix rest)
       (format #f "export ~a=\"~a${~a:+:}$~a\""
               var (string-join rest ":") var var))
      ((var 'suffix rest)
       (format #f "export ~a=\"$~a${~a:+:}~a\""
               var var var (string-join rest ":")))))

  (if already-wrapped?

      ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just
      ;; before the last line.
      (let* ((port (open-file prog "r+"))
             (last (last-line port)))
        (for-each (lambda (var)
                    (display (export-variable var) port)
                    (newline port))
                  vars)
        (display last port)
        (close-port port))

      ;; PROG is not wrapped yet: create a shell script that sets VARS.
      (let ((prog-tmp (string-append wrapped-file "-tmp")))
        (link prog wrapped-file)

        (call-with-output-file prog-tmp
          (lambda (port)
            (format port
                    "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
                    (which "bash")
                    (string-join (map export-variable vars) "\n")
                    (canonicalize-path wrapped-file))))

        (chmod prog-tmp #o755)
        (rename-file prog-tmp prog))))

;;;
;;; Locales.
;;;

(define (locale-category->string category)
  "Return the name of locale category CATEGORY, one of the 'LC_' constants.
If CATEGORY is a bitwise or of several 'LC_' constants, an approximation is
returned."
  (letrec-syntax ((convert (syntax-rules ()
                             ((_)
                              (number->string category))
                             ((_ first rest ...)
                              (if (= first category)
                                  (symbol->string 'first)
                                  (convert rest ...))))))
    (convert LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE
             LC_IDENTIFICATION LC_MEASUREMENT LC_MESSAGES LC_MONETARY
             LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE
             LC_TIME)))

;;; Local Variables:
;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1)
;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
;;; eval: (put 'let-matches 'scheme-indent-function 3)
;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2018 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 build waf-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            waf-build))

;; Commentary:
;;
;; Builder-side code of the standard waf build procedure.
;;
;; Code:

(define (call-waf command params)
  (if (file-exists? "waf")
      (begin
         (format #t "running \"python waf\" with command ~s and parameters ~s~%"
                command params)
         (apply invoke "python" "waf" command params)
         #t)
      (error "no waf found")))

(define* (configure #:key target native-inputs inputs outputs
                    (configure-flags '())
                    #:allow-other-keys)
  "Build a given waf application."
  (let* ((prefix (assoc-ref outputs "out"))
         (flags  `(,(string-append "--prefix=" prefix)
                   ,@configure-flags)))
    (call-waf "configure" flags)))

(define* (build #:rest empty)
  "Build a given waf application."
  (call-waf "build" '()))

(define* (check #:key tests? test-target #:allow-other-keys)
  "Run the test suite of a given waf application."
  (if tests?
    (call-waf test-target '())
    #t))

(define* (install #:key outputs inputs (configure-flags '())
                  #:allow-other-keys)
  "Install a given waf application."
  (let* ((out (assoc-ref outputs "out"))
         (params (append (list (string-append "--prefix=" out))
                         configure-flags)))
        (call-waf "install" params)))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (replace 'configure configure)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)))

(define* (waf-build #:key inputs (phases %standard-phases)
                       #:allow-other-keys #:rest args)
  "Build the given waf application, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; waf-build-system.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 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 cache)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (obsolete?
            delete-file*
            file-expiration-time
            remove-expired-cache-entries
            maybe-remove-expired-cache-entries))

;;; Commentary:
;;;
;;; This module provides tools to manage a simple on-disk cache consisting of
;;; individual files.
;;;
;;; Code:

(cond-expand
  (guile-2.2
   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
   (define time-monotonic time-tai))
  (else #t))

(define (obsolete? date now ttl)
  "Return #t if DATE is obsolete compared to NOW + TTL seconds."
  (time>? (subtract-duration now (make-time time-duration 0 ttl))
          (make-time time-monotonic 0 date)))

(define (delete-file* file)
  "Like 'delete-file', but does not raise an error when FILE does not exist."
  (catch 'system-error
    (lambda ()
      (delete-file file))
    (lambda args
      (unless (= ENOENT (system-error-errno args))
        (apply throw args)))))

(define (file-expiration-time ttl)
  "Return a procedure that, when passed a file, returns its \"expiration
time\" computed as its last-access time + TTL seconds."
  (lambda (file)
    (match (stat file #f)
      (#f 0)                       ;FILE may have been deleted in the meantime
      (st (+ (stat:atime st) ttl)))))

(define* (remove-expired-cache-entries entries
                                       #:key
                                       (now (current-time time-monotonic))
                                       (entry-expiration
                                        (file-expiration-time 3600))
                                       (delete-entry delete-file*))
  "Given ENTRIES, a list of file names, remove those whose expiration time,
as returned by ENTRY-EXPIRATION, has passed.  Use DELETE-ENTRY to delete
them."
  (for-each (lambda (entry)
              (when (<= (entry-expiration entry) (time-second now))
                (delete-entry entry)))
            entries))

(define* (maybe-remove-expired-cache-entries cache
                                             cache-entries
                                             #:key
                                             (entry-expiration
                                              (file-expiration-time 3600))
                                             (delete-entry delete-file*)
                                             (cleanup-period (* 24 3600)))
  "Remove expired narinfo entries from the cache if deemed necessary.  Call
CACHE-ENTRIES with CACHE to retrieve the list of cache entries.

ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the
expiration time of that entry in seconds since the Epoch.  DELETE-ENTRY is a
procedure that removes the entry passed as an argument.  Finally,
CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
  (define now
    (current-time time-monotonic))

  (define expiry-file
    (string-append cache "/last-expiry-cleanup"))

  (define last-expiry-date
    (catch 'system-error
      (lambda ()
        (call-with-input-file expiry-file read))
      (const 0)))

  (when (obsolete? last-expiry-date now cleanup-period)
    (remove-expired-cache-entries (cache-entries cache)
                                  #:now now
                                  #:entry-expiration entry-expiration
                                  #:delete-entry delete-entry)
    (call-with-output-file expiry-file
      (cute write (time-second now) <>))))

;;; cache.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 channels)
  #:use-module (guix git)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix discovery)
  #:use-module (guix monads)
  #:use-module (guix profiles)
  #:use-module (guix derivations)
  #:use-module (guix store)
  #:use-module (guix i18n)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:autoload   (guix self) (whole-package)
  #:use-module (ice-9 match)
  #:export (channel
            channel?
            channel-name
            channel-url
            channel-branch
            channel-commit
            channel-location

            %default-channels

            channel-instance?
            channel-instance-channel
            channel-instance-commit
            channel-instance-checkout

            latest-channel-instances
            latest-channel-derivation
            channel-instances->manifest
            channel-instances->derivation))

;;; Commentary:
;;;
;;; This module implements "channels."  A channel is usually a source of
;;; package definitions.  There's a special channel, the 'guix' channel, that
;;; provides all of Guix, including its commands and its documentation.
;;; User-defined channels are expected to typically provide a bunch of .scm
;;; files meant to be added to the '%package-search-path'.
;;;
;;; This module provides tools to fetch and update channels from a Git
;;; repository and to build them.
;;;
;;; Code:

(define-record-type* <channel> channel make-channel
  channel?
  (name      channel-name)
  (url       channel-url)
  (branch    channel-branch (default "master"))
  (commit    channel-commit (default #f))
  (location  channel-location
             (default (current-source-location)) (innate)))
;; TODO: Add a way to express dependencies among channels.

(define %default-channels
  ;; Default list of channels.
  (list (channel
         (name 'guix)
         (branch "master")
         (url "https://git.savannah.gnu.org/git/guix.git"))))

(define (guix-channel? channel)
  "Return true if CHANNEL is the 'guix' channel."
  (eq? 'guix (channel-name channel)))

(define-record-type <channel-instance>
  (channel-instance channel commit checkout)
  channel-instance?
  (channel   channel-instance-channel)
  (commit    channel-instance-commit)
  (checkout  channel-instance-checkout))

(define (channel-reference channel)
  "Return the \"reference\" for CHANNEL, an sexp suitable for
'latest-repository-commit'."
  (match (channel-commit channel)
    (#f      `(branch . ,(channel-branch channel)))
    (commit  `(commit . ,(channel-commit channel)))))

(define (latest-channel-instances store channels)
  "Return a list of channel instances corresponding to the latest checkouts of
CHANNELS."
  (map (lambda (channel)
         (format (current-error-port)
                 (G_ "Updating channel '~a' from Git repository at '~a'...~%")
                 (channel-name channel)
                 (channel-url channel))
         (let-values (((checkout commit)
                       (latest-repository-commit store (channel-url channel)
                                                 #:ref (channel-reference
                                                        channel))))
           (channel-instance channel commit checkout)))
       channels))

(define %self-build-file
  ;; The file containing code to build Guix.  This serves the same purpose as
  ;; a makefile, and, similarly, is intended to always keep this name.
  "build-aux/build-self.scm")

(define %pull-version
  ;; This is the version of the 'guix pull' protocol.  It specifies what's
  ;; expected from %SELF-BUILD-FILE.  The initial version ("0") was when we'd
  ;; place a set of compiled Guile modules in ~/.config/guix/latest.
  1)

(define (standard-module-derivation name source dependencies)
  "Return a derivation that builds the Scheme modules in SOURCE and that
depend on DEPENDENCIES, a list of lowerable objects.  The assumption is that
SOURCE contains package modules to be added to '%package-module-path'."
  (define modules
    (scheme-modules* source))

  ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow
  ;; channel publishers to specify things such as the sub-directory where .scm
  ;; files live, files to exclude from the channel, preferred substitute URLs,
  ;; etc.
  (mlet* %store-monad ((compiled
                        (compiled-modules modules
                                          #:name name
                                          #:module-path (list source)
                                          #:extensions dependencies)))

    (gexp->derivation name
                      (with-extensions dependencies
                        (with-imported-modules '((guix build utils))
                          #~(begin
                              (use-modules (guix build utils))

                              (let ((go  (string-append #$output "/lib/guile/"
                                                        (effective-version)
                                                        "/site-ccache"))
                                    (scm (string-append #$output
                                                        "/share/guile/site/"
                                                        (effective-version))))
                                (mkdir-p (dirname go))
                                (symlink #$compiled go)
                                (mkdir-p (dirname scm))
                                (symlink #$source scm))))))))

(define* (build-from-source name source
                            #:key verbose? commit
                            (dependencies '()))
  "Return a derivation to build Guix from SOURCE, using the self-build script
contained therein.  Use COMMIT as the version string."
  ;; Running the self-build script makes it easier to update the build
  ;; procedure: the self-build script of the Guix-to-be-installed contains the
  ;; right dependencies, build procedure, etc., which the Guix-in-use may not
  ;; be know.
  (define script
    (string-append source "/" %self-build-file))

  (if (file-exists? script)
      (let ((build (save-module-excursion
                    (lambda ()
                      (primitive-load script)))))
        ;; BUILD must be a monadic procedure of at least one argument: the
        ;; source tree.
        ;;
        ;; Note: BUILD can return #f if it does not support %PULL-VERSION.  In
        ;; the future we'll fall back to a previous version of the protocol
        ;; when that happens.
        (build source #:verbose? verbose? #:version commit
               #:pull-version %pull-version))

      ;; Build a set of modules that extend Guix using the standard method.
      (standard-module-derivation name source dependencies)))

(define* (build-channel-instance instance #:optional (dependencies '()))
  "Return, as a monadic value, the derivation for INSTANCE, a channel
instance.  DEPENDENCIES is a list of extensions providing Guile modules that
INSTANCE depends on."
  (build-from-source (symbol->string
                      (channel-name (channel-instance-channel instance)))
                     (channel-instance-checkout instance)
                     #:commit (channel-instance-commit instance)
                     #:dependencies dependencies))

(define (channel-instance-derivations instances)
  "Return the list of derivations to build INSTANCES, in the same order as
INSTANCES."
  (define core-instance
    ;; The 'guix' channel is treated specially: it's an implicit dependency of
    ;; all the other channels.
    (find (lambda (instance)
            (guix-channel? (channel-instance-channel instance)))
          instances))

  (define dependencies
    ;; Dependencies of CORE-INSTANCE.
    ;; FIXME: It would be best not to hard-wire this information here and
    ;; instead query it to CORE-INSTANCE.
    (list (module-ref (resolve-interface '(gnu packages gnupg))
                      'guile-gcrypt)
          (module-ref (resolve-interface '(gnu packages guile))
                      'guile-git)
          (module-ref (resolve-interface '(gnu packages guile))
                      'guile-bytestructures)))

  (mlet %store-monad ((core (build-channel-instance core-instance)))
    (mapm %store-monad
          (lambda (instance)
            (if (eq? instance core-instance)
                (return core)
                (build-channel-instance instance
                                        (cons core dependencies))))
          instances)))

(define (whole-package-for-legacy name modules)
  "Return a full-blown Guix package for MODULES, a derivation that builds Guix
modules in the old ~/.config/guix/latest style."
  (define packages
    (resolve-interface '(gnu packages guile)))

  (letrec-syntax ((list (syntax-rules (->)
                          ((_)
                           '())
                          ((_ (module -> variable) rest ...)
                           (cons (module-ref (resolve-interface
                                              '(gnu packages module))
                                             'variable)
                                 (list rest ...)))
                          ((_ variable rest ...)
                           (cons (module-ref packages 'variable)
                                 (list rest ...))))))
    (whole-package name modules

                   ;; In the "old style", %SELF-BUILD-FILE would simply return a
                   ;; derivation that builds modules.  We have to infer what the
                   ;; dependencies of these modules were.
                   (list guile-json guile-git guile-bytestructures
                         (ssh -> guile-ssh) (tls -> gnutls)))))

(define (old-style-guix? drv)
  "Return true if DRV corresponds to a ~/.config/guix/latest style of
derivation."
  ;; Here we rely on a gross historical fact: that derivations produced by the
  ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
  ;; dated May 30, 2018) did not depend on "guix-command.drv".
  (not (find (lambda (input)
               (string-suffix? "-guix-command.drv"
                               (derivation-input-path input)))
             (derivation-inputs drv))))

(define (channel-instances->manifest instances)
  "Return a profile manifest with entries for all of INSTANCES, a list of
channel instances."
  (define instance->entry
    (match-lambda
      ((instance drv)
       (let ((commit  (channel-instance-commit instance))
             (channel (channel-instance-channel instance)))
         (with-monad %store-monad
           (return (manifest-entry
                     (name (symbol->string (channel-name channel)))
                     (version (string-take commit 7))
                     (item (if (guix-channel? channel)
                               (if (old-style-guix? drv)
                                   (whole-package-for-legacy
                                    (string-append name "-" version)
                                    drv)
                                   drv)
                               drv))
                     (properties
                      `((source (repository
                                 (version 0)
                                 (url ,(channel-url channel))
                                 (branch ,(channel-branch channel))
                                 (commit ,commit))))))))))))

  (mlet* %store-monad ((derivations (channel-instance-derivations instances))
                       (entries     (mapm %store-monad instance->entry
                                          (zip instances derivations))))
    (return (manifest entries))))

(define (channel-instances->derivation instances)
  "Return the derivation of the profile containing INSTANCES, a list of
channel instances."
  (mlet %store-monad ((manifest (channel-instances->manifest instances)))
    (profile-derivation manifest)))

(define latest-channel-instances*
  (store-lift latest-channel-instances))

(define* (latest-channel-derivation #:optional (channels %default-channels))
  "Return as a monadic value the derivation that builds the profile for the
latest instances of CHANNELS."
  (mlet %store-monad ((instances (latest-channel-instances* channels)))
    (channel-instances->derivation instances)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 ci)
  #:use-module (guix http-client)
  #:autoload   (json parser) (json->scm)
  #:use-module (srfi srfi-9)
  #:export (build?
            build-id
            build-derivation
            build-system
            build-status
            build-timestamp

            %query-limit
            queued-builds
            latest-builds))

;;; Commentary:
;;;
;;; This module provides a client to the HTTP interface of the Hydra and
;;; Cuirass continuous integration (CI) tools.
;;;
;;; Code:

(define-record-type <build>
  (make-build id derivation system status timestamp)
  build?
  (id          build-id)                          ;integer
  (derivation  build-derivation)                  ;string | #f
  (system      build-system)                      ;string
  (status      build-status)                      ;integer
  (timestamp   build-timestamp))                  ;integer

(define %query-limit
  ;; Max number of builds requested in queries.
  1000)

(define (json-fetch url)
  (let* ((port (http-fetch url))
         (json (json->scm port)))
    (close-port port)
    json))

(define (json->build json)
  (make-build (hash-ref json "id")
              (hash-ref json "derivation")
              (hash-ref json "system")
              (hash-ref json "buildstatus")
              (hash-ref json "timestamp")))

(define* (queued-builds url #:optional (limit %query-limit))
  "Return the list of queued derivations on URL."
  (let ((queue (json-fetch (string-append url "/api/queue?nr="
                                          (number->string limit)))))
    (map json->build queue)))

(define* (latest-builds url #:optional (limit %query-limit))
  (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
                                           (number->string limit)))))
    ;; Note: Hydra does not provide a "derivation" field for entries in
    ;; 'latestbuilds', but Cuirass does.
    (map json->build latest)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.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 combinators)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (fold2
            fold-tree
            fold-tree-leaves
            compile-time-value))

;;; Commentary:
;;;
;;; This module provides useful combinators that complement SRFI-1 and
;;; friends.
;;;
;;; Code:

(define fold2
  (case-lambda
    ((proc seed1 seed2 lst)
     "Like `fold', but with a single list and two seeds."
     (let loop ((result1 seed1)
                (result2 seed2)
                (lst     lst))
       (if (null? lst)
           (values result1 result2)
           (call-with-values
               (lambda () (proc (car lst) result1 result2))
             (lambda (result1 result2)
               (loop result1 result2 (cdr lst)))))))
    ((proc seed1 seed2 lst1 lst2)
     "Like `fold', but with a two lists and two seeds."
     (let loop ((result1 seed1)
                (result2 seed2)
                (lst1    lst1)
                (lst2    lst2))
       (if (or (null? lst1) (null? lst2))
           (values result1 result2)
           (call-with-values
               (lambda () (proc (car lst1) (car lst2) result1 result2))
             (lambda (result1 result2)
               (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))

(define (fold-tree proc init children roots)
  "Call (PROC NODE RESULT) for each node in the tree that is reachable from
ROOTS, using INIT as the initial value of RESULT.  The order in which nodes
are traversed is not specified, however, each node is visited only once, based
on an eq? check.  Children of a node to be visited are generated by
calling (CHILDREN NODE), the result of which should be a list of nodes that
are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
  (let loop ((result init)
             (seen vlist-null)
             (lst roots))
    (match lst
      (() result)
      ((head . tail)
       (if (not (vhash-assq head seen))
           (loop (proc head result)
                 (vhash-consq head #t seen)
                 (match (children head)
                   ((or () #f) tail)
                   (children (append tail children))))
           (loop result seen tail))))))

(define (fold-tree-leaves proc init children roots)
  "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
  (fold-tree
   (lambda (node result)
     (match (children node)
       ((or () #f) (proc node result))
       (else result)))
   init children roots))

(define-syntax compile-time-value                 ;not quite at home
  (syntax-rules ()
    "Evaluate the given expression at compile time.  The expression must
evaluate to a simple datum."
    ((_ exp)
     (let-syntax ((v (lambda (s)
                       (let ((val exp))
                         (syntax-case s ()
                           (_ #`'#,(datum->syntax s val)))))))
       v))))

;;; combinators.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.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 config)
  #:export (%guix-package-name
            %guix-version
            %guix-bug-report-address
            %guix-home-page-url

            %storedir
            %localstatedir
            %sysconfdir

            %store-directory
            %state-directory
            %store-database-directory
            %config-directory

            %system
            %libgcrypt
            %libz
            %gzip
            %bzip2
            %xz))

;;; Commentary:
;;;
;;; Compile-time configuration of Guix.  When adding a substitution variable
;;; here, make sure to equip (guix scripts pull) to substitute it.
;;;
;;; Code:

(define %guix-package-name
  "@PACKAGE_NAME@")

(define %guix-version
  "@PACKAGE_VERSION@")

(define %guix-bug-report-address
  "@PACKAGE_BUGREPORT@")

(define %guix-home-page-url
  "@PACKAGE_URL@")

(define %storedir
  "@storedir@")

(define %localstatedir
  "@guix_localstatedir@")

(define %sysconfdir
  "@guix_sysconfdir@")

(define %store-directory
  (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
      %storedir))

(define %state-directory
  ;; This must match `NIX_STATE_DIR' as defined in `nix/local.mk'.
  (or (getenv "NIX_STATE_DIR")
      (string-append %localstatedir "/guix")))

(define %store-database-directory
  (or (getenv "NIX_DB_DIR")
      (string-append %state-directory "/db")))

(define %config-directory
  ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'.
  (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
      (string-append %sysconfdir "/guix")))

(define %system
  "@guix_system@")

(define %libgcrypt
  "@LIBGCRYPT@")

(define %libz
  "@LIBZ@")

(define %gzip
  "@GZIP@")

(define %bzip2
  "@BZIP2@")

(define %xz
  "@XZ@")

;;; config.scm ends here


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

(define-module (guix cpio)
  #:use-module ((guix build utils) #:select (dump-port))
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:export (cpio-header?
            make-cpio-header
            file->cpio-header
            file->cpio-header*
            write-cpio-header
            read-cpio-header

            write-cpio-archive))

;;; Commentary:
;;;
;;; This module implements the cpio "new ASCII" format, bit-for-bit identical
;;; to GNU cpio with the '-H newc' option.
;;;
;;; Code:

;; Values for 'mode', OR'd together.

(define C_IRUSR #o000400)
(define C_IWUSR #o000200)
(define C_IXUSR #o000100)
(define C_IRGRP #o000040)
(define C_IWGRP #o000020)
(define C_IXGRP #o000010)
(define C_IROTH #o000004)
(define C_IWOTH #o000002)
(define C_IXOTH #o000001)

(define C_ISUID #o004000)
(define C_ISGID #o002000)
(define C_ISVTX #o001000)

(define C_FMT   #o170000)                         ;bit mask
(define C_ISBLK #o060000)
(define C_ISCHR #o020000)
(define C_ISDIR #o040000)
(define C_ISFIFO #o010000)
(define C_ISSOCK #o0140000)
(define C_ISLNK #o0120000)
(define C_ISCTG #o0110000)
(define C_ISREG #o0100000)

(define MAGIC
  ;; The "new" portable format with ASCII header, as produced by GNU cpio with
  ;; '-H newc'.
  (string->number "070701" 16))

(define (read-header-field size port)
  (string->number (get-string-n port size) 16))

(define (write-header-field value size port)
  (put-bytevector port
                  (string->utf8
                   (string-pad (string-upcase (number->string value 16))
                               size #\0))))

(define-syntax define-pack
  (syntax-rules ()
    ((_ type ctor pred write read (field-names field-sizes field-getters) ...)
     (begin
       (define-record-type type
         (ctor field-names ...)
         pred
         (field-names field-getters) ...)

       (define (read port)
         (set-port-encoding! port "ISO-8859-1")
         (ctor (read-header-field field-sizes port)
               ...))

       (define (write obj port)
         (let* ((size (+ field-sizes ...)))
           (match obj
             (($ type field-names ...)
              (write-header-field field-names field-sizes port)
              ...))))))))

;; cpio header in "new ASCII" format, without checksum.
(define-pack <cpio-header>
  %make-cpio-header cpio-header?
  write-cpio-header read-cpio-header
  (magic     6  cpio-header-magic)
  (ino       8  cpio-header-inode)
  (mode      8  cpio-header-mode)
  (uid       8  cpio-header-uid)
  (gid       8  cpio-header-gid)
  (nlink     8  cpio-header-nlink)
  (mtime     8  cpio-header-mtime)
  (file-size 8  cpio-header-file-size)
  (dev-maj   8  cpio-header-device-major)
  (dev-min   8  cpio-header-device-minor)
  (rdev-maj  8  cpio-header-rdevice-major)
  (rdev-min  8  cpio-header-rdevice-minor)
  (name-size 8  cpio-header-name-size)
  (checksum  8  cpio-header-checksum))            ;0 for "newc" format

(define* (make-cpio-header #:key
                           (inode 0)
                           (mode (logior C_ISREG C_IRUSR))
                           (uid 0) (gid 0)
                           (nlink 1) (mtime 0) (size 0)
                           (dev 0) (rdev 0) (name-size 0))
  "Return a new cpio file header."
  (let-values (((major minor)   (device->major+minor dev))
               ((rmajor rminor) (device->major+minor rdev)))
    (%make-cpio-header MAGIC
                       inode mode uid gid
                       nlink mtime
                       (if (= C_ISDIR (logand mode C_FMT))
                           0
                           size)
                       major minor rmajor rminor
                       (+ name-size 1)              ;include trailing zero
                       0)))                          ;checksum

(define (mode->type mode)
  "Given the number MODE, return a symbol representing the kind of file MODE
denotes, similar to 'stat:type'."
  (let ((fmt (logand mode C_FMT)))
    (cond ((= C_ISREG fmt) 'regular)
          ((= C_ISDIR fmt) 'directory)
          ((= C_ISLNK fmt) 'symlink)
          (else
           (error "unsupported file type" mode)))))

(define (device-number major minor)               ;see <sys/sysmacros.h>
  "Return the device number for the device with MAJOR and MINOR, for use as
the last argument of `mknod'."
  (+ (* major 256) minor))

(define (device->major+minor device)
  "Return two values: the major and minor device numbers that make up DEVICE."
  (values (ash device -8)
          (logand device #xff)))

(define* (file->cpio-header file #:optional (file-name file)
                            #:key (stat lstat))
  "Return a cpio header corresponding to the info returned by STAT for FILE,
using FILE-NAME as its file name."
  (let ((st (stat file)))
    (make-cpio-header #:inode (stat:ino st)
                      #:mode (stat:mode st)
                      #:uid (stat:uid st)
                      #:gid (stat:gid st)
                      #:nlink (stat:nlink st)
                      #:mtime (stat:mtime st)
                      #:size (stat:size st)
                      #:dev (stat:dev st)
                      #:rdev (stat:rdev st)
                      #:name-size (string-length file-name))))

(define* (file->cpio-header* file
                             #:optional (file-name file)
                             #:key (stat lstat))
  "Similar to 'file->cpio-header', but return a header with a zeroed
modification time, inode number, UID/GID, etc.  This allows archives to be
produced in a deterministic fashion."
  (let ((st (stat file)))
    (make-cpio-header #:mode (stat:mode st)
                      #:nlink (stat:nlink st)
                      #:size (stat:size st)
                      #:name-size (string-length file-name))))

(define %trailer
  "TRAILER!!!")

(define %last-header
  ;; The header that marks the end of the archive.
  (make-cpio-header #:mode 0
                    #:name-size (string-length %trailer)))

(define* (write-cpio-archive files port
                             #:key (file->header file->cpio-header))
  "Write to PORT a cpio archive in \"new ASCII\" format containing all of FILES.

The archive written to PORT is intended to be bit-identical to what GNU cpio
produces with the '-H newc' option."
  (define (write-padding offset port)
    (let ((padding (modulo (- 4 (modulo offset 4)) 4)))
      (put-bytevector port (make-bytevector padding))))

  (define (pad-block port)
    ;; Write padding to PORT such that we finish with a 512-byte block.
    ;; XXX: We rely on PORT's internal state, assuming it's a file port.
    (let* ((offset  (seek port 0 SEEK_CUR))
           (padding (modulo (- 512 (modulo offset 512)) 512)))
      (put-bytevector port (make-bytevector padding))))

  (define (dump-file file)
    (let* ((header (file->header file))
           (size   (cpio-header-file-size header)))
      (write-cpio-header header port)
      (put-bytevector port (string->utf8 file))
      (put-u8 port 0)

      ;; We're padding the header + following file name + trailing zero, and
      ;; the header is 110 byte long.
      (write-padding (+ 110 1 (string-length file)) port)

      (case (mode->type (cpio-header-mode header))
        ((regular)
         (call-with-input-file file
           (lambda (input)
             (dump-port input port))))
        ((symlink)
         (let ((target (readlink file)))
           (put-string port target)))
        ((directory)
         #t)
        (else
         (error "file type not supported")))

      ;; Pad the file content.
      (write-padding size port)))

  (set-port-encoding! port "ISO-8859-1")

  (for-each dump-file files)

  (write-cpio-header %last-header port)
  (put-bytevector port (string->utf8 %trailer))
  (write-padding (string-length %trailer) port)

  ;; Pad so the last block is 512-byte long.
  (pad-block port))

;;; cpio.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018 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 cve)
  #:use-module (guix utils)
  #:use-module (guix http-client)
  #:use-module (sxml ssax)
  #:use-module (web uri)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:export (vulnerability?
            vulnerability-id
            vulnerability-packages

            xml->vulnerabilities
            current-vulnerabilities
            vulnerabilities->lookup-proc))

;;; Commentary:
;;;
;;; This modules provides the tools to fetch, parse, and digest part of the
;;; Common Vulnerabilities and Exposures (CVE) feeds provided by the US NIST
;;; at <https://nvd.nist.gov/download.cfm#CVE_FEED>.
;;;
;;; Code:

(define-record-type <vulnerability>
  (vulnerability id packages)
  vulnerability?
  (id         vulnerability-id)                   ;string
  (packages   vulnerability-packages))            ;((p1 v1 v2 v3) (p2 v1) ...)

(define %now
  (current-date))
(define %current-year
  (date-year %now))
(define %past-year
  (- %current-year 1))

(define (yearly-feed-uri year)
  "Return the URI for the CVE feed for YEAR."
  (string->uri
   (string-append "https://nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-"
                  (number->string year) ".xml.gz")))

(define %current-year-ttl
  ;; According to <https://nvd.nist.gov/download.cfm#CVE_FEED>, feeds are
  ;; updated "approximately every two hours."
  (* 60 30))

(define %past-year-ttl
  ;; Update the previous year's database more and more infrequently.
  (* 3600 24 (date-month %now)))

(define %cpe-package-rx
  ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes
  ;; "cpe/a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL".
  (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)((:.+)?)"))

(define (cpe->package-name cpe)
  "Converts the Common Platform Enumeration (CPE) string CPE to a package
name, in a very naive way.  Return two values: the package name, and its
version string.  Return #f and #f if CPE does not look like an application CPE
string."
  (cond ((regexp-exec %cpe-package-rx (string-trim-both cpe))
         =>
         (lambda (matches)
           (values (match:substring matches 2)
                   (string-append (match:substring matches 3)
                                  (match (match:substring matches 4)
                                    ("" "")
                                    (patch-level
                                     ;; Drop the colon from things like
                                     ;; "cpe:/a:openbsd:openssh:6.8:p1".
                                     (string-drop patch-level 1)))))))
        (else
         (values #f #f))))

(define (cpe->product-alist products)
  "Given PRODUCTS, a list of CPE names, return the subset limited to the
applications listed in PRODUCTS, with names converted to package names:

  (cpe->product-alist
    '(\"cpe:/a:gnu:libtasn1:4.7\" \"cpe:/a:gnu:libtasn1:4.6\" \"cpe:/a:gnu:cpio:2.11\"))
  => ((\"libtasn1\" \"4.7\" \"4.6\") (\"cpio\" \"2.11\"))
"
  (fold (lambda (product result)
          (let-values (((name version) (cpe->package-name product)))
            (if name
                (match result
                  (((previous . versions) . tail)
                   ;; Attempt to coalesce NAME and PREVIOUS.
                   (if (string=? name previous)
                       (alist-cons name (cons version versions) tail)
                       (alist-cons name (list version) result)))
                  (()
                   (alist-cons name (list version) result)))
                result)))
        '()
        (sort products string<?)))

(define %parse-vulnerability-feed
  ;; Parse the XML vulnerability feed from
  ;; <https://nvd.nist.gov/download.cfm#CVE_FEED> and return a list of
  ;; vulnerability objects.
  (ssax:make-parser NEW-LEVEL-SEED
                    (lambda (elem-gi attributes namespaces expected-content
                                     seed)
                      (match elem-gi
                        ((name-space . 'entry)
                         (cons (assoc-ref attributes 'id) seed))
                        ((name-space . 'vulnerable-software-list)
                         (cons '() seed))
                        ((name-space . 'product)
                         (cons 'product seed))
                        (x seed)))

                    FINISH-ELEMENT
                    (lambda (elem-gi attributes namespaces parent-seed
                                     seed)
                      (match elem-gi
                        ((name-space . 'entry)
                         (match seed
                           (((? string? id) . rest)
                            ;; Some entries have no vulnerable-software-list.
                            rest)
                           ((products id . rest)
                            (match (cpe->product-alist products)
                              (()
                               ;; No application among PRODUCTS.
                               rest)
                              (packages
                               (cons (vulnerability id packages)
                                     rest))))))
                        (x
                         seed)))

                    CHAR-DATA-HANDLER
                    (lambda (str _ seed)
                      (match seed
                        (('product software-list . rest)
                         ;; Add STR to the vulnerable software list this
                         ;; <product> tag is part of.
                         (cons (cons str software-list) rest))
                        (x x)))))

(define (xml->vulnerabilities port)
  "Read from PORT an XML feed of vulnerabilities and return a list of
vulnerability objects."
  (reverse (%parse-vulnerability-feed port '())))

(define vulnerability->sexp
  (match-lambda
    (($ <vulnerability> id packages)
     `(v ,id ,packages))))

(define sexp->vulnerability
  (match-lambda
    (('v id (packages ...))
     (vulnerability id packages))))

(define (write-cache input cache)
  "Read vulnerabilities as gzipped XML from INPUT, and write it as a compact
sexp to CACHE."
  (call-with-decompressed-port 'gzip input
    (lambda (input)
      ;; XXX: The SSAX "error port" is used to send pointless warnings such as
      ;; "warning: Skipping PI".  Turn that off.
      (define vulns
        (parameterize ((current-ssax-error-port (%make-void-port "w")))
          (xml->vulnerabilities input)))

      (write `(vulnerabilities
               1                                  ;format version
               ,(map vulnerability->sexp vulns))
             cache))))

(define (fetch-vulnerabilities year ttl)
  "Return the list of <vulnerability> for YEAR, assuming the on-disk cache has
the given TTL (fetch from the NIST web site when TTL has expired)."
  (define (cache-miss uri)
    (format (current-error-port) "fetching CVE database for ~a...~%" year))

  (define (read* port)
    ;; Disable read options to avoid populating the source property weak
    ;; table, which speeds things up, saves memory, and works around
    ;; <https://lists.gnu.org/archive/html/guile-devel/2017-09/msg00031.html>.
    (let ((options (read-options)))
      (dynamic-wind
        (lambda ()
          (read-disable 'positions))
        (lambda ()
          (read port))
        (lambda ()
          (read-options options)))))

  ;; Note: We used to keep the original XML files in cache but parsing it
  ;; would take typically ~15s for a year of data.  Thus, we instead store a
  ;; summarized version thereof as an sexp, which can be parsed in 1s or so.
  (let* ((port (http-fetch/cached (yearly-feed-uri year)
                                  #:ttl ttl
                                  #:write-cache write-cache
                                  #:cache-miss cache-miss))
         (sexp (read* port)))
    (close-port port)
    (match sexp
      (('vulnerabilities 1 vulns)
       (map sexp->vulnerability vulns)))))

(define (current-vulnerabilities)
  "Return the current list of Common Vulnerabilities and Exposures (CVE) as
published by the US NIST."
  (let ((past-years (unfold (cut > <> 3)
                            (lambda (n)
                              (- %current-year n))
                            1+
                            1))
        (past-ttls  (unfold (cut > <> 3)
                            (lambda (n)
                              (* n %past-year-ttl))
                            1+
                            1)))
    (append-map fetch-vulnerabilities
                (cons %current-year past-years)
                (cons %current-year-ttl past-ttls))))

(define (vulnerabilities->lookup-proc vulnerabilities)
  "Return a lookup procedure built from VULNERABILITIES that takes a package
name and optionally a version number.  When the version is omitted, the lookup
procedure returns a list of vulnerabilities; otherwise, it returns a list of
vulnerabilities affecting the given package version."
  (define table
    ;; Map package names to lists of version/vulnerability pairs.
    (fold (lambda (vuln table)
            (match vuln
              (($ <vulnerability> id packages)
               (fold (lambda (package table)
                       (match package
                         ((name . versions)
                          (vhash-cons name (cons vuln versions)
                                      table))))
                     table
                     packages))))
          vlist-null
          vulnerabilities))

  (lambda* (package #:optional version)
    (vhash-fold* (if version
                     (lambda (pair result)
                       (match pair
                         ((vuln . versions)
                          (if (member version versions)
                              (cons vuln result)
                              result))))
                     (lambda (pair result)
                       (match pair
                         ((vuln . _)
                          (cons vuln result)))))
                 '()
                 package table)))

;;; cve.scm ends here


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

(define-module (guix cvs-download)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:export (cvs-reference
            cvs-reference?
            cvs-reference-url
            cvs-reference-revision
            cvs-fetch))

;;; Commentary:
;;;
;;; An <origin> method that fetches a specific revision or date from a CVS
;;; repository.  The CVS-ROOT-DIRECTORY, MODULE and REVISION are specified
;;; with a <cvs-reference> object.  REVISION should be specified as either a
;;; date string in ISO-8601 format (e.g. "2012-12-21") or a CVS tag.
;;;
;;; Code:

(define-record-type* <cvs-reference>
  cvs-reference make-cvs-reference
  cvs-reference?
  (root-directory cvs-reference-root-directory)         ; string
  (module         cvs-reference-module)                 ; string
  (revision       cvs-reference-revision))              ; string

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

(define* (cvs-fetch ref hash-algo hash
                    #:optional name
                    #:key (system (%current-system)) (guile (default-guile))
                    (cvs (cvs-package)))
  "Return a fixed-output derivation that fetches REF, a <cvs-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 zlib
    (module-ref (resolve-interface '(gnu packages compression)) 'zlib))

  (define config.scm
    (scheme-file "config.scm"
                 #~(begin
                     (define-module (guix config)
                       #:export (%libz))

                     (define %libz
                       #+(file-append zlib "/lib/libz")))))

  (define modules
    (cons `((guix config) => ,config.scm)
          (delete '(guix config)
                  (source-module-closure '((guix build cvs)
                                           (guix build download-nar))))))
  (define build
    (with-imported-modules modules
      #~(begin
          (use-modules (guix build cvs)
                       (guix build download-nar))

          (or (cvs-fetch '#$(cvs-reference-root-directory ref)
                         '#$(cvs-reference-module ref)
                         '#$(cvs-reference-revision ref)
                         #$output
                         #:cvs-command (string-append #+cvs "/bin/cvs"))
              (download-nar #$output)))))

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

;;; cvs-download.scm ends here