code:
/* GNU Guix --- Functional package management for GNU
   Copyright (C) 2012  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/>.  */

/* Release file to build Guix with Nix.  Useful to bootstrap Guix on
   Guix-enabled Hydra instances.  */

let
  nixpkgs = <nixpkgs>;

  buildOutOfSourceTree = true;
  succeedOnFailure = true;
  keepBuildDirectory = true;

  # The Guile used to bootstrap the whole thing.  It's normally
  # downloaded by the build system, but here we download it via a
  # fixed-output derivation and stuff it into the build tree.
  bootstrap_guile =
    let pkgs = import nixpkgs {}; in {
      i686 = pkgs.fetchurl {
        url = http://www.fdn.fr/~lcourtes/software/guix/packages/i686-linux/20121219/guile-2.0.7.tar.xz;
        sha256 = "45d1f9bfb9e4531a8f1c5a105f7ab094cd481b8a179ccc63cbabb73ce6b8437f";
      };

      x86_64 = pkgs.fetchurl {
        url = http://www.fdn.fr/~lcourtes/software/guix/packages/x86_64-linux/20121219/guile-2.0.7.tar.xz;
        sha256 = "953fbcc8db6e310626be79b67319cf4141dc23b296447952a99d95425b3a4dc1";
      };
    };

  jobs = {
    tarball =
      let pkgs = import nixpkgs {}; in
      pkgs.releaseTools.sourceTarball {
        name = "guix-tarball";
        src = <guix>;
        buildInputs = with pkgs; [ guile sqlite bzip2 git libgcrypt ];
        buildNativeInputs = with pkgs; [ texinfo gettext cvs pkgconfig ];
        preAutoconf = ''git config submodule.nix.url "${<nix>}"'';
        configureFlags =
          [ "--with-libgcrypt-prefix=${pkgs.libgcrypt}"
            "--localstatedir=/nix/var"
          ];
      };

    build =
      { system ? builtins.currentSystem }:

      let pkgs = import nixpkgs { inherit system; }; in
      pkgs.releaseTools.nixBuild {
        name = "guix";
        buildInputs = with pkgs; [ guile sqlite bzip2 libgcrypt ];
        buildNativeInputs = [ pkgs.pkgconfig ];
        src = jobs.tarball;
        configureFlags =
          [ "--with-libgcrypt-prefix=${pkgs.libgcrypt}"
            "--localstatedir=/nix/var"
          ];

        preBuild =
          # Use our pre-downloaded bootstrap tarballs instead of letting
          # the build system download it over and over again.
          '' mkdir -p distro/packages/bootstrap/{i686,x86_64}-linux
             cp -v "${bootstrap_guile.i686}" \
               distro/packages/bootstrap/i686-linux/guile-2.0.7.tar.xz
             cp -v "${bootstrap_guile.x86_64}" \
               distro/packages/bootstrap/x86_64-linux/guile-2.0.7.tar.xz
          '';

        inherit succeedOnFailure keepBuildDirectory
          buildOutOfSourceTree;
      };

    build_disable_daemon =
      { system ? builtins.currentSystem }:

      let
        pkgs = import nixpkgs { inherit system; };
        build = jobs.build { inherit system; };
      in
        pkgs.lib.overrideDerivation build ({ configureFlags, ... }: {
          configureFlags = configureFlags ++ [ "--disable-daemon" ];
          buildInputs = with pkgs; [ guile nixUnstable pkgconfig ];

          # Since we need to talk to a running daemon, we need to escape
          # the chroot.
          preConfigure = "export NIX_REMOTE=daemon";
          __noChroot = true;
        });

    # Jobs to test the distro.
    distro = {
      hello =
        { system ? builtins.currentSystem }:

        let
          pkgs = import nixpkgs { inherit system; };
          guix = jobs.build { inherit system; };
        in
          # XXX: We have no way to tell the Nix code to swallow the .drv
          # produced by `guix-build', so we have a pointless indirection
          # here.  This could be worked around by generating Nix code
          # from the .drv, and importing that.
          pkgs.releaseTools.nixBuild {
            src = null;
            name = "guix-hello";
            phases = "buildPhase";
            buildPhase = "${guix}/bin/guix-build --no-substitutes hello | tee $out";
            __noChroot = true;
          };
    };
  };
in
  jobs

license: mit


code:
#!@GUILE@ \
--no-auto-compile -e main -s
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Mathieu Lirzin <mthl@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/>.

;; IMPORTANT: We must avoid loading any modules from Guix here,
;; because we need to adjust the guile load paths first.
;; It's okay to import modules from core Guile though.

(define-syntax-rule (push! elt v) (set! v (cons elt v)))

(define (augment-load-paths!)
  ;; Add installed modules to load-path.
  (push! "@guilemoduledir@" %load-path)
  (push! "@guileobjectdir@" %load-compiled-path))

