guix-devel/guix/build/gremlin.scm

310 lines
11 KiB
Scheme
Raw Normal View History

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 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 (guix build gremlin)
#:use-module (guix elf)
#:use-module ((guix build utils) #:select (store-file-name?))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:export (elf-error?
elf-error-elf
invalid-segment-size?
invalid-segment-size-segment
elf-dynamic-info
elf-dynamic-info?
elf-dynamic-info-sopath
elf-dynamic-info-needed
elf-dynamic-info-rpath
elf-dynamic-info-runpath
expand-origin
validate-needed-in-runpath))
;;; Commentary:
;;;
;;; A gremlin is sort-of like an elf, you know, and this module provides tools
;;; to deal with dynamic-link information from ELF files.
;;;
;;; Code:
(define-condition-type &elf-error &error
elf-error?
(elf elf-error-elf))
(define-condition-type &invalid-segment-size &elf-error
invalid-segment-size?
(segment invalid-segment-size-segment))
(define (dynamic-link-segment elf)
"Return the 'PT_DYNAMIC' segment of ELF--i.e., the segment that contains
dynamic linking information."
(let ((size (bytevector-length (elf-bytes elf))))
(find (lambda (segment)
(unless (<= (+ (elf-segment-offset segment)
(elf-segment-filesz segment))
size)
;; This happens on separate debug output files created by
;; 'strip --only-keep-debug' (Binutils 2.25.)
(raise (condition (&invalid-segment-size
(elf elf)
(segment segment)))))
(= (elf-segment-type segment) PT_DYNAMIC))
(elf-segments elf))))
(define (word-reader size byte-order)
"Return a procedure to read a word of SIZE bytes according to BYTE-ORDER."
(case size
((8)
(lambda (bv index)
(bytevector-u64-ref bv index byte-order)))
((4)
(lambda (bv index)
(bytevector-u32-ref bv index byte-order)))))
;; Dynamic entry:
;;
;; typedef struct
;; {
;; Elf64_Sxword d_tag; /* Dynamic entry type */
;; union
;; {
;; Elf64_Xword d_val; /* Integer value */
;; Elf64_Addr d_ptr; /* Address value */
;; } d_un;
;; } Elf64_Dyn;
(define (raw-dynamic-entries elf segment)
"Return as a list of type/value pairs all the dynamic entries found in
SEGMENT, the 'PT_DYNAMIC' segment of ELF. In the result, each car is a DT_
value, and the interpretation of the cdr depends on the type."
(define start
(elf-segment-offset segment))
(define bytes
(elf-bytes elf))
(define word-size
(elf-word-size elf))
(define byte-order
(elf-byte-order elf))
(define read-word
(word-reader word-size byte-order))
(let loop ((offset 0)
(result '()))
(if (>= offset (elf-segment-memsz segment))
(reverse result)
(let ((type (read-word bytes (+ start offset)))
(value (read-word bytes (+ start offset word-size))))
(if (= type DT_NULL) ;finished?
(reverse result)
(loop (+ offset (* 2 word-size))
(alist-cons type value result)))))))
(define (vma->offset elf vma)
"Convert VMA, a virtual memory address, to an offset within ELF.
Do that by looking at the loadable program segment (PT_LOAD) of ELF that
contains VMA and by taking into account that segment's virtual address and
offset."
;; See 'offset_from_vma' in Binutils.
(define loads
(filter (lambda (segment)
(= (elf-segment-type segment) PT_LOAD))
(elf-segments elf)))
(let ((load (find (lambda (segment)
(let ((vaddr (elf-segment-vaddr segment)))
(and (>= vma vaddr)
(< vma (+ (elf-segment-memsz segment)
vaddr)))))
loads)))
(+ (- vma (elf-segment-vaddr load))
(elf-segment-offset load))))
(define (dynamic-entries elf segment)
"Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment
of ELF, as a list of type/value pairs. The type is a DT_ value, and the value
may be a string or an integer depending on the entry type (for instance, the
value of DT_NEEDED entries is a string.)"
(define entries
(raw-dynamic-entries elf segment))
(define string-table-offset
(any (match-lambda
((type . value)
(and (= type DT_STRTAB) value))
(_ #f))
entries))
(define (interpret-dynamic-entry type value)
(cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
(if string-table-offset
(pointer->string
(bytevector->pointer (elf-bytes elf)
(vma->offset
elf
(+ string-table-offset value))))
value))
(else
value)))
(map (match-lambda
((type . value)
(cons type (interpret-dynamic-entry type value))))
entries))
;;;
;;; High-level interface.
;;;
(define-record-type <elf-dynamic-info>
(%elf-dynamic-info soname needed rpath runpath)
elf-dynamic-info?
(soname elf-dynamic-info-soname)
(needed elf-dynamic-info-needed)
(rpath elf-dynamic-info-rpath)
(runpath elf-dynamic-info-runpath))
(define search-path->list
(let ((not-colon (char-set-complement (char-set #\:))))
(lambda (str)
"Split STR on ':' characters."
(string-tokenize str not-colon))))
(define (elf-dynamic-info elf)
"Return dynamic-link information for ELF as an <elf-dynamic-info> object, or
#f if ELF lacks dynamic-link information."
(match (dynamic-link-segment elf)
(#f #f)
((? elf-segment? dynamic)
(let ((entries (dynamic-entries elf dynamic)))
(%elf-dynamic-info (assv-ref entries DT_SONAME)
(filter-map (match-lambda
((type . value)
(and (= type DT_NEEDED) value))
(_ #f))
entries)
(or (and=> (assv-ref entries DT_RPATH)
search-path->list)
'())
(or (and=> (assv-ref entries DT_RUNPATH)
search-path->list)
'()))))))
(define %libc-libraries
;; List of libraries as of glibc 2.21 (there are more but those are
;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.)
'("libanl.so"
"libcrypt.so"
"libc.so"
"libdl.so"
"libm.so"
"libnsl.so" ;NEEDED by nscd
"libpthread.so"
"libresolv.so"
"librt.so"
"libutil.so"))
(define (libc-library? lib)
"Return #t if LIB is one of the libraries shipped with the GNU C Library."
(find (lambda (libc-lib)
(string-prefix? libc-lib lib))
%libc-libraries))
(define (expand-variable str variable value)
"Replace occurrences of '$VARIABLE' or '${VARIABLE}' in STR with VALUE."
(define variables
(list (string-append "$" variable)
(string-append "${" variable "}")))
(let loop ((thing variables)
(str str))
(match thing
(()
str)
((head tail ...)
(let ((index (string-contains str head))
(len (string-length head)))
(loop (if index variables tail)
(if index
(string-replace str value
index (+ index len))
str)))))))
(define (expand-origin str directory)
"Replace occurrences of '$ORIGIN' in STR with DIRECTORY."
(expand-variable str "ORIGIN" directory))
(define* (validate-needed-in-runpath file
#:key (always-found? libc-library?))
"Return #t if all the libraries listed as FILE's 'DT_NEEDED' entries are
present in its RUNPATH, or if FILE lacks dynamic-link information. Return #f
otherwise. Libraries whose name matches ALWAYS-FOUND? are considered to be
always available."
(guard (c ((invalid-segment-size? c)
(let ((segment (invalid-segment-size-segment c)))
(format (current-error-port)
"~a: error: offset + size of segment ~a (type ~a) \
exceeds total size~%"
file
(elf-segment-index segment)
(elf-segment-type segment))
#f)))
(let* ((elf (call-with-input-file file
(compose parse-elf get-bytevector-all)))
(expand (cute expand-origin <> (dirname file)))
(dyninfo (elf-dynamic-info elf)))
(when dyninfo
;; XXX: In theory we should also expand $PLATFORM and $LIB, but these
;; appear to be really unused.
(let* ((expanded (map expand (elf-dynamic-info-runpath dyninfo)))
(runpath (filter store-file-name? expanded))
(bogus (remove store-file-name? expanded))
(needed (remove always-found?
(elf-dynamic-info-needed dyninfo)))
(not-found (remove (cut search-path runpath <>)
needed)))
(unless (null? bogus)
(format (current-error-port)
"~a: warning: RUNPATH contains bogus entries: ~s~%"
file bogus))
(for-each (lambda (lib)
(format (current-error-port)
"~a: error: depends on '~a', which cannot \
be found in RUNPATH ~s~%"
file lib runpath))
not-found)
;; (when (null? not-found)
;; (format (current-error-port) "~a is OK~%" file))
(null? not-found))))))
;;; gremlin.scm ends here