04/10: guix: Add "potluck" command.

[Andy Wingo]

wingo pushed a commit to branch wip-potluck
in repository guix.

commit 3d3b569d638f153a8f45526e1c3334f1fd966f3d
Author: Andy Wingo <address@hidden>
Date:   Mon Apr 24 14:00:07 2017 +0200

    guix: Add "potluck" command.
    
    * guix/scripts/potluck.scm: New file.
    * Makefile.am: Add new file.
---
 Makefile.am              |   1 +
 guix/scripts/potluck.scm | 310 +++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 311 insertions(+)

diff --git a/Makefile.am b/Makefile.am
index 64a7a92..295d7b3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -167,6 +167,7 @@ MODULES =                                   \
   guix/scripts/graph.scm                       \
   guix/scripts/container.scm                   \
   guix/scripts/container/exec.scm              \
+  guix/scripts/potluck.scm                     \
   guix.scm                                     \
   $(GNU_SYSTEM_MODULES)
 
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
new file mode 100644
index 0000000..f9cd40b
--- /dev/null
+++ b/guix/scripts/potluck.scm
@@ -0,0 +1,310 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Andy Wingo <address@hidden>
+;;;
+;;; 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 potluck)
+  #:use-module (guix config)
+  #:use-module (guix base32)
+  #:use-module ((guix build-system) #:select (build-system-description))
+  #:use-module ((guix licenses) #:select (license-uri))
+  #:use-module (guix git)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix potluck build-systems)
+  #:use-module (guix potluck licenses)
+  #:use-module (guix potluck packages)
+  #:use-module (guix scripts)
+  #:use-module (guix scripts hash)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (guix-potluck))
+
+
+;;;
+;;; guix potluck init
+;;;
+
+(define* (init-potluck remote-git-url #:key
+                       (build-system 'gnu) (autoreconf? #f)
+                       (license 'gplv3+))
+  (let* ((cwd (getcwd))
+         (dot-git (in-vicinity cwd ".git"))
+         (potluck-dir (in-vicinity cwd "potluck"))
+         (package-name (basename cwd)))
+    (unless (and (file-exists? dot-git)
+                 (file-is-directory? dot-git))
+      (leave (_ "init: must be run from the root of a git checkout~%")))
+    (when (file-exists? potluck-dir)
+      (leave (_ "init: ~a already exists~%") potluck-dir))
+    (let* ((user-name (git-config "user.name"))
+           (pkg-name (basename cwd))
+           (pkg-commit (git-rev-parse "HEAD"))
+           (pkg-version
+            (catch #t
+              (lambda () (git-describe pkg-commit))
+              (lambda _
+                (format (current-error-port)
+                        "guix potluck init: git describe failed\n")
+                (format (current-error-port)
+                        "Add a tag so that git can compute a version.\n")
+                (exit 1))))
+           ;; FIXME: Race condition if HEAD changes between git-rev-parse and
+           ;; here.
+           (pkg-sha256 (guix-hash-git-checkout cwd)))
+      (format #t (_ "Creating potluck/~%"))
+      (mkdir potluck-dir)
+      (format #t (_ "Creating potluck/README.md~%"))
+      (call-with-output-file (in-vicinity potluck-dir "README.md")
+        (lambda (port)
+          (format port
+                  "\
+This directory defines potluck packages.  Each file in this directory should
+define one package.  See https://potluck.guixsd.org/ for more information.
+")))
+      (format #t (_ "Creating potluck/~a.scm~%") package-name)
+      (call-with-output-file (in-vicinity potluck-dir
+                                          (string-append package-name ".scm"))
+        (lambda (port)
+          
+          (define-syntax-rule (dsp exp) (display exp port))
+          (dsp ";;; guix potluck package\n")
+          (dsp ";;; Copyright (C) 2017 ")
+          (dsp user-name)
+          (dsp "\n")
+          (dsp "
+;;; This file 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.  No warranty.  See
+;;; https://www.gnu.org/licenses/gpl.html for a copy of the GPLv3.
+
+")
+          (pretty-print-potluck-package
+           port
+           (potluck-package
+            (name pkg-name)
+            (version pkg-version)
+            (source
+             (potluck-source
+              (git-uri remote-git-url)
+              (git-commit pkg-commit)
+              (sha256 (bytevector->nix-base32-string pkg-sha256))))
+            (build-system build-system)
+            (inputs '())
+            (native-inputs
+             (if autoreconf?
+                 '("autoconf" "automake" "libtool" "pkg-config")
+                 '()))
+            (arguments
+             (if autoreconf?
+                 '(#:phases (modify-phases %standard-phases
+                              (add-before 'configure 'autoconf
+                                (lambda _
+                                  (zero?
+                                   (system* "autoreconf" "-vfi"))))))
+                 '()))
+            (home-page remote-git-url)
+            (synopsis "Declarative synopsis here")
+            (description
+             (string-append (string-titlecase pkg-name)
+                            " is a ..."))
+            (license license)))))
+      (format #t (_ "
+Done.  Now open potluck/~a.scm in your editor, fill out its \"synopsis\" and
+\"description\" fields, add dependencies to the 'inputs' field, and try to
+build with
+
+  guix build --file=potluck/~a.scm
+
+When you get that working, commit your results to git via:
+
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.'
+") pkg-name pkg-name))))
+
+
+;;;
+;;; Options.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix potluck [OPTION ...] ACTION [ARG ...]
+Create \"potluck\" packages, register them with a central service, and arrange
+to serve those packages as a Guix channel. Some ACTIONS require additional
+ARGS.\n"))
+  (newline)
+  (display (_ "The valid values for ACTION are:\n"))
+  (newline)
+  (display (_ "\
+   init             create potluck recipe for current working directory\n"))
+
+  (newline)
+  (display (_ "The available OPTION flags are:\n"))
+  (display (_ "
+      --build-system=SYS for 'init', specify the build system.  Use
+                         --build-system=help for all available options."))
+  (display (_ "
+      --autotools        for 'init', like --build-system=gnu but additionally
+                         indicating that the package needs autoreconf before
+                         running ./configure"))
+  (display (_ "
+      --license=LICENSE  for 'init', specify the license of the package.  Use
+                         --license=help for all available options."))
+  (display (_ "
+      --verbosity=LEVEL  use the given verbosity LEVEL"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix potluck")))
+        (option '("build-system") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-system arg result)))
+        (option '("autotools") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'autoreconf? #t
+                              (alist-cons 'build-system "gnu" result))))
+        (option '("license") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'license arg result)))
+        (option '("verbosity") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'verbosity (string->number arg) result)))))
+
+(define %default-options
+  ;; Alist of default option values.
+  `((verbosity . 0)))
+
+(define (parse-url url-str)
+  (unless (string->uri url-str)
+    (leave (_ "invalid url: ~a~%") url-str))
+  url-str)
+
+(define (parse-build-system sys-str)
+  (unless sys-str
+    (leave (_ "\
+init: missing --build-system; try --build-system=help for options~%")))
+  (let ((sys (string->symbol (string-downcase sys-str))))
+    (when (eq? sys 'help)
+      (format #t "guix potluck: Available build systems:~%")
+      (for-each
+       (lambda (name)
+         (let ((sys (build-system-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (build-system-description sys))))
+       (all-potluck-build-system-names))
+      (format #t "
+Additionally, --autotools is like --build-system=gnu, but also indicating
+that the package needs autoreconf before running ./configure.~%")
+      (exit 0))
+    (unless (build-system-by-name sys)
+      (leave (_ "invalid build system: ~a; try --build-system=help~%") sys))
+    sys))
+
+(define (parse-license license-str)
+  (unless license-str
+    (leave (_ "init: missing --license; try --license=help for options~%")))
+  (let ((license (string->symbol (string-downcase license-str))))
+    (when (eq? license 'help)
+      (format #t "guix potluck: Available licenses:~%")
+      (for-each
+       (lambda (name)
+         (let ((license (license-by-name name)))
+           (format #t "  ~a ~25t~a~%" name (license-uri license))))
+       (all-potluck-license-names))
+      (format #t "
+If your package's license is not in this list, add it to Guix first.~%")
+      (exit 0))
+    (unless (license-by-name license)
+      (leave (_ "invalid license: ~a; try --license=help~%") license))
+    license))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-potluck . args)
+  (define (parse-sub-command arg result)
+    (if (assoc-ref result 'action)
+        (alist-cons 'argument arg result)
+        (alist-cons 'action (string->symbol arg) result)))
+
+  (define (match-pair car)
+    ;; Return a procedure that matches a pair with CAR.
+    (match-lambda
+      ((head . tail)
+       (and (eq? car head) tail))
+      (_ #f)))
+
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:argument-handler
+                                         parse-sub-command))
+           (action   (assoc-ref opts 'action))
+           (args     (reverse (filter-map (match-pair 'argument) opts))))
+      (define (see-help)
+        (format (current-error-port)
+                (_ "Try 'guix potluck --help' for more information.~%")))
+      (define (wrong-number-of-args usage)
+        (format (current-error-port)
+                (_ "guix potluck ~a: wrong number of arguments~%")
+                action)
+        (display usage (current-error-port))
+        (newline (current-error-port))
+        (see-help)
+        (exit 1))
+      (match action
+        (#f
+         (format (current-error-port)
+                 (_ "guix potluck: missing command name~%"))
+         (see-help)
+         (exit 1))
+        ('init
+         (match args
+           ((remote-git-url)
+            (init-potluck (parse-url remote-git-url)
+                          #:build-system (parse-build-system
+                                          (assoc-ref opts 'build-system))
+                          #:autoreconf? (assoc-ref opts 'autoreconf?)
+                          #:license (parse-license
+                                     (assoc-ref opts 'license))))
+           (args
+            (wrong-number-of-args
+             (_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+        (action
+         (leave (_ "~a: unknown action~%") action))))))