[jackhill/guix/guix.git] / tests / build-utils.scm

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


(define-module (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-35)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 popen))

\f
(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.
       (with-environment-variable "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-assert "invoke/quiet, success"
  (begin
    (invoke/quiet "true")
    #t))

(test-assert "invoke/quiet, failure"
  (guard (c ((message-condition? c)
             (string-contains (condition-message c) "This is an error.")))
    (invoke/quiet "sh" "-c" "echo This is an error. ; false")
    #f))

(test-assert "invoke/quiet, failure, message on stderr"
  (guard (c ((message-condition? c)
             (string-contains (condition-message c)
                              "This is another error.")))
    (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false")
    #f))

(let ((script-contents "\
#!/anything/cabbage-bash-1.2.3/bin/sh

echo hello world"))

  (test-equal "wrap-script, simple case"
    (string-append
     (format #f "\
#!GUILE --no-auto-compile
#!#; Guix wrapper
#\\-~s
#\\-~s
"
             '(begin (let ((current (getenv "GUIX_FOO")))
                       (setenv "GUIX_FOO"
                               (if current
                                   (string-append "/some/path:/some/other/path"
                                                  ":" current)
                                   "/some/path:/some/other/path"))))
             '(let ((cl (command-line)))
                (apply execl "/anything/cabbage-bash-1.2.3/bin/sh"
                       (car cl)
                       (cons (car cl)
                             (append '("") cl)))))
     script-contents)
    (call-with-temporary-directory
     (lambda (directory)
       (let ((script-file-name (string-append directory "/foo")))
         (call-with-output-file script-file-name
           (lambda (port)
             (format port script-contents)))
         (chmod script-file-name #o777)

         (mock ((guix build utils) which (const "GUILE"))
               (wrap-script script-file-name
                            `("GUIX_FOO" prefix ("/some/path"
                                                 "/some/other/path"))))
         (let ((str (call-with-input-file script-file-name get-string-all)))
           (with-directory-excursion directory
             (delete-file "foo"))
           str))))))

(let ((script-contents "\
#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
# vim:fileencoding=utf-8
print('hello world')"))

  (test-equal "wrap-script, with encoding declaration"
    (string-append
     (format #f "\
#!MYGUILE --no-auto-compile
#!#; # vim:fileencoding=utf-8
#\\-~s
#\\-~s
"
             '(begin (let ((current (getenv "GUIX_FOO")))
                       (setenv "GUIX_FOO"
                               (if current
                                   (string-append "/some/path:/some/other/path"
                                                  ":" current)
                                   "/some/path:/some/other/path"))))
             `(let ((cl (command-line)))
                (apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
                       (car cl)
                       (cons (car cl)
                             (append '("" "-and" "-args") cl)))))
     script-contents)
    (call-with-temporary-directory
     (lambda (directory)
       (let ((script-file-name (string-append directory "/foo")))
         (call-with-output-file script-file-name
           (lambda (port)
             (format port script-contents)))
         (chmod script-file-name #o777)

         (wrap-script script-file-name
                      #:guile "MYGUILE"
                      `("GUIX_FOO" prefix ("/some/path"
                                           "/some/other/path")))
         (let ((str (call-with-input-file script-file-name get-string-all)))
           (with-directory-excursion directory
             (delete-file "foo"))
           str))))))

(test-assert "wrap-script, raises condition"
  (call-with-temporary-directory
   (lambda (directory)
     (let ((script-file-name (string-append directory "/foo")))
       (call-with-output-file script-file-name
         (lambda (port)
           (format port "This is not a script")))
       (chmod script-file-name #o777)
       (catch 'srfi-34
         (lambda ()
           (wrap-script script-file-name
                        #:guile "MYGUILE"
                        `("GUIX_FOO" prefix ("/some/path"
                                             "/some/other/path"))))
         (lambda (type obj)
           (wrap-error? obj)))))))

(test-end)
Commit	Line	Data
233e7676	1	;;; GNU Guix --- Functional package management for GNU
f0cc5e7e	2	;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
0fb9a8df	3	;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
b0e0d0e9	4	;;;
233e7676	5	;;; This file is part of GNU Guix.
b0e0d0e9	6	;;;
233e7676	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
b0e0d0e9 LC	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
233e7676	12	;;; GNU Guix is distributed in the hope that it will be useful, but
b0e0d0e9 LC	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
233e7676	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
b0e0d0e9 LC	19
	20
	21	(define-module (test-build-utils)
de611138	22	#:use-module (guix tests)
b0e0d0e9	23	#:use-module (guix build utils)
7370c021 LC	24	#:use-module ((guix utils)
7370c021 LC	25	#:select (%current-system call-with-temporary-directory))
de611138 EB	26	#:use-module (gnu packages)
	27	#:use-module (gnu packages bootstrap)
	28	#:use-module (srfi srfi-34)
f0cc5e7e	29	#:use-module (srfi srfi-35)
de611138 EB	30	#:use-module (srfi srfi-64)
	31	#:use-module (rnrs io ports)
	32	#:use-module (ice-9 popen))
b0e0d0e9	33
de611138	34	\f
b0e0d0e9 LC	35	(test-begin "build-utils")
	36
	37	(test-equal "alist-cons-before"
	38	'((a . 1) (x . 42) (b . 2) (c . 3))
	39	(alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
	40
	41	(test-equal "alist-cons-before, reference not found"
	42	'((a . 1) (b . 2) (c . 3) (x . 42))
	43	(alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
	44
	45	(test-equal "alist-cons-after"
	46	'((a . 1) (b . 2) (x . 42) (c . 3))
	47	(alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
	48
	49	(test-equal "alist-cons-after, reference not found"
	50	'((a . 1) (b . 2) (c . 3) (x . 42))
	51	(alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
	52
	53	(test-equal "alist-replace"
	54	'((a . 1) (b . 77) (c . 3))
	55	(alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))
	56
	57	(test-assert "alist-replace, key not found"
	58	(not (false-if-exception
	59	(alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))
	60
91133c2d LC	61	(test-equal "fold-port-matches"
	62	(make-list 3 "Guix")
	63	(call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
	64	(lambda (port)
	65	(fold-port-matches cons '() "Guix" port))))
	66
	67	(test-equal "fold-port-matches, trickier"
	68	(reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
	69	(call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
	70	(lambda (port)
	71	(fold-port-matches cons '()
	72	(list (char-set #\G #\g)
	73	(char-set #\u)
	74	(char-set #\i)
	75	(char-set #\x #\X))
	76	port))))
	77
	78	(test-equal "fold-port-matches, with unmatched chars"
	79	'("Guix" #\, #\space
	80	"guix" #\, #\space
	81	#\G #\u #\i "Guix" "guiX" #\, #\space
	82	"Guix")
	83	(call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
	84	(lambda (port)
	85	(reverse
	86	(fold-port-matches cons '()
	87	(list (char-set #\G #\g)
	88	(char-set #\u)
	89	(char-set #\i)
	90	(char-set #\x #\X))
	91	port
	92	cons)))))
	93
7370c021 LC	94	(test-equal "wrap-program, one input, multiple calls"
	95	"hello world\n"
	96	(call-with-temporary-directory
	97	(lambda (directory)
	98	(let ((bash (search-bootstrap-binary "bash" (%current-system)))
	99	(foo (string-append directory "/foo")))
	100
	101	(call-with-output-file foo
	102	(lambda (p)
	103	(format p
	104	"#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
	105	bash)))
	106	(chmod foo #o777)
	107
	108	;; wrap-program uses `which' to find bash for the wrapper shebang, but
	109	;; it can't know about the bootstrap bash in the store, since it's not
	110	;; named "bash". Help it out a bit by providing a symlink it this
	111	;; package's output.
22f95e02 LC	112	(with-environment-variable "PATH" (dirname bash)
	113	(wrap-program foo `("GUIX_FOO" prefix ("hello")))
	114	(wrap-program foo `("GUIX_BAR" prefix ("world")))
	115
	116	;; The bootstrap Bash is linked against an old libc and would abort
	117	;; with an assertion failure when trying to load incompatible locale
	118	;; data.
	119	(unsetenv "LOCPATH")
	120
	121	(let* ((pipe (open-input-pipe foo))
	122	(str (get-string-all pipe)))
	123	(with-directory-excursion directory
	124	(for-each delete-file '("foo" ".foo-real")))
	125	(and (zero? (close-pipe pipe))
	126	str)))))))
	127
f0cc5e7e LC	128	(test-assert "invoke/quiet, success"
	129	(begin
	130	(invoke/quiet "true")
	131	#t))
	132
	133	(test-assert "invoke/quiet, failure"
	134	(guard (c ((message-condition? c)
	135	(string-contains (condition-message c) "This is an error.")))
	136	(invoke/quiet "sh" "-c" "echo This is an error. ; false")
	137	#f))
	138
	139	(test-assert "invoke/quiet, failure, message on stderr"
	140	(guard (c ((message-condition? c)
	141	(string-contains (condition-message c)
	142	"This is another error.")))
	143	(invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false")
	144	#f))
de611138	145
0fb9a8df RW	146	(let ((script-contents "\
	147	#!/anything/cabbage-bash-1.2.3/bin/sh
	148
	149	echo hello world"))
	150
	151	(test-equal "wrap-script, simple case"
	152	(string-append
	153	(format #f "\
	154	#!GUILE --no-auto-compile
	155	#!#; Guix wrapper
	156	#\\-~s
	157	#\\-~s
	158	"
	159	'(begin (let ((current (getenv "GUIX_FOO")))
	160	(setenv "GUIX_FOO"
	161	(if current
	162	(string-append "/some/path:/some/other/path"
	163	":" current)
	164	"/some/path:/some/other/path"))))
	165	'(let ((cl (command-line)))
	166	(apply execl "/anything/cabbage-bash-1.2.3/bin/sh"
	167	(car cl)
	168	(cons (car cl)
	169	(append '("") cl)))))
	170	script-contents)
	171	(call-with-temporary-directory
	172	(lambda (directory)
	173	(let ((script-file-name (string-append directory "/foo")))
	174	(call-with-output-file script-file-name
	175	(lambda (port)
	176	(format port script-contents)))
	177	(chmod script-file-name #o777)
	178
	179	(mock ((guix build utils) which (const "GUILE"))
	180	(wrap-script script-file-name
	181	`("GUIX_FOO" prefix ("/some/path"
	182	"/some/other/path"))))
	183	(let ((str (call-with-input-file script-file-name get-string-all)))
	184	(with-directory-excursion directory
	185	(delete-file "foo"))
	186	str))))))
	187
	188	(let ((script-contents "\
	189	#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
	190	# vim:fileencoding=utf-8
	191	print('hello world')"))
	192
	193	(test-equal "wrap-script, with encoding declaration"
	194	(string-append
	195	(format #f "\
	196	#!MYGUILE --no-auto-compile
	197	#!#; # vim:fileencoding=utf-8
	198	#\\-~s
	199	#\\-~s
	200	"
	201	'(begin (let ((current (getenv "GUIX_FOO")))
	202	(setenv "GUIX_FOO"
	203	(if current
	204	(string-append "/some/path:/some/other/path"
	205	":" current)
	206	"/some/path:/some/other/path"))))
	207	`(let ((cl (command-line)))
	208	(apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
	209	(car cl)
210	(cons (car cl)
211	(append '("" "-and" "-args") cl)))))
212	script-contents)
213	(call-with-temporary-directory
214	(lambda (directory)
215	(let ((script-file-name (string-append directory "/foo")))
216	(call-with-output-file script-file-name
217	(lambda (port)
218	(format port script-contents)))
219	(chmod script-file-name #o777)
220
221	(wrap-script script-file-name
222	#:guile "MYGUILE"
223	`("GUIX_FOO" prefix ("/some/path"
224	"/some/other/path")))
225	(let ((str (call-with-input-file script-file-name get-string-all)))
226	(with-directory-excursion directory
227	(delete-file "foo"))
228	str))))))
229
230	(test-assert "wrap-script, raises condition"
231	(call-with-temporary-directory
232	(lambda (directory)
233	(let ((script-file-name (string-append directory "/foo")))
234	(call-with-output-file script-file-name
235	(lambda (port)
236	(format port "This is not a script")))
237	(chmod script-file-name #o777)
238	(catch 'srfi-34
239	(lambda ()
240	(wrap-script script-file-name
241	#:guile "MYGUILE"
242	`("GUIX_FOO" prefix ("/some/path"
243	"/some/other/path"))))
244	(lambda (type obj)
245	(wrap-error? obj)))))))
246
b0e0d0e9	247	(test-end)