guix/missing-propagated-inputs.scm

;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;;
;;; This module 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.
;;;
;;; This module 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 this module.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix missing-propagated-inputs)
  #:export (fold-missing-propagated-inputs
            print-missing-propagated-inputs))

(use-modules (guix build utils)
             (guix derivations)
             (guix packages)
             (guix store)
             (gnu packages)
             (srfi srfi-1)
             (srfi srfi-13)
             (srfi srfi-26)
             (ice-9 ftw)
             (ice-9 match)
             (ice-9 regex)
             (ice-9 rdelim))


;;; Helpers

(define (map* n proc . lists)
  "Like `map', but PROC must return a list of N elements; the elements are
gathered in separate lists and a list of those lists returned.  If any of LISTS
is empty, a list of N empty lists is returned.

 (10 20 30) -> (^x (list (double x) (halve x))) -> ((20 40 60) (5 10 15))"
  (let ((results (apply map proc lists)))
    (if (null? results)
        (make-list n '())
        (apply map list results))))

(define (read-line*)
  "Like read-line, but merges lines separated by a backslash."
  (let ((line (read-line)))
    (if (eof-object? line)
        line
        (let lp ((line line))
          (let ((match (string-match "(.*)\\\\$" line)))
            (if (not match)
                line
                (let* ((line (match:substring match 1))
                       (next-line (read-line)))
                  ;; Ignore backslash at end of last line.
                  (if (eof-object? next-line)
                      line
                      (lp (string-append line next-line))))))))))

(define (fold-lines init proc)
  "Fold over input lines, merging backslash-separated lines."
  (let lp ((value init)
           (line (read-line*)))
    (if (eof-object? line)
        value
        (lp (proc line value)
            (read-line)))))

(define (package-output-paths store package)
  "Returns an alist of outputs/paths of PACKAGE."
  (map (lambda (entry)
         (cons (car entry)
               (derivation-output-path (cdr entry))))
       (derivation-outputs
        (package-derivation store package))))

(define (list-libs-in-directory dir)
  "Returns a list of the names of the libraries found in DIR.  I.e. for every
file \"libfoo.so[.xyz]\" under DIR, the list contains \"foo\"."
  (let* ((libs (scandir dir (cut string-match "^lib.*\\.so[.0-9]*" <>)))
         (libnames
          (map (lambda (lib)
                 (let ((match (string-match "^lib(.*)\\.so[.0-9]*" lib)))
                   (match:substring match 1)))
               libs)))
    libnames))


;;; Standard libc libraries

(define (list-standard-libc-libraries)
  "Returns a list of library names that are components of libc."
  (with-store store
    (let* ((glibc (car (find-best-packages-by-name "glibc" #f)))
           (glibc-dir (assoc-ref (package-output-paths store glibc) "out"))
           (lib-dir (string-append glibc-dir "/lib")))
      (list-libs-in-directory lib-dir))))

(define standard-libc-libraries (make-parameter '()))


;;; .pc parsing

(define (parse-requires string)
  "Parses the contents of a pkg-config Requires line."
  (let lp ((requires '())
           (rest string))
    (cond
     ;; Some files use commas to separate Requires elements.
     ((string-match "[[:space:]]*([^[:space:],]+),?(.*)" rest)
      => (lambda (match)
           (let* ((part (match:substring match 1))
                  (rest (match:substring match 2))
                  (rest-match
                   (string-match
                    "[[:space:]]*(=|<=|>=|<|>)[[:space:]]*[^[:space:]]+(.*)"
                    rest)))
             (if rest-match
                 (lp (cons part requires)
                     (match:substring rest-match 2))
                 (lp (cons part requires)
                     rest)))))
     (else
      requires))))

(define (parse-libs string)
  "Parses the contents of a pkg-config Libs line."
  (let lp ((libs '())
           (rest string))
    (cond
     ((string-match "[[:space:]]*([^[:space:]]+)(.*)" rest)
      => (lambda (match)
           (let ((part (match:substring match 1))
                 (rest (match:substring match 2)))
             (lp (cons part libs)
                 rest))))
     (else
      libs))))

(define (parse-pc-file)
  "Parses a pkg-config file from the current input port, returning a list of two
lists: the Requires and Libs elements."
  (define (apply-variables variables line)
    (cond
     ((string-match "(.*)\\$\\{([a-zA-Z0-9_]+)\\}(.*)" line)
      => (lambda (match)
           (let ((pre (match:substring match 1))
                 (var (match:substring match 2))
                 (post (match:substring match 3)))
             (apply-variables
              variables
              (string-append pre (or (assoc-ref variables var)
                                     ;; Prevent infinite recursion.
                                     (string-append "%{" var "}"))
                             post)))))
     (else line)))
  (define (handle-hash-comment line)
    (cond
     ((string-match "(.*) #.*" line)
      => (lambda (match)
           (match:substring match 1)))
     (else line)))
  (match-let
      (((variables requires libs)
        (fold-lines
         (list '() '() '())
         (lambda (line state)
           (match-let (((variables requires libs) state))
             (let ((line (handle-hash-comment
                          (apply-variables variables line))))
               (cond
                ((string-match "^([a-zA-Z0-9_]+)=(.*)" line)
                 => (lambda (match)
                      (let ((var (match:substring match 1))
                            (val (match:substring match 2)))
                        (list (alist-cons var val variables) requires libs))))
                ((string-match "^Requires(\\.private)?:(.*)" line)
                 => (lambda (match)
                      (let ((requires* (parse-requires
                                        (match:substring match 2))))
                        (list variables (append requires requires*) libs))))
                ((string-match "^Libs:(.*)" line)
                 => (lambda (match)
                      (let ((libs* (parse-libs (match:substring match 1))))
                        (list variables requires (append libs libs*)))))
                (else
                 (list variables requires libs)))))))))
    (list requires libs)))

(define (requires-and-libs-for-path path)
  "Parses all *.pc files under PATH and returns a list of two lists: all
Requires and Libs elements found."
  (let lp ((files (find-files path "\\.pc$"))
           (requires '())
           (libs '()))
    (if (null? files)
        (list requires libs)
        (match-let (((requires* libs*)
                     (with-input-from-file (car files) parse-pc-file)))
          (lp (cdr files)
              (append requires requires*)
              (append libs libs*))))))

(define (missing-packages input-dirs requires)
  "Filters pkg-config package names REQUIRES to those not satisfied by .pc files
in the INPUT-DIRS directories, which are Guix store items."
  ;; XXX Only consider .pc files in $prefix/lib/pkgconfig, or all?
  (let* ((pc-dirs (filter file-exists?
                          (map (lambda (dir)
                                 (string-append dir "/lib/pkgconfig"))
                               input-dirs)))
         (pc-files (apply append (map (cut find-files <> "\\.pc$") pc-dirs)))
         (basenames (map basename pc-files))
         (pkgnames (map (lambda (name)
                          (let ((match (string-match "(.*)\\.pc$" name)))
                            (match:substring match 1)))
                        basenames)))
    (delete-duplicates
     (lset-difference string=? requires pkgnames))))

(define (missing-libraries input-dirs libs)
  "Returns a list of library names which the linker argument list LIBS wants to
link against but would not find given -L flags in the argument list and lib/
subdirectories of INPUT-DIRS."
  (let* ((link-flags (filter (cut string-prefix? "-l" <>) libs))
         (link-libs (map (lambda (flag)
                           (let ((match (string-match "-l(.*)" flag)))
                             (match:substring match 1)))
                         link-flags))
         (lib-dir-flags (filter (cut string-prefix? "-L" <>) libs))
         (lib-dirs (filter
                    (cut access? <> (logior R_OK X_OK))
                    (append
                     (map (lambda (flag)
                            (let ((match (string-match "-L(.*)" flag)))
                              (match:substring match 1)))
                          lib-dir-flags)
                     (map (cut string-append <> "/lib") input-dirs))))
         (found-libs (append
                      (apply append (map list-libs-in-directory lib-dirs))
                      (standard-libc-libraries))))
    (delete-duplicates
     (lset-difference string=? link-libs found-libs))))


;;; Package path iteration

(define (fold-package-outputs store proc init)
  "Folds over packages/outputs, calling PROC with the package, output name,
output path, and the fold accumulation value."
  (fold-packages
   (lambda (package acc)
     (let ((outputs (package-output-paths store package)))
       (fold (lambda (output acc)
               (let ((name (car output))
                     (path (cdr output)))
                 (if (file-exists? path)
                     (proc package name path acc)
                     acc)))
             acc
             outputs)))
   init))


;;; Main

(define (fold-missing-propagated-inputs proc init)
  "Folds over packages that seem to have missing propagated inputs, calling PROC
with the package, the name of its output for which inputs seem to be missing,
the list of missing pkg-config packages, the list of missing dynamic libraries,
and the fold accumulation value.  The detection is heuristic; false negatives
and positives are both likely.  Detection works via packages's outputs in the
store, so missing outputs will limit the detection."
  (parameterize ((standard-libc-libraries (list-standard-libc-libraries)))
    (with-store store
      (fold-package-outputs
       store
       (lambda (package output path acc)
         (let* ((inputs (package-propagated-inputs package))
                (input-dirs
                 (map
                  (match-lambda
                    ((name package out)
                     (assoc-ref (package-output-paths store package) out))
                    ((name package)
                     (assoc-ref (package-output-paths store package) "out")))
                  inputs))
                (input-dirs (cons path input-dirs)))
           (when (every file-exists? input-dirs)
             (match-let (((requires libs) (requires-and-libs-for-path path)))
               (let ((missing-pc-pkgs (missing-packages input-dirs requires))
                     (missing-libs (missing-libraries input-dirs libs)))
                 (unless (and (null? missing-pc-pkgs) (null? missing-libs))
                   (proc package output missing-pc-pkgs missing-libs acc)))))))
       init))))

(define (print-missing-propagated-inputs)
  (fold-missing-propagated-inputs
   (lambda (pkg out pc-pkgs libs acc)
     (format #t "~a~a: pkg-config: ~s libs: ~s\n"
             (package-name pkg)
             (if (string=? "out" out) "" (string-append ":" out))
             pc-pkgs
             libs))
   #f))