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

(define-module (test-containers)
  #:use-module (guix utils)
  #:use-module (guix build syscalls)
  #:use-module (gnu build linux-container)
  #:use-module ((gnu system linux-container)
                #:select (eval/container))
  #:use-module (gnu system file-systems)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix derivations)
  #:use-module (guix tests)
  #:use-module (srfi srfi-1)
  #: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, user namespace, guest UID/GID"
  (zero?
   (call-with-container '()
     (lambda ()
       (assert-exit (and (= 42 (getuid)) (= 77 (getgid)))))
     #:guest-uid 42
     #:guest-gid 77
     #: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 "call-with-container, mnt namespace, root permissions"
  (zero?
   (call-with-container '()
     (lambda ()
       (assert-exit (= #o755 (stat:perms (lstat "/")))))
     #:namespaces '(user mnt))))

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

(skip-if-unsupported)
(test-equal "eval/container, exit status"
  42
  (let* ((store  (open-connection-for-tests))
         (status (run-with-store store
                   (eval/container #~(exit 42)))))
    (close-connection store)
    (status:exit-val status)))

(skip-if-unsupported)
(test-assert "eval/container, writable user mapping"
  (call-with-temporary-directory
   (lambda (directory)
     (define store
       (open-connection-for-tests))
     (define result
       (string-append directory "/r"))
     (define requisites*
       (store-lift requisites))

     (call-with-output-file result (const #t))
     (run-with-store store
       (mlet %store-monad ((status (eval/container
                                    #~(begin
                                        (use-modules (ice-9 ftw))
                                        (call-with-output-file "/result"
                                          (lambda (port)
                                            (write (scandir #$(%store-prefix))
                                                   port))))
                                    #:mappings
                                    (list (file-system-mapping
                                           (source result)
                                           (target "/result")
                                           (writable? #t)))))
                           (reqs   (requisites*
                                    (list (derivation->output-path
                                           (%guile-for-build))))))
         (close-connection store)
         (return (and (zero? (pk 'status status))
                      (lset= string=? (cons* "." ".." (map basename reqs))
                             (pk (call-with-input-file result read))))))))))

(skip-if-unsupported)
(test-assert "eval/container, non-empty load path"
  (call-with-temporary-directory
   (lambda (directory)
     (define store
       (open-connection-for-tests))
     (define result
       (string-append directory "/r"))
     (define requisites*
       (store-lift requisites))

     (mkdir result)
     (run-with-store store
       (mlet %store-monad ((status (eval/container
                                    (with-imported-modules '((guix build utils))
                                      #~(begin
                                          (use-modules (guix build utils))
                                          (mkdir-p "/result/a/b/c")))
                                    #:mappings
                                    (list (file-system-mapping
                                           (source result)
                                           (target "/result")
                                           (writable? #t))))))
         (close-connection store)
         (return (and (zero? status)
                      (file-is-directory?
                       (string-append result "/a/b/c")))))))))

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

(define-module (test-cpan)
  #:use-module (guix import cpan)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module (guix tests http)
  #:use-module (guix grafts)
  #:use-module (srfi srfi-64)
  #:use-module (web client)
  #:use-module (ice-9 match))

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

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

(define test-source
  "foobar")

;; Avoid collisions with other tests.
(%http-server-port 10400)

(test-begin "cpan")

(test-assert "cpan->guix-package"
  ;; Replace network resources with sample data.
  (with-http-server `((200 ,test-json)
                      (200 ,test-source)
                      (200 "{ \"distribution\" : \"Test-Script\" }"))
    (parameterize ((%metacpan-base-url (%local-url))
                   (current-http-proxy (%local-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 "metacpan-url->mirror-url, http"
  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
  (metacpan-url->mirror-url
   "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))

(test-equal "metacpan-url->mirror-url, https"
  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
  (metacpan-url->mirror-url
   "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))

(test-end "cpan")

repo_name: maximed/guix

license: mit


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
  (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 "listifyx: 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 (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>
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.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-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 (gnu packages)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-64))

;; crate versions and dependencies used here
;; foo-0.8.1
;; foo-1.0.0
;; foo-1.0.3
;; 	leaf-alice 0.7.5
;;
;; root-1.0.0
;; root-1.0.4
;; 	intermediate-a  1.0.42
;; 	intermeidate-b ^1.0.0
;; 	leaf-alice     ^0.7
;; 	leaf-bob     ^3
;;
;; intermediate-a-1.0.40
;; intermediate-a-1.0.42
;; intermediate-a-1.1.0-alpha.1
;; 	intermediate-a	1.2.3
;; 	leaf-alice	0.7.5
;; 	leaf-bob	^3
;;
;; intermediate-b-1.2.3
;; 	leaf-bob	3.0.1
;;
;; leaf-alice-0.7.3
;; leaf-alice-0.7.5
;;
;; leaf-bob-3.0.1

(define test-foo-crate
  "{
  \"crate\": {
    \"max_version\": \"1.0.3\",
    \"name\": \"foo\",
    \"description\": \"summary\",
    \"homepage\": \"http://example.com\",
    \"repository\": \"http://example.com\",
    \"keywords\": [\"dummy\", \"test\"],
    \"categories\": [\"test\"],
    \"actual_versions\": [
      { \"id\": 234210,
        \"num\": \"0.8.1\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/foo/0.8.1/dependencies\"
        }
      },
      { \"id\": 234212,
        \"num\": \"1.0.0\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\"
        }
      },
      { \"id\": 234214,
        \"num\": \"1.0.3\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/foo/1.0.3/dependencies\"
        }
      }
    ]
  }
}")

(define test-foo-dependencies
  "{
  \"dependencies\": [
     {
       \"crate_id\": \"leaf-alice\",
       \"kind\": \"normal\",
       \"req\": \"0.7.5\"
     }
  ]
}")

(define test-root-crate
  "{
  \"crate\": {
    \"max_version\": \"1.0.4\",
    \"name\": \"root\",
    \"description\": \"summary\",
    \"homepage\": \"http://example.com\",
    \"repository\": \"http://example.com\",
    \"keywords\": [\"dummy\", \"test\"],
    \"categories\": [\"test\"],
    \"actual_versions\": [
      { \"id\": 234240,
        \"num\": \"1.0.0\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/root/1.0.0/dependencies\"
        }
      },
      { \"id\": 234242,
        \"num\": \"1.0.4\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/root/1.0.4/dependencies\"
        }
      }
    ]
  }
}")

(define test-root-dependencies
  "{
  \"dependencies\": [
     {
       \"crate_id\": \"intermediate-a\",
       \"kind\": \"normal\",
       \"req\": \"1.0.42\"
     },
     {
       \"crate_id\": \"intermediate-b\",
       \"kind\": \"normal\",
       \"req\": \"^1.0.0\"
     },
     {
       \"crate_id\": \"leaf-alice\",
       \"kind\": \"normal\",
       \"req\": \"^0.7\"
     },
     {
       \"crate_id\": \"leaf-bob\",
       \"kind\": \"normal\",
       \"req\": \"^3\"
     }
  ]
}")

(define test-intermediate-a-crate
  "{
  \"crate\": {
    \"max_version\": \"1.1.0-alpha.1\",
    \"name\": \"intermediate-a\",
    \"description\": \"summary\",
    \"homepage\": \"http://example.com\",
    \"repository\": \"http://example.com\",
    \"keywords\": [\"dummy\", \"test\"],
    \"categories\": [\"test\"],
    \"actual_versions\": [
      { \"id\": 234251,
        \"num\": \"1.0.40\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/intermediate-a/1.0.40/dependencies\"
        }
      },
      { \"id\": 234250,
        \"num\": \"1.0.42\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/intermediate-a/1.0.42/dependencies\"
        }
      },
      { \"id\": 234252,
        \"num\": \"1.1.0-alpha.1\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/intermediate-a/1.1.0-alpha.1/dependencies\"
        }
      }
    ]
  }
}")

(define test-intermediate-a-dependencies
  "{
  \"dependencies\": [
     {
       \"crate_id\": \"intermediate-b\",
       \"kind\": \"normal\",
       \"req\": \"1.2.3\"
     },
     {
       \"crate_id\": \"leaf-alice\",
       \"kind\": \"normal\",
       \"req\": \"0.7.5\"
     },
     {
       \"crate_id\": \"leaf-bob\",
       \"kind\": \"normal\",
       \"req\": \"^3\"
     }
  ]
}")

(define test-intermediate-b-crate
  "{
  \"crate\": {
    \"max_version\": \"1.2.3\",
    \"name\": \"intermediate-b\",
    \"description\": \"summary\",
    \"homepage\": \"http://example.com\",
    \"repository\": \"http://example.com\",
    \"keywords\": [\"dummy\", \"test\"],
    \"categories\": [\"test\"],
    \"actual_versions\": [
      { \"id\": 234260,
        \"num\": \"1.2.3\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/intermediate-b/1.2.3/dependencies\"
        }
      }
    ]
  }
}")

(define test-intermediate-b-dependencies
  "{
  \"dependencies\": [
     {
       \"crate_id\": \"leaf-bob\",
       \"kind\": \"normal\",
       \"req\": \"3.0.1\"
     }
  ]
}")

(define test-leaf-alice-crate
  "{
  \"crate\": {
    \"max_version\": \"0.7.5\",
    \"name\": \"leaf-alice\",
    \"description\": \"summary\",
    \"homepage\": \"http://example.com\",
    \"repository\": \"http://example.com\",
    \"keywords\": [\"dummy\", \"test\"],
    \"categories\": [\"test\"],
    \"actual_versions\": [
      { \"id\": 234270,
        \"num\": \"0.7.3\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/leaf-alice/0.7.3/dependencies\"
        }
      },
      { \"id\": 234272,
        \"num\": \"0.7.5\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/leaf-alice/0.7.5/dependencies\"
        }
      }
    ]
  }
}")

(define test-leaf-alice-dependencies
  "{
  \"dependencies\": []
}")

(define test-leaf-bob-crate
  "{
  \"crate\": {
    \"max_version\": \"3.0.1\",
    \"name\": \"leaf-bob\",
    \"description\": \"summary\",
    \"homepage\": \"http://example.com\",
    \"repository\": \"http://example.com\",
    \"keywords\": [\"dummy\", \"test\"],
    \"categories\": [\"test\"]
    \"actual_versions\": [
      { \"id\": 234280,
        \"num\": \"3.0.1\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/leaf-bob/3.0.1/dependencies\"
        }
      }
    ]
  }
}")

(define test-leaf-bob-dependencies
  "{
  \"dependencies\": []
}")

(define test-source-hash
  "")

(define have-guile-semver?
  (false-if-exception (resolve-interface '(semver))))

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

(unless have-guile-semver? (test-skip 1))
(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-foo-crate))
             ("https://crates.io/api/v1/crates/foo/1.0.3/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.3/dependencies"
              (open-input-string test-foo-dependencies))
             ("https://crates.io/api/v1/crates/leaf-alice"
              (open-input-string test-leaf-alice-crate))
             ("https://crates.io/api/v1/crates/leaf-alice/0.7.5/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/leaf-alice/0.7.5/dependencies"
              (open-input-string test-leaf-alice-dependencies))
             (_ (error "Unexpected URL: " url)))))

        (match (crate->guix-package "foo")
          ((define-public 'rust-foo-1
             (package (name "rust-foo")
                      (version "1.0.3")
                      (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)
                      (arguments
                       ('quasiquote
                        (#:skip-build? #t
                         #:cargo-inputs
                         (("rust-leaf-alice" ('unquote 'rust-leaf-alice-0.7))))))
                      (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)))))

(unless have-guile-semver? (test-skip 1))
(test-assert "cargo-recursive-import"
  ;; Replace network resources with sample data.
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://crates.io/api/v1/crates/root"
              (open-input-string test-root-crate))
             ("https://crates.io/api/v1/crates/root/1.0.4/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/root/1.0.4/dependencies"
              (open-input-string test-root-dependencies))
             ("https://crates.io/api/v1/crates/intermediate-a"
              (open-input-string test-intermediate-a-crate))
             ("https://crates.io/api/v1/crates/intermediate-a/1.0.42/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/intermediate-a/1.0.42/dependencies"
              (open-input-string test-intermediate-a-dependencies))
             ("https://crates.io/api/v1/crates/intermediate-b"
              (open-input-string test-intermediate-b-crate))
             ("https://crates.io/api/v1/crates/intermediate-b/1.2.3/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/intermediate-b/1.2.3/dependencies"
              (open-input-string test-intermediate-b-dependencies))
             ("https://crates.io/api/v1/crates/leaf-alice"
              (open-input-string test-leaf-alice-crate))
             ("https://crates.io/api/v1/crates/leaf-alice/0.7.5/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/leaf-alice/0.7.5/dependencies"
              (open-input-string test-leaf-alice-dependencies))
             ("https://crates.io/api/v1/crates/leaf-bob"
              (open-input-string test-leaf-bob-crate))
             ("https://crates.io/api/v1/crates/leaf-bob/3.0.1/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/leaf-bob/3.0.1/dependencies"
              (open-input-string test-leaf-bob-dependencies))
             (_ (error "Unexpected URL: " url)))))
        (match (crate-recursive-import "root")
          ;; rust-intermediate-b has no dependency on the rust-leaf-alice
          ;; package, so this is a valid ordering
          (((define-public 'rust-leaf-alice-0.7
              (package
                (name "rust-leaf-alice")
                (version "0.7.5")
                (source
                 (origin
                   (method url-fetch)
                   (uri (crate-uri "leaf-alice" version))
                   (file-name
                    (string-append name "-" version ".tar.gz"))
                   (sha256
                    (base32
                     (?  string? hash)))))
                (build-system cargo-build-system)
                (arguments ('quasiquote (#:skip-build? #t)))
                (home-page "http://example.com")
                (synopsis "summary")
                (description "summary")
                (license (list license:expat license:asl2.0))))
            (define-public 'rust-leaf-bob-3
              (package
                (name "rust-leaf-bob")
                (version "3.0.1")
                (source
                 (origin
                   (method url-fetch)
                   (uri (crate-uri "leaf-bob" version))
                   (file-name
                    (string-append name "-" version ".tar.gz"))
                   (sha256
                    (base32
                     (?  string? hash)))))
                (build-system cargo-build-system)
                (arguments ('quasiquote (#:skip-build? #t)))
                (home-page "http://example.com")
                (synopsis "summary")
                (description "summary")
                (license (list license:expat license:asl2.0))))
            (define-public 'rust-intermediate-b-1
              (package
                (name "rust-intermediate-b")
                (version "1.2.3")
                (source
                 (origin
                   (method url-fetch)
                   (uri (crate-uri "intermediate-b" version))
                   (file-name
                    (string-append name "-" version ".tar.gz"))
                   (sha256
                    (base32
                     (?  string? hash)))))
                (build-system cargo-build-system)
                (arguments
                 ('quasiquote (#:skip-build? #t
                               #:cargo-inputs
                               (("rust-leaf-bob"
                                 ('unquote rust-leaf-bob-3))))))
                (home-page "http://example.com")
                (synopsis "summary")
                (description "summary")
                (license (list license:expat license:asl2.0))))
            (define-public 'rust-intermediate-a-1
              (package
                (name "rust-intermediate-a")
                (version "1.0.42")
                (source
                 (origin
                   (method url-fetch)
                   (uri (crate-uri "intermediate-a" version))
                   (file-name
                    (string-append name "-" version ".tar.gz"))
                   (sha256
                    (base32
                     (?  string? hash)))))
                (build-system cargo-build-system)
                (arguments
                 ('quasiquote (#:skip-build? #t
                               #:cargo-inputs
                               (("rust-intermediate-b"
                                 ('unquote rust-intermediate-b-1))
                                ("rust-leaf-alice"
                                 ('unquote 'rust-leaf-alice-0.7))
                                ("rust-leaf-bob"
                                 ('unquote rust-leaf-bob-3))))))
                (home-page "http://example.com")
                (synopsis "summary")
                (description "summary")
                (license (list license:expat license:asl2.0))))
            (define-public 'rust-root-1
              (package
                (name "rust-root")
                (version "1.0.4")
                (source
                 (origin
                   (method url-fetch)
                   (uri (crate-uri "root" version))
                   (file-name
                    (string-append name "-" version ".tar.gz"))
                   (sha256
                    (base32
                     (?  string? hash)))))
                (build-system cargo-build-system)
                (arguments
                 ('quasiquote (#:cargo-inputs
                               (("rust-intermediate-a"
                                 ('unquote rust-intermediate-a-1))
                                ("rust-intermediate-b"
                                 ('unquote rust-intermediate-b-1))
                                ("rust-leaf-alice"
                                 ('unquote 'rust-leaf-alice-0.7))
                                ("rust-leaf-bob"
                                 ('unquote rust-leaf-bob-3))))))
                (home-page "http://example.com")
                (synopsis "summary")
                (description "summary")
                (license (list license:expat license:asl2.0)))))
           #t)
          (x
           (pk 'fail x #f)))))

(test-equal "licenses: MIT OR Apache-2.0"
  '(license:expat license:asl2.0)
  (string->license "MIT OR Apache-2.0"))

(test-equal "licenses: Apache-2.0 / MIT"
  '(license:asl2.0 license:expat)
  (string->license "Apache-2.0 / MIT"))

(test-equal "licenses: Apache-2.0 WITH LLVM-exception"
  '(license:asl2.0 unknown-license!)
  (string->license "Apache-2.0 WITH LLVM-exception"))

(test-equal "licenses: MIT/Apache-2.0 AND BSD-2-Clause"
  '(license:expat license:asl2.0 unknown-license!)
  (string->license "MIT/Apache-2.0 AND BSD-2-Clause"))

(test-equal "licenses: MIT/Apache-2.0"
  '(license:expat license:asl2.0)
  (string->license "MIT/Apache-2.0"))

(define test-doctool-crate
  "{
  \"crate\": {
    \"max_version\": \"2.2.2\",
    \"name\": \"leaf-bob\",
    \"description\": \"summary\",
    \"homepage\": \"http://example.com\",
    \"repository\": \"http://example.com\",
    \"keywords\": [\"dummy\", \"test\"],
    \"categories\": [\"test\"]
    \"actual_versions\": [
      { \"id\": 234280,
        \"num\": \"2.2.2\",
        \"license\": \"MIT OR Apache-2.0\",
        \"links\": {
          \"dependencies\": \"/api/v1/crates/doctool/2.2.2/dependencies\"
        }
      }
    ]
  }
}")

;; FIXME: This test depends on some existing packages
(define test-doctool-dependencies
  "{
  \"dependencies\": [
     {
       \"crate_id\": \"docopt\",
       \"kind\": \"normal\",
       \"req\": \"^0.8.1\"
     }
  ]
}")

(test-assert "self-test: rust-docopt 0.8.x is gone, please adjust the test case"
  (not (null? (find-packages-by-name "rust-docopt" "0.8"))))

(unless have-guile-semver? (test-skip 1))
(test-assert "cargo-recursive-import-hoors-existing-packages"
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://crates.io/api/v1/crates/doctool"
              (open-input-string test-doctool-crate))
             ("https://crates.io/api/v1/crates/doctool/2.2.2/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/doctool/2.2.2/dependencies"
              (open-input-string test-doctool-dependencies))
             (_ (error "Unexpected URL: " url)))))
        (match (crate-recursive-import "doctool")
          (((define-public 'rust-doctool-2
              (package
                (name "rust-doctool")
                (version "2.2.2")
                (source
                 (origin
                   (method url-fetch)
                   (uri (crate-uri "doctool" version))
                   (file-name
                    (string-append name "-" version ".tar.gz"))
                   (sha256
                    (base32
                     (?  string? hash)))))
                (build-system cargo-build-system)
                (arguments
                 ('quasiquote (#:cargo-inputs
                               (("rust-docopt"
                                 ('unquote 'rust-docopt-0.8))))))
                (home-page "http://example.com")
                (synopsis "summary")
                (description "summary")
                (license (list license:expat license:asl2.0)))))
            #t)
          (x
           (pk 'fail x #f)))))

(test-end "crate")


CVE_data_type: CVE

CVE_data_format: MITRE

data_type: CVE

data_format: MITRE

refsource: BID

refsource: CONFIRM

value: Receipt of a malformed packet on MX Series devices with dynamic vlan configuration can trigger an uncontrolled recursion loop in the Broadband Edge subscriber management daemon (bbe-smgd), and lead to high CPU usage and a crash of the bbe-smgd service. Repeated receipt of the same packet can result in an extended denial of service condition for the device. Affected releases are Juniper Networks Junos OS: 16.1 versions prior to 16.1R7-S1; 16.2 versions prior to 16.2R2-S7; 17.1 versions prior to 17.1R2-S10, 17.1R3; 17.2 versions prior to 17.2R3; 17.3 versions prior to 17.3R3-S1; 17.4 versions prior to 17.4R2; 18.1 versions prior to 18.1R3; 18.2 versions prior to 18.2R2.

operator: OR

attackVector: NETWORK

attackComplexity: HIGH

scope: UNCHANGED

availabilityImpact: HIGH

baseSeverity: MEDIUM

accessVector: NETWORK

accessComplexity: MEDIUM

availabilityImpact: COMPLETE

severity: HIGH

value: On EX2300, EX3400, EX4600, QFX3K and QFX5K series, firewall filter configuration cannot perform packet matching on any IPv6 extension headers. This issue may allow IPv6 packets that should have been blocked to be forwarded. IPv4 packet filtering is unaffected by this vulnerability. Affected releases are Juniper Networks Junos OS on EX and QFX series;: 14.1X53 versions prior to 14.1X53-D47; 15.1 versions prior to 15.1R7; 15.1X53 versions prior to 15.1X53-D234 on QFX5200/QFX5110 series; 15.1X53 versions prior to 15.1X53-D591 on EX2300/EX3400 series; 16.1 versions prior to 16.1R7; 17.1 versions prior to 17.1R2-S10, 17.1R3; 17.2 versions prior to 17.2R3; 17.3 versions prior to 17.3R3; 17.4 versions prior to 17.4R2; 18.1 versions prior to 18.1R2.

operator: AND

attackComplexity: LOW

integrityImpact: LOW

accessComplexity: LOW

integrityImpact: PARTIAL

severity: MEDIUM

refsource: SUSE

refsource: REDHAT

name: [debian-lts-announce] 20190909 [SECURITY] [DLA 1915-1] ghostscript security update

refsource: MLIST

refsource: FEDORA

name: 20190910 [SECURITY] [DSA 4518-1] ghostscript security update

refsource: BUGTRAQ

refsource: DEBIAN

value: A flaw was found in, ghostscript versions prior to 9.28, in the .pdf_hook_DSC_Creator procedure where it did not properly secure its privileged calls, enabling scripts to bypass `-dSAFER` restrictions. A specially crafted PostScript file could disable security protection and then have access to the file system, or execute arbitrary commands.

attackVector: LOCAL

userInteraction: REQUIRED

confidentialityImpact: HIGH

integrityImpact: HIGH

baseSeverity: HIGH

confidentialityImpact: PARTIAL

availabilityImpact: PARTIAL

refsource: MISC

name: [oss-security] 20191010 Re: CVE-2019-17365: Nix per-user profile directory hijack

value: Nix through 2.3 allows local users to gain access to an arbitrary user's account because the parent directory of the user-profile directories is world writable.

privilegesRequired: LOW

value: GNU gdb All versions is affected by: Buffer Overflow - Out of bound memory access. The impact is: Deny of Service, Memory Disclosure, and Possible Code Execution. The component is: The main gdb module. The attack vector is: Open an ELF for debugging. The fixed version is: Not fixed yet.

value: GNU binutils gold gold v1.11-v1.16 (GNU binutils v2.21-v2.31.1) is affected by: Improper Input Validation, Signed/Unsigned Comparison, Out-of-bounds Read. The impact is: Denial of service. The component is: gold/fileread.cc:497, elfcpp/elfcpp_file.h:644. The attack vector is: An ELF file with an invalid e_shoff header field must be opened.

name: [oss-security] 20191017 CVE-2019-18192: Insecure permissions on Guix profile directory

value: GNU Guix 1.0.1 allows local users to gain access to an arbitrary user's account because the parent directory of the user-profile directories is world writable, a similar issue to CVE-2019-17365.


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

(define-module (test-cve)
  #:use-module (guix cve)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-64))

(define %sample
  (search-path %load-path "tests/cve-sample.json"))

(define (vulnerability id packages)
  (make-struct/no-tail (@@ (guix cve) <vulnerability>) id packages))

(define %expected-vulnerabilities
  ;; What we should get when reading %SAMPLE.
  (list
   (vulnerability "CVE-2019-0001"
                  ;; Only the "a" CPE configurations are kept; the "o"
                  ;; configurations are discarded.
                  '(("junos" (or "18.21-s4" (or "18.21-s3" "18.2")))))
   (vulnerability "CVE-2019-0005"
                  '(("junos" (or "18.11" "18.1"))))
   ;; CVE-2019-0005 has no "a" configurations.
   (vulnerability "CVE-2019-14811"
                  '(("ghostscript" (< "9.28"))))
   (vulnerability "CVE-2019-17365"
                  '(("nix" (<= "2.3"))))
   (vulnerability "CVE-2019-1010180"
                  '(("gdb" _)))                   ;any version
   (vulnerability "CVE-2019-1010204"
                  '(("binutils" (and (>= "2.21") (<= "2.31.1")))
                    ("binutils_gold" (and (>= "1.11") (<= "1.16")))))
   ;; CVE-2019-18192 has no associated configurations.
   ))

(test-begin "cve")

(test-equal "json->cve-items"
  '("CVE-2019-0001"
    "CVE-2019-0005"
    "CVE-2019-14811"
    "CVE-2019-17365"
    "CVE-2019-1010180"
    "CVE-2019-1010204"
    "CVE-2019-18192")
  (map (compose cve-id cve-item-cve)
       (call-with-input-file %sample json->cve-items)))

(test-equal "cve-item-published-date"
  '(2019)
  (delete-duplicates
   (map (compose date-year cve-item-published-date)
        (call-with-input-file %sample json->cve-items))))

(test-equal "json->vulnerabilities"
  %expected-vulnerabilities
  (call-with-input-file %sample json->vulnerabilities))

(test-equal "vulnerabilities->lookup-proc"
  (list (list (third %expected-vulnerabilities))  ;ghostscript
        (list (third %expected-vulnerabilities))
        '()

        (list (fifth %expected-vulnerabilities))  ;gdb
        (list (fifth %expected-vulnerabilities))

        (list (fourth %expected-vulnerabilities)) ;nix
        '()

        (list (sixth %expected-vulnerabilities))  ;binutils
        '()
        (list (sixth %expected-vulnerabilities))
        '())
  (let* ((vulns  (call-with-input-file %sample json->vulnerabilities))
         (lookup (vulnerabilities->lookup-proc vulns)))
    (list (lookup "ghostscript")
          (lookup "ghostscript" "9.27")
          (lookup "ghostscript" "9.28")
          (lookup "gdb")
          (lookup "gdb" "42.0")
          (lookup "nix")
          (lookup "nix" "2.4")
          (lookup "binutils" "2.31.1")
          (lookup "binutils" "2.10")
          (lookup "binutils_gold" "1.11")
          (lookup "binutils" "2.32"))))

(test-end "cve")


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 (test-debug-link)
  #:use-module (guix elf)
  #:use-module (guix build utils)
  #:use-module (guix build debug-link)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix tests)
  #:use-module (guix monads)
  #:use-module (guix derivations)
  #:use-module (gnu packages bootstrap)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match))

(define %guile-executable
  (match (false-if-exception (readlink "/proc/self/exe"))
    ((? string? program)
     (and (file-exists? program) (elf-file? program)
          program))
    (_
     #f)))

(define read-elf
  (compose parse-elf get-bytevector-all))

(test-begin "debug-link")

(unless %guile-executable (test-skip 1))
(test-assert "elf-debuglink"
  (let ((elf (call-with-input-file %guile-executable read-elf)))
    (match (call-with-values (lambda () (elf-debuglink elf)) list)
      ((#f #f)                                    ;no '.gnu_debuglink' section
       (pk 'no-debuglink #t))
      (((? string? file) (? integer? crc))
       (string-suffix? ".debug" file)))))

;; Since we need %BOOTSTRAP-GCC and co., we have to skip the following tests
;; when networking is unreachable because we'd fail to download it.
(unless (network-reachable?) (test-skip 1))
(test-assertm "elf-debuglink"
  ;; Check whether we can compute the CRC just like objcopy, and whether we
  ;; can retrieve it.
  (let* ((code (plain-file "test.c" "int main () { return 42; }"))
         (exp  (with-imported-modules '((guix build utils)
                                        (guix build debug-link)
                                        (guix elf))
                 #~(begin
                     (use-modules (guix build utils)
                                  (guix build debug-link)
                                  (guix elf)
                                  (rnrs io ports))

                     (define read-elf
                       (compose parse-elf get-bytevector-all))

                     (setenv "PATH" (string-join '(#$%bootstrap-gcc
                                                   #$%bootstrap-binutils)
                                                 "/bin:" 'suffix))
                     (invoke "gcc" "-O0" "-g" #$code "-o" "exe")
                     (copy-file "exe" "exe.debug")
                     (invoke "strip" "--only-keep-debug" "exe.debug")
                     (invoke "strip" "--strip-debug" "exe")
                     (invoke "objcopy" "--add-gnu-debuglink=exe.debug"
                             "exe")
                     (call-with-values (lambda ()
                                         (elf-debuglink
                                          (call-with-input-file "exe"
                                            read-elf)))
                       (lambda (file crc)
                         (call-with-output-file #$output
                           (lambda (port)
                             (let ((expected (call-with-input-file "exe.debug"
                                               debuglink-crc32)))
                               (write (list file (= crc expected))
                                      port))))))))))
    (mlet* %store-monad ((drv (gexp->derivation "debuglink" exp))
                         (x   (built-derivations (list drv))))
      (call-with-input-file (derivation->output-path drv)
        (lambda (port)
          (return (match (read port)
                    (("exe.debug" #t) #t)
                    (x                (pk 'fail x #f)))))))))

(unless (network-reachable?) (test-skip 1))
(test-assertm "set-debuglink-crc"
  ;; Check whether 'set-debuglink-crc' successfully updates the CRC.
  (let* ((code  (plain-file "test.c" "int main () { return 42; }"))
         (debug (plain-file "exe.debug" "a"))
         (exp   (with-imported-modules '((guix build utils)
                                         (guix build debug-link)
                                         (guix elf))
                  #~(begin
                      (use-modules (guix build utils)
                                   (guix build debug-link)
                                   (guix elf)
                                   (rnrs io ports))

                      (define read-elf
                        (compose parse-elf get-bytevector-all))

                      (setenv "PATH" (string-join '(#$%bootstrap-gcc
                                                    #$%bootstrap-binutils)
                                                  "/bin:" 'suffix))
                      (invoke "gcc" "-O0" "-g" #$code "-o" "exe")
                      (copy-file "exe" "exe.debug")
                      (invoke "strip" "--only-keep-debug" "exe.debug")
                      (invoke "strip" "--strip-debug" "exe")
                      (invoke "objcopy" "--add-gnu-debuglink=exe.debug"
                              "exe")
                      (set-debuglink-crc "exe" #$debug)
                      (call-with-values (lambda ()
                                          (elf-debuglink
                                           (call-with-input-file "exe"
                                             read-elf)))
                        (lambda (file crc)
                          (call-with-output-file #$output
                            (lambda (port)
                              (write (list file crc) port)))))))))
    (mlet* %store-monad ((drv (gexp->derivation "debuglink" exp))
                         (x   (built-derivations (list drv))))
      (call-with-input-file (derivation->output-path drv)
        (lambda (port)
          (return (match (read port)
                    (("exe.debug" crc)
                     (= crc (debuglink-crc32 (open-input-string "a"))))
                    (x
                     (pk 'fail x #f)))))))))

(test-end "debug-link")