aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Joshua S. Grant <jgrant@parenthetical.io>
;;; 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 (gnu)
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:use-module (gnu services)
  #:export (use-package-modules
            use-service-modules
            use-system-modules))

;;; Commentary:
;;;
;;; This composite module re-exports core parts the (gnu …) public modules.
;;;
;;; Code:

(eval-when (eval load compile)
  (begin
    (define %public-modules
      '((gnu system)
        (gnu system mapped-devices)
        (gnu system file-systems)
        (gnu bootloader)
        (gnu bootloader grub)
        (gnu system keyboard)
        (gnu system pam)
        (gnu system shadow)                       ; 'user-account'
        (gnu system linux-initrd)
        (gnu system nss)
        (gnu services)
        (gnu services base)
        (gnu packages)
        (gnu packages base)
        (guix gexp)))                             ; so gexps can be used

    (for-each (let ((i (module-public-interface (current-module))))
                (lambda (m)
                  (module-use! i (resolve-interface m))))
              %public-modules)))

(define (%try-use-modules modules location make-hint)
  "Attempt to load all of MODULES.  Report errors as coming from LOCATION, a
<location> record, and use MAKE-HINT to produce a fix hint."
  (define (location->string loc)
    (match loc
      (#f "")
      (($ <location> file line column)
       (format #f "~a:~a:~a: " file line column))))

  (for-each (lambda (module)
              (catch 'misc-error
                (lambda ()
                  (process-use-modules `((,module))))
                (lambda _
                  (raise
                   (apply
                    make-compound-condition
                    (formatted-message (G_ "module ~a not found")
                                       module)
                    (condition
                     (&error-location (location location)))
                    (or (and=> (make-hint module) list)
                        '()))))))
            modules))

(define (package-module-hint module)
  (define last-name
    (match module
      ((_ ... last)
       (symbol->string last))))

  (match (find-packages-by-name last-name)
    (()
     (condition
      (&fix-hint
       (hint (G_ "\
You may use @command{guix package --show=foo | grep location} to search
for the location of package @code{foo}.
If you get the line @code{location: gnu/packages/bar.scm:174:2},
add @code{bar} to the @code{use-package-modules} form.")))))
    ((package _ ...)
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
Try adding @code{(use-package-modules ~a)}.")
                     (basename (location-file (package-location package))
                               ".scm"))))))))

(define (service-module-hint module)
  (define last-name
    (match module
      ((_ ... last)
       last)))

  (match (lookup-service-types last-name)
    (()
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
You may use @command{guix system search ~a} to search for a service
matching @code{~a}.
If you get the line @code{location: gnu/services/foo.scm:188:2},
add @code{foo} to the @code{use-service-modules} form.")
                     last-name last-name)))))
    ((package _ ...)
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
Try adding @code{(use-service-modules ~a)}.")
                     (basename (location-file (service-type-location package))
                               ".scm"))))))))

(define-syntax-rule (try-use-modules hint modules ...)
  (eval-when (expand load eval)
    (%try-use-modules '(modules ...)
                      (source-properties->location
                       (current-source-location))
                      hint)))

(define-syntax-rule (use-package-modules module ...)
  (try-use-modules package-module-hint
                   (gnu packages module) ...))

(define-syntax-rule (use-service-modules module ...)
  (try-use-modules service-module-hint
                   (gnu services module) ...))

(define-syntax-rule (use-system-modules module ...)
  (try-use-modules (const #f)                     ;no hint
                   (gnu system module) ...))

;;; gnu.scm ends here
put (string-append %test-dir "/output"))) (dynamic-wind (lambda () #t) (lambda () (define-values (port get-bytevector) (open-bytevector-output-port)) (write-file-tree "root" port #:file-type+size (match-lambda ("root" (values 'directory 0)) ("root/foo" (values 'regular (stat:size (stat file1)))) ("root/lnk" (values 'symlink 0)) ("root/dir" (values 'directory 0)) ("root/dir/bar" (values 'regular (stat:size (stat file2)))) ("root/dir/exe" (values 'executable (string-length file3)))) #:file-port (match-lambda ("root/foo" (open-input-file file1)) ("root/dir/bar" (open-input-file file2)) ("root/dir/exe" (open-input-string file3))) #:symlink-target (match-lambda ("root/lnk" "foo")) #:directory-entries (match-lambda ("root" '("foo" "dir" "lnk")) ("root/dir" '("bar" "exe")))) (close-port port) (rm-rf %test-dir) (mkdir %test-dir) (restore-file (open-bytevector-input-port (get-bytevector)) output) (and (file=? (string-append output "/foo") file1) (string=? (readlink (string-append output "/lnk")) "foo") (file=? (string-append output "/dir/bar") file2) (string=? (call-with-input-file (string-append output "/dir/exe") get-string-all) file3) (> (logand (stat:mode (lstat (string-append output "/dir/exe"))) #o100) 0) (equal? '("." ".." "bar" "exe") (scandir (string-append output "/dir"))) (equal? '("." ".." "dir" "foo" "lnk") (scandir output)))) (lambda () (false-if-exception (rm-rf %test-dir)))))) (test-equal "write-file-tree + fold-archive" '(("R" directory #f) ("R/dir" directory #f) ("R/dir/exe" executable "1234") ("R/dir" directory-complete #f) ("R/foo" regular "abcdefg") ("R/lnk" symlink "foo") ("R" directory-complete #f)) (let () (define-values (port get-bytevector) (open-bytevector-output-port)) (write-file-tree "root" port #:file-type+size (match-lambda ("root" (values 'directory 0)) ("root/foo" (values 'regular 7)) ("root/lnk" (values 'symlink 0)) ("root/dir" (values 'directory 0)) ("root/dir/exe" (values 'executable 4))) #:file-port (match-lambda ("root/foo" (open-input-string "abcdefg")) ("root/dir/exe" (open-input-string "1234"))) #:symlink-target (match-lambda ("root/lnk" "foo")) #:directory-entries (match-lambda ("root" '("foo" "dir" "lnk")) ("root/dir" '("exe")))) (close-port port) (reverse (fold-archive (lambda (file type contents result) (let ((contents (if (memq type '(regular executable)) (utf8->string (get-bytevector-n (car contents) (cdr contents))) contents))) (cons `(,file ,type ,contents) result))) '() (open-bytevector-input-port (get-bytevector)) "R")))) (test-equal "write-file-tree + fold-archive, flat file" '(("R" regular "abcdefg")) (let () (define-values (port get-bytevector) (open-bytevector-output-port)) (write-file-tree "root" port #:file-type+size (match-lambda ("root" (values 'regular 7))) #:file-port (match-lambda ("root" (open-input-string "abcdefg")))) (close-port port) (reverse (fold-archive (lambda (file type contents result) (let ((contents (utf8->string (get-bytevector-n (car contents) (cdr contents))))) (cons `(,file ,type ,contents) result))) '() (open-bytevector-input-port (get-bytevector)) "R")))) (test-assert "write-file supports non-file output ports" (let ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) (output (%make-void-port "w"))) (write-file input output) #t)) (test-equal "write-file puts file in C locale collation order" (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3") (let ((input (string-append %test-dir ".input"))) (dynamic-wind (lambda () (define (touch file) (call-with-output-file (string-append input "/" file) (const #t))) (mkdir input) (touch "B") (touch "Z") (touch "a") (symlink "B" (string-append input "/z"))) (lambda () (let-values (((port get-hash) (open-sha256-port))) (write-file input port) (close-port port) (get-hash))) (lambda () (rm-rf input))))) (test-equal "restore-file with incomplete input" (string-append %test-dir "/foo") (let ((port (open-bytevector-input-port #vu8(1 2 3)))) (guard (c ((nar-error? c) (and (eq? port (nar-error-port c)) (nar-error-file c)))) (restore-file port (string-append %test-dir "/foo")) #f))) (test-assert "write-file + restore-file" (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) (output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) (lambda () (call-with-output-file nar (cut write-file input <>)) (call-with-input-file nar (cut restore-file <> output)) (file-tree-equal? input output)) (lambda () (false-if-exception (delete-file nar)) (false-if-exception (rm-rf output)))))) (test-assert "write-file + restore-file with symlinks" (let ((input (string-append %test-dir ".input"))) (mkdir input) (dynamic-wind (const #t) (lambda () (with-file-tree input (directory "root" (("reg") ("exe" #o777) ("sym" -> "reg"))) (let* ((output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) (lambda () (call-with-output-file nar (cut write-file input <>)) (call-with-input-file nar (cut restore-file <> output)) (and (file-tree-equal? input output) (every (lambda (file) (canonical-file? (string-append output "/" file))) '("root" "root/reg" "root/exe")))) (lambda () (false-if-exception (delete-file nar)) (false-if-exception (rm-rf output))))))) (lambda () (rmdir input))))) (test-assert "write-file #:select? + restore-file" (let ((input (string-append %test-dir ".input"))) (mkdir input) (dynamic-wind (const #t) (lambda () (with-file-tree input (directory "root" ((directory "a" (("x") ("y") ("z"))) ("b") ("c") ("d" -> "b"))) (let* ((output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) (lambda () (call-with-output-file nar (lambda (port) (write-file input port #:select? (lambda (file stat) (and (not (string=? (basename file) "a")) (not (eq? (stat:type stat) 'symlink))))))) (call-with-input-file nar (cut restore-file <> output)) ;; Make sure "a" and "d" have been filtered out. (and (not (file-exists? (string-append output "/root/a"))) (file=? (string-append output "/root/b") (string-append input "/root/b")) (file=? (string-append output "/root/c") (string-append input "/root/c")) (not (file-exists? (string-append output "/root/d"))))) (lambda () (false-if-exception (delete-file nar)) (false-if-exception (rm-rf output))))))) (lambda () (rmdir input))))) (test-eq "restore-file with non-UTF8 locale" ;<https://bugs.gnu.org/33603> 'encoding-error (let* ((file (search-path %load-path "guix.scm")) (output (string-append %test-dir "/output")) (locale (setlocale LC_ALL "C"))) (dynamic-wind (lambda () #t) (lambda () (define-values (port get-bytevector) (open-bytevector-output-port)) (write-file-tree "root" port #:file-type+size (match-lambda ("root" (values 'directory 0)) ("root/λ" (values 'regular 0))) #:file-port (const (%make-void-port "r")) #:symlink-target (const #f) #:directory-entries (const '("λ"))) (close-port port) (mkdir %test-dir) (catch 'encoding-error (lambda () ;; This show throw to 'encoding-error. (restore-file (open-bytevector-input-port (get-bytevector)) output) (scandir output)) (lambda args 'encoding-error))) (lambda () (false-if-exception (rm-rf %test-dir)) (setlocale LC_ALL locale))))) ;; XXX: Tell the 'deduplicate' procedure what store we're actually using. (setenv "NIX_STORE" (%store-prefix)) (test-assert "restore-file-set (signed, valid)" (with-store store (let* ((texts (unfold (cut >= <> 10) (lambda _ (random-text)) 1+ 0)) (files (map (cut add-text-to-store store "text" <>) texts)) (dump (call-with-bytevector-output-port (cut export-paths store files <>)))) (delete-paths store files) (and (every (negate file-exists?) files) (let* ((source (open-bytevector-input-port dump)) (imported (restore-file-set source))) (and (equal? imported files) (every (lambda (file) (and (file-exists? file) (valid-path? store file))) files) (equal? texts (map (lambda (file) (call-with-input-file file get-string-all)) files)) (every canonical-file? files))))))) (test-assert "restore-file-set with directories (signed, valid)" ;; <https://bugs.gnu.org/33361> describes a bug whereby directories ;; containing files subject to deduplication were not canonicalized--i.e., ;; their mtime and permissions were not reset. Ensure that this bug is ;; gone. (with-store store ;; Note: TEXT1 and TEXT2 must be longer than %DEDUPLICATION-MINIMUM-SIZE. (let* ((text1 (string-concatenate (make-list 200 (random-text)))) (text2 (string-concatenate (make-list 200 (random-text)))) (tree `("tree" directory ("a" regular (data ,text1)) ("b" directory ("c" regular (data ,text2)) ("d" regular (data ,text1))))) ;duplicate (file (add-file-tree-to-store store tree)) (dump (call-with-bytevector-output-port (cute export-paths store (list file) <>)))) (delete-paths store (list file)) (and (not (file-exists? file)) (let* ((source (open-bytevector-input-port dump)) (imported (restore-file-set source))) (and (equal? imported (list file)) (file-exists? file) (valid-path? store file) (string=? text1 (call-with-input-file (string-append file "/a") get-string-all)) (string=? text2 (call-with-input-file (string-append file "/b/c") get-string-all)) (= (stat:ino (stat (string-append file "/a"))) ;deduplication (stat:ino (stat (string-append file "/b/d")))) (every canonical-file? (find-files file #:directories? #t)))))))) (test-assert "restore-file-set (missing signature)" (let/ec return (with-store store (let* ((file (add-text-to-store store "foo" (random-text))) (dump (call-with-bytevector-output-port (cute export-paths store (list file) <> #:sign? #f)))) (delete-paths store (list file)) (and (not (file-exists? file)) (let ((source (open-bytevector-input-port dump))) (guard (c ((nar-signature-error? c) (let ((message (condition-message c)) (port (nar-error-port c))) (return (and (string-match "lacks.*signature" message) (string=? file (nar-error-file c)) (eq? source port)))))) (restore-file-set source)) #f)))))) (test-assert "restore-file-set (corrupt)" (let/ec return (with-store store (let* ((file (add-text-to-store store "foo" (random-text))) (dump (call-with-bytevector-output-port (cute export-paths store (list file) <>)))) (delete-paths store (list file)) ;; Flip a byte in the file contents. (let* ((index 120) (byte (bytevector-u8-ref dump index))) (bytevector-u8-set! dump index (logxor #xff byte))) (and (not (file-exists? file)) (let ((source (open-bytevector-input-port dump))) (guard (c ((nar-invalid-hash-error? c) (let ((message (condition-message c)) (port (nar-error-port c))) (return (and (string-contains message "hash") (string=? file (nar-error-file c)) (eq? source port)))))) (restore-file-set source)) #f)))))) (test-end "nar") ;;; Local Variables: ;;; eval: (put 'with-file-tree 'scheme-indent-function 2) ;;; End: