aboutsummaryrefslogtreecommitdiff
Read the shared library cache relative to $ORIGIN instead of reading
from /etc/ld.so.cache.  Also arrange so that this cache takes
precedence over RUNPATH.

diff --git a/elf/dl-cache.c b/elf/dl-cache.c
index 93d185e788..e0760a1f40 100644
--- a/elf/dl-cache.c
+++ b/elf/dl-cache.c
@@ -171,6 +171,52 @@ _dl_cache_libcmp (const char *p1, const char *p2)
   return *p1 - *p2;
 }
 
+/* Special value representing the lack of an ld.so cache.  */
+static const char ld_so_cache_lacking[] = "/ld.so cache is lacking";
+
+/* Return the per-application ld.so cache, relative to $ORIGIN, or NULL if
+   that fails for some reason.  Do not return the system-wide LD_SO_CACHE
+   since on a foreign distro it would contain invalid information.  */
+static const char *
+ld_so_cache (void)
+{
+  static const char *loader_cache;
+
+  if (loader_cache == NULL)
+    {
+      static const char store[] = @STORE_DIRECTORY@;
+      const char *origin = _dl_get_origin ();
+
+      /* Check whether ORIGIN is something like "/gnu/store/…-foo/bin".  */
+      if (origin != (char *) -1   /* _dl_get_origin reported failure */
+	  && strncmp (store, origin, strlen (store)) == 0
+	  && origin[sizeof store - 1] == '/')
+	{
+	  char *store_item_end = strchr (origin + sizeof store, '/');
+
+	  if (store_item_end != NULL)
+	    {
+	      static const char suffix[] = "/etc/ld.so.cache";
+	      size_t store_item_len = store_item_end - origin;
+
+	      /* Note: We can't use 'malloc' because it can be interposed.
+		 Likewise, 'strncpy' is not available.  */
+	      char *cache = alloca (strlen (origin) + sizeof suffix);
+
+	      strcpy (cache, origin);
+	      strcpy (cache + store_item_len, suffix);
+
+	      loader_cache = __strdup (cache) ?: ld_so_cache_lacking;
+	    }
+	  else
+	    loader_cache = ld_so_cache_lacking;
+	}
+      else
+	loader_cache = ld_so_cache_lacking;
+    }
+
+  return loader_cache;
+}
 
 /* Look up NAME in ld.so.cache and return the file name stored there, or null
    if none is found.  The cache is loaded if it was not already.  If loading
@@ -190,12 +235,15 @@ _dl_load_cache_lookup (const char *name)
 
   /* Print a message if the loading of libs is traced.  */
   if (__glibc_unlikely (GLRO(dl_debug_mask) & DL_DEBUG_LIBS))