(define* (main #:optional (args (command-line)))
  (unless (getenv "GUIX_UNINSTALLED")
    (augment-load-paths!))

  (let ((guix-main (module-ref (resolve-interface '(guix ui))
                               'guix-main)))
    (bindtextdomain "guix" "@localedir@")
    (bindtextdomain "guix-packages" "@localedir@")
    ;; XXX: It would be more convenient to change it to:
    ;;   (exit (apply guix-main (command-line)))
    ;; but since the 'guix' command is not updated by 'guix pull', we cannot
    ;; really do it now.
    (apply guix-main args)))

;;; Local Variables:
;;; mode: scheme
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 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 (test-base16)
  #:use-module (guix base16)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors))

(test-begin "base16")

(test-assert "bytevector->base16-string->bytevector"
  (every (lambda (bv)
           (equal? (base16-string->bytevector
                    (bytevector->base16-string bv))
                   bv))
         (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))

(test-end "base16")


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

(define-module (test-base32)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports))

;; Test the (guix base32) module.

(define %nix-hash
  (or (and=> (getenv "NIX_HASH")
             (match-lambda
              ("" #f)
              (val val)))
      "nix-hash"))

(define %have-nix-hash?
  ;; Note: Use `system', not `system*', because of <http://bugs.gnu.org/13166>.
  (false-if-exception
   (zero? (system (string-append %nix-hash " --version")))))

(test-begin "base32")

(test-assert "bytevector->base32-string"
  (fold (lambda (bv expected result)
          (and result
               (string=? (bytevector->base32-string bv)
                         expected)))
        #t

        ;; Examples from RFC 4648.
        (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))
        '(""
          "my"
          "mzxq"
          "mzxw6"
          "mzxw6yq"
          "mzxw6ytb"
          "mzxw6ytboi")))

(test-assert "base32-string->bytevector"
  (every (lambda (bv)
           (equal? (base32-string->bytevector
                    (bytevector->base32-string bv))
                   bv))
         ;; Examples from RFC 4648.
         (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))

(test-assert "nix-base32-string->bytevector"
  (every (lambda (bv)
           (equal? (nix-base32-string->bytevector
                    (bytevector->nix-base32-string bv))
                   bv))
         ;; Examples from RFC 4648.
         (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))

(test-equal "&invalid-base32-character"
  #\e
  (guard (c ((invalid-base32-character? c)
             (invalid-base32-character-value c)))
    (nix-base32-string->bytevector
     (string-append (make-string 51 #\a) "e"))))

;; The following test requires `nix-hash' in $PATH.
(unless %have-nix-hash?
  (test-skip 1))

(test-assert "sha256 & bytevector->nix-base32-string"
  (let ((file (search-path %load-path "tests/test.drv")))
    (equal? (bytevector->nix-base32-string
             (sha256 (call-with-input-file file get-bytevector-all)))
            (let* ((c (format #f "~a --type sha256 --base32 --flat \"~a\""
                              %nix-hash file))
                   (p (open-input-pipe c))
                   (l (read-line p)))
              (close-pipe p)
              l))))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.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 (test-base64)
  #:use-module (guix base64)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-64))

(define (string->base64 str)
  (base64-encode (string->utf8 str)))

;;; Test vectors from <https://tools.ietf.org/rfc/rfc4648.txt>.

(test-begin "base64")

(test-equal "empty string"
  (string->base64 "")
  "")

(test-equal "f"
  (string->base64 "f")
  "Zg==")

(test-equal "fo"
  (string->base64 "fo")
  "Zm8=")

(test-equal "foo"
  (string->base64 "foo")
  "Zm9v")

(test-equal "foob"
  (string->base64 "foob")
  "Zm9vYg==")

(test-equal "fooba"
  (string->base64 "fooba")
  "Zm9vYmE=")

(test-equal "foobar"
  (string->base64 "foobar")
  "Zm9vYmFy")

(test-end "base64")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
;;; 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 (test-bournish)
  #:use-module (guix build bournish)
  #:use-module (system base compile)
  #:use-module (system base language)
  #:use-module (srfi srfi-64))

(test-begin "bournish")

(test-equal "single statement"
  '(chdir "/foo")
  (read-and-compile (open-input-string "cd /foo")
                    #:from %bournish-language #:to 'scheme))

(test-equal "multiple statements"
  '(begin
     (chdir "/foo")
     (getcwd)
     ((@@ (guix build bournish) ls-command-implementation)))
  (read-and-compile (open-input-string "cd /foo\npwd\nls")
                    #:from %bournish-language #:to 'scheme))

(test-equal "rm"
  '(for-each delete-file (list "foo" "bar"))
  (read-and-compile (open-input-string "rm foo bar\n")
                    #:from %bournish-language #:to 'scheme))

(test-equal "rm -r"
  '(for-each (@ (guix build utils) delete-file-recursively)
             (list "/foo" "/bar"))
  (read-and-compile (open-input-string "rm -r /foo /bar\n")
                    #:from %bournish-language #:to 'scheme))

(test-end "bournish")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2015, 2016 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 (test-build-utils)
  #:use-module (guix tests)
  #:use-module (guix build utils)
  #:use-module ((guix utils)
                #:select (%current-system call-with-temporary-directory))
  #:use-module (gnu packages)
  #:use-module (gnu packages bootstrap)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 popen))

(test-begin "build-utils")

(test-equal "alist-cons-before"
  '((a . 1) (x . 42) (b . 2) (c . 3))
  (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3))))

(test-equal "alist-cons-before, reference not found"
  '((a . 1) (b . 2) (c . 3) (x . 42))
  (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))

(test-equal "alist-cons-after"
  '((a . 1) (b . 2) (x . 42) (c . 3))
  (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3))))

(test-equal "alist-cons-after, reference not found"
  '((a . 1) (b . 2) (c . 3) (x . 42))
  (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))

(test-equal "alist-replace"
  '((a . 1) (b . 77) (c . 3))
  (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))

(test-assert "alist-replace, key not found"
  (not (false-if-exception
        (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))

(test-equal "fold-port-matches"
  (make-list 3 "Guix")
  (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
    (lambda (port)
      (fold-port-matches cons '() "Guix" port))))

(test-equal "fold-port-matches, trickier"
  (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
  (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
    (lambda (port)
      (fold-port-matches cons '()
                         (list (char-set #\G #\g)
                               (char-set #\u)
                               (char-set #\i)
                               (char-set #\x #\X))
                         port))))

(test-equal "fold-port-matches, with unmatched chars"
  '("Guix" #\, #\space
    "guix" #\, #\space
    #\G #\u #\i "Guix" "guiX" #\, #\space
    "Guix")
  (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
    (lambda (port)
      (reverse
       (fold-port-matches cons '()
                          (list (char-set #\G #\g)
                                (char-set #\u)
                                (char-set #\i)
                                (char-set #\x #\X))
                          port
                          cons)))))

(test-equal "wrap-program, one input, multiple calls"
  "hello world\n"
  (call-with-temporary-directory
   (lambda (directory)
     (let ((bash (search-bootstrap-binary "bash" (%current-system)))
           (foo  (string-append directory "/foo")))

       (call-with-output-file foo
         (lambda (p)
           (format p
                   "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
                   bash)))
       (chmod foo #o777)

       ;; wrap-program uses `which' to find bash for the wrapper shebang, but
       ;; it can't know about the bootstrap bash in the store, since it's not
       ;; named "bash".  Help it out a bit by providing a symlink it this
       ;; package's output.
       (setenv "PATH" (dirname bash))
       (wrap-program foo `("GUIX_FOO" prefix ("hello")))
       (wrap-program foo `("GUIX_BAR" prefix ("world")))

       ;; The bootstrap Bash is linked against an old libc and would abort with
       ;; an assertion failure when trying to load incompatible locale data.
       (unsetenv "LOCPATH")

       (let* ((pipe (open-input-pipe foo))
              (str  (get-string-all pipe)))
         (with-directory-excursion directory
           (for-each delete-file '("foo" ".foo-real")))
         (and (zero? (close-pipe pipe))
              str))))))

(test-end)


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

(define-module (test-builders)
  #:use-module (guix download)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix base32)
  #:use-module (guix derivations)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module ((guix packages)
                #:select (package-derivation package-native-search-paths))
  #:use-module (gnu packages bootstrap)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64))

;; Test the higher-level builders.

(define %store
  (open-connection-for-tests))

(define %bootstrap-inputs
  ;; Use the bootstrap inputs so it doesn't take ages to run these tests.
  ;; This still involves building Make, Diffutils, and Findutils.
  ;; XXX: We're relying on the higher-level `package-derivations' here.
  (and %store
       (map (match-lambda
             ((name package)
              (list name (package-derivation %store package))))
            (@@ (gnu packages commencement) %boot0-inputs))))

(define %bootstrap-search-paths
  ;; Search path specifications that go with %BOOTSTRAP-INPUTS.
  (append-map (match-lambda
               ((name package _ ...)
                (package-native-search-paths package)))
              (@@ (gnu packages commencement) %boot0-inputs)))

(define url-fetch*
  (store-lower url-fetch))

(test-begin "builders")

(unless (network-reachable?) (test-skip 1))
(test-assert "url-fetch"
  (let* ((url      '("http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz"
                     "ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz"))
         (hash     (nix-base32-string->bytevector
                    "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
         (drv      (url-fetch* %store url 'sha256 hash
                               #:guile %bootstrap-guile))
         (out-path (derivation->output-path drv)))
    (and (build-derivations %store (list drv))
         (file-exists? out-path)
         (valid-path? %store out-path))))

(test-assert "url-fetch, file"
  (let* ((file (search-path %load-path "guix.scm"))
         (hash (call-with-input-file file port-sha256))
         (out  (url-fetch* %store file 'sha256 hash)))
    (and (file-exists? out)
         (valid-path? %store out))))

(test-assert "url-fetch, file URI"
  (let* ((file (search-path %load-path "guix.scm"))
         (hash (call-with-input-file file port-sha256))
         (out  (url-fetch* %store
                           (string-append "file://" (canonicalize-path file))
                           'sha256 hash)))
    (and (file-exists? out)
         (valid-path? %store out))))

(test-assert "gnu-build-system"
  (build-system? gnu-build-system))

(when (or (not (network-reachable?)) (shebang-too-long?))
  (test-skip 1))
(test-assert "gnu-build"
  (let* ((url      "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")
         (hash     (nix-base32-string->bytevector
                    "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
         (tarball  (url-fetch* %store url 'sha256 hash
                               #:guile %bootstrap-guile))
         (build    (gnu-build %store "hello-2.8"
                              `(("source" ,tarball)
                                ,@%bootstrap-inputs)
                              #:guile %bootstrap-guile
                              #:search-paths %bootstrap-search-paths))
         (out      (derivation->output-path build)))
    (and (build-derivations %store (list (pk 'hello-drv build)))
         (valid-path? %store out)
         (file-exists? (string-append out "/bin/hello")))))

(test-end "builders")


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 (test-cache)
  #:use-module (guix cache)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-64)
  #:use-module ((guix utils) #:select (call-with-temporary-directory))
  #:use-module (ice-9 match))

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

(test-begin "cache")

(test-equal "remove-expired-cache-entries"
  '("o" "l" "d")
  (let* ((removed '())
         (now     (time-second (current-time time-monotonic)))
         (ttl     100)
         (stamp   (match-lambda
                    ((or "n" "e" "w") (+ now 100))
                    ((or "o" "l" "d") (- now 100))))
         (delete  (lambda (entry)
                    (set! removed (cons entry removed)))))
    (remove-expired-cache-entries (reverse '("n" "e" "w"
                                             "o" "l" "d"))
                                  #:entry-expiration stamp
                                  #:delete-entry delete)
    removed))

(define-syntax-rule (test-cache-cleanup cache exp ...)
  (call-with-temporary-directory
   (lambda (cache)
     (let* ((deleted '())
            (delete! (lambda (entry)
                       (set! deleted (cons entry deleted)))))
       exp ...
       (maybe-remove-expired-cache-entries cache
                                           (const '("a" "b" "c"))
                                           #:entry-expiration (const 0)
                                           #:delete-entry delete!)
       (reverse deleted)))))

(test-equal "maybe-remove-expired-cache-entries, first cleanup"
  '("a" "b" "c")
  (test-cache-cleanup cache))

(test-equal "maybe-remove-expired-cache-entries, no cleanup needed"
  '()
  (test-cache-cleanup cache
    (call-with-output-file (string-append cache "/last-expiry-cleanup")
      (lambda (port)
        (display (+ (time-second (current-time time-monotonic)) 100)
                 port)))))

(test-equal "maybe-remove-expired-cache-entries, cleanup needed"
  '("a" "b" "c")
  (test-cache-cleanup cache
    (call-with-output-file (string-append cache "/last-expiry-cleanup")
      (lambda (port)
        (display 0 port)))))

(test-end "cache")

;;; Local Variables:
;;; eval: (put 'test-cache-cleanup 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 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 (test-challenge)
  #:use-module (guix tests)
  #:use-module (gcrypt hash)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix scripts challenge)
  #:use-module (guix scripts substitute)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match))

(define %store
  (open-connection-for-tests))

(define query-path-hash*
  (store-lift query-path-hash))

(define-syntax-rule (test-assertm name exp)
  (test-assert name
    (run-with-store %store exp
                    #:guile-for-build (%guile-for-build))))

(define* (call-with-derivation-narinfo* drv thunk hash)
  (lambda (store)
    (with-derivation-narinfo drv (sha256 => hash)
      (values (run-with-store store (thunk)) store))))

(define-syntax with-derivation-narinfo*
  (syntax-rules (sha256 =>)
    ((_ drv (sha256 => hash) body ...)
     (call-with-derivation-narinfo* drv
       (lambda () body ...)
       hash))))

(test-begin "challenge")

(test-assertm "no discrepancies"
  (let ((text (random-text)))
    (mlet* %store-monad ((drv (gexp->derivation "something"
                                                #~(call-with-output-file
                                                      #$output
                                                    (lambda (port)
                                                      (display #$text port)))))
                         (out -> (derivation->output-path drv)))
      (mbegin %store-monad
        (built-derivations (list drv))
        (mlet %store-monad ((hash (query-path-hash* out)))
          (with-derivation-narinfo* drv (sha256 => hash)
            (>>= (compare-contents (list out) (%test-substitute-urls))
                 (match-lambda
                   ((report)
                    (return
                     (and (string=? out (comparison-report-item report))
                          (bytevector=?
                           (comparison-report-local-sha256 report)
                           hash)
                          (comparison-report-match? report))))))))))))

(test-assertm "one discrepancy"
  (let ((text (random-text)))
    (mlet* %store-monad ((drv (gexp->derivation "something"
                                                #~(call-with-output-file
                                                      #$output
                                                    (lambda (port)
                                                      (display #$text port)))))
                         (out -> (derivation->output-path drv)))
      (mbegin %store-monad
        (built-derivations (list drv))
        (mlet* %store-monad ((hash (query-path-hash* out))
                             (wrong-hash
                              -> (let* ((w (bytevector-copy hash))
                                        (b (bytevector-u8-ref w 0)))
                                   (bytevector-u8-set! w 0
                                                       (modulo (+ b 1) 128))
                                   w)))
          (with-derivation-narinfo* drv (sha256 => wrong-hash)
            (>>= (compare-contents (list out) (%test-substitute-urls))
                 (match-lambda
                   ((report)
                    (return
                     (and (string=? out (comparison-report-item (pk report)))
                          (eq? 'mismatch (comparison-report-result report))
                          (bytevector=? hash
                                        (comparison-report-local-sha256
                                         report))
                          (match (comparison-report-narinfos report)
                            ((bad)
                             (bytevector=? wrong-hash
                                           (narinfo-hash->sha256
                                            (narinfo-hash bad))))))))))))))))

(test-assertm "inconclusive: no substitutes"
  (mlet* %store-monad ((drv  (gexp->derivation "foo" #~(mkdir #$output)))
                       (out -> (derivation->output-path drv))
                       (_    (built-derivations (list drv)))
                       (hash (query-path-hash* out)))
    (>>= (compare-contents (list out) (%test-substitute-urls))
         (match-lambda
           ((report)
            (return
             (and (string=? out (comparison-report-item report))
                  (comparison-report-inconclusive? report)
                  (null? (comparison-report-narinfos report))
                  (bytevector=? (comparison-report-local-sha256 report)
                                hash))))))))

(test-assertm "inconclusive: no local build"
  (let ((text (random-text)))
    (mlet* %store-monad ((drv (gexp->derivation "something"
                                                #~(list #$output #$text)))
                         (out -> (derivation->output-path drv))
                         (hash -> (sha256 #vu8())))
      (with-derivation-narinfo* drv (sha256 => hash)
        (>>= (compare-contents (list out) (%test-substitute-urls))
             (match-lambda
               ((report)
                (return
                 (and (string=? out (comparison-report-item report))
                      (comparison-report-inconclusive? report)
                      (not (comparison-report-local-sha256 report))
                      (match (comparison-report-narinfos report)
                        ((narinfo)
                         (bytevector=? (narinfo-hash->sha256
                                        (narinfo-hash narinfo))
                                       hash))))))))))))

(test-end)

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


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

(define-module (test-combinators)
  #:use-module (guix combinators)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 vlist))

(test-begin "combinators")

(test-equal "fold2, 1 list"
    (list (reverse (iota 5))
          (map - (reverse (iota 5))))
  (call-with-values
      (lambda ()
        (fold2 (lambda (i r1 r2)
                 (values (cons i r1)
                         (cons (- i) r2)))
               '() '()
               (iota 5)))
    list))

(test-equal "fold2, 2 lists"
    (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
          (reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
  (call-with-values
      (lambda ()
        (fold2 (lambda (k v r1 r2)
                 (values (alist-cons k v r1)
                         (alist-cons k (- v) r2)))
               '() '()
               '(a b c d)
               '(0 1 2 3)))
    list))

(let* ((tree (alist->vhash
              '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
              hashq))
       (add-one (lambda (_ r) (1+ r)))
       (tree-lookup (lambda (n) (cdr (vhash-assq n tree)))))
  (test-equal "fold-tree, single root"
    5 (fold-tree add-one 0 tree-lookup '(0)))
  (test-equal "fold-tree, two roots"
    7 (fold-tree add-one 0 tree-lookup '(0 1)))
  (test-equal "fold-tree, sum"
    16 (fold-tree + 0 tree-lookup '(0)))
  (test-equal "fold-tree, internal"
    18 (fold-tree + 0 tree-lookup '(3 4)))
  (test-equal "fold-tree, cons"
    '(1 3 4 5 6)
    (sort (fold-tree cons '() tree-lookup '(1)) <))
  (test-equal "fold-tree, overlapping paths"
    '(1 3 4 5 6)
    (sort (fold-tree cons '() tree-lookup '(1 4)) <))
  (test-equal "fold-tree, cons, two roots"
    '(0 2 3 4 5 6)
    (sort (fold-tree cons '() tree-lookup '(0 4)) <))
  (test-equal "fold-tree-leaves, single root"
    2 (fold-tree-leaves add-one 0 tree-lookup '(1)))
  (test-equal "fold-tree-leaves, single root, sum"
    11 (fold-tree-leaves + 0 tree-lookup '(1)))
  (test-equal "fold-tree-leaves, two roots"
    3 (fold-tree-leaves add-one 0 tree-lookup '(0 1)))
  (test-equal "fold-tree-leaves, two roots, sum"
    13 (fold-tree-leaves + 0 tree-lookup '(0 1))))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@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 (test-containers)
  #:use-module (guix utils)
  #:use-module (guix build syscalls)
  #:use-module (gnu build linux-container)
  #:use-module (gnu system file-systems)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define (assert-exit x)
  (primitive-exit (if x 0 1)))

(test-begin "containers")

;; Skip these tests unless user namespaces are available and the setgroups
;; file (introduced in Linux 3.19 to address a security issue) exists.
(define (skip-if-unsupported)
  (unless (and (user-namespace-supported?)
               (unprivileged-user-namespace-supported?)
               (setgroups-supported?))
    (test-skip 1)))

(skip-if-unsupported)
(test-assert "call-with-container, exit with 0 when there is no error"
  (zero?
   (call-with-container '() (const #t) #:namespaces '(user))))

(skip-if-unsupported)
(test-assert "call-with-container, user namespace"
  (zero?
   (call-with-container '()
     (lambda ()
       ;; The user is root within the new user namespace.
       (assert-exit (and (zero? (getuid)) (zero? (getgid)))))
     #:namespaces '(user))))

(skip-if-unsupported)
(test-assert "call-with-container, uts namespace"
  (zero?
   (call-with-container '()
     (lambda ()
       ;; The user is root within the container and should be able to change
       ;; the hostname of that container.
       (sethostname "test-container")
       (primitive-exit 0))
     #:namespaces '(user uts))))

(skip-if-unsupported)
(test-assert "call-with-container, pid namespace"
  (zero?
   (call-with-container '()
     (lambda ()
       (match (primitive-fork)
         (0
          ;; The first forked process in the new pid namespace is pid 2.
          (assert-exit (= 2 (getpid))))
         (pid
          (primitive-exit
           (match (waitpid pid)
             ((_ . status)
              (status:exit-val status)))))))
     #:namespaces '(user pid))))

(skip-if-unsupported)
(test-assert "call-with-container, mnt namespace"
  (zero?
   (call-with-container (list (file-system
                                (device "none")
                                (mount-point "/testing")
                                (type "tmpfs")
                                (check? #f)))
     (lambda ()
       (assert-exit (file-exists? "/testing")))
     #:namespaces '(user mnt))))

(skip-if-unsupported)
(test-equal "call-with-container, mnt namespace, wrong bind mount"
  `(system-error ,ENOENT)
  ;; An exception should be raised; see <http://bugs.gnu.org/23306>.
  (catch 'system-error
    (lambda ()
      (call-with-container (list (file-system
                                   (device "/does-not-exist")
                                   (mount-point "/foo")
                                   (type "none")
                                   (flags '(bind-mount))
                                   (check? #f)))
        (const #t)
        #:namespaces '(user mnt)))
    (lambda args
      (list 'system-error (system-error-errno args)))))

(skip-if-unsupported)
(test-assert "call-with-container, all namespaces"
  (zero?
   (call-with-container '()
     (lambda ()
       (primitive-exit 0)))))

(skip-if-unsupported)
(test-assert "container-excursion"
  (call-with-temporary-directory
   (lambda (root)
     ;; Two pipes: One for the container to signal that the test can begin,
     ;; and one for the parent to signal to the container that the test is
     ;; over.
     (match (list (pipe) (pipe))
       (((start-in . start-out) (end-in . end-out))
        (define (container)
          (close end-out)
          (close start-in)
          ;; Signal for the test to start.
          (write 'ready start-out)
          (close start-out)
          ;; Wait for test completion.
          (read end-in)
          (close end-in))

        (define (namespaces pid)
          (let ((pid (number->string pid)))
            (map (lambda (ns)
                   (readlink (string-append "/proc/" pid "/ns/" ns)))
                 '("user" "ipc" "uts" "net" "pid" "mnt"))))

        (let* ((pid (run-container root '() %namespaces 1 container))
               (container-namespaces (namespaces pid))
               (result
                (begin
                  (close start-out)
                  ;; Wait for container to be ready.
                  (read start-in)
                  (close start-in)
                  (container-excursion pid
                    (lambda ()
                      ;; Fork again so that the pid is within the context of
                      ;; the joined pid namespace instead of the original pid
                      ;; namespace.
                      (match (primitive-fork)
                        (0
                         ;; Check that all of the namespace identifiers are
                         ;; the same as the container process.
                         (assert-exit
                          (equal? container-namespaces
                                  (namespaces (getpid)))))
                        (fork-pid
                         (match (waitpid fork-pid)
                           ((_ . status)
                            (primitive-exit
                             (status:exit-val status)))))))))))
          (close end-in)
          ;; Stop the container.
          (write 'done end-out)
          (close end-out)
          (waitpid pid)
          (zero? result)))))))

(skip-if-unsupported)
(test-equal "container-excursion, same namespaces"
  42
  ;; The parent and child are in the same namespaces.  'container-excursion'
  ;; should notice that and avoid calling 'setns' since that would fail.
  (container-excursion (getpid)
    (lambda ()
      (primitive-exit 42))))

(skip-if-unsupported)
(test-assert "container-excursion*"
  (call-with-temporary-directory
   (lambda (root)
     (define (namespaces pid)
       (let ((pid (number->string pid)))
         (map (lambda (ns)
                (readlink (string-append "/proc/" pid "/ns/" ns)))
              '("user" "ipc" "uts" "net" "pid" "mnt"))))

     (let* ((pid    (run-container root '()
                                   %namespaces 1
                                   (lambda ()
                                     (sleep 100))))
            (expected (namespaces pid))
            (result (container-excursion* pid
                      (lambda ()
                        (namespaces 1)))))
       (kill pid SIGKILL)
       (equal? result expected)))))

(skip-if-unsupported)
(test-equal "container-excursion*, same namespaces"
  42
  (container-excursion* (getpid)
    (lambda ()
      (* 6 7))))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
;;;
;;; 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 (test-cpan)
  #:use-module (guix import cpan)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module (guix grafts)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

;; Globally disable grafts because they can trigger early builds.
(%graft? #f)

(define test-json
  "{
  \"metadata\" : {
    \"prereqs\" : {
      \"runtime\" : {
        \"requires\" : {
          \"Test::Script\" : \"1.05\",
        }
      }
    }
    \"name\" : \"Foo-Bar\",
    \"version\" : \"0.1\"
  }
  \"name\" : \"Foo-Bar-0.1\",
  \"distribution\" : \"Foo-Bar\",
  \"license\" : [
    \"perl_5\"
  ],
  \"abstract\" : \"Fizzle Fuzz\",
  \"download_url\" : \"http://example.com/Foo-Bar-0.1.tar.gz\",
  \"author\" : \"Guix\",
  \"version\" : \"0.1\"
}")

(define test-source
  "foobar")

(test-begin "cpan")

(test-assert "cpan->guix-package"
  ;; Replace network resources with sample data.
  (mock ((guix build download) url-fetch
         (lambda* (url file-name
                       #:key
                       (mirrors '()) verify-certificate?)
           (with-output-to-file file-name
             (lambda ()
               (display
                (match url
                  ("http://example.com/Foo-Bar-0.1.tar.gz"
                   test-source)
                  (_ (error "Unexpected URL: " url))))))))
        (mock ((guix http-client) http-fetch
               (lambda (url . rest)
                 (match url
                   ("https://fastapi.metacpan.org/v1/release/Foo-Bar"
                    (values (open-input-string test-json)
                            (string-length test-json)))
                   ("https://fastapi.metacpan.org/v1/module/Test::Script?fields=distribution"
                    (let ((result "{ \"distribution\" : \"Test-Script\" }"))
                      (values (open-input-string result)
                              (string-length result))))
                   (_ (error "Unexpected URL: " url)))))
              (match (cpan->guix-package "Foo::Bar")
                (('package
                   ('name "perl-foo-bar")
                   ('version "0.1")
                   ('source ('origin
                              ('method 'url-fetch)
                              ('uri ('string-append "http://example.com/Foo-Bar-"
                                                    'version ".tar.gz"))
                              ('sha256
                               ('base32
                                (? string? hash)))))
                   ('build-system 'perl-build-system)
                   ('propagated-inputs
                    ('quasiquote
                     (("perl-test-script" ('unquote 'perl-test-script)))))
                   ('home-page "https://metacpan.org/release/Foo-Bar")
                   ('synopsis "Fizzle Fuzz")
                   ('description 'fill-in-yourself!)
                   ('license 'perl-license))
                 (string=? (bytevector->nix-base32-string
                            (call-with-input-string test-source port-sha256))
                           hash))
                (x
                 (pk 'fail x #f))))))

(test-equal "source-url-http"
  ((@@ (guix import cpan) cpan-source-url)
   `(("download_url" .
      "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")))
  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")

(test-equal "source-url-https"
  ((@@ (guix import cpan) cpan-source-url)
   `(("download_url" .
      "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")))
  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")

(test-end "cpan")


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

(define-module (test-cpio)
  #:use-module (guix cpio)
  #:use-module (guix tests)
  #:use-module ((guix build utils) #:select (which))
  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

(define %cpio-program
  (which "cpio"))

(test-begin "cpio")

(test-assert "file->cpio-header + write-cpio-header + read-cpio-header"
  (let* ((file   (search-path %load-path "guix.scm"))
         (header (file->cpio-header file)))
    (call-with-values
        (lambda ()
          (open-bytevector-output-port))
      (lambda (port get-bv)
        (write-cpio-header header port)
        (let ((port (open-bytevector-input-port (get-bv))))
          (equal? header (read-cpio-header port)))))))

(unless %cpio-program (test-skip 1))
(test-assert "bit-identical to GNU cpio's output"
  (call-with-temporary-output-file
   (lambda (link _)
     (delete-file link)
     (symlink "chbouib" link)

     (let ((files (cons* "/"
                         (canonicalize-path
                          (dirname (search-path %load-path "guix.scm")))
                         link
                         (map (compose canonicalize-path
                                       (cut search-path %load-path <>))
                              '("guix.scm" "guix/build/syscalls.scm"
                                "guix/packages.scm")))))
       (call-with-temporary-output-file
        (lambda (ref-file _)
          (let ((pipe (open-pipe* OPEN_WRITE %cpio-program "-o" "-O" ref-file
                                  "-H" "newc" "--null")))
            (for-each (lambda (file)
                        (format pipe "~a\0" file))
                      files)
            (and (zero? (close-pipe pipe))
                 (call-with-temporary-output-file
                  (lambda (file port)
                    (write-cpio-archive files port)
                    (close-port port)
                    (or (file=? ref-file file)
                        (throw 'cpio-archives-differ files
                               ref-file file
                               (stat:size (stat ref-file))
                               (stat:size (stat file))))))))))))))

(test-end "cpio")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
;;; 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 (test-cran)
  #:use-module (gnu packages statistics)
  #:use-module (guix import cran)
  #:use-module (guix tests)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match))

(define description "
Package: My-Example
Type: Package
Title: Example package
Version: 1.2.3
Date: 2015-12-10
Author: Ricardo Wurmus
Maintainer: Guix Schmeeks <guix@gnu.org>
URL: http://gnu.org/s/my-example
Description: This is a long description
spanning multiple lines: and it could confuse the parser that
there is a colon : on the lines.
  And: this line continues the description.
biocViews: 0
SystemRequirements: Cairo (>= 0)
Depends: A C++11 compiler. Version 4.6.* of g++ (as
	currently in Rtools) is insufficient; versions 4.8.*, 4.9.* or
	later will be fine.
License: GPL (>= 3)
Imports: Rcpp (>= 0.11.5), proto, Scales
LinkingTo: Rcpp, BH
NeedsCompilation: yes
Repository: CRAN
Date/Publication: 2015-07-14 14:15:16
")

(define description-alist
  ((@@ (guix import cran) description->alist) description))

(define simple-alist
  '(("Key"        . "Value")
    ("SimpleList" . "R, Rcpp, something, whatever")
    ("BadList"    . "This is not a real list, you know?")
    ("List"       . "R (>= 2.2), BH (for no reason), GenomicRanges")))

(test-begin "cran")

(test-assert "description->alist: contains all valid keys"
  (let ((keys '("Package" "Type" "Title" "Version" "Date"
                "Author" "Maintainer" "URL" "Description"
                "SystemRequirements" "Depends" "License"
                "Imports" "biocViews" "LinkingTo"
                "NeedsCompilation" "Repository"
                "Date/Publication")))
    (lset= string=? keys (map car description-alist))))

(test-equal "listify: return empty list if key cannot be found"
  '()
  ((@@ (guix import cran) listify) simple-alist "Letters"))

(test-equal "listify: split comma-separated value into elements"
  '("R" "Rcpp" "something" "whatever")
  ((@@ (guix import cran) listify) simple-alist "SimpleList"))

(test-equal "listify: strip off parentheses"
  '("R" "BH" "GenomicRanges")
  ((@@ (guix import cran) listify) simple-alist "List"))

(test-equal "listify: ignore values that are no lists"
  '()
  ((@@ (guix import cran) listify) simple-alist "BadList"))

(test-equal "r-mininal is not a cran package"
  #f
  ((@@ (guix import cran) cran-package?) r-minimal))

(test-assert "description->package"
  ;; Replace network resources with sample data.
  (mock ((guix build download) url-fetch
         (lambda* (url file-name
                       #:key
                       (mirrors '()) verify-certificate?)
           (with-output-to-file file-name
             (lambda ()
               (display
                (match url
                  ("mirror://cran/src/contrib/My-Example_1.2.3.tar.gz"
                   "source")
                  (_ (error "Unexpected URL: " url))))))))
    (match ((@@ (guix import cran) description->package) 'cran description-alist)
      (('package
         ('name "r-my-example")
         ('version "1.2.3")
         ('source ('origin
                    ('method 'url-fetch)
                    ('uri ('cran-uri "My-Example" 'version))
                    ('sha256
                     ('base32
                      (? string? hash)))))
         ('properties ('quasiquote (('upstream-name . "My-Example"))))
         ('build-system 'r-build-system)
         ('inputs
          ('quasiquote
           (("cairo" ('unquote 'cairo)))))
         ('propagated-inputs
          ('quasiquote
           (("r-bh" ('unquote 'r-bh))
            ("r-proto" ('unquote 'r-proto))
            ("r-rcpp" ('unquote 'r-rcpp))
            ("r-scales" ('unquote 'r-scales)))))
         ('home-page "http://gnu.org/s/my-example")
         ('synopsis "Example package")
         ('description
          "This is a long description spanning multiple lines: \
and it could confuse the parser that there is a colon : on the \
lines.  And: this line continues the description.")
         ('license 'gpl3+))
       #t)
      (x
       (begin
         (format #t "~s\n" x)
         (pk 'fail x #f))))))

(test-end "cran")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;;
;;; 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 (test-crate)
  #:use-module (guix import crate)
  #:use-module (guix base32)
  #:use-module (guix build-system cargo)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-64))

(define test-crate
  "{
  \"crate\": {
    \"max_version\": \"1.0.0\",
    \"name\": \"foo\",
    \"license\": \"MIT/Apache-2.0\",
    \"description\": \"summary\",
    \"homepage\": \"http://example.com\",
    \"repository\": \"http://example.com\",
  }
}")

(define test-dependencies
  "{
  \"dependencies\": [
     {
       \"crate_id\": \"bar\",
       \"kind\": \"normal\",
     }
  ]
}")

(define test-source-hash
  "")

(test-begin "crate")

(test-equal "guix-package->crate-name"
  "rustc-serialize"
  (guix-package->crate-name
   (dummy-package
    "rust-rustc-serialize"
    (source (dummy-origin
     (uri (crate-uri "rustc-serialize" "1.0")))))))

(test-assert "crate->guix-package"
  ;; Replace network resources with sample data.
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://crates.io/api/v1/crates/foo"
              (open-input-string test-crate))
             ("https://crates.io/api/v1/crates/foo/1.0.0/download"
              (set! test-source-hash
                (bytevector->nix-base32-string
                 (sha256 (string->bytevector "empty file\n" "utf-8"))))
              (open-input-string "empty file\n"))
             ("https://crates.io/api/v1/crates/foo/1.0.0/dependencies"
              (open-input-string test-dependencies))
             (_ (error "Unexpected URL: " url)))))
    (match (crate->guix-package "foo")
      (('package
         ('name "rust-foo")
         ('version "1.0.0")
         ('source ('origin
                    ('method 'url-fetch)
                    ('uri ('crate-uri "foo" 'version))
                    ('file-name ('string-append 'name "-" 'version ".tar.gz"))
                    ('sha256
                     ('base32
                      (? string? hash)))))
         ('build-system 'cargo-build-system)
         ('inputs
          ('quasiquote
           (("rust-bar" ('unquote 'rust-bar) "src"))))
         ('home-page "http://example.com")
         ('synopsis "summary")
         ('description "summary")
         ('license ('list 'license:expat 'license:asl2.0)))
       (string=? test-source-hash hash))
      (x
       (pk 'fail x #f)))))

(test-end "crate")