aboutsummaryr
aboutsummaryrefslogtreecommitdiff
path: root/lib/sourcemap.js
blob: 342990812469233fbb4d7cdd752bc3bebbbb231b (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
/***********************************************************************

  A JavaScript tokenizer / parser / beautifier / compressor.
  https://github.com/mishoo/UglifyJS2

  -------------------------------- (C) ---------------------------------

                           Author: Mihai Bazon
                         <mihai.bazon@gmail.com>
                       http://mihai.bazon.net/blog

  Distributed under the BSD license:

    Copyright 2012 (c) Mihai Bazon <mihai.bazon@gmail.com>

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

        * Redistributions of source code must retain the above
          copyright notice, this list of conditions and the following
          disclaimer.

        * Redistributions in binary form must reproduce the above
          copyright notice, this list of conditions and the following
          disclaimer in the documentation and/or other materials
          provided with the distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER “AS IS” AND ANY
    EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
    IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
    LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
    OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
    PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
    PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
    TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF
    THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
    SUCH DAMAGE.

 ***********************************************************************/

"use strict";

// a small wrapper around fitzgen's source-map library
function SourceMap(options) {
    options = defaults(options, {
        file : null,
        root : null,
        orig : null,
    });
    var generator = new MOZ_SourceMap.SourceMapGenerator({
        file       : options.file,
        sourceRoot : options.root
    });
    var orig_map = options.orig && new MOZ_SourceMap.SourceMapConsumer(options.orig);
    function add(source, gen_line, gen_col, orig_line, orig_col, name) {
        if (orig_map) {
            var info = orig_map.originalPositionFor({
                line: orig_line,
                column: orig_col
            });
            source = info.source;
            orig_line = info.line;
            orig_col = info.column;
            name = info.name;
        }
        generator.addMapping({
            generated : { line: gen_line, column: gen_col },
            original  : { line: orig_line, column: orig_col },
            source    : source,
            name      : name
        });
    };
    return {
        add        : add,
        get        : function() { return generator },
        toString   : function() { return generator.toString() }
    };
};
(use-modules (ice-9 match)) (let loop ((result '())) (match (getpw) (#f (reverse result)) (x (loop (cons x result)))))) marionette))) (lset= equal? (map (lambda (user) (list (passwd:name user) (passwd:dir user))) users) (list #$@(map (lambda (account) `(list ,(user-account-name account) ,(user-account-home-directory account))) (operating-system-user-accounts os)))))) (test-assert "shepherd services" (let ((services (marionette-eval '(begin (use-modules (gnu services herd) (srfi srfi-1)) (append-map live-service-provision (current-services))) marionette))) (lset= eq? (pk 'services services) '(root shepherd #$@(operating-system-shepherd-service-names os))))) (test-equal "libc honors /etc/localtime" -7200 ;CEST = GMT+2 ;; Assume OS is configured to have a CEST timezone. (let* ((sept-2021 (time-second (date->time-utc (make-date 0 0 00 12 01 09 2021 7200))))) (marionette-eval `(tm:gmtoff (localtime ,sept-2021)) marionette))) (test-equal "/var/log/messages is not world-readable" #o640 ;<https://bugs.gnu.org/40405> (begin (wait-for-file "/var/log/messages" marionette #:read 'get-u8) (marionette-eval '(stat:perms (lstat "/var/log/messages")) marionette))) (test-assert "homes" (let ((homes '#$(map user-account-home-directory (filter user-account-create-home-directory? (operating-system-user-accounts os))))) (marionette-eval `(begin (use-modules (gnu services herd) (srfi srfi-1)) ;; Home directories are supposed to exist once 'user-homes' ;; has been started. (start-service 'user-homes) (every (lambda (home) (and (file-exists? home) (file-is-directory? home))) ',homes)) marionette))) (test-assert "skeletons in home directories" (let ((users+homes '#$(filter-map (lambda (account) (and (user-account-create-home-directory? account) (not (user-account-system? account)) (list (user-account-name account) (user-account-home-directory account)))) (operating-system-user-accounts os)))) (marionette-eval `(begin (use-modules (guix build utils) (srfi srfi-1) (ice-9 ftw) (ice-9 match)) (every (match-lambda ((user home) ;; Make sure HOME has all the skeletons... (and (null? (lset-difference string=? (scandir "/etc/skel/") (scandir home))) ;; ... and that everything is user-owned. (let* ((pw (getpwnam user)) (uid (passwd:uid pw)) (gid (passwd:gid pw)) (st (lstat home))) (define (user-owned? file) (= uid (stat:uid (lstat file)))) (and (= uid (stat:uid st)) (eq? 'directory (stat:type st)) (every user-owned? (find-files home #:directories? #t))))))) ',users+homes)) marionette))) (test-equal "permissions on /root" #o700 (let ((root-home #$(any (lambda (account) (and (zero? (user-account-uid account)) (user-account-home-directory account))) (operating-system-user-accounts os)))) (stat:perms (marionette-eval `(stat ,root-home) marionette)))) (test-equal "ownership and permissions of /var/empty" '(0 0 #o555) (let ((st (marionette-eval `(stat "/var/empty") marionette))) (list (stat:uid st) (stat:gid st) (stat:perms st)))) (test-equal "no extra home directories" '() ;; Make sure the home directories that are not supposed to be ;; created are indeed not created. (let ((nonexistent '#$(filter-map (lambda (user) (and (not (user-account-create-home-directory? user)) (user-account-home-directory user))) (operating-system-user-accounts os)))) (marionette-eval `(begin (use-modules (srfi srfi-1)) ;; Note: Do not flag "/var/empty". (filter file-exists? ',(remove (cut string-prefix? "/var/" <>) nonexistent))) marionette))) (test-equal "login on tty1" "root\n" (begin ;; XXX: On desktop, GDM3 will switch to TTY7. If this happens ;; after we switched to TTY1, we won't be able to login. Make ;; sure to wait long enough before switching to TTY1. (when #$desktop? (sleep 30)) (marionette-control "sendkey ctrl-alt-f1" marionette) ;; Wait for the 'term-tty1' service to be running (using ;; 'start-service' is the simplest and most reliable way to do ;; that.) (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'term-tty1)) marionette) ;; Now we can type. (let ((password #$root-password)) (if password (begin (marionette-type "root\n" marionette) (wait-for-screen-text marionette (lambda (text) (string-contains text "Password")) #:ocr #$(file-append ocrad "/bin/ocrad")) (marionette-type (string-append password "\n\n") marionette)) (marionette-type "root\n\n" marionette))) (marionette-type "id -un > logged-in\n" marionette) ;; It can take a while before the shell commands are executed. (marionette-eval '(use-modules (rnrs io ports)) marionette) (wait-for-file "/root/logged-in" marionette #:read 'get-string-all #:timeout 30))) (test-equal "getlogin on tty1" "\"root\"" (begin ;; Assume we logged in in the previous test and type. (marionette-type "guile -c '(write (getlogin))' > /root/login-id.tmp\n" marionette) (marionette-type "mv /root/login-id{.tmp,}\n" marionette) ;; It can take a while before the shell commands are executed. (marionette-eval '(use-modules (rnrs io ports)) marionette) (wait-for-file "/root/login-id" marionette #:read 'get-string-all #:timeout 30))) ;; There should be one utmpx entry for the user logged in on tty1. (test-equal "utmpx entry" '(("root" "tty1" #f)) (marionette-eval '(begin (use-modules (guix build syscalls) (srfi srfi-1)) (filter-map (lambda (entry) (and (equal? (login-type USER_PROCESS) (utmpx-login-type entry)) (list (utmpx-user entry) (utmpx-line entry) (utmpx-host entry)))) (utmpx-entries))) marionette)) ;; Likewise for /var/log/wtmp (used by 'last'). (test-assert "wtmp entry" (match (marionette-eval '(begin (use-modules (guix build syscalls) (srfi srfi-1)) (define (entry->list entry) (list (utmpx-user entry) (utmpx-line entry) (utmpx-host entry) (utmpx-login-type entry))) (call-with-input-file "/var/log/wtmp" (lambda (port) (let loop ((result '())) (if (eof-object? (peek-char port)) (map entry->list (reverse result)) (loop (cons (read-utmpx port) result))))))) marionette) (((users lines hosts types) ..1) (every (lambda (type) (eqv? type (login-type LOGIN_PROCESS))) types)))) (test-assert "host name resolution" (match (marionette-eval '(begin ;; Wait for nscd or our requests go through it. (use-modules (gnu services herd)) (start-service 'nscd) (list (getaddrinfo "localhost") (getaddrinfo #$(operating-system-host-name os)))) marionette) ((((? vector?) ..1) ((? vector?) ..1)) #t) (x (pk 'failure x #f)))) (test-assert "nscd configuration action" (marionette-eval '(with-shepherd-action 'nscd ('configuration) results (file-exists? (car results))) marionette)) (test-equal "nscd invalidate action" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts") result result) marionette)) ;; FIXME: The 'invalidate' action can't reliably obtain the exit ;; code of 'nscd' so skip this test. (test-skip 1) (test-equal "nscd invalidate action, wrong table" '(#f) ;one value, #f (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz") result result) marionette)) (test-equal "host not found" #f (marionette-eval '(false-if-exception (getaddrinfo "does-not-exist")) marionette)) (test-equal "locale" "en_US.utf8" (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8"))) (setlocale LC_ALL before)) marionette)) (test-eq "/run/current-system is a GC root" 'success! (marionette-eval '(begin ;; Make sure the (guix …) modules are found. (eval-when (expand load eval) (set! %load-path (append (map (lambda (package) (string-append package "/share/guile/site/" (effective-version))) '#$guix&co) %load-path))) (use-modules (srfi srfi-34) (guix store)) (let ((system (readlink "/run/current-system"))) (guard (c ((store-protocol-error? c) (and (file-exists? system) 'success!))) (with-store store (delete-paths store (list system)) #f)))) marionette)) ;; This symlink is currently unused, but better have it point to the ;; right place. See ;; <https://lists.gnu.org/archive/html/guix-devel/2016-08/msg01641.html>. (test-equal "/var/guix/gcroots/profiles is a valid symlink" "/var/guix/profiles" (marionette-eval '(readlink "/var/guix/gcroots/profiles") marionette)) (test-equal "guix-daemon set-http-proxy action" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'guix-daemon ('set-http-proxy "http://localhost:8118") result result) marionette)) (test-equal "guix-daemon set-http-proxy action, clear" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'guix-daemon ('set-http-proxy) result result) marionette)) (test-assert "screendump" (begin (let ((capture (string-append #$output "/tty1.ppm"))) (marionette-control (string-append "screendump " capture) marionette) (file-exists? capture)))) (test-assert "screen text" (wait-for-screen-text marionette (lambda (text) ;; Check whether the welcome message and shell prompt are ;; displayed. Note: OCR confuses "y" and "V" for instance, so ;; we cannot reliably match the whole text. (and (string-contains text "This is the GNU") (string-contains text (string-append "root@" #$(operating-system-host-name os))))) #:ocr #$(file-append ocrad "/bin/ocrad"))) (test-end)))) (gexp->derivation name test)) (define* (test-basic-os #:optional (kernel linux-libre)) (system-test (name (if (eq? kernel linux-libre) "basic" (string-append (package-name kernel) "-" (version-major+minor (package-version kernel))))) (description "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic functionality tests, using the given KERNEL.") (value (let* ((os (marionette-operating-system (operating-system (inherit %simple-os) (kernel kernel)) #:imported-modules '((gnu services herd) (guix combinators)))) (vm (virtual-machine os))) ;; XXX: Add call to 'virtualized-operating-system' to get the exact same ;; set of services as the OS produced by ;; 'system-qemu-image/shared-store-script'. (run-basic-test (virtualized-operating-system os '()) #~(list #$vm) name))))) (define %test-basic-os (test-basic-os)) ;; Ensure the LTS kernels are up to snuff, too. (define %test-linux-libre-5.15 (test-basic-os linux-libre-5.15)) (define %test-linux-libre-5.10 (test-basic-os linux-libre-5.10)) (define %test-linux-libre-5.4 (test-basic-os linux-libre-5.4)) (define %test-linux-libre-4.19 (test-basic-os linux-libre-4.19)) ;;; ;;; Halt. ;;; (define (run-halt-test vm) ;; As reported in <http://bugs.gnu.org/26931>, running tmux would previously ;; lead the 'stop' method of 'user-processes' to an infinite loop, with the ;; tmux server process as a zombie that remains in the list of processes. ;; This test reproduces this scenario. (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (gnu build marionette)) (define marionette (make-marionette '(#$vm))) (define ocrad #$(file-append ocrad "/bin/ocrad")) ;; Wait for tty1 and log in. (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'term-tty1)) marionette) (marionette-type "root\n" marionette) ;; Start tmux and wait for it to be ready. (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n" marionette) (wait-for-file "/ready" marionette) ;; Make sure to stop the test after a while. (sigaction SIGALRM (lambda _ (format (current-error-port) "FAIL: Time is up, but VM still running.\n") (primitive-exit 1))) (alarm 10) ;; Get debugging info. (marionette-eval '(current-output-port (open-file "/dev/console" "w0")) marionette) (marionette-eval '(system* #$(file-append procps "/bin/ps") "-eo" "pid,ppid,stat,comm") marionette) ;; See if 'halt' actually works. (marionette-eval '(system* "/run/current-system/profile/sbin/halt") marionette) ;; If we reach this line, that means the VM was properly stopped in ;; a timely fashion. (alarm 0) (call-with-output-file #$output (lambda (port) (display "success!" port)))))) (gexp->derivation "halt" test)) (define %test-halt (system-test (name "halt") (description "Use the 'halt' command and make sure it succeeds and does not get stuck in a loop. See <http://bugs.gnu.org/26931>.") (value (let ((os (marionette-operating-system (operating-system (inherit %simple-os) (packages (cons tmux %base-packages))) #:imported-modules '((gnu services herd) (guix combinators))))) (run-halt-test (virtual-machine os)))))) ;;; ;;; Root cleanly unmounted. ;;; (define (run-root-unmount-test os) (define test-image (image (operating-system os) (format 'compressed-qcow2) (volatile-root? #f) (shared-store? #f) (partition-table-type 'mbr) (partitions (list (partition (size 'guess) (offset (* 512 2048)) ;leave room for GRUB (flags '(boot)) (label "root-under-test")))))) ;max 16 characters! (define observer-os (marionette-operating-system %simple-os #:imported-modules (source-module-closure '((guix build syscalls) (gnu build file-systems))))) (define test (with-imported-modules (source-module-closure '((gnu build marionette) (guix build utils))) #~(begin (use-modules (gnu build marionette) (guix build utils) (srfi srfi-64) (ice-9 ftw)) (define image "/tmp/writable-image.qcow2") (define (test-system-marionette) ;; Return a marionette on a system where we'll run 'halt'. (invoke #$(file-append qemu-minimal "/bin/qemu-img") "create" "-f" "qcow2" image "3G" "-b" #$(system-image test-image) "-F" "qcow2") (make-marionette `(,(string-append #$qemu-minimal "/bin/" (qemu-command)) ,@(if (file-exists? "/dev/kvm") '("-enable-kvm") '()) "-no-reboot" "-m" "1024" ;memory size, in MiB "-drive" ,(format #f "file=~a,if=virtio" image)))) (define witness-size ;; Size of the /witness file. (* 20 (expt 2 20))) (test-runner-current (system-test-runner #$output)) (test-begin "root-unmount") (let ((marionette (test-system-marionette))) (test-assert "file created" (marionette-eval `(begin (use-modules (guix build utils)) (call-with-output-file "/witness" (lambda (port) (call-with-input-file "/dev/random" (lambda (input) (dump-port input port ,witness-size)))))) marionette)) ;; Halt the system. (marionette-eval '(system* "/run/current-system/profile/sbin/halt") marionette) (display "waiting for marionette to complete...") (force-output) (false-if-exception (waitpid (marionette-pid marionette))) (display " done\n") (force-output)) ;; Remove the sockets used by the marionette above to avoid ;; EADDRINUSE. (for-each delete-file (find-files "/tmp" (lambda (file stat) (eq? (stat:type stat) 'socket)))) ;; Now boot another system and check whether the root file system of ;; the first one was cleanly unmounted. (let ((observer (make-marionette (list #$(virtual-machine observer-os) "-drive" (format #f "file=~a,if=virtio" image))))) (test-assert "partitions" (marionette-eval '(begin (use-modules (gnu build file-systems)) (disk-partitions)) observer)) (test-assert "partition found" (marionette-eval '(find-partition-by-label "root-under-test") observer)) (test-assert "root file system is clean" (marionette-eval '(cleanly-unmounted-ext2? (find-partition-by-label "root-under-test")) observer)) (test-equal "root file system contains /witness" witness-size (let ((files (marionette-eval '(begin (use-modules (guix build syscalls) (ice-9 ftw)) (mount (find-partition-by-label "root-under-test") "/mnt" "ext4" MS_RDONLY) (scandir "/mnt")) observer))) (if (member "witness" files) (marionette-eval '(stat:size (stat "/mnt/witness")) observer) files)))) (test-end)))) (gexp->derivation "root-unmount" test)) (define %test-root-unmount (system-test (name "root-unmount") (description "Make sure the root file system is cleanly unmounted when the system is halted.") (value (let ((os (marionette-operating-system %simple-os))) (run-root-unmount-test os))))) ;;; ;;; Cleanup of /tmp, /var/run, etc. ;;; (define %cleanup-os (simple-operating-system (simple-service 'dirty-things boot-service-type (let ((script (plain-file "create-utf8-file.sh" (string-append "echo $0: dirtying /tmp...\n" "set -e; set -x\n" "touch /witness\n" "exec touch /tmp/λαμβδα")))) (with-imported-modules '((guix build utils)) #~(begin (setenv "PATH" #$(file-append coreutils "/bin")) (invoke #$(file-append bash "/bin/sh") #$script))))))) (define (run-cleanup-test name) (define os (marionette-operating-system %cleanup-os #:imported-modules '((gnu services herd) (guix combinators)))) (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (gnu build marionette) (srfi srfi-64) (ice-9 match)) (define marionette (make-marionette (list #$(virtual-machine os)))) (test-runner-current (system-test-runner #$output)) (test-begin "cleanup") (test-assert "dirty service worked" (marionette-eval '(file-exists? "/witness") marionette)) (test-equal "/tmp cleaned up" '("." "..") (marionette-eval '(begin (use-modules (ice-9 ftw)) (scandir "/tmp")) marionette)) (test-end)))) (gexp->derivation "cleanup" test)) (define %test-cleanup ;; See <https://bugs.gnu.org/26353>. (system-test (name "cleanup") (description "Make sure the 'cleanup' service can remove files with non-ASCII names from /tmp.") (value (run-cleanup-test name)))) ;;; ;;; Mcron. ;;; (define %mcron-os ;; System with an mcron service, with one mcron job for "root" and one mcron ;; job for an unprivileged user. (let ((job1 #~(job '(next-second '(0 5 10 15 20 25 30 35 40 45 50 55)) (lambda () (unless (file-exists? "witness") (call-with-output-file "witness" (lambda (port) (display (list (getuid) (getgid)) port))))))) (job2 #~(job next-second-from (lambda () (call-with-output-file "witness" (lambda (port) (display (list (getuid) (getgid)) port)))) #:user "alice")) (job3 #~(job next-second-from ;to test $PATH "touch witness-touch"))) (simple-operating-system (service mcron-service-type (mcron-configuration (jobs (list job1 job2 job3))))))) (define (run-mcron-test name) (define os (marionette-operating-system %mcron-os #:imported-modules '((gnu services herd) (guix combinators)))) (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (gnu build marionette) (srfi srfi-64) (ice-9 match)) (define marionette (make-marionette (list #$(virtual-machine os)))) (test-runner-current (system-test-runner #$output)) (test-begin "mcron") (test-assert "service running" (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'mcron)) marionette)) ;; Make sure root's mcron job runs, has its cwd set to "/root", and ;; runs with the right UID/GID. (test-equal "root's job" '(0 0) (wait-for-file "/root/witness" marionette)) ;; Likewise for Alice's job. We cannot know what its GID is since ;; it's chosen by 'groupadd', but it's strictly positive. (test-assert "alice's job" (match (wait-for-file "/home/alice/witness" marionette) ((1000 gid) (>= gid 100)))) ;; Last, the job that uses a command; allows us to test whether ;; $PATH is sane. (test-equal "root's job with command" "" (wait-for-file "/root/witness-touch" marionette #:read '(@ (ice-9 rdelim) read-string))) ;; Make sure the 'schedule' action is accepted. (test-equal "schedule action" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'mcron ('schedule) result result) marionette)) (test-end)))) (gexp->derivation name test)) (define %test-mcron (system-test (name "mcron") (description "Make sure the mcron service works as advertised.") (value (run-mcron-test name)))) ;;; ;;; Avahi and NSS-mDNS. ;;; (define %avahi-os