#!@BASH@ # -*- mode: scheme; coding: utf-8; -*- # XXX: We have to go through Bash because there's no command-line switch to # augment %load-compiled-path, and because of the silly 127-byte limit for # the shebang line in Linux. # Use `load-compiled' because `load' (and `-l') doesn't otherwise load our # .go file (see ). # Unset 'GUILE_LOAD_COMPILED_PATH' to make sure we do not stumble upon # incompatible .go files. See # . unset GUILE_LOAD_COMPILED_PATH unset GUILE_SYSTEM_COMPILED_PATH main="(@ (gnu build-support ld-wrapper) ld-wrapper)" exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@" !# ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès ;;; Copyright © 2020 Marius Bakke ;;; ;;; 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 (gnu build-support ld-wrapper) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:autoload (ice-9 rdelim) (read-delimited) #:export (ld-wrapper)) ;;; Commentary: ;;; ;;; This is a wrapper for the linker. Its purpose is to inspect the -L and ;;; -l switches passed to the linker, add 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012-2021 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-nar)
  #:use-module (guix tests)
  #:use-module (guix nar)
  #:use-module (guix serialization)
  #:use-module (guix store)
  #:use-module ((gcrypt hash)
                #:select (open-sha256-port open-sha256-input-port))
  #:use-module ((guix packages)
                #:select (base32))
  #:use-module ((guix build utils)
                #:select (find-files))
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 regex)
  #:use-module ((ice-9 control) #:select (let/ec))
  #:use-module (ice-9 match))

;; Test the (guix nar) module.


;;;
;;; File system testing tools, initially contributed to Guile, then libchop.
;;;

(define (random-file-size)
  (define %average (* 1024 512))                  ; 512 KiB
  (define %stddev  (* 1024 64))                   ; 64 KiB
  (inexact->exact
   (max 0 (round (+ %average (* %stddev (random:normal)))))))

(define (make-file-tree dir tree)
  "Make file system TREE at DIR."
  (let loop ((dir  dir)
             (tree tree))
    (define (scope file)
      (string-append dir "/" file))

    (match tree
      (('directory name (body ...))
       (mkdir (scope name))
       (for-each (cute loop (scope name) <>) body))
      (('directory name (? integer? mode) (body ...))
       (mkdir (scope name))
       (for-each (cute loop (scope name) <>) body)
       (chmod (scope name) mode))
      ((file)
       (populate-file (scope file) (random-file-size)))
      ((file (? integer? mode))
       (populate-file (scope file) (random-file-size))
       (chmod (scope file) mode))
      ((from '-> to)
       (symlink to (scope from))))))

(define (delete-file-tree dir tree)
  "Delete file TREE from DIR."
  (let loop ((dir  dir)
             (tree tree))
    (define (scope file)
      (string-append dir "/" file))

    (match tree
      (('directory name (body ...))
       (for-each (cute loop (scope name) <>) body)
       (rmdir (scope name)))
      (('directory name (? integer? mode) (body ...))
       (chmod (scope name) #o755)          ; make sure it can be entered
       (for-each (cute loop (scope name) <>) body)
       (rmdir (scope name)))
      ((from '-> _)
       (delete-file (scope from)))
      ((file _ ...)
       (delete-file (scope file))))))

(define-syntax-rule (with-file-tree dir tree body ...)
  (dynamic-wind
    (lambda ()
      (make-file-tree dir 'tree))
    (lambda ()
      body ...)
    (lambda ()
      (delete-file-tree dir 'tree))))

(define (file-tree-equal? input output)
  "Return #t if the file trees at INPUT and OUTPUT are equal."
  (define strip
    (cute string-drop <> (string-length input)))
  (define sibling
    (compose (cut string-append output <>) strip))

  (file-system-fold (const #t)
                    (lambda (name stat result)    ; leaf
                      (and result
                           (file=? name (sibling name))))
                    (lambda (name stat result)    ; down
                      result)
                    (lambda (name stat result)    ; up
                      result)
                    (const #f)                    ; skip
                    (lambda (name stat errno result)
                      (pk 'error name stat errno)
                      #f)
                    #t                            ; result
                    input
                    lstat))

(define (populate-file file size)
  (call-with-output-file file
    (lambda (p)
      (put-bytevector p (random-bytevector size)))))

(define (rm-rf dir)
  (file-system-fold (const #t)                    ; enter?
                    (lambda (file stat result)    ; leaf
                      (unless (eq? 'symlink (stat:type stat))
                        (chmod file #o644))
                      (delete-file file))
                    (lambda (dir stat result)     ; down
                      (chmod dir #o755))
                    (lambda (dir stat result)     ; up
                      (rmdir dir))
                    (const #t)                    ; skip
                    (const #t)                    ; error
                    #t
                    dir
                    lstat))

(define %test-dir
  ;; An output directory under $top_builddir.
  (string-append (dirname (search-path %load-path "pre-inst-env"))
                 "/test-nar-" (number->string (getpid))))


(test-begin "nar")

(test-assert "write-file-tree + restore-file"
  (let* ((file1  (search-path %load-path "guix.scm"))
         (file2  (search-path %load-path "guix/base32.scm"))
         (file3  "#!/bin/something")
         (output (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