code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; 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 asdf-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build lisp-utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:export (%standard-phases
            %standard-phases/source
            asdf-build
            asdf-build/source))

;; Commentary:
;;
;; System for building ASDF packages; creating executable programs and images
;; from them.
;;
;; Code:

(define %object-prefix "/lib")

(define (%lisp-source-install-prefix)
  (string-append %source-install-prefix "/" (%lisp-type) "-source"))

(define %system-install-prefix
  (string-append %source-install-prefix "/systems"))

(define (lisp-source-directory output name)
  (string-append output (%lisp-source-install-prefix) "/" name))

(define (source-directory output name)
  (string-append output %source-install-prefix "/source/" name))

(define (library-directory output)
  (string-append output %object-prefix
                 "/" (%lisp-type)))

(define (output-translation source-path
                            object-output)
  "Return a translation for the system's source path
to it's binary output."
  `((,source-path
     :**/ :*.*.*)
    (,(library-directory object-output)
     :**/ :*.*.*)))

(define (source-asd-file output name asd-file)
  (string-append (lisp-source-directory output name) "/" asd-file))

(define (copy-files-to-output out name)
  "Copy all files from the current directory to OUT.  Create an extra link to
any system-defining files in the source to a convenient location.  This is
done before any compiling so that the compiled source locations will be
valid."
  (let ((source (getcwd))
        (target (source-directory out name))
        (system-path (string-append out %system-install-prefix)))
    (copy-recursively source target)
    (mkdir-p system-path)
    (for-each
     (lambda (file)
       (symlink file
                (string-append system-path "/" (basename file))))
     (find-files target "\\.asd$"))
    #t))

(define* (install #:key outputs #:allow-other-keys)
  "Copy and symlink all the source files."
  (define output (assoc-ref outputs "out"))
  (copy-files-to-output output
                        (package-name->name+version
                         (strip-store-file-name output))))

(define* (copy-source #:key outputs asd-system-name #:allow-other-keys)
  "Copy the source to the library output."
  (let* ((out (library-output outputs))
         (install-path (string-append out %source-install-prefix)))
    (copy-files-to-output out asd-system-name)
    ;; Hide the files from asdf
    (with-directory-excursion install-path
      (rename-file "source" (string-append (%lisp-type) "-source"))
      (delete-file-recursively "systems")))
  #t)

(define* (build #:key outputs inputs asd-file asd-system-name
                #:allow-other-keys)
  "Compile the system."
  (let* ((out (library-output outputs))
         (source-path (lisp-source-directory out asd-system-name))
         (translations (wrap-output-translations
                        `(,(output-translation source-path
                                               out))))
         (asd-file (source-asd-file out asd-system-name asd-file)))

    (setenv "ASDF_OUTPUT_TRANSLATIONS"
            (replace-escaped-macros (format #f "~S" translations)))

    (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache

    (compile-system asd-system-name asd-file)

    ;; As above, ecl will sometimes create this even though it doesn't use it

    (let ((cache-directory (string-append out "/.cache")))
      (when (directory-exists? cache-directory)
        (delete-file-recursively cache-directory))))
  #t)

(define* (check #:key tests? outputs inputs asd-file asd-system-name
                test-asd-file
                #:allow-other-keys)
  "Test the system."
  (let* ((out (library-output outputs))
         (asd-file (source-asd-file out asd-system-name asd-file))
         (test-asd-file
          (and=> test-asd-file
                 (cut source-asd-file out asd-system-name <>))))
    (if tests?
        (test-system asd-system-name asd-file test-asd-file)
        (format #t "test suite not run~%")))
  #t)

(define* (create-asd-file #:key outputs
                          inputs
                          asd-file
                          asd-system-name
                          #:allow-other-keys)
  "Create a system definition file for the built system."
  (let*-values (((out) (library-output outputs))
                ((_ version) (package-name->name+version
                              (strip-store-file-name out)))
                ((new-asd-file) (string-append
                                 (library-directory out)
                                 "/" (normalize-string asd-system-name)
                                 ".asd")))

    (make-asd-file new-asd-file
                   #:system asd-system-name
                   #:version version
                   #:inputs inputs
                   #:system-asd-file asd-file))
  #t)

(define* (symlink-asd-files #:key outputs #:allow-other-keys)
  "Create an extra reference to the system in a convenient location."
  (let* ((out (library-output outputs)))
    (for-each
     (lambda (asd-file)
       (receive (new-asd-file asd-file-directory)
           (bundle-asd-file out asd-file)
         (mkdir-p asd-file-directory)
         (symlink asd-file new-asd-file)
         ;; Update the source registry for future phases which might want to
         ;; use the newly compiled system.
         (prepend-to-source-registry
          (string-append asd-file-directory "/"))))

     (find-files (string-append out %object-prefix) "\\.asd$")))
  #t)

(define* (cleanup-files #:key outputs
                        #:allow-other-keys)
  "Remove any compiled files which are not a part of the final bundle."
  (let ((out (library-output outputs)))
    (match (%lisp-type)
      ("sbcl"
       (for-each
        (lambda (file)
          (unless (string-suffix? "--system.fasl" file)
            (delete-file file)))
        (find-files out "\\.fasl$")))
      ("ecl"
       (for-each delete-file
                 (append (find-files out "\\.fas$")
                         (find-files out "\\.o$")))))

    (with-directory-excursion (library-directory out)
      (for-each
       (lambda (file)
         (rename-file file
                      (string-append "./" (basename file))))
       (find-files "."))
      (for-each delete-file-recursively
                (scandir "."
                         (lambda (file)
                           (and
                            (directory-exists? file)
                            (string<> "." file)
                            (string<> ".." file)))))))
  #t)

(define* (strip #:rest args)
  ;; stripping sbcl binaries removes their entry program and extra systems
  (or (string=? (%lisp-type) "sbcl")
      (apply (assoc-ref gnu:%standard-phases 'strip) args)))

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

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'install)
    (replace 'build build)
    (add-before 'build 'copy-source copy-source)
    (replace 'check check)
    (replace 'strip strip)
    (add-after 'check 'create-asd-file create-asd-file)
    (add-after 'create-asd-file 'cleanup cleanup-files)
    (add-after 'cleanup 'create-symlinks symlink-asd-files)))

(define* (asdf-build #:key inputs
                     (phases %standard-phases)
                     #:allow-other-keys
                     #:rest args)
  (apply gnu:gnu-build
         #:inputs inputs
         #:phases phases
         args))

(define* (asdf-build/source #:key inputs
                            (phases %standard-phases/source)
                            #:allow-other-keys
                            #:rest args)
  (apply gnu:gnu-build
         #:inputs inputs
         #:phases phases
         args))

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 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 bournish)
  #:use-module (system base language)
  #:use-module (system base compile)
  #:use-module (system repl command)
  #:use-module (system repl common)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (%bournish-language))

;;; Commentary:
;;;
;;; This is a super minimal Bourne-like shell language for Guile.  It is meant
;;; to be used at the REPL as a rescue shell.  In a way, this is to Guile what
;;; eshell is to Emacs.
;;;
;;; Code:

(define (expand-variable str)
  "Return STR or code to obtain the value of the environment variable STR
refers to."
  ;; XXX: No support for "${VAR}".
  (if (string-prefix? "$" str)
      `(or (getenv ,(string-drop str 1)) "")
      str))

(define* (display-tabulated lst
                            #:key
                            (terminal-width 80)
                            (column-gap 2))
  "Display the list of string LST in as many columns as needed given
TERMINAL-WIDTH.  Use COLUMN-GAP spaces between two subsequent columns."
  (define len (length lst))
  (define column-width
    ;; The width of a column.  Assume all the columns have the same width
    ;; (GNU ls is smarter than that.)
    (+ column-gap (reduce max 0 (map string-length lst))))
  (define columns
    (max 1
         (quotient terminal-width column-width)))
  (define pad
    (if (zero? (modulo len columns))
        0
        columns))
  (define items-per-column
    (quotient (+ len pad) columns))
  (define items (list->vector lst))

  (let loop ((indexes (unfold (cut >= <> columns)
                              (cut * <> items-per-column)
                              1+
                              0)))
    (unless (>= (first indexes) items-per-column)
      (for-each (lambda (index)
                  (let ((item (if (< index len)
                                  (vector-ref items index)
                                  "")))
                    (display (string-pad-right item column-width))))
                indexes)
      (newline)
      (loop (map 1+ indexes)))))

(define ls-command-implementation
  ;; Run-time support procedure.
  (case-lambda
    (()
     (display-tabulated (scandir ".")))
    (files
     (let ((files (append-map (lambda (file)
                                (catch 'system-error
                                  (lambda ()
                                    (match (stat:type (lstat file))
                                      ('directory
                                       ;; Like GNU ls, list the contents of
                                       ;; FILE rather than FILE itself.
                                       (match (scandir file
                                                       (match-lambda
                                                         ((or "." "..") #f)
                                                         (_ #t)))
                                         (#f
                                          (list file))
                                         ((files ...)
                                          (map (cut string-append file "/" <>)
                                               files))))
                                      (_
                                       (list file))))
                                  (lambda args
                                    (let ((errno (system-error-errno args)))
                                      (format (current-error-port) "~a: ~a~%"
                                              file (strerror errno))
                                      '()))))
                              files)))
       (display-tabulated files)))))

(define (ls-command . files)
  `((@@ (guix build bournish) ls-command-implementation) ,@files))

(define (which-command program)
  `(search-path ((@@ (guix build bournish) executable-path))
                ,program))

(define (cat-command file)
  `(call-with-input-file ,file
     (lambda (port)
       ((@ (guix build utils) dump-port) port (current-output-port))
       *unspecified*)))

(define (rm-command . args)
  "Emit code for the 'rm' command."
  (cond ((member "-r" args)
         `(for-each (@ (guix build utils) delete-file-recursively)
                    (list ,@(delete "-r" args))))
        (else
         `(for-each delete-file (list ,@args)))))

(define (lines+chars port)
  "Return the number of lines and number of chars read from PORT."
  (let loop ((lines 0) (chars 0))
    (match (read-char port)
      ((? eof-object?)              ;done!
       (values lines chars))
      (#\newline                    ;recurse
       (loop (1+ lines) (1+ chars)))
      (_                            ;recurse
       (loop lines (1+ chars))))))

(define (file-exists?* file)
  "Like 'file-exists?' but emits a warning if FILE is not accessible."
  (catch 'system-error
    (lambda ()
      (stat file))
    (lambda args
      (let ((errno (system-error-errno args)))
        (format (current-error-port) "~a: ~a~%"
                file (strerror errno))
        #f))))

(define (wc-print file)
  (let-values (((lines chars)
                (call-with-input-file file lines+chars)))
              (format #t "~a ~a ~a~%" lines chars file)))

(define (wc-l-print file)
  (let-values (((lines chars)
                (call-with-input-file file lines+chars)))
              (format #t "~a ~a~%" lines file)))

(define (wc-c-print file)
  (let-values (((lines chars)
                (call-with-input-file file lines+chars)))
              (format #t "~a ~a~%" chars file)))

(define (wc-command-implementation . files)
  (for-each wc-print (filter file-exists?* files)))

(define (wc-l-command-implementation . files)
  (for-each wc-l-print (filter file-exists?* files)))

(define (wc-c-command-implementation . files)
  (for-each wc-c-print (filter file-exists?* files)))

(define (wc-command . args)
  "Emit code for the 'wc' command."
  (cond ((member "-l" args)
         `((@@ (guix build bournish) wc-l-command-implementation)
           ,@(delete "-l" args)))
        ((member "-c" args)
         `((@@ (guix build bournish) wc-c-command-implementation)
           ,@(delete "-c" args)))
        (else
         `((@@ (guix build bournish) wc-command-implementation) ,@args))))

(define (reboot-command . args)
  "Emit code for 'reboot'."
  ;; Normally Bournish is used in the initrd, where 'reboot' is provided
  ;; directly by (guile-user).  In other cases, just bail out.
  `(if (defined? 'reboot)
       (reboot)
       (begin
         (format (current-error-port)
                 "I don't know how to reboot, sorry about that!~%")
         #f)))

(define (help-command . _)
  (display "\
Hello, this is Bournish, a minimal Bourne-like shell in Guile!

The shell is good enough to navigate the file system and run commands but not
much beyond that.  It is meant to be used as a rescue shell in the initial RAM
disk and is probably not very useful apart from that.  It has a few built-in
commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n"))

(define %not-colon (char-set-complement (char-set #\:)))
(define (executable-path)
  "Return the search path for programs as a list."
  (match (getenv "PATH")
    (#f  '())
    (str (string-tokenize str %not-colon))))

(define %commands
  ;; Built-in commands.
  `(("echo"   ,(lambda strings `(list ,@strings)))
    ("cd"     ,(lambda (dir) `(chdir ,dir)))
    ("pwd"    ,(lambda () `(getcwd)))
    ("rm"     ,rm-command)
    ("cp"     ,(lambda (source dest) `(copy-file ,source ,dest)))
    ("help"   ,help-command)
    ("ls"     ,ls-command)
    ("which"  ,which-command)
    ("cat"    ,cat-command)
    ("wc"     ,wc-command)
    ("reboot" ,reboot-command)))

(define (read-bournish port env)
  "Read a Bournish expression from PORT, and return the corresponding Scheme
code as an sexp."
  (match (read-line port)
    ((? eof-object? eof)
     eof)
    ((= string-tokenize (command args ...))
     (match (assoc command %commands)
       ((command proc)                            ;built-in command
        (apply proc (map expand-variable args)))
       (#f
        (let ((command (if (string-prefix? "\\" command)
                           (string-drop command 1)
                           command)))
          `(system* ,command ,@(map expand-variable args))))))))

(define %bournish-language
  (let ((scheme (lookup-language 'scheme)))
    ;; XXX: The 'scheme' language lacks a "joiner", so we add one here.  This
    ;; allows us to have 'read-bournish' read one shell statement at a time
    ;; instead of having to read until EOF.
    (set! (language-joiner scheme)
      (lambda (exps env)
        (match exps
          (()   '(begin))
          ((exp) exp)
          (_    `(begin ,@exps)))))

    (make-language #:name 'bournish
                   #:title "Bournish"

                   ;; The reader does all the heavy lifting.
                   #:reader read-bournish
                   #:compilers `((scheme . ,(lambda (exp env options)
                                              (values exp env env))))
                   #:decompilers '()
                   #:evaluator (language-evaluator scheme)
                   #:printer (language-printer scheme)
                   #:make-default-environment
                   (language-make-default-environment scheme))))

;; XXX: ",L bournish" won't work unless we call our module (language bournish
;; spec), which is kinda annoying, so provide another meta-command.
(define-meta-command ((bournish guix) repl)
  "bournish
Switch to the Bournish language."
  (let ((current (repl-language repl)))
    (format #t "Welcome to ~a, a minimal Bourne-like shell!~%To switch back, type `,L ~a'.\n"
            (language-title %bournish-language)
            (language-name current))
    (current-language %bournish-language)
    (set! (repl-language repl) %bournish-language)))

;;; bournish.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 cargo-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            cargo-build
            generate-checksums))

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

;; FIXME: Needs to be parsed from url not package name.
(define (package-name->crate-name name)
  "Return the crate name of NAME."
  (match (string-split name #\-)
    (("rust" rest ...)
     (string-join rest "-"))
    (_ #f)))

(define* (configure #:key inputs #:allow-other-keys)
  "Replace Cargo.toml [dependencies] section with guix inputs."
  ;; Make sure Cargo.toml is writeable when the crate uses git-fetch.
  (chmod "Cargo.toml" #o644)
  (chmod "." #o755)
  (if (not (file-exists? "vendor"))
    (if (not (file-exists? "Cargo.lock"))
      (begin
        (substitute* "Cargo.toml"
          ((".*32-sys.*") "
")
          ((".*winapi.*") "
")
          ((".*core-foundation.*") "
"))
        ;; Prepare one new directory with all the required dependencies.
        ;; It's necessary to do this (instead of just using /gnu/store as the
        ;; directory) because we want to hide the libraries in subdirectories
        ;;   share/rust-source/... instead of polluting the user's profile root.
        (mkdir "vendor")
        (for-each
          (match-lambda
            ((name . path)
             (let ((crate (package-name->crate-name name)))
               (when (and crate path)
                 (match (string-split (basename path) #\-)
                   ((_ ... version)
                    (symlink (string-append path "/share/rust-source")
                             (string-append "vendor/" (basename path)))))))))
          inputs)
        ;; Configure cargo to actually use this new directory.
        (mkdir-p ".cargo")
        (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8")))
          (display "
[source.crates-io]
registry = 'https://github.com/rust-lang/crates.io-index'
replace-with = 'vendored-sources'

[source.vendored-sources]
directory = '" port)
          (display (getcwd) port)
          (display "/vendor" port)
          (display "'
" port)
          (close-port port)))))
    (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc"))

    ;(setenv "CARGO_HOME" "/gnu/store")
    ; (setenv "CMAKE_C_COMPILER" cc)
  #t)

(define* (build #:key (cargo-build-flags '("--release"))
                #:allow-other-keys)
  "Build a given Cargo package."
  (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))))

(define* (check #:key tests? #:allow-other-keys)
  "Run tests for a given Cargo package."
  (if (and tests? (file-exists? "Cargo.lock"))
      (zero? (system* "cargo" "test"))
      #t))

(define (file-sha256 file-name)
  "Calculate the hexdigest of the sha256 checksum of FILE-NAME and return it."
  (let ((port (open-pipe* OPEN_READ
                          "sha256sum"
                          "--"
                          file-name)))
    (let ((result (read-delimited " " port)))
      (close-pipe port)
      result)))

(define (generate-checksums dir-name src-name)
  "Given DIR-NAME, a store directory, checksum all the files in it one
by one and put the result into the file \".cargo-checksum.json\" in
the same directory.  Also includes the checksum of an extra file
SRC-NAME as if it was part of the directory DIR-NAME with name
\"package\"."
  (let* ((file-names (find-files dir-name "."))
         (dir-prefix-name (string-append dir-name "/"))
         (dir-prefix-name-len (string-length dir-prefix-name))
         (checksums-file-name (string-append dir-name "/.cargo-checksum.json")))
    (call-with-output-file checksums-file-name
      (lambda (port)
        (display "{\"files\":{" port)
        (let ((sep ""))
          (for-each (lambda (file-name)
            (let ((file-relative-name (string-drop file-name dir-prefix-name-len)))
                  (display sep port)
                  (set! sep ",")
                  (write file-relative-name port)
                  (display ":" port)
                  (write (file-sha256 file-name) port))) file-names))
        (display "},\"package\":" port)
        (write (file-sha256 src-name) port)
        (display "}" port)))))

(define (touch file-name)
  (call-with-output-file file-name (const #t)))

(define* (install #:key inputs outputs #:allow-other-keys)
  "Install a given Cargo package."
  (let* ((out (assoc-ref outputs "out"))
         (src (assoc-ref inputs "source"))
         (rsrc (string-append (assoc-ref outputs "src")
                              "/share/rust-source")))
    (mkdir-p rsrc)
    ;; Rust doesn't have a stable ABI yet. Because of this
    ;; Cargo doesn't have a search path for binaries yet.
    ;; Until this changes we are working around this by
    ;; distributing crates as source and replacing
    ;; references in Cargo.toml with store paths.
    (copy-recursively "src" (string-append rsrc "/src"))
    (touch (string-append rsrc "/.cargo-ok"))
    (generate-checksums rsrc src)
    (install-file "Cargo.toml" rsrc)
    ;; When the package includes executables we install
    ;; it using cargo install. This fails when the crate
    ;; doesn't contain an executable.
    (if (file-exists? "Cargo.lock")
        (zero? (system* "cargo" "install" "--root" out))
        (begin
          (mkdir out)
          #t))))

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

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 cmake-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            cmake-build))

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

(define* (configure #:key outputs (configure-flags '()) (out-of-source? #t)
                    build-type target
                    #:allow-other-keys)
  "Configure the given package."
  (let* ((out        (assoc-ref outputs "out"))
         (abs-srcdir (getcwd))
         (srcdir     (if out-of-source?
                         (string-append "../" (basename abs-srcdir))
                         ".")))
    (format #t "source directory: ~s (relative from build: ~s)~%"
            abs-srcdir srcdir)
    (when out-of-source?
      (mkdir "../build")
      (chdir "../build"))
    (format #t "build directory: ~s~%" (getcwd))

    (let ((args `(,srcdir
                  ,@(if build-type
                        (list (string-append "-DCMAKE_BUILD_TYPE="
                                             build-type))
                        '())
                  ,(string-append "-DCMAKE_INSTALL_PREFIX=" out)
                  ;; ensure that the libraries are installed into /lib
                  "-DCMAKE_INSTALL_LIBDIR=lib"
                  ;; add input libraries to rpath
                  "-DCMAKE_INSTALL_RPATH_USE_LINK_PATH=TRUE"
                  ;; add (other) libraries of the project itself to rpath
                  ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib")
                  ;; enable verbose output from builds
                  "-DCMAKE_VERBOSE_MAKEFILE=ON"

                  ;;  Cross-build
                  ,@(if target
                        (list (string-append "-DCMAKE_C_COMPILER="
                                             target "-gcc")
                              (if (string-contains target "mingw")
                                  "-DCMAKE_SYSTEM_NAME=Windows"
                                  "-DCMAKE_SYSTEM_NAME=Linux"))
                        '())
                  ,@configure-flags)))
      (format #t "running 'cmake' with arguments ~s~%" args)
      (apply invoke "cmake" args))))

(define* (check #:key (tests? #t) (parallel-tests? #t) (test-target "test")
                #:allow-other-keys)
  (let ((gnu-check (assoc-ref gnu:%standard-phases 'check)))
    (setenv "CTEST_OUTPUT_ON_FAILURE" "1")
    (gnu-check #:tests? tests? #:test-target test-target
              #:parallel-tests? parallel-tests?)))

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; and 'check' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (replace 'check check)
    (replace 'configure configure)))

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;;
;;; 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 compile)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 threads)
  #:use-module (system base target)
  #:use-module (system base compile)
  #:use-module (system base message)
  #:use-module (guix modules)
  #:use-module (guix build utils)
  #:export (%default-optimizations
            %lightweight-optimizations
            compile-files))

;;; Commentary:
;;;
;;; Support code to compile Guile code as efficiently as possible (both with
;;; Guile 2.0 and 2.2).
;;;
;;; Code:

(cond-expand
  (guile-2.2 (use-modules (language tree-il optimize)
                          (language cps optimize)))
  (else #f))

(define %default-optimizations
  ;; Default optimization options (equivalent to -O2 on Guile 2.2).
  (cond-expand
    (guile-2.2 (append (tree-il-default-optimization-options)
                       (cps-default-optimization-options)))
    (else '())))

(define %lightweight-optimizations
  ;; Lightweight optimizations (like -O0, but with partial evaluation).
  (let loop ((opts %default-optimizations)
             (result '()))
    (match opts
      (() (reverse result))
      ((#:partial-eval? _ rest ...)
       (loop rest `(#t #:partial-eval? ,@result)))
      ((kw _ rest ...)
       (loop rest `(#f ,kw ,@result))))))

(define %warnings
  ;; FIXME: 'format' is missing because it reports "non-literal format
  ;; strings" due to the fact that we use 'G_' instead of '_'.  We'll need
  ;; help from Guile to solve this.
  '(unsupported-warning unbound-variable arity-mismatch
    macro-use-before-definition))                 ;new in 2.2

(define (optimization-options file)
  "Return the default set of optimizations options for FILE."
  (if (string-contains file "gnu/packages/")
      %lightweight-optimizations                  ;build faster
      '()))

(define (scm->go file)
  "Strip the \".scm\" suffix from FILE, and append \".go\"."
  (string-append (string-drop-right file 4) ".go"))

(define (relative-file directory file)
  "Return FILE relative to DIRECTORY, if possible."
  (if (string-prefix? (string-append directory "/") file)
      (string-drop file (+ 1 (string-length directory)))
      file))

(define* (load-files directory files
                     #:key
                     (report-load (const #f))
                     (debug-port (%make-void-port "w")))
  "Load FILES, a list of relative file names, from DIRECTORY."
  (define total
    (length files))

  (let loop ((files files)
             (completed 0))
    (match files
      (()
       (unless (zero? total)
         (report-load #f total completed))
       *unspecified*)
      ((file files ...)
       (let ((file (relative-file directory file)))
         (report-load file total completed)
         (format debug-port "~%loading '~a'...~%" file)

         (parameterize ((current-warning-port debug-port))
           (resolve-interface (file-name->module-name file)))

         (loop files (+ 1 completed)))))))

(define-syntax-rule (with-augmented-search-path path item body ...)
  "Within the dynamic extent of BODY, augment PATH by adding ITEM to the
front."
  (let ((initial-value path))
    (dynamic-wind
      (lambda ()
        (set! path (cons item path)))
      (lambda ()
        body ...)
      (lambda ()
        (set! path initial-value)))))

(define (call/exit-on-exception thunk)
  "Evaluate THUNK and exit right away if an exception is thrown."
  (catch #t
    thunk
    (const #f)
    (lambda (key . args)
      (false-if-exception
       ;; Duplicate stderr to avoid thread-safety issues.
       (let* ((port  (duplicate-port (current-error-port) "w0"))
              (stack (make-stack #t))
              (depth (stack-length stack))
              (frame (and (> depth 1) (stack-ref stack 1))))
         (false-if-exception (display-backtrace stack port))
         (print-exception port frame key args)))

      ;; Don't go any further.
      (primitive-exit 1))))

(define-syntax-rule (exit-on-exception exp ...)
  "Evaluate EXP and exit if an exception is thrown."
  (call/exit-on-exception (lambda () exp ...)))

(define* (compile-files source-directory build-directory files
                        #:key
                        (host %host-type)
                        (workers (current-processor-count))
                        (optimization-options optimization-options)
                        (warning-options `(#:warnings ,%warnings))
                        (report-load (const #f))
                        (report-compilation (const #f))
                        (debug-port (%make-void-port "w")))
  "Compile FILES, a list of source files taken from SOURCE-DIRECTORY, to
BUILD-DIRECTORY, using up to WORKERS parallel workers.  The resulting object
files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
  (define progress-lock (make-mutex))
  (define total (length files))
  (define completed 0)

  (define (build file)
    (with-mutex progress-lock
      (report-compilation file total completed))

    ;; Exit as soon as something goes wrong.
    (exit-on-exception
     (with-fluids ((*current-warning-prefix* ""))
       (with-target host
         (lambda ()
           (let ((relative (relative-file source-directory file)))
             (compile-file file
                           #:output-file (string-append build-directory "/"
                                                        (scm->go relative))
                           #:opts (append warning-options
                                          (optimization-options relative))))))))
    (with-mutex progress-lock
      (set! completed (+ 1 completed))))

  (with-augmented-search-path %load-path source-directory
    (with-augmented-search-path %load-compiled-path build-directory
      ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all
      ;; of FILES.
      (load-files source-directory files
                  #:report-load report-load
                  #:debug-port debug-port)

      ;; Make sure compilation related modules are loaded before starting to
      ;; compile files in parallel.
      (compile #f)

      ;; XXX: Don't use too many workers to work around the insane memory
      ;; requirements of the compiler in Guile 2.2.2:
      ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
      (n-par-for-each (min workers 8) build files)

      (unless (zero? total)
        (report-compilation #f total total)))))

(eval-when (eval load)
  (when (and (string=? "2" (major-version))
             (or (string=? "0" (minor-version))
                 (and (string=? (minor-version) "2")
                      (< (string->number (micro-version)) 4))))
    ;; Work around <https://bugs.gnu.org/31878> on Guile < 2.2.4.
    ;; Serialize 'try-module-autoload' calls.
    (set! (@ (guile) try-module-autoload)
      (let ((mutex (make-mutex 'recursive))
            (real  (@ (guile) try-module-autoload)))
        (lambda* (module #:optional version)
          (with-mutex mutex
            (real module version)))))))

;;; Local Variables:
;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2)
;;; eval: (put 'with-target 'scheme-indent-function 1)
;;; End:


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

(define-module (guix build cvs)
  #:use-module (guix build utils)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 ftw)
  #:export (cvs-fetch))

;;; Commentary:
;;;
;;; This is the build-side support code of (guix cvs-download).  It allows a
;;; CVS repository to be checked out at a specific revision or date.
;;;
;;; Code:

(define (find-cvs-directories)
  (define (enter? path st result)
    (not (string-suffix? "/CVS" path)))
  (define (leaf path st result) result)
  (define (down path st result) result)
  (define (up   path st result) result)
  (define (skip path st result)
    (if (and (string-suffix? "/CVS" path)
             (eqv? 'directory (stat:type st)))
        (cons path result)
        result))
  (define (error path st errno result)
    (format (current-error-port) "cvs-fetch: ~a: ~a~%"
            path (strerror errno)))
  (sort (file-system-fold enter? leaf down up skip error '() "." lstat)
        string<?))

(define* (cvs-fetch cvs-root-directory module revision directory
                    #:key (cvs-command "cvs"))
  "Fetch REVISION from MODULE of CVS-ROOT-DIRECTORY into DIRECTORY.  REVISION
must either be a date in ISO-8601 format (e.g. \"2012-12-21\") or a CVS tag.
Return #t on success, #f otherwise."
  ;; Use "-z0" because enabling compression leads to hangs during checkout on
  ;; certain repositories, such as
  ;; ":pserver:anonymous@cvs.savannah.gnu.org:/sources/gnustandards".
  (invoke cvs-command "-z0"
          "-d" cvs-root-directory
          "checkout"
          (if (string-match "^[0-9]{4}-[0-9]{2}-[0-9]{2}$" revision)
              "-D" "-r")
          revision
          module)

  ;; Copy rather than rename in case MODULE and DIRECTORY are on
  ;; different devices.
  (copy-recursively module directory)

  (with-directory-excursion directory
    (for-each delete-file-recursively (find-cvs-directories)))
  #t)

;;; cvs.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 build debug-link)
  #:use-module (guix elf)
  #:use-module ((guix build utils)
                #:select (find-files elf-file? make-file-writable))
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (system foreign)
  #:use-module (ice-9 match)
  #:export (debuglink-crc32
            elf-debuglink
            set-debuglink-crc

            graft-debug-links))

;;; Commentary:
;;;
;;; This module provides tools to deal with '.gnu_debuglink' sections in ELF
;;; files.  These sections are created by 'objcopy --add-gnu-debuglink' to
;;; create separate debug files (info "(gdb) Separate Debug Files").
;;;
;;; The main facility of this module is 'graft-debug-links', which allows us
;;; to update the CRC that appears in '.gnu_debuglink' sections when grafting,
;;; such that separate debug files remain usable after grafting.  Failing to
;;; do that, GDB would complain about CRC mismatch---see
;;; <https://bugs.gnu.org/19973>.
;;;
;;; Code:

(define %crc32-table
  ;; CRC table taken from "(gdb) Separate Debug Files".
  ;; TODO: Wouldn't it be nice to generate it "from source" with a macro?
  #(#x00000000 #x77073096 #xee0e612c #x990951ba #x076dc419
    #x706af48f #xe963a535 #x9e6495a3 #x0edb8832 #x79dcb8a4
    #xe0d5e91e #x97d2d988 #x09b64c2b #x7eb17cbd #xe7b82d07
    #x90bf1d91 #x1db71064 #x6ab020f2 #xf3b97148 #x84be41de
    #x1adad47d #x6ddde4eb #xf4d4b551 #x83d385c7 #x136c9856
    #x646ba8c0 #xfd62f97a #x8a65c9ec #x14015c4f #x63066cd9
    #xfa0f3d63 #x8d080df5 #x3b6e20c8 #x4c69105e #xd56041e4
    #xa2677172 #x3c03e4d1 #x4b04d447 #xd20d85fd #xa50ab56b
    #x35b5a8fa #x42b2986c #xdbbbc9d6 #xacbcf940 #x32d86ce3
    #x45df5c75 #xdcd60dcf #xabd13d59 #x26d930ac #x51de003a
    #xc8d75180 #xbfd06116 #x21b4f4b5 #x56b3c423 #xcfba9599
    #xb8bda50f #x2802b89e #x5f058808 #xc60cd9b2 #xb10be924
    #x2f6f7c87 #x58684c11 #xc1611dab #xb6662d3d #x76dc4190
    #x01db7106 #x98d220bc #xefd5102a #x71b18589 #x06b6b51f
    #x9fbfe4a5 #xe8b8d433 #x7807c9a2 #x0f00f934 #x9609a88e
    #xe10e9818 #x7f6a0dbb #x086d3d2d #x91646c97 #xe6635c01
    #x6b6b51f4 #x1c6c6162 #x856530d8 #xf262004e #x6c0695ed
    #x1b01a57b #x8208f4c1 #xf50fc457 #x65b0d9c6 #x12b7e950
    #x8bbeb8ea #xfcb9887c #x62dd1ddf #x15da2d49 #x8cd37cf3
    #xfbd44c65 #x4db26158 #x3ab551ce #xa3bc0074 #xd4bb30e2
    #x4adfa541 #x3dd895d7 #xa4d1c46d #xd3d6f4fb #x4369e96a
    #x346ed9fc #xad678846 #xda60b8d0 #x44042d73 #x33031de5
    #xaa0a4c5f #xdd0d7cc9 #x5005713c #x270241aa #xbe0b1010
    #xc90c2086 #x5768b525 #x206f85b3 #xb966d409 #xce61e49f
    #x5edef90e #x29d9c998 #xb0d09822 #xc7d7a8b4 #x59b33d17
    #x2eb40d81 #xb7bd5c3b #xc0ba6cad #xedb88320 #x9abfb3b6
    #x03b6e20c #x74b1d29a #xead54739 #x9dd277af #x04db2615
    #x73dc1683 #xe3630b12 #x94643b84 #x0d6d6a3e #x7a6a5aa8
    #xe40ecf0b #x9309ff9d #x0a00ae27 #x7d079eb1 #xf00f9344
    #x8708a3d2 #x1e01f268 #x6906c2fe #xf762575d #x806567cb
    #x196c3671 #x6e6b06e7 #xfed41b76 #x89d32be0 #x10da7a5a
    #x67dd4acc #xf9b9df6f #x8ebeeff9 #x17b7be43 #x60b08ed5
    #xd6d6a3e8 #xa1d1937e #x38d8c2c4 #x4fdff252 #xd1bb67f1
    #xa6bc5767 #x3fb506dd #x48b2364b #xd80d2bda #xaf0a1b4c
    #x36034af6 #x41047a60 #xdf60efc3 #xa867df55 #x316e8eef
    #x4669be79 #xcb61b38c #xbc66831a #x256fd2a0 #x5268e236
    #xcc0c7795 #xbb0b4703 #x220216b9 #x5505262f #xc5ba3bbe
    #xb2bd0b28 #x2bb45a92 #x5cb36a04 #xc2d7ffa7 #xb5d0cf31
    #x2cd99e8b #x5bdeae1d #x9b64c2b0 #xec63f226 #x756aa39c
    #x026d930a #x9c0906a9 #xeb0e363f #x72076785 #x05005713
    #x95bf4a82 #xe2b87a14 #x7bb12bae #x0cb61b38 #x92d28e9b
    #xe5d5be0d #x7cdcefb7 #x0bdbdf21 #x86d3d2d4 #xf1d4e242
    #x68ddb3f8 #x1fda836e #x81be16cd #xf6b9265b #x6fb077e1
    #x18b74777 #x88085ae6 #xff0f6a70 #x66063bca #x11010b5c
    #x8f659eff #xf862ae69 #x616bffd3 #x166ccf45 #xa00ae278
    #xd70dd2ee #x4e048354 #x3903b3c2 #xa7672661 #xd06016f7
    #x4969474d #x3e6e77db #xaed16a4a #xd9d65adc #x40df0b66
    #x37d83bf0 #xa9bcae53 #xdebb9ec5 #x47b2cf7f #x30b5ffe9
    #xbdbdf21c #xcabac28a #x53b39330 #x24b4a3a6 #xbad03605
    #xcdd70693 #x54de5729 #x23d967bf #xb3667a2e #xc4614ab8
    #x5d681b02 #x2a6f2b94 #xb40bbe37 #xc30c8ea1 #x5a05df1b
    #x2d02ef8d))

(define (debuglink-crc32 port)
  "Compute the 32-bit CRC used in in '.gnu_debuglink' over the data read from
PORT and return it."                      ;(info "(gdb) Separate Debug Files")
  (let loop ((crc #xffffffff))
    (let ((byte (get-u8 port)))
      (if (eof-object? byte)
          (logand (lognot crc) #xffffffff)
          (let* ((index (logand (logxor crc byte) #xff))
                 (lhs   (vector-ref %crc32-table index)))
            (loop (logxor lhs (ash crc -8))))))))

(define (section-contents elf section)     ;XXX: copied from linux-modules.scm
  "Return the contents of SECTION in ELF as a bytevector."
  (let* ((contents (make-bytevector (elf-section-size section))))
    (bytevector-copy! (elf-bytes elf) (elf-section-offset section)
                      contents 0
                      (elf-section-size section))
    contents))

(define null-terminated-bytevector->string
  (compose pointer->string bytevector->pointer))

(define (elf-debuglink elf)
  "Return two values: the '.gnu_debuglink' file name of ELF and its CRC.
Return #f for both if ELF lacks a '.gnu_debuglink' section."
  (let ((section (elf-section-by-name elf ".gnu_debuglink")))
    (if section
        (let ((size       (elf-section-size section))
              (bv         (section-contents elf section))
              (endianness (elf-byte-order elf)))
          (values (null-terminated-bytevector->string bv)
                  (bytevector-u32-ref bv (- size 4) endianness)))
        (values #f #f))))

(define (elf-debuglink-crc-offset elf)
  "Return the offset of the '.gnu_debuglink' 32-bit CRC, or #f if ELF lacks a
'.gnu_debuglink' section."
  (let ((section (elf-section-by-name elf ".gnu_debuglink")))
    (and section
         (+ (elf-section-offset section)
            (elf-section-size section)
            -4))))

(define (set-debuglink-crc file debug-file)
  "Compute the CRC of DEBUG-FILE and set it as the '.gnu_debuglink' CRC in
FILE."
  (let* ((elf    (parse-elf (call-with-input-file file get-bytevector-all)))
         (offset (elf-debuglink-crc-offset elf)))
    (and offset
         (let* ((crc (call-with-input-file debug-file debuglink-crc32))
                (bv  (make-bytevector 4)))
           (bytevector-u32-set! bv 0 crc (elf-byte-order elf))
           (let ((port (open file O_RDWR)))
             (set-port-position! port offset)
             (put-bytevector port bv)
             (close-port port))))))

;;;
;;; Updating debuglink CRC.
;;;

(define (find-elf-files outputs)
  "Return the list of ELF files found in OUTPUTS, a list of top-level store
directories."
  (define directories
    (append-map (lambda (output)
                  (list (string-append output "/bin")
                        (string-append output "/sbin")
                        (string-append output "/lib")
                        (string-append output "/libexec")))
                outputs))

  (append-map (lambda (directory)
                (filter elf-file?
                        (with-error-to-port (%make-void-port "w")
                          (lambda ()
                            (find-files directory)))))
              directories))

(define* (graft-debug-links old-outputs new-outputs mapping
                            #:key (log-port (current-error-port)))
  "Update the '.gnu_debuglink' CRCs found in ELF files of NEW-OUTPUTS,
provided NEW-OUTPUTS contains a \"debug\" output, such that those CRCs match
those of the corresponding '.debug' files found in the \"debug\" output.

This procedure is meant to be used as a \"grafting hook\" by (guix build
graft)."
  (match (assoc-ref new-outputs "debug")
    (#f #t)                                       ;nothing to do
    (debug-directory
     (let ((files (find-elf-files (filter-map (match-lambda
                                                (("debug" . _)
                                                 #f)
                                                ((name . directory)
                                                 directory))
                                              new-outputs))))
       (for-each (lambda (file)
                   (let ((debug (string-append debug-directory
                                               "/lib/debug" file ".debug")))
                     (when (file-exists? debug)
                       (format log-port
                               "updating '.gnu_debuglink' CRC in '~a'~%"
                               file)
                       (make-file-writable file)
                       (set-debuglink-crc file debug))))
                 files)))))


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

(define-module (guix build download-nar)
  #:use-module (guix build download)
  #:use-module (guix build utils)
  #:use-module (guix serialization)
  #:use-module (guix zlib)
  #:use-module (guix progress)
  #:use-module (web uri)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (download-nar))

;;; Commentary:
;;;
;;; Download a normalized archive or "nar", similar to what 'guix substitute'
;;; does.  The intent here is to use substitute servers as content-addressed
;;; mirrors of VCS checkouts.  This is mostly useful for users who have
;;; disabled substitutes.
;;;
;;; Code:

(define (urls-for-item item)
  "Return the fallback nar URL for ITEM--e.g.,
\"/gnu/store/cabbag3…-foo-1.2-checkout\"."
  ;; Here we hard-code nar URLs without checking narinfos.  That's probably OK
  ;; though.
  ;; TODO: Use HTTPS?  The downside is the extra dependency.
  (let ((bases '("http://mirror.hydra.gnu.org/guix"
                 "http://berlin.guixsd.org"))
        (item  (basename item)))
    (append (map (cut string-append <> "/nar/gzip/" item) bases)
            (map (cut string-append <> "/nar/" item) bases))))

(define (restore-gzipped-nar port item size)
  "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to
ITEM."
  ;; Since PORT is typically a non-file port (for instance because 'http-get'
  ;; returns a delimited port), create a child process so we're back to a file
  ;; port that can be passed to 'call-with-gzip-input-port'.
  (match (pipe)
    ((input . output)
     (match (primitive-fork)
       (0
        (dynamic-wind
          (const #t)
          (lambda ()
            (close-port output)
            (close-port port)
            (catch #t
              (lambda ()
                (call-with-gzip-input-port input
                  (cut restore-file <> item)))
              (lambda (key . args)
                (print-exception (current-error-port)
                                 (stack-ref (make-stack #t) 1)
                                 key args)
                (primitive-exit 1))))
          (lambda ()
            (primitive-exit 0))))
       (child
        (close-port input)
        (dump-port* port output
                    #:reporter (progress-reporter/file item size
                                                       #:abbreviation
                                                       store-path-abbreviation))
        (close-port output)
        (newline)
        (match (waitpid child)
          ((_ . status)
           (unless (zero? status)
             (error "nar decompression failed" status)))))))))

(define (download-nar item)
  "Download and extract the normalized archive for ITEM.  Return #t on
success, #f otherwise."
  ;; Let progress reports go through.
  (setvbuf (current-error-port) _IONBF)
  (setvbuf (current-output-port) _IONBF)

  (let loop ((urls (urls-for-item item)))
    (match urls
      ((url rest ...)
       (format #t "Trying content-addressed mirror at ~a...~%"
               (uri-host (string->uri url)))
       (let-values (((port size)
                     (catch #t
                       (lambda ()
                         (http-fetch (string->uri url)))
                       (lambda args
                         (values #f #f)))))
         (if (not port)
             (loop rest)
             (begin
               (if size
                   (format #t "Downloading from ~a (~,2h MiB)...~%" url
                           (/ size (expt 2 20.)))
                   (format #t "Downloading from ~a...~%" url))
               (if (string-contains url "/gzip")
                   (restore-gzipped-nar port item size)
                   (begin
                     ;; FIXME: Add progress report.
                     (restore-file port item)
                     (close-port port)))
               #t))))
      (()
       #f))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 download)
  #:use-module (web uri)
  #:use-module (web http)
  #:use-module ((web client) #:hide (open-socket-for-uri))
  #:use-module (web response)
  #:use-module (guix base64)
  #:use-module (guix ftp-client)
  #:use-module (guix build utils)
  #:use-module (guix progress)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:autoload   (ice-9 ftw) (scandir)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (open-socket-for-uri
            open-connection-for-uri
            http-fetch
            %x509-certificate-directory
            close-connection
            resolve-uri-reference
            maybe-expand-mirrors
            url-fetch
            byte-count->string
            uri-abbreviation
            nar-uri-abbreviation
            store-path-abbreviation))

;;; Commentary:
;;;
;;; Fetch data such as tarballs over HTTP or FTP (builder-side code).
;;;
;;; Code:

(define %http-receive-buffer-size
  ;; Size of the HTTP receive buffer.
  65536)

(define* (ellipsis #:optional (port (current-output-port)))
  "Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written
in PORT's encoding, and return either that or ASCII dots."
  (if (equal? (port-encoding port) "UTF-8")
      "…"
      "..."))

(define* (store-path-abbreviation store-path #:optional (prefix-length 6))
  "If STORE-PATH is the file name of a store entry, return an abbreviation of
STORE-PATH for display, showing PREFIX-LENGTH characters of the hash.
Otherwise return STORE-PATH."
  (if (string-prefix? (%store-directory) store-path)
      (let ((base (basename store-path)))
        (string-append (string-take base prefix-length)
                       (ellipsis)
                       (string-drop base 32)))
      store-path))

(define* (uri-abbreviation uri #:optional (max-length 42))
  "If URI's string representation is larger than MAX-LENGTH, return an
abbreviation of URI showing the scheme, host, and basename of the file."
  (define uri-as-string
    (uri->string uri))

  (define (elide-path)
    (let* ((path   (uri-path uri))
           (base   (basename path))
           (prefix (string-append (symbol->string (uri-scheme uri)) "://"

                                  ;; `file' URIs have no host part.
                                  (or (uri-host uri) "")

                                  (string-append "/" (ellipsis) "/"))))
      (if (> (+ (string-length prefix) (string-length base)) max-length)
          (string-append prefix (ellipsis)
                         (string-drop base (quotient (string-length base) 2)))
          (string-append prefix base))))

  (if (> (string-length uri-as-string) max-length)
      (let ((short (elide-path)))
        (if (< (string-length short) (string-length uri-as-string))
            short
            uri-as-string))
      uri-as-string))

(define (nar-uri-abbreviation uri)
  "Abbreviate URI, which is assumed to be the URI of a nar as served by Hydra
and 'guix publish', something like
\"http://example.org/nar/1ldrllwbna0aw5z8kpci4fsvbd2w8cw4-texlive-bin-2015\"."
  (let* ((uri  (if (string? uri) (string->uri uri) uri))
         (path (basename (uri-path uri))))
    (if (and (> (string-length path) 33)
             (char=? (string-ref path 32) #\-))
        (string-drop path 33)
        path)))

(define* (ftp-fetch uri file #:key timeout print-build-trace?)
  "Fetch data from URI and write it to FILE.  Return FILE on success.  Bail
out if the connection could not be established in less than TIMEOUT seconds."
  (let* ((conn (match (and=> (uri-userinfo uri)
                             (cut string-split <> #\:))
                 (((? string? user))
                  (ftp-open (uri-host uri) #:timeout timeout
                                           #:username user))
                 (((? string? user) (? string? pass))
                  (ftp-open (uri-host uri) #:timeout timeout
                                           #:username user
                                           #:password pass))
                 (_ (ftp-open (uri-host uri) #:timeout timeout))))
         (size (false-if-exception (ftp-size conn (uri-path uri))))
         (in   (ftp-retr conn (basename (uri-path uri))
                         (dirname (uri-path uri))
                         #:timeout timeout)))
    (call-with-output-file file
      (lambda (out)
        (dump-port* in out
                    #:buffer-size %http-receive-buffer-size
                    #:reporter
                    (if print-build-trace?
                        (progress-reporter/trace
                         file (uri->string uri) size)
                        (progress-reporter/file
                         (uri-abbreviation uri) size)))))

    (ftp-close conn)
    (unless print-build-trace?
      (newline))
    file))

;; Autoload GnuTLS so that this module can be used even when GnuTLS is
;; not available.  At compile time, this yields "possibly unbound
;; variable" warnings, but these are OK: we know that the variables will
;; be bound if we need them, because (guix download) adds GnuTLS as an
;; input in that case.

;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
;; See <http://bugs.gnu.org/12202>.
(module-autoload! (current-module)
                  '(gnutls) '(make-session connection-end/client))

(define %tls-ports
  ;; Mapping of session record ports to the underlying file port.
  (make-weak-key-hash-table))

(define (register-tls-record-port record-port port)
  "Hold a weak reference from RECORD-PORT to PORT, where RECORD-PORT is a TLS
session record port using PORT as its underlying communication port."
  (hashq-set! %tls-ports record-port port))

(define %x509-certificate-directory
  ;; The directory where X.509 authority PEM certificates are stored.
  (make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
                      (getenv "SSL_CERT_DIR"))))  ;like OpenSSL

(define (set-certificate-credentials-x509-trust-file!* cred file format)
  "Like 'set-certificate-credentials-x509-trust-file!', but without the file
name decoding bug described at
<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>."
  (let ((data (call-with-input-file file get-bytevector-all)))
    (set-certificate-credentials-x509-trust-data! cred data format)))

(define (make-credendials-with-ca-trust-files directory)
  "Return certificate credentials with X.509 authority certificates read from
DIRECTORY.  Those authority certificates are checked when
'peer-certificate-status' is later called."
  (let ((cred  (make-certificate-credentials))
        (files (or (scandir directory
                            (lambda (file)
                              (string-suffix? ".pem" file)))
                   '())))
    (for-each (lambda (file)
                (let ((file (string-append directory "/" file)))
                  ;; Protect against dangling symlinks.
                  (when (file-exists? file)
                    (set-certificate-credentials-x509-trust-file!*
                     cred file
                     x509-certificate-format/pem))))
              (or files '()))
    cred))

(define (peer-certificate session)
  "Return the certificate of the remote peer in SESSION."
  (match (session-peer-certificate-chain session)
    ((first _ ...)
     (import-x509-certificate first x509-certificate-format/der))))

(define (assert-valid-server-certificate session server)
  "Return #t if the certificate of the remote peer for SESSION is a valid
certificate for SERVER, where SERVER is the expected host name of peer."
  (define cert
    (peer-certificate session))

  ;; First check whether the server's certificate matches SERVER.
  (unless (x509-certificate-matches-hostname? cert server)
    (throw 'tls-certificate-error 'host-mismatch cert server))

  ;; Second check its validity and reachability from the set of authority
  ;; certificates loaded via 'set-certificate-credentials-x509-trust-file!'.
  (match (peer-certificate-status session)
    (()                                           ;certificate is valid
     #t)
    ((statuses ...)
     (throw 'tls-certificate-error 'invalid-certificate cert server
            statuses))))

(define (print-tls-certificate-error port key args default-printer)
  "Print the TLS certificate error represented by ARGS in an intelligible
way."
  (match args
    (('host-mismatch cert server)
     (format port
             "X.509 server certificate for '~a' does not match: ~a~%"
             server (x509-certificate-dn cert)))
    (('invalid-certificate cert server statuses)
     (format port
             "X.509 certificate of '~a' could not be verified:~%~{  ~a~%~}"
             server
             (map certificate-status->string statuses)))))

(set-exception-printer! 'tls-certificate-error
                        print-tls-certificate-error)

(define* (tls-wrap port server #:key (verify-certificate? #t))
  "Return PORT wrapped in a TLS connection to SERVER.  SERVER must be a DNS
host name without trailing dot."
  (define (log level str)
    (format (current-error-port)
            "gnutls: [~a|~a] ~a" (getpid) level str))

  (let ((session  (make-session connection-end/client))
        (ca-certs (%x509-certificate-directory)))

    ;; Some servers such as 'cloud.github.com' require the client to support
    ;; the 'SERVER NAME' extension.  However, 'set-session-server-name!' is
    ;; not available in older GnuTLS releases.  See
    ;; <http://bugs.gnu.org/18526> for details.
    (if (module-defined? (resolve-interface '(gnutls))
                         'set-session-server-name!)
        (set-session-server-name! session server-name-type/dns server)
        (format (current-error-port)
                "warning: TLS 'SERVER NAME' extension not supported~%"))

    (set-session-transport-fd! session (fileno port))
    (set-session-default-priority! session)

    ;; The "%COMPAT" bit allows us to work around firewall issues (info
    ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
    ;; Explicitly disable SSLv3, which is insecure:
    ;; <https://tools.ietf.org/html/rfc7568>.
    (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")

    (set-session-credentials! session
                              (if (and verify-certificate? ca-certs)
                                  (make-credendials-with-ca-trust-files
                                   ca-certs)
                                  (make-certificate-credentials)))

    ;; Uncomment the following lines in case of debugging emergency.
    ;;(set-log-level! 10)
    ;;(set-log-procedure! log)

    (catch 'gnutls-error
      (lambda ()
        (handshake session))
      (lambda (key err proc . rest)
        (cond ((eq? err error/warning-alert-received)
               ;; Like Wget, do no stop upon non-fatal alerts such as
               ;; 'alert-description/unrecognized-name'.
               (format (current-error-port)
                       "warning: TLS warning alert received: ~a~%"
                       (alert-description->string (alert-get session)))
               (handshake session))
              (else
               ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't
               ;; provide a binding for this.
               (apply throw key err proc rest)))))

    ;; Verify the server's certificate if needed.
    (when verify-certificate?
      (catch 'tls-certificate-error
        (lambda ()
          (assert-valid-server-certificate session server))
        (lambda args
          (close-port port)
          (apply throw args))))

    (let ((record (session-record-port session)))
      ;; Since we use `fileno' above, the file descriptor behind PORT would be
      ;; closed when PORT is GC'd.  If we used `port->fdes', it would instead
      ;; never be closed.  So we use `fileno', but keep a weak reference to
      ;; PORT, so the file descriptor gets closed when RECORD is GC'd.
      (register-tls-record-port record port)

      ;; Write HTTP requests line by line rather than byte by byte:
      ;; <https://bugs.gnu.org/22966>.  This is possible with Guile >= 2.2.
      (cond-expand
        (guile-2.2 (setvbuf record 'line))
        (else #f))

      record)))

(define (ensure-uri uri-or-string)                ;XXX: copied from (web http)
  (cond
   ((string? uri-or-string) (string->uri uri-or-string))
   ((uri? uri-or-string) uri-or-string)
   (else (error "Invalid URI" uri-or-string))))

(define* (open-socket-for-uri uri-or-string #:key timeout)
  "Return an open input/output port for a connection to URI.  When TIMEOUT is
not #f, it must be a (possibly inexact) number denoting the maximum duration
in seconds to wait for the connection to complete; passed TIMEOUT, an
ETIMEDOUT error is raised."
  ;; Includes a fix for <http://bugs.gnu.org/15368> which affects Guile's
  ;; 'open-socket-for-uri' up to 2.0.11 included, uses 'connect*' instead
  ;; of 'connect', and uses AI_ADDRCONFIG.

  (define http-proxy (current-http-proxy))
  (define uri (ensure-uri (or http-proxy uri-or-string)))
  (define addresses
    (let ((port (uri-port uri)))
      (delete-duplicates
       (getaddrinfo (uri-host uri)
                    (cond (port => number->string)
                          (else (symbol->string (uri-scheme uri))))
                    (if (number? port)
                        (logior AI_ADDRCONFIG AI_NUMERICSERV)
                        AI_ADDRCONFIG))
       (lambda (ai1 ai2)
         (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))

  (let loop ((addresses addresses))
    (let* ((ai (car addresses))
           (s  (with-fluids ((%default-port-encoding #f))
                 ;; Restrict ourselves to TCP.
                 (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
      (catch 'system-error
        (lambda ()
          (connect* s (addrinfo:addr ai) timeout)

          ;; Buffer input and output on this port.
          (setvbuf s _IOFBF)
          ;; If we're using a proxy, make a note of that.
          (when http-proxy (set-http-proxy-port?! s #t))
          s)
        (lambda args
          ;; Connection failed, so try one of the other addresses.
          (close s)
          (if (null? (cdr addresses))
              (apply throw args)
              (loop (cdr addresses))))))))

(define* (open-connection-for-uri uri
                                  #:key
                                  timeout
                                  (verify-certificate? #t))
  "Like 'open-socket-for-uri', but also handle HTTPS connections.  The
resulting port must be closed with 'close-connection'.  When
VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
  ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually
  ;; undefined.  See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047.

  (define https?
    (eq? 'https (uri-scheme uri)))

  (let-syntax ((with-https-proxy
                (syntax-rules ()
                  ((_ exp)
                   ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
                   ;; FIXME: Proxying is not supported for https.
                   (let ((thunk (lambda () exp)))
                     (if (and https?
                              (module-variable
                               (resolve-interface '(web client))
                               'current-http-proxy))
                         (parameterize ((current-http-proxy #f))
                           (when (and=> (getenv "https_proxy")
                                        (negate string-null?))
                             (format (current-error-port)
                                     "warning: 'https_proxy' is ignored~%"))
                           (thunk))
                         (thunk)))))))
    (with-https-proxy
     (let ((s (open-socket-for-uri uri #:timeout timeout)))
       ;; Buffer input and output on this port.
       (setvbuf s _IOFBF %http-receive-buffer-size)

       (if https?
           (tls-wrap s (uri-host uri)
                     #:verify-certificate? verify-certificate?)
           s)))))

(define (close-connection port)
  "Like 'close-port', but (1) idempotent, and (2) also closes the underlying
port if PORT is a TLS session record port."
  ;; FIXME: This is a partial workaround for <http://bugs.gnu.org/20145>,
  ;; because 'http-fetch' & co. may return a chunked input port whose 'close'
  ;; method calls 'close-port', not 'close-connection'.
  (unless (port-closed? port)
    (close-port port))
  (and=> (hashq-ref %tls-ports port)
         close-connection))

;; XXX: This is an awful hack to make sure the (set-port-encoding! p
;; "ISO-8859-1") call in `read-response' passes, even during bootstrap
;; where iconv is not available.
(module-define! (resolve-module '(web response))
                'set-port-encoding!
                (lambda (p e) #f))

;; XXX: Work around <http://bugs.gnu.org/23421>, fixed in Guile commit
;; 16050431f29d56f80c4a8253506fc851b8441840.  Guile's date validation
;; procedure rejects dates in which the hour is not padded with a zero but
;; with whitespace.
(begin
  (define-syntax string-match?
    (lambda (x)
      (syntax-case x ()
        ((_ str pat) (string? (syntax->datum #'pat))
         (let ((p (syntax->datum #'pat)))
           #`(let ((s str))
               (and
                (= (string-length s) #,(string-length p))
                #,@(let lp ((i 0) (tests '()))
                     (if (< i (string-length p))
                         (let ((c (string-ref p i)))
                           (lp (1+ i)
                               (case c
                                 ((#\.)  ; Whatever.
                                  tests)
                                 ((#\d)  ; Digit.
                                  (cons #`(char-numeric? (string-ref s #,i))
                                        tests))
                                 ((#\a)  ; Alphabetic.
                                  (cons #`(char-alphabetic? (string-ref s #,i))
                                        tests))
                                 (else   ; Literal.
                                  (cons #`(eqv? (string-ref s #,i) #,c)
                                        tests)))))
                         tests)))))))))

  (define (parse-rfc-822-date str space zone-offset)
    (let ((parse-non-negative-integer (@@ (web http) parse-non-negative-integer))
          (parse-month (@@ (web http) parse-month))
          (bad-header (@@ (web http) bad-header)))
      ;; We could verify the day of the week but we don't.
      (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd")
             (let ((date (parse-non-negative-integer str 5 7))
                   (month (parse-month str 8 11))
                   (year (parse-non-negative-integer str 12 16))
                   (hour (parse-non-negative-integer str 17 19))
                   (minute (parse-non-negative-integer str 20 22))
                   (second (parse-non-negative-integer str 23 25)))
               (make-date 0 second minute hour date month year zone-offset)))
            ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd")
             (let ((date (parse-non-negative-integer str 5 6))
                   (month (parse-month str 7 10))
                   (year (parse-non-negative-integer str 11 15))
                   (hour (parse-non-negative-integer str 16 18))
                   (minute (parse-non-negative-integer str 19 21))
                   (second (parse-non-negative-integer str 22 24)))
               (make-date 0 second minute hour date month year zone-offset)))

            ;; The next two clauses match dates that have a space instead of
            ;; a leading zero for hours, like " 8:49:37".
            ((string-match? (substring str 0 space) "aaa, dd aaa dddd  d:dd:dd")
             (let ((date (parse-non-negative-integer str 5 7))
                   (month (parse-month str 8 11))
                   (year (parse-non-negative-integer str 12 16))
                   (hour (parse-non-negative-integer str 18 19))
                   (minute (parse-non-negative-integer str 20 22))
                   (second (parse-non-negative-integer str 23 25)))
               (make-date 0 second minute hour date month year zone-offset)))
            ((string-match? (substring str 0 space) "aaa, d aaa dddd  d:dd:dd")
             (let ((date (parse-non-negative-integer str 5 6))
                   (month (parse-month str 7 10))
                   (year (parse-non-negative-integer str 11 15))
                   (hour (parse-non-negative-integer str 17 18))
                   (minute (parse-non-negative-integer str 19 21))
                   (second (parse-non-negative-integer str 22 24)))
               (make-date 0 second minute hour date month year zone-offset)))

            (else
             (bad-header 'date str)        ; prevent tail call
             #f))))
  (module-set! (resolve-module '(web http))
               'parse-rfc-822-date parse-rfc-822-date))

;; XXX: Work around <http://bugs.gnu.org/19840>, present in Guile
;; up to 2.0.11.
(unless (or (> (string->number (major-version)) 2)
            (> (string->number (minor-version)) 0)
            (> (string->number (micro-version)) 11))
  (let ((var (module-variable (resolve-module '(web http))
                              'declare-relative-uri-header!)))
    ;; If 'declare-relative-uri-header!' doesn't exist, forget it.
    (when (and var (variable-bound? var))
      (let ((declare-relative-uri-header! (variable-ref var)))
        (declare-relative-uri-header! "Location")))))

;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in
;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and
;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143.  See bug report at
;; <https://lists.gnu.org/archive/html/guix-devel/2017-11/msg00070.html>.
(cond-expand
  (guile-2.2
   (when (<= (string->number (micro-version)) 2)
     (let ()
       (define put-symbol (@@ (web http) put-symbol))
       (define put-non-negative-integer
         (@@ (web http) put-non-negative-integer))
       (define write-http-version
         (@@ (web http) write-http-version))

       (define (write-request-line method uri version port)
         "Write the first line of an HTTP request to PORT."
         (put-symbol port method)
         (put-char port #\space)
         (when (http-proxy-port? port)
           (let ((scheme (uri-scheme uri))
                 (host (uri-host uri))
                 (host-port (uri-port uri)))
             (when (and scheme host)
               (put-symbol port scheme)
               (put-string port "://")
               (cond
                ((string-index host #\:)          ;<---- The fix is here!
                 (put-char port #\[)              ;<---- And here!
                 (put-string port host)
                 (put-char port #\]))
                (else
                 (put-string port host)))
               (unless ((@@ (web uri) default-port?) scheme host-port)
                 (put-char port #\:)
                 (put-non-negative-integer port host-port)))))
         (let ((path (uri-path uri))
               (query (uri-query uri)))
           (if (string-null? path)
               (put-string port "/")
               (put-string port path))
           (when query
             (put-string port "?")
             (put-string port query)))
         (put-char port #\space)
         (write-http-version version port)
         (put-string port "\r\n"))

       (module-set! (resolve-module '(web http)) 'write-request-line
                    write-request-line))))
  (else #t))

(define (resolve-uri-reference ref base)
  "Resolve the URI reference REF, interpreted relative to the BASE URI, into a
target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
Return the resulting target URI."

  (define (merge-paths base-path rel-path)
    (let* ((base-components (string-split base-path #\/))
           (base-directory-components (match base-components
                                        ((components ... last) components)
                                        (() '())))
           (base-directory (string-join base-directory-components "/")))
      (string-append base-directory "/" rel-path)))

  (define (remove-dot-segments path)
    (let loop ((in
                ;; Drop leading "." and ".." components from a relative path.
                ;; (absolute paths will start with a "" component)
                (drop-while (match-lambda
                              ((or "." "..") #t)
                              (_ #f))
                            (string-split path #\/)))
               (out '()))
      (match in
        (("." . rest)
         (loop rest out))
        ((".." . rest)
         (match out
           ((or () (""))
            (error "remove-dot-segments: too many '..' components" path))
           (_
            (loop rest (cdr out)))))
        ((component . rest)
         (loop rest (cons component out)))
        (()
         (string-join (reverse out) "/")))))

  (cond ((or (uri-scheme ref)
             (uri-host   ref))
         (build-uri (or (uri-scheme ref)
                        (uri-scheme base))
                    #:userinfo (uri-userinfo ref)
                    #:host     (uri-host     ref)
                    #:port     (uri-port     ref)
                    #:path     (remove-dot-segments (uri-path ref))
                    #:query    (uri-query    ref)
                    #:fragment (uri-fragment ref)))
        ((string-null? (uri-path ref))
         (build-uri (uri-scheme base)
                    #:userinfo (uri-userinfo base)
                    #:host     (uri-host     base)
                    #:port     (uri-port     base)
                    #:path     (remove-dot-segments (uri-path base))
                    #:query    (or (uri-query ref)
                                   (uri-query base))
                    #:fragment (uri-fragment ref)))
        (else
         (build-uri (uri-scheme base)
                    #:userinfo (uri-userinfo base)
                    #:host     (uri-host     base)
                    #:port     (uri-port     base)
                    #:path     (remove-dot-segments
                                (if (string-prefix? "/" (uri-path ref))
                                    (uri-path ref)
                                    (merge-paths (uri-path base)
                                                 (uri-path ref))))
                    #:query    (uri-query    ref)
                    #:fragment (uri-fragment ref)))))

(define* (http-fetch uri #:key timeout (verify-certificate? #t))
  "Return an input port containing the data at URI, and the expected number of
bytes available or #f.  When TIMEOUT is true, bail out if the connection could
not be established in less than TIMEOUT seconds.  When VERIFY-CERTIFICATE? is
true, verify HTTPS certificates; otherwise simply ignore them."

  (define headers
    `(;; Some web sites, such as http://dist.schmorp.de, would block you if
      ;; there's no 'User-Agent' header, presumably on the assumption that
      ;; you're a spammer.  So work around that.
      (User-Agent . "GNU Guile")

      ;; Some servers, such as https://alioth.debian.org, return "406 Not
      ;; Acceptable" when not explicitly told that everything is accepted.
      (Accept . "*/*")

      ;; Basic authentication, if needed.
      ,@(match (uri-userinfo uri)
          ((? string? str)
           `((Authorization . ,(string-append "Basic "
                                              (base64-encode
                                               (string->utf8 str))))))
          (_ '()))))

  (let*-values (((connection)
                 (open-connection-for-uri uri
                                          #:timeout timeout
                                          #:verify-certificate?
                                          verify-certificate?))
                ((resp port)
                 (http-get uri #:port connection #:decode-body? #f
                           #:streaming? #t
                           #:headers headers))
                ((code)
                 (response-code resp)))
    (case code
      ((200)                                      ; OK
       (values port (response-content-length resp)))
      ((301                                       ; moved permanently
        302                                       ; found (redirection)
        303                                       ; see other
        307                                       ; temporary redirection
        308)                                      ; permanent redirection
       (let ((uri (resolve-uri-reference (response-location resp) uri)))
         (format #t "following redirection to `~a'...~%"
                 (uri->string uri))
         (close connection)
         (http-fetch uri
                     #:timeout timeout
                     #:verify-certificate? verify-certificate?)))
      (else
       (error "download failed" (uri->string uri)
              code (response-reason-phrase resp))))))

(define-syntax-rule (false-if-exception* body ...)
  "Like `false-if-exception', but print the exception on the error port."
  (catch #t
    (lambda ()
      body ...)
    (lambda (key . args)
      #f)
    (lambda (key . args)
      (print-exception (current-error-port) #f key args))))

(define (uri-vicinity dir file)
  "Concatenate DIR, slash, and FILE, keeping only one slash in between.
This is required by some HTTP servers."
  (string-append (string-trim-right dir #\/) "/"
                 (string-trim file #\/)))

(define (maybe-expand-mirrors uri mirrors)
  "If URI uses the 'mirror' scheme, expand it according to the MIRRORS alist.
Return a list of URIs."
  (case (uri-scheme uri)
    ((mirror)
     (let ((kind (string->symbol (uri-host uri)))
           (path (uri-path uri)))
       (match (assoc-ref mirrors kind)
         ((mirrors ..1)
          (map (compose string->uri (cut uri-vicinity <> path))
               mirrors))
         (_
          (error "unsupported URL mirror kind" kind uri)))))
    (else
     (list uri))))

(define* (url-fetch url file
                    #:key
                    (timeout 10) (verify-certificate? #t)
                    (mirrors '()) (content-addressed-mirrors '())
                    (hashes '())
                    print-build-trace?)
  "Fetch FILE from URL; URL may be either a single string, or a list of
string denoting alternate URLs for FILE.  Return #f on failure, and FILE
on success.

When MIRRORS is defined, it must be an alist of mirrors; it is used to resolve
'mirror://' URIs.

HASHES must be a list of algorithm/hash pairs, where each algorithm is a
symbol such as 'sha256 and each hash is a bytevector.
CONTENT-ADDRESSED-MIRRORS must be a list of procedures that, given a hash
algorithm and a hash, return a URL where the specified data can be retrieved
or #f.

When VERIFY-CERTIFICATE? is true, validate HTTPS server certificates;
otherwise simply ignore them."
  (define uri
    (append-map (cut maybe-expand-mirrors <> mirrors)
                (match url
                  ((_ ...) (map string->uri url))
                  (_       (list (string->uri url))))))

  (define (fetch uri file)
    (format #t "~%Starting download of ~a~%From ~a...~%"
            file (uri->string uri))
    (case (uri-scheme uri)
      ((http https)
       (false-if-exception*
        (let-values (((port size)
                      (http-fetch uri
                                  #:verify-certificate? verify-certificate?
                                  #:timeout timeout)))
          (call-with-output-file file
            (lambda (output)
              (dump-port* port output
                          #:buffer-size %http-receive-buffer-size
                          #:reporter (if print-build-trace?
                                         (progress-reporter/trace
                                          file (uri->string uri) size)
                                         (progress-reporter/file
                                          (uri-abbreviation uri) size)))
              (newline)))
          file)))
      ((ftp)
       (false-if-exception* (ftp-fetch uri file
                                       #:timeout timeout
                                       #:print-build-trace?
                                       print-build-trace?)))
      (else
       (format #t "skipping URI with unsupported scheme: ~s~%"
               uri)
       #f)))

  (define content-addressed-uris
    (append-map (lambda (make-url)
                  (filter-map (match-lambda
                                ((hash-algo . hash)
                                 (let ((file (strip-store-file-name file)))
                                   (string->uri (make-url file hash-algo hash)))))
                              hashes))
                content-addressed-mirrors))

  ;; Make this unbuffered so 'progress-report/file' works as expected.  _IOLBF
  ;; means '\n', not '\r', so it's not appropriate here.
  (setvbuf (current-output-port) _IONBF)

  (setvbuf (current-error-port) _IOLBF)

  (let try ((uri (append uri content-addressed-uris)))
    (match uri
      ((uri tail ...)
       (or (fetch uri file)
           (try tail)))
      (()
       (format (current-error-port) "failed to download ~s from ~s~%"
               file url)
       #f))))

;;; download.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 dub-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            dub-build))

;; Commentary:
;;
;; Builder-side code of the DUB (the build tool for D) build system.
;;
;; Code:

;; FIXME: Needs to be parsed from url not package name.
(define (package-name->d-package-name name)
  "Return the package name of NAME."
  (match (string-split name #\-)
    (("d" rest ...)
     (string-join rest "-"))
    (_ #f)))

(define* (configure #:key inputs #:allow-other-keys)
  "Prepare one new directory with all the required dependencies.
   It's necessary to do this (instead of just using /gnu/store as the
   directory) because we want to hide the libraries in subdirectories
   lib/dub/... instead of polluting the user's profile root."
  (let* ((dir (mkdtemp! "/tmp/dub.XXXXXX"))
         (vendor-dir (string-append dir "/vendor")))
    (setenv "HOME" dir)
    (mkdir vendor-dir)
    (for-each
      (match-lambda
        ((name . path)
         (let* ((d-package (package-name->d-package-name name))
                (d-basename (basename path)))
           (when (and d-package path)
             (match (string-split (basename path) #\-)
               ((_ ... version)
                (symlink (string-append path "/lib/dub/" d-basename)
                         (string-append vendor-dir "/" d-basename))))))))
      inputs)
    (zero? (system* "dub" "add-path" vendor-dir))))

(define (grep string file-name)
  "Find the first occurrence of STRING in the file named FILE-NAME.
   Return the position of this occurrence, or #f if none was found."
  (string-contains (call-with-input-file file-name get-string-all)
                   string))

(define (grep* string file-name)
  "Find the first occurrence of STRING in the file named FILE-NAME.
   Return the position of this occurrence, or #f if none was found.
   If the file named FILE-NAME doesn't exist, return #f."
  (catch 'system-error
    (lambda ()
      (grep string file-name))
    (lambda args
      #f)))

(define* (build #:key (dub-build-flags '())
                #:allow-other-keys)
  "Build a given DUB package."
  (if (or (grep* "sourceLibrary" "package.json")
          (grep* "sourceLibrary" "dub.sdl") ; note: format is different!
          (grep* "sourceLibrary" "dub.json"))
    #t
    (let ((status (zero? (apply system* `("dub" "build" ,@dub-build-flags)))))
      (substitute* ".dub/dub.json"
        (("\"lastUpgrade\": \"[^\"]*\"")
         "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\""))
      status)))

(define* (check #:key tests? #:allow-other-keys)
  (if tests?
    (let ((status (zero? (system* "dub" "test"))))
      (substitute* ".dub/dub.json"
        (("\"lastUpgrade\": \"[^\"]*\"")
         "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\""))
      status)
    #t))

(define* (install #:key inputs outputs #:allow-other-keys)
  "Install a given DUB package."
  (let* ((out (assoc-ref outputs "out"))
         (outbin (string-append out "/bin"))
         (outlib (string-append out "/lib/dub/" (basename out))))
    (mkdir-p outbin)
    ;; TODO remove "-test-application"
    (copy-recursively "bin" outbin)
    (mkdir-p outlib)
    (copy-recursively "." (string-append outlib))
    #t))

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

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