-    _dl_debug_printf (" search cache=%s\n", LD_SO_CACHE);
+    _dl_debug_printf (" search cache=%s\n", ld_so_cache ());
+
+  if (__glibc_unlikely (ld_so_cache () == ld_so_cache_lacking))
+    return NULL;
 
   if (cache == NULL)
     {
       /* Read the contents of the file.  */
-      void *file = _dl_sysdep_read_whole_file (LD_SO_CACHE, &cachesize,
+      void *file = _dl_sysdep_read_whole_file (ld_so_cache (), &cachesize,
 					       PROT_READ);
 
       /* We can handle three different cache file formats here:
diff --git a/elf/dl-load.c b/elf/dl-load.c
index f3201e7c14..a69aec3428 100644
--- a/elf/dl-load.c
+++ b/elf/dl-load.c
@@ -2152,28 +2152,6 @@ _dl_map_object (struct link_map *loader, const char *name,
 			loader ?: GL(dl_ns)[LM_ID_BASE]._ns_loaded,
 			LA_SER_LIBPATH, &found_other_class);
 
-      /* Look at the RUNPATH information for this binary.  */
-      if (fd == -1 && loader != NULL
-	  && cache_rpath (loader, &loader->l_runpath_dirs,
-			  DT_RUNPATH, "RUNPATH"))
-	fd = open_path (name, namelen, mode,
-			&loader->l_runpath_dirs, &realname, &fb, loader,
-			LA_SER_RUNPATH, &found_other_class);
-
-      if (fd == -1)
-        {
-          realname = _dl_sysdep_open_object (name, namelen, &fd);
-          if (realname != NULL)
-            {
-              fd = open_verify (realname, fd,
-                                &fb, loader ?: GL(dl_ns)[nsid]._ns_loaded,
-                                LA_SER_CONFIG, mode, &found_other_class,
-                                false);
-              if (fd == -1)
-                free (realname);
-            }
-        }
-
 #ifdef USE_LDCONFIG
       if (fd == -1
 	  && (__glibc_likely ((mode & __RTLD_SECURE) == 0)
@@ -2232,6 +2210,28 @@ _dl_map_object (struct link_map *loader, const char *name,
 	}
 #endif
 
+      /* Look at the RUNPATH information for this binary.  */
+      if (fd == -1 && loader != NULL
+	  && cache_rpath (loader, &loader->l_runpath_dirs,
+			  DT_RUNPATH, "RUNPATH"))
+	fd = open_path (name, namelen, mode,
+			&loader->l_runpath_dirs, &realname, &fb, loader,
+			LA_SER_RUNPATH, &found_other_class);
+
+      if (fd == -1)
+        {
+          realname = _dl_sysdep_open_object (name, namelen, &fd);
+          if (realname != NULL)
+            {
+              fd = open_verify (realname, fd,
+                                &fb, loader ?: GL(dl_ns)[nsid]._ns_loaded,
+                                LA_SER_CONFIG, mode, &found_other_class,
+                                false);
+              if (fd == -1)
+                free (realname);
+            }
+        }
+
       /* Finally, try the default path.  */
       if (fd == -1
 	  && ((l = loader ?: GL(dl_ns)[nsid]._ns_loaded) == NULL
href='#n156'>156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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)
  #:use-module (guix gexp)
  #:use-module (guix diagnostics)
  #:use-module (guix records)
  #:use-module ((guix ui) #:select (warn-about-load-error))
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader grub)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system shadow)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (guix discovery)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (ice-9 match)
  #:export (marionette-configuration
            marionette-configuration?
            marionette-configuration-device
            marionette-configuration-imported-modules
            marionette-configuration-requirements

            marionette-service-type
            marionette-operating-system
            define-os-with-source

            %simple-os
            simple-operating-system

            system-test
            system-test?
            system-test-name
            system-test-value
            system-test-description
            system-test-location

            fold-system-tests
            all-system-tests))

;;; Commentary:
;;;
;;; This module provides the infrastructure to run operating system tests.
;;; The most important part of that is tools to instrument the OS under test,
;;; essentially allowing it to run in a virtual machine controlled by the host
;;; system--hence the name "marionette".
;;;
;;; Code:

(define-record-type* <marionette-configuration>
  marionette-configuration make-marionette-configuration
  marionette-configuration?
  (device           marionette-configuration-device ;string
                    (default "/dev/virtio-ports/org.gnu.guix.port.0"))
  (imported-modules marionette-configuration-imported-modules
                    (default '()))
  (extensions       marionette-configuration-extensions
                    (default '())) ; list of packages
  (requirements     marionette-configuration-requirements ;list of symbols
                    (default '())))

;; Hack: avoid indenting code beyond column 80 in marionette-shepherd-service.
(define-syntax-rule (with-imported-modules-and-extensions imported-modules
                                                          extensions
                                                          gexp)
  (with-imported-modules imported-modules
    (with-extensions extensions
      gexp)))

(define (marionette-shepherd-service config)
  "Return the Shepherd service for the marionette REPL"
  (match config
    (($ <marionette-configuration> device imported-modules extensions
                                   requirement)
     (list (shepherd-service
            (provision '(marionette))

            ;; Always depend on UDEV so that DEVICE is available.
            (requirement `(udev ,@requirement))

            (modules '((ice-9 match)
                       (srfi srfi-9 gnu)))
            (start
             (with-imported-modules-and-extensions imported-modules extensions
               #~(lambda ()
                   (define (self-quoting? x)
                     (letrec-syntax ((one-of (syntax-rules ()
                                               ((_) #f)
                                               ((_ pred rest ...)
                                                (or (pred x)
                                                    (one-of rest ...))))))
                       (one-of symbol? string? keyword? pair? null? array?
                               number? boolean? char?)))

                   (match (primitive-fork)
                     (0
                      (dynamic-wind
                        (const #t)
                        (lambda ()
                          (let ((repl    (open-file #$device "r+0"))
                                (console (open-file "/dev/console" "r+0")))
                            ;; Redirect output to the console.
                            (close-fdes 1)
                            (close-fdes 2)
                            (dup2 (fileno console) 1)
                            (dup2 (fileno console) 2)
                            (close-port console)

                            (display 'ready repl)
                            (let loop ()
                              (newline repl)

                              (match (read repl)
                                ((? eof-object?)
                                 (primitive-exit 0))
                                (expr
                                 (catch #t
                                   (lambda ()
                                     (let ((result (primitive-eval expr)))
                                       (write (if (self-quoting? result)
                                                  result
                                                  (object->string result))
                                              repl)))
                                   (lambda (key . args)
                                     (print-exception (current-error-port)
                                                      (stack-ref (make-stack #t) 1)
                                                      key args)
                                     (write #f repl)))))
                              (loop))))
                        (lambda ()
                          (primitive-exit 1))))
                     (pid
                      pid)))))
            (stop #~(make-kill-destructor)))))))

(define marionette-service-type
  ;; This is the type of the "marionette" service, allowing a guest system to
  ;; be manipulated from the host.  This marionette REPL is essentially a
  ;; universal backdoor.
  (service-type (name 'marionette-repl)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          marionette-shepherd-service)))
                (description "The @dfn{marionette} service allows a guest
system (virtual machine) to be manipulated by the host.  It is used for system
tests.")))

(define* (marionette-operating-system os
                                      #:key
                                      (imported-modules '())
                                      (extensions '())
                                      (requirements '()))
  "Return a marionetteed variant of OS such that OS can be used as a
marionette in a virtual machine--i.e., controlled from the host system.  The
marionette service in the guest is started after the Shepherd services listed
in REQUIREMENTS.  The packages in the list EXTENSIONS are made available from
the backdoor REPL."
  (operating-system
    (inherit os)
    ;; Make sure the guest dies on error.
    (kernel-arguments (cons "panic=1"
                            (operating-system-user-kernel-arguments os)))
    ;; Make sure the guest doesn't hang in the REPL on error.
    (initrd (lambda (fs . rest)
              (apply (operating-system-initrd os) fs
                     #:on-error 'backtrace
                     rest)))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (requirements requirements)
                              (extensions extensions)
                              (imported-modules imported-modules)))
                    (operating-system-user-services os)))))

(define-syntax define-os-with-source
  (syntax-rules (use-modules operating-system)
    "Define two variables: OS containing the given operating system, and
SOURCE containing the source to define OS as an sexp.

This is convenient when we need both the <operating-system> object so we can
instantiate it, and the source to create it so we can store in in a file in
the system under test."
    ((_ (os source)
        (use-modules modules ...)
        (operating-system fields ...))
     (begin
       (define os
         (operating-system fields ...))
       (define source
         '(begin
            (use-modules modules ...)
            (operating-system fields ...)))))))


;;;
;;; Simple operating systems.
;;;

(define %simple-os
  (operating-system
    (host-name "komputilo")
    (timezone "Europe/Berlin")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (targets '("/dev/sdX"))))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (firmware '())

    (users (cons (user-account
                  (name "alice")
                  (comment "Bob's sister")
                  (group "users")
                  (supplementary-groups '("wheel" "audio" "video")))
                 %base-user-accounts))))

(define-syntax-rule (simple-operating-system user-services ...)
  "Return an operating system that includes USER-SERVICES in addition to
%BASE-SERVICES."
  (operating-system (inherit %simple-os)
                    (services (cons* user-services ... %base-services))))



;;;
;;; Tests.
;;;

(define-record-type* <system-test> system-test make-system-test
  system-test?
  (name        system-test-name)                  ;string
  (value       system-test-value)                 ;%STORE-MONAD value
  (description system-test-description)           ;string
  (location    system-test-location (innate)      ;<location>
               (default (and=> (current-source-location)
                               source-properties->location))))

(define (write-system-test test port)
  (match test
    (($ <system-test> name _ _ ($ <location> file line))
     (format port "#<system-test ~a ~a:~a ~a>"
             name file line
             (number->string (object-address test) 16)))
    (($ <system-test> name)
     (format port "#<system-test ~a ~a>" name
             (number->string (object-address test) 16)))))

(set-record-type-printer! <system-test> write-system-test)

(define-gexp-compiler (compile-system-test (test <system-test>)
                                           system target)
  "Compile TEST to a derivation."
  ;; XXX: SYSTEM and TARGET are ignored.
  (system-test-value test))

(define (test-modules)
  "Return the list of modules that define system tests."
  (scheme-modules (dirname (search-path %load-path "guix.scm"))
                  "gnu/tests"
                  #:warn warn-about-load-error))

(define (fold-system-tests proc seed)
  "Invoke PROC on each system test, passing it the test and the previous
result."
  (fold-module-public-variables (lambda (obj result)
                                  (if (system-test? obj)
                                      (cons obj result)
                                      result))
                                '()
                                (test-modules)))

(define (all-system-tests)
  "Return the list of system tests."
  (reverse (fold-system-tests cons '())))


;; Local Variables:
;; eval: (put 'with-imported-modules-and-extensions 'scheme-indent-function 2)
;; End:

;;; tests.scm ends here