;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013-2023 Ludovic Courtès ;;; Copyright © 2014 Alex Kost ;;; ;;; 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 . (define-module (test-profiles) #:use-module (guix tests) #:use-module (guix profiles) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix build-system trivial) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages base) #:prefix packages:) #:use-module ((gnu packages guile) #:prefix packages:) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 popen) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) ;; Test the (guix profiles) module. (define %store (open-connection-for-tests)) ;; Globally disable grafts because they can trigger early builds. (%graft? #f) ;; Example manifest entries. (define guile-1.8.8 (manifest-entry (name "guile") (version "1.8.8") (item "/gnu/store/...") (output "out"))) (define guile-2.0.9 (manifest-entry (name "guile") (version "2.0.9") (item "/gnu/store/...") (output "out"));;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2017-2018, 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Christopher Baines <mail@cbaines.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 (gnu tests version-control) #:use-module (gnu tests) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system shadow) #:use-module (gnu system vm) #:use-module (gnu services) #:use-module (gnu services version-control) #:use-module (gnu services cgit) #:use-module (gnu services ssh) #:use-module (gnu services web) #:use-module (gnu services networking) #:use-module (gnu packages version-control) #:use-module (gnu packages ssh) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix modules) #:export (%test-cgit %test-git-http %test-gitolite %test-gitile)) (define README-contents "Hello! This is what goes inside the 'README' file.") (define %make-git-repository ;; Create Git repository in /srv/git/test. (with-imported-modules (source-module-closure '((guix build utils))) #~(begin (use-modules (guix build utils)) (let ((git (string-append #$git "/bin/git"))) (mkdir-p "/tmp/test-repo") (with-directory-excursion "/tmp/test-repo" (call-with-output-file "/tmp/test-repo/README" (lambda (port) (display #$README-contents port))) (invoke git "config" "--global" "user.email" "charlie@example.org") (invoke git "config" "--global" "user.name" "A U Thor") (invoke git "init") (invoke git "add" ".") (invoke git "commit" "-m" "That's a commit.")) (mkdir-p "/srv/git") (rename-file "/tmp/test-repo/.git" "/srv/git/test") (with-output-to-file "/srv/git/test/git-daemon-export-ok" (lambda _ (display ""))))))) (define %test-repository-service ;; Service that creates /srv/git/test. (simple-service 'make-git-repository activation-service-type %make-git-repository)) (define %cgit-configuration-nginx (list (nginx-server-configuration (root cgit) (locations (list (nginx-location-configuration (uri "@cgit") (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;" "fastcgi_param PATH_INFO $uri;" "fastcgi_param QUERY_STRING $args;" "fastcgi_param HTTP_HOST $server_name;" "fastcgi_pass 127.0.0.1:9000;"))))) (try-files (list "$uri" "@cgit")) (listen '("19418")) (ssl-certificate #f) (ssl-certificate-key #f)))) (define %cgit-os ;; Operating system under test. (let ((base-os (simple-operating-system (service dhcp-client-service-type) (service cgit-service-type (cgit-configuration (nginx %cgit-configuration-nginx))) %test-repository-service))) (operating-system (inherit base-os) (packages (cons* git (operating-system-packages base-os)))))) (define* (run-cgit-test #:optional (http-port 19418)) "Run tests in %CGIT-OS, which has nginx running and listening on HTTP-PORT." (define os (marionette-operating-system %cgit-os #:imported-modules '((gnu services herd) (guix combinators)))) (define vm (virtual-machine (operating-system os) (port-forwardings `((8080 . ,http-port))))) (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (srfi srfi-11) (srfi srfi-64) (gnu build marionette) (web uri) (web client) (web response)) (define marionette (make-marionette (list #$vm))) (test-runner-current (system-test-runner #$output)) (test-begin "cgit") ;; XXX: Shepherd reads the config file *before* binding its control ;; socket, so /var/run/shepherd/socket might not exist yet when the ;; 'marionette' service is started. (test-assert "shepherd socket ready" (marionette-eval `(begin (use-modules (gnu services herd)) (let loop ((i 10)) (cond ((file-exists? (%shepherd-socket-file)) #t) ((> i 0) (sleep 1) (loop (- i 1))) (else 'failure)))) marionette)) ;; Wait for nginx to be up and running. (test-assert "nginx running" (wait-for-file "/var/run/nginx/pid" marionette)) ;; Wait for fcgiwrap to be up and running. (test-assert "fcgiwrap running" (wait-for-tcp-port 9000 marionette)) ;; Make sure the PID file is created. (test-assert "PID file" (marionette-eval '(file-exists? "/var/run/nginx/pid") marionette)) ;; Make sure the configuration file is created. (test-assert "configuration file" (marionette-eval '(file-exists? "/etc/cgitrc") marionette)) ;; Make sure Git test repository is created. (test-assert "Git test repository" (marionette-eval '(file-exists? "/srv/git/test") marionette)) ;; Make sure we can access pages that correspond to our repository. (letrec-syntax ((test-url (syntax-rules () ((_ path code) (test-equal (string-append "GET " path) code (let-values (((response body) (http-get (string-append "http://localhost:8080" path)))) (response-code response)))) ((_ path) (test-url path 200))))) (test-url "/") (test-url "/test") (test-url "/test/log") (test-url "/test/tree") (test-url "/test/tree/README") (test-url "/test/does-not-exist" 404) (test-url "/test/tree/does-not-exist" 404) (test-url "/does-not-exist" 404)) (test-end)))) (gexp->derivation "cgit-test" test)) (define %test-cgit (system-test (name "cgit") (description "Connect to a running Cgit server.") (value (run-cgit-test)))) ;;; ;;; Git server. ;;; (define %git-nginx-configuration (nginx-configuration (server-blocks (list (nginx-server-configuration (listen '("19418")) (ssl-certificate #f) (ssl-certificate-key #f) (locations (list (git-http-nginx-location-configuration (git-http-configuration (export-all? #t) (uri-path "/git")))))))))) (define %git-http-os (simple-operating-system (service dhcp-client-service-type) (service fcgiwrap-service-type) (service nginx-service-type %git-nginx-configuration) %test-repository-service)) (define* (run-git-http-test #:optional (http-port 19418)) (define os (marionette-operating-system %git-http-os #:imported-modules '((gnu services herd) (guix combinators)))) (define vm (virtual-machine (operating-system os) (port-forwardings `((8080 . ,http-port))))) (define test (with-imported-modules '((gnu build marionette) (guix build utils)) #~(begin (use-modules (srfi srfi-64) (rnrs io ports) (gnu build marionette) (guix build utils)) (define marionette (make-marionette (list #$vm))) (test-runner-current (system-test-runner #$output)) (test-begin "git-http") ;; Wait for nginx to be up and running. (test-assert "nginx running" (wait-for-file "/var/run/nginx/pid" marionette)) ;; Make sure Git test repository is created. (test-assert "Git test repository" (marionette-eval '(file-exists? "/srv/git/test") marionette)) (test-assert "fcgiwrap listens" ;; Wait for fcgiwrap to be ready before cloning. (wait-for-tcp-port 9000 marionette)) ;; Make sure we can clone the repo from the host. (test-equal "clone" '#$README-contents (begin (invoke #$(file-append git "/bin/git") "clone" "-v" "http://localhost:8080/git/test" "/tmp/clone") (call-with-input-file "/tmp/clone/README" get-string-all))) (test-end)))) (gexp->derivation "git-http" test)) (define %test-git-http (system-test (name "git-http") (description "Connect to a running Git HTTP server.") (value (run-git-http-test)))) ;;; ;;; Gitolite. ;;; (define %gitolite-test-admin-keypair (computed-file "gitolite-test-admin-keypair" (with-imported-modules (source-module-closure '((guix build utils))) #~(begin (use-modules (ice-9 match) (srfi srfi-26) (guix build utils)) (mkdir #$output) (invoke #$(file-append openssh "/bin/ssh-keygen") "-f" (string-append #$output "/test-admin") "-t" "rsa" "-q" "-N" ""))))) (define %gitolite-os (simple-operating-system (service dhcp-client-service-type) (service openssh-service-type) (service gitolite-service-type (gitolite-configuration (admin-pubkey (file-append %gitolite-test-admin-keypair "/test-admin.pub")))))) (define (run-gitolite-test) (define os (marionette-operating-system %gitolite-os #:imported-modules '((gnu services herd) (guix combinators)))) (define vm (virtual-machine (operating-system os) (port-forwardings `((2222 . 22))))) (define test (with-imported-modules '((gnu build marionette) (guix build utils)) #~(begin (use-modules (srfi srfi-64) (rnrs io ports) (gnu build marionette) (guix build utils)) (define marionette (make-marionette (list #$vm))) (test-runner-current (system-test-runner #$output)) (test-begin "gitolite") ;; Wait for sshd to be up and running. (test-assert "service running" (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'ssh-daemon)) marionette)) (display #$%gitolite-test-admin-keypair) (setenv "GIT_SSH_VARIANT" "ssh") (setenv "GIT_SSH_COMMAND" (string-join '(#$(file-append openssh "/bin/ssh") "-i" #$(file-append %gitolite-test-admin-keypair "/test-admin") "-o" "UserKnownHostsFile=/dev/null" "-o" "StrictHostKeyChecking=no"))) (test-assert "cloning the admin repository" (invoke #$(file-append git "/bin/git") "clone" "-v" "ssh://git@localhost:2222/gitolite-admin" "/tmp/clone")) (test-assert "admin key exists" (file-exists? "/tmp/clone/keydir/test-admin.pub")) (with-directory-excursion "/tmp/clone" (invoke #$(file-append git "/bin/git") "-c" "user.name=Guix" "-c" "user.email=guix" "commit" "-m" "Test commit" "--allow-empty") (test-assert "pushing, and the associated hooks" (invoke #$(file-append git "/bin/git") "push"))) (test-end)))) (gexp->derivation "gitolite" test)) (define %test-gitolite (system-test (name "gitolite") (description "Clone the Gitolite admin repository.") (value (run-gitolite-test)))) ;;; ;;; Gitile. ;;; (define %gitile-configuration-nginx (nginx-server-configuration (root "/does/not/exists") (try-files (list "$uri" "=404")) (listen '("19418")) (ssl-certificate #f) (ssl-certificate-key #f))) (define %gitile-os ;; Operating system under test. (simple-operating-system (service dhcp-client-service-type) (simple-service 'srv-git activation-service-type #~(mkdir-p "/srv/git")) (service gitile-service-type (gitile-configuration (base-git-url "http://localhost") (repositories "/srv/git") (nginx %gitile-configuration-nginx))) %test-repository-service)) (define* (run-gitile-test #:optional (http-port 19418)) "Run tests in %GITOLITE-OS, which has nginx running and listening on HTTP-PORT." (define os (marionette-operating-system %gitile-os #:imported-modules '((gnu services herd) (guix combinators)))) (define vm (virtual-machine (operating-system os) (port-forwardings `((8081 . ,http-port))) (memory-size 1024))) (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (srfi srfi-11) (srfi srfi-64) (gnu build marionette) (web uri) (web client) (web response)) (define marionette (make-marionette (list #$vm))) (test-runner-current (system-test-runner #$output)) (test-begin "gitile") ;; XXX: Shepherd reads the config file *before* binding its control ;; socket, so /var/run/shepherd/socket might not exist yet when the ;; 'marionette' service is started. (test-assert "shepherd socket ready" (marionette-eval `(begin (use-modules (gnu services herd)) (let loop ((i 10)) (cond ((file-exists? (%shepherd-socket-file)) #t) ((> i 0) (sleep 1) (loop (- i 1))) (else 'failure)))) marionette)) ;; Wait for nginx to be up and running. (test-assert "nginx running" (wait-for-file "/var/run/nginx/pid" marionette)) ;; Make sure Git test repository is created. (test-assert "Git test repository" (marionette-eval '(file-exists? "/srv/git/test") marionette)) (sleep 2) ;; Make sure we can access pages that correspond to our repository. (letrec-syntax ((test-url (syntax-rules () ((_ path code) (test-equal (string-append "GET " path) code (let-values (((response body) (http-get (string-append "http://localhost:8081" path)))) (response-code response)))) ((_ path) (test-url path 200))))) (test-url "/") (test-url "/css/gitile.css") (test-url "/test") (test-url "/test/commits") (test-url "/test/tree" 404) (test-url "/test/tree/-") (test-url "/test/tree/-/README") (test-url "/test/does-not-exist" 404) (test-url "/test/tree/-/does-not-exist" 404) (test-url "/does-not-exist" 404)) (test-end)))) (gexp->derivation "gitile-test" test)) (define %test-gitile (system-test (name "gitile") (description "Connect to a running Gitile server.") (value (run-gitile-test)))) ackage-outputs packages:glibc))) (equal? (manifest-entry-output (package->manifest-entry (package (inherit packages:glibc) (outputs (reverse outputs))))) (manifest-entry-output (package->manifest-entry packages:glibc)) "out"))) (test-assertm "profile-manifest, search-paths" (mlet* %store-monad ((guile -> (package (inherit %bootstrap-guile) (native-search-paths (package-native-search-paths packages:guile-2.0)))) (entry -> (package->manifest-entry guile)) (drv (profile-derivation (manifest (list entry)) #:hooks '() #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) ;; Read the manifest back and make sure search paths are preserved. (let ((manifest (profile-manifest profile))) (match (manifest-entries manifest) ((result) (return (equal? (manifest-entry-search-paths result) (manifest-entry-search-paths entry) (package-native-search-paths packages:guile-2.0))))))))) (test-assert "package->manifest-entry, search paths" ;; See . (let ((mpl (@ (gnu packages python-xyz) python-matplotlib))) (lset= eq? (package-transitive-native-search-paths mpl) (manifest-entry-search-paths (package->manifest-entry mpl))))) (test-assert "packages->manifest, no duplicates" (let ((expected (manifest (list (package->manifest-entry packages:guile-2.2)))) (manifest (packages->manifest (list packages:guile-2.2 packages:guile-2.2)))) (every manifest-entry=? (manifest-entries expected) (manifest-entries manifest)))) (test-equal "packages->manifest, propagated inputs" (map (match-lambda ((label package) (list (package-name package) (package-version package) package))) (package-propagated-inputs packages:guile-2.2)) (map (lambda (entry) (list (manifest-entry-name entry) (manifest-entry-version entry) (manifest-entry-item entry))) (manifest-entry-dependencies (package->manifest-entry packages:guile-2.2)))) (test-assert "manifest-entry-parent" (let ((entry (package->manifest-entry packages:guile-2.2))) (match (manifest-entry-dependencies entry) ((dependencies ..1) (and (every (lambda (parent) (eq? entry (force parent))) (map manifest-entry-parent dependencies)) (not (force (manifest-entry-parent entry)))))))) (test-assertm "read-manifest" (mlet* %store-monad ((manifest -> (packages->manifest (list (package (inherit %bootstrap-guile) (native-search-paths (package-native-search-paths packages:guile-2.0)))))) (drv (profile-derivation manifest #:hooks '() #:locales? #f)) (out -> (derivation->output-path drv))) (define (entry->sexp entry) (list (manifest-entry-name entry) (manifest-entry-version entry) (manifest-entry-search-paths entry) (manifest-entry-dependencies entry) (force (manifest-entry-parent entry)))) (mbegin %store-monad (built-derivations (list drv)) (let ((manifest2 (profile-manifest out))) (return (equal? (map entry->sexp (manifest-entries manifest)) (map entry->sexp (manifest-entries manifest2)))))))) (test-equal "collision" '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42")) (guard (c ((profile-collision-error? c) (let ((entry1 (profile-collision-error-entry c)) (entry2 (profile-collision-error-conflict c))) (list (list (manifest-entry-name entry1) (manifest-entry-version entry1)) (list (manifest-entry-name entry2) (manifest-entry-version entry2)))))) (run-with-store %store (mlet* %store-monad ((p0 -> (package (inherit %bootstrap-guile) (version "42"))) (p1 -> (dummy-package "p1" (propagated-inputs `(("p0" ,p0))))) (manifest -> (packages->manifest (list %bootstrap-guile p1))) (drv (profile-derivation manifest #:hooks '() #:locales? #f))) (return #f))))) (test-equal "collision of propagated inputs" '(("guile-bootstrap" "2.0") "p1" <> ("guile-bootstrap" "42") "p2") (guard (c ((profile-collision-error? c) (let ((entry1 (profile-collision-error-entry c)) (entry2 (profile-collision-error-conflict c))) (list (list (manifest-entry-name entry1) (manifest-entry-version entry1)) (manifest-entry-name (force (manifest-entry-parent entry1))) '<> (list (manifest-entry-name entry2) (manifest-entry-version entry2)) (manifest-entry-name (force (manifest-entry-parent entry2))))))) (run-with-store %store (mlet* %store-monad ((p0 -> (package (inherit %bootstrap-guile) (version "42"))) (p1 -> (dummy-package "p1" (propagated-inputs `(("guile" ,%bootstrap-guile))))) (p2 -> (dummy-package "p2" (propagated-inputs `(("guile" ,p0))))) (manifest -> (packages->manifest (list p1 p2))) (drv (profile-derivation manifest #:hooks '() #:locales? #f))) (return #f))))) (test-assertm "deduplication of repeated entries" ;; Make sure the 'manifest' file does not duplicate identical entries. ;; See . (mlet* %store-monad ((p0 -> (dummy-package "p0" (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (mkdir (assoc-ref %outputs "out")))) (propagated-inputs `(("guile" ,%bootstrap-guile))))) (p1 -> (package (inherit p0) (name "p1"))) (drv (profile-derivation (packages->manifest (list p0 p1)) #:hooks '() #:locales? #f))) (mbegin %store-monad (built-derivations (list drv)) (let ((file (string-append (derivation->output-path drv) "/manifest")) (manifest (profile-manifest (derivation->output-path drv)))) (define (contains-repeated? sexp) (match sexp (('repeated _ ...) #t) ((lst ...) (any contains-repeated? sexp)) (_ #f))) (return (and (contains-repeated? (call-with-input-file file read)) ;; MANIFEST has two entries for %BOOTSTRAP-GUILE since ;; it's propagated both from P0 and from P1. When ;; reading a 'repeated' node, 'read-manifest' should ;; reuse the previously-read entry so the two ;; %BOOTSTRAP-GUILE entries must be 'eq?'. (match (manifest-entries manifest) (((= manifest-entry-dependencies (dep0)) (= manifest-entry-dependencies (dep1))) (and (string=? (manifest-entry-name dep0) (package-name %bootstrap-guile)) (eq? dep0 dep1)))))))))) (test-assertm "no collision" ;; Here we have an entry that is "lowered" (its 'item' field is a store file ;; name) and another entry (its 'item' field is a package) that is ;; equivalent. (mlet* %store-monad ((p -> (dummy-package "p" (propagated-inputs `(("guile" ,%bootstrap-guile))))) (guile (package->derivation %bootstrap-guile)) (entry -> (manifest-entry (inherit (package->manifest-entry %bootstrap-guile)) (item (derivation->output-path guile)))) (manifest -> (manifest (list entry (package->manifest-entry p)))) (drv (profile-derivation manifest))) (return (->bool drv)))) (test-assertm "etc/profile" ;; Make sure we get an 'etc/profile' file that at least defines $PATH. (mlet* %store-monad ((guile -> (package (inherit %bootstrap-guile) (native-search-paths (package-native-search-paths packages:guile-2.0)))) (entry -> (package->manifest-entry guile)) (drv (profile-derivation (manifest (list entry)) #:hooks '() #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (let* ((pipe (open-input-pipe (string-append "unset GUIX_PROFILE; " ;; 'source' is a Bashism; use '.' (dot). ". " profile "/etc/profile; " ;; Don't try to parse set(1) output because ;; it differs among shells; just use echo. "echo $PATH"))) (path (get-string-all pipe))) (return (and (zero? (close-pipe pipe)) (string-contains path (string-append profile "/bin")))))))) (test-assertm "etc/profile when etc/ already exists" ;; Here 'union-build' makes the profile's etc/ a symlink to the package's ;; etc/ directory, which makes it read-only. Make sure the profile build ;; handles that. (mlet* %store-monad ((thing -> (dummy-package "dummy" (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (mkdir (string-append out "/etc")) (call-with-output-file (string-append out "/etc/foo") (lambda (port) (display "foo!" port))) #t))))) (entry -> (package->manifest-entry thing)) (drv (profile-derivation (manifest (list entry)) #:hooks '() #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (return (and (file-exists? (string-append profile "/etc/profile")) (string=? (call-with-input-file (string-append profile "/etc/foo") get-string-all) "foo!")))))) (test-assertm "etc/profile when etc/ is a symlink" ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail ;; gracelessly because 'scandir' would return #f. (mlet* %store-monad ((thing -> (dummy-package "dummy" (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (mkdir (string-append out "/foo")) (symlink "foo" (string-append out "/etc")) (call-with-output-file (string-append out "/etc/bar") (lambda (port) (display "foo!" port))) #t))))) (entry -> (package->manifest-entry thing)) (drv (profile-derivation (manifest (list entry)) #:hooks '() #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (return (and (file-exists? (string-append profile "/etc/profile")) (string=? (call-with-input-file (string-append profile "/etc/bar") get-string-all) "foo!")))))) (test-assertm "profile-derivation when etc/ is a relative symlink" ;; See . (mlet* %store-monad ((etc (gexp->derivation "etc" #~(begin (mkdir #$output) (call-with-output-file (string-append #$output "/foo") (lambda (port) (display "Heya!" port)))))) (thing -> (dummy-package "dummy" (build-system trivial-build-system) (inputs `(("etc" ,etc))) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out")) (etc (assoc-ref %build-inputs "etc"))) (mkdir out) (symlink etc (string-append out "/etc")) #t))))) (entry -> (package->manifest-entry thing)) (drv (profile-derivation (manifest (list entry)) #:relative-symlinks? #t #:hooks '() #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (return (string=? (call-with-input-file (string-append profile "/etc/foo") get-string-all) "Heya!"))))) (test-equalm "union vs. dangling symlink" ; "does-not-exist" (mlet* %store-monad ((thing1 -> (dummy-package "dummy" (build-system trivial-build-system) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) (symlink "does-not-exist" (string-append out "/dangling")) #t))))) (thing2 -> (package (inherit thing1) (name "dummy2"))) (drv (profile-derivation (packages->manifest (list thing1 thing2)) #:hooks '() #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (return (readlink (readlink (string-append profile "/dangling"))))))) (test-equalm "profile in profile" '("foo" "0") ;; Make sure we can build a profile that has another profile has one of its ;; entries. The new profile's /manifest and /etc/profile must override the ;; other's. (mlet* %store-monad ((prof0 (profile-derivation (manifest (list (package->manifest-entry %bootstrap-guile))) #:hooks '() #:locales? #f)) (prof1 (profile-derivation (manifest (list (manifest-entry (name "foo") (version "0") (item prof0)))) #:hooks '() #:locales? #f))) (mbegin %store-monad (built-derivations (list prof1)) (let ((out (derivation->output-path prof1))) (return (and (file-exists? (string-append out "/bin/guile")) (let ((manifest (profile-manifest out))) (match (manifest-entries manifest) ((entry) (list (manifest-entry-name entry) (manifest-entry-version entry))))))))))) (test-end "profiles") ;;; Local Variables: ;;; eval: (put 'dummy-package 'scheme-indent-function 1) ;;; End: