Merge branch 'master' into core-updates

6 files changed, 246 insertions, 39 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 5e4647de79..09401e923c 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -33,7 +33,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
-  #:autoload   (gnu packages) (find-best-packages-by-name)
+  #:autoload   (gnu packages) (specification->package)
   #:autoload   (guix download) (download-to-store)
   #:export (%standard-build-options
             set-build-options-from-command-line
@@ -41,27 +41,6 @@
 
             guix-build))
 
-(define (specification->package spec)
-  "Return a package matching SPEC.  SPEC may be a package name, or a package
-name followed by a hyphen and a version number.  If the version number is not
-present, return the preferred newest version."
-  (let-values (((name version)
-                (package-name->name+version spec)))
-    (match (find-best-packages-by-name name version)
-      ((p)                                      ; one match
-       p)
-      ((p x ...)                                ; several matches
-       (warning (_ "ambiguous package specification `~a'~%") spec)
-       (warning (_ "choosing ~a from ~a~%")
-                (package-full-name p)
-                (location->string (package-location p)))
-       p)
-      (_                                        ; no matches
-       (if version
-           (leave (_ "~A: package not found for version ~a~%")
-                  name version)
-           (leave (_ "~A: unknown package~%") name))))))
-
 (define (register-root store paths root)
   "Register ROOT as an indirect GC root for all of PATHS."
   (let* ((root (string-append (canonicalize-path (dirname root))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
new file mode 100644
index 0000000000..83dde9a1a1
--- /dev/null
+++ b/guix/scripts/lint.scm
@@ -0,0 +1,213 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
+;;;
+;;; 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 scripts lint)
+  #:use-module (guix base32)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (gnu packages)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-37)
+  #:export (guix-lint
+            check-inputs-should-be-native
+            check-patches
+            check-synopsis-style))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  ;; Alist of default option values.
+  '())
+
+(define (show-help)
+  (display (_ "Usage: guix lint [OPTION]... [PACKAGE]...
+Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n"))
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -l, --list-checkers    display the list of available lint checkers"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specification of the command-line options.
+  ;; TODO: add some options:
+  ;; * --checkers=checker1,checker2...: only run the specified checkers
+  ;; * --certainty=[low,medium,high]: only run checkers that have at least this
+  ;;                                  'certainty'.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\l "list-checkers") #f #f
+                (lambda args
+                   (list-checkers-and-exit)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix lint")))))
+
+
+;;;
+;;; Helpers
+;;;
+(define* (emit-warning package message #:optional field)
+  ;; Emit a warning about PACKAGE, printing the location of FIELD if it is
+  ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
+  ;; provided MESSAGE.
+  (let ((loc (or (package-field-location package field)
+                 (package-location package))))
+    (format (guix-warning-port) (_ "~a: ~a: ~a~%")
+            (location->string loc)
+            (package-full-name package)
+            message)))
+
+
+;;;
+;;; Checkers
+;;;
+(define-record-type* <lint-checker>
+  lint-checker make-lint-checker
+  lint-checker?
+  ;; TODO: add a 'certainty' field that shows how confident we are in the
+  ;; checker. Then allow users to only run checkers that have a certain
+  ;; 'certainty' level.
+  (name        lint-checker-name)
+  (description lint-checker-description)
+  (check       lint-checker-check))
+
+(define (list-checkers-and-exit)
+  ;; Print information about all available checkers and exit.
+  (format #t (_ "Available checkers:~%"))
+  (for-each (lambda (checker)
+              (format #t "- ~a: ~a~%"
+                      (lint-checker-name checker)
+                      (lint-checker-description checker)))
+            %checkers)
+  (exit 0))
+
+(define (check-inputs-should-be-native package)
+  ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
+  ;; native inputs.
+  (let ((inputs (package-inputs package)))
+    (match inputs
+      (((labels packages . _) ...)
+       (when (member "pkg-config"
+                     (map package-name (filter package? packages)))
+        (emit-warning package
+                      "pkg-config should probably be a native input"
+                      'inputs))))))
+
+
+(define (check-synopsis-style package)
+  ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
+  (define (check-final-period synopsis)
+    ;; Synopsis should not end with a period, except for some special cases.
+    (if (and (string=? (string-take-right synopsis 1) ".")
+             (not (string=? (string-take-right synopsis 4) "etc.")))
+        (emit-warning package
+                      "no period allowed at the end of the synopsis"
+                      'synopsis)))
+
+  (define (check-start-article synopsis)
+   (if (or (string=? (string-take synopsis 2) "A ")
+           (string=? (string-take synopsis 3) "An "))
+       (emit-warning package
+                     "no article allowed at the beginning of the synopsis"
+                     'synopsis)))
+
+ (let ((synopsis (package-synopsis package)))
+   (if (string? synopsis)
+       (begin
+        (check-final-period synopsis)
+        (check-start-article synopsis)))))
+
+(define (check-patches package)
+  ;; Emit a warning if the patches requires by PACKAGE are badly named.
+  (let ((patches   (and=> (package-source package) origin-patches))
+        (name      (package-name package))
+        (full-name (package-full-name package)))
+    (if (and patches
+             (any (lambda (patch)
+                    (let ((filename (basename patch)))
+                      (not (or (eq? (string-contains filename name) 0)
+                               (eq? (string-contains filename full-name) 0)))))
+                  patches))
+        (emit-warning package
+          "file names of patches should start with the package name"
+          'patches))))
+
+(define %checkers
+  (list
+   (lint-checker
+     (name        "inputs-should-be-native")
+     (description "Identify inputs that should be native inputs")
+     (check       check-inputs-should-be-native))
+   (lint-checker
+     (name        "patch-filenames")
+     (description "Validate filenames of patches")
+     (check       check-patches))
+   (lint-checker
+     (name        "synopsis")
+     (description "Validate package synopsis")
+     (check       check-synopsis-style))))
+
+(define (run-checkers package)
+  ;; Run all the checkers on PACKAGE.
+  (for-each (lambda (checker)
+              ((lint-checker-check checker) package))
+            %checkers))
+
+
+;;;
+;;; Entry Point
+;;;
+
+(define (guix-lint . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (args-fold* args %options
+                (lambda (opt name arg result)
+                  (leave (_ "~A: unrecognized option~%") name))
+                (lambda (arg result)
+                  (alist-cons 'argument arg result))
+                %default-options))
+
+  (let* ((opts (parse-options))
+         (args (filter-map (match-lambda
+                            (('argument . value)
+                             value)
+                            (_ #f))
+                           (reverse opts))))
+
+
+   (if (null? args)
+        (fold-packages (lambda (p r) (run-checkers p)) '())
+        (for-each
+          (lambda (spec)
+            (run-checkers spec))
+          (map specification->package args)))))
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 18af511ed8..b3b502425c 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -181,7 +181,8 @@ determined."
                       #:key (error-port (current-error-port)) (quote? #t))
   "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been
 set up.  When QUOTE? is true, perform shell-quotation of all the elements of
-COMMAND."
+COMMAND.  Return either a pipe opened with MODE, or #f if the lsh client could
+not be started."
   (define (shell-quote str)
     ;; Sort-of shell-quote STR so it can be passed as an argument to the
     ;; shell.
@@ -315,8 +316,17 @@ hook."
        (let ((root-directory (string-append %state-directory
                                             "/gcroots/tmp")))
          (false-if-exception (mkdir root-directory))
-         (symlink ,file
-                  (string-append root-directory "/" ,%gc-root-file)))))
+         (catch 'system-error
+           (lambda ()
+             (symlink ,file
+                      (string-append root-directory "/" ,%gc-root-file)))
+           (lambda args
+             ;; If FILE already exists, we can assume that either it's a stale
+             ;; reference (which is fine), or another process is already
+             ;; building the derivation represented by FILE (which is fine
+             ;; too.)  Thus, do nothing in that case.
+             (unless (= EEXIST (system-error-errno args))
+               (apply throw args)))))))
 
   (let ((pipe (remote-pipe machine OPEN_READ
                            `("guile" "-c" ,(object->string script)))))
@@ -535,7 +545,7 @@ allowed on MACHINE."
          (line (read-line pipe)))
     (close-pipe pipe)
     (if (eof-object? line)
-        1.
+        +inf.0    ;MACHINE does not respond, so assume it is infinitely loaded
         (match (string-tokenize line)
           ((one five fifteen . _)
            (let* ((raw        (string->number five))
@@ -546,7 +556,7 @@ allowed on MACHINE."
                      (build-machine-name machine) raw normalized)
              normalized))
           (_
-           1.)))))
+           +inf.0)))))           ;something's fishy about MACHINE, so avoid it
 
 (define (machine-less-loaded? m1 m2)
   "Return #t if the load on M1 is lower than that on M2."
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 6ecf37e1a6..95c0130c95 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -305,10 +305,12 @@ current settings and report only settings not already effective."
         ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
         ;; the former traverses the module tree only once and then allows for
         ;; efficient access via a vhash.
-        (match (or (find-best-packages-by-name name version)
-                   (find-best-packages-by-name name #f))
+        (match (find-best-packages-by-name name version)
           ((p _ ...) p)
-          (_ #f)))))
+          (_
+           (match (find-best-packages-by-name name #f)
+             ((p _ ...) p)
+             (_ #f)))))))
 
     (define search-path-definition
       (match-lambda
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index c2bf536e86..5dafb84f91 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -38,15 +38,21 @@
   "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
   )
 
-(define (unpack store tarball)
+(define* (unpack store tarball #:key verbose?)
   "Return a derivation that unpacks TARBALL into STORE and compiles Scheme
 files."
   (define builder
-    '(begin
+    `(begin
        (use-modules (guix build pull))
 
        (build-guix (assoc-ref %outputs "out")
                    (assoc-ref %build-inputs "tarball")
+
+                   ;; XXX: This is not perfect, enabling VERBOSE? means
+                   ;; building a different derivation.
+                   #:debug-port (if ',verbose?
+                                    (current-error-port)
+                                    (%make-void-port "w"))
                    #:tar (assoc-ref %build-inputs "tar")
                    #:gzip (assoc-ref %build-inputs "gzip")
                    #:gcrypt (assoc-ref %build-inputs "gcrypt"))))
@@ -129,13 +135,10 @@ Download and deploy the latest version of Guix.\n"))
                         (package-derivation store
                                             (if (assoc-ref opts 'bootstrap?)
                                                 %bootstrap-guile
-                                                (canonical-package guile-2.0))))
-                       (current-build-output-port
-                        (if (assoc-ref opts 'verbose?)
-                            (current-error-port)
-                            (%make-void-port "w"))))
+                                                (canonical-package guile-2.0)))))
           (let* ((config-dir (config-directory))
-                 (source     (unpack store tarball))
+                 (source     (unpack store tarball
+                                     #:verbose? (assoc-ref opts 'verbose?)))
                  (source-dir (derivation->output-path source)))
             (if (show-what-to-build store (list source))
                 (if (build-derivations store (list source))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 4f1869af38..7c0dde9030 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -28,7 +28,7 @@
   #:use-module (guix profiles)
   #:use-module (guix scripts build)
   #:use-module (guix build utils)
-  #:use-module (guix build install)
+  #:use-module (gnu build install)
   #:use-module (gnu system)
   #:use-module (gnu system vm)
   #:use-module (gnu system grub)