wingo pushed a commit to branch wip-potluck
in repository guix.
commit 3d3b569d638f153a8f45526e1c3334f1fd966f3d
Author: Andy Wingo <wi...@igalia.com>
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 <wi...@pobox.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 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))))))
