wingo pushed a commit to branch wip-potluck
in repository guix.
commit ce2d563e7b36f0c2585b9c319fb7d41cb5139298
Author: Andy Wingo <wi...@igalia.com>
Date: Mon Apr 24 13:54:51 2017 +0200
potluck: Add host-channel subcommand.
* guix/potluck/host.scm: New file.
* Makefile.am (MODULES): Add new file.
* guix/scripts/potluck.scm: Add host-channel command.
---
Makefile.am | 1 +
guix/potluck/host.scm | 461 +++++++++++++++++++++++++++++++++++++++++++++++
guix/scripts/potluck.scm | 137 ++++++++++++--
3 files changed, 587 insertions(+), 12 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 628283b..94fa05d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -129,6 +129,7 @@ MODULES = \
guix/git.scm \
guix/potluck/build-systems.scm \
guix/potluck/environment.scm \
+ guix/potluck/host.scm \
guix/potluck/licenses.scm \
guix/potluck/packages.scm \
guix/import/utils.scm \
diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
new file mode 100644
index 0000000..4a10325
--- /dev/null
+++ b/guix/potluck/host.scm
@@ -0,0 +1,461 @@
+;;; 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 potluck host)
+ #:use-module (guix config)
+ #:use-module (guix base32)
+ #:use-module (guix ui)
+ #:use-module ((guix build utils)
+ #:select (mkdir-p
+ delete-file-recursively
+ with-directory-excursion))
+ #:use-module (guix git)
+ #:use-module (guix utils)
+ #:use-module (guix potluck packages)
+ #:use-module (guix potluck build-systems)
+ #:use-module (guix potluck licenses)
+ #:use-module (guix scripts)
+ #:use-module (guix scripts hash)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 q)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 threads)
+ #:use-module (json)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-37)
+ #:use-module (sxml simple)
+ #:use-module (web uri)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web server)
+ #:export (host-potluck))
+
+
+;;;
+;;; lossy log
+;;;
+
+(define-record-type <log>
+ (%make-log buffer read-pos write-pos mutex)
+ log?
+ (buffer log-buffer) ; vector
+ (read-pos log-read-pos set-log-read-pos!) ; natural
+ (write-pos log-write-pos set-log-write-pos!) ; natural
+ (mutex log-mutex))
+
+(set-record-type-printer!
+ <log>
+ (lambda (log port)
+ (format port "<log ~a-~a ~a>" (log-read-pos log) (log-write-pos log)
+ (object-address log))))
+
+(define* (make-log #:key (capacity 100))
+ (%make-log (make-vector capacity) 0 0 (make-mutex)))
+
+(define (log-capacity log)
+ (vector-length (log-buffer log)))
+
+(define (log-pos->idx log pos)
+ (modulo pos (log-capacity log)))
+
+(define (add-log-entry log obj)
+ (with-mutex (log-mutex log)
+ (let ((pos (log-write-pos log))
+ (entry (cons (gettimeofday) obj)))
+ (vector-set! (log-buffer log) (log-pos->idx log pos) entry)
+ (set-log-write-pos! log (1+ pos))
+ (set-log-read-pos! log (max (log-read-pos log)
+ (1+ (- pos (log-capacity log))))))))
+
+(define (sxml-log log . args)
+ (add-log-entry log (cons 'span args)))
+
+(define (format-log log fmt . args)
+ (add-log-entry log (apply format #f fmt args)))
+
+(define (read-log-entries log)
+ (with-mutex (log-mutex log)
+ (let ((end (log-write-pos log))
+ (buf (log-buffer log)))
+ (let lp ((pos (log-read-pos log)) (out '()))
+ (if (< pos end)
+ (lp (1+ pos) (cons (vector-ref buf (log-pos->idx log pos)) out))
+ out)))))
+
+
+;;;
+;;; async queues
+;;;
+
+(define-record-type <async-queue>
+ (make-aq mutex condvar q)
+ async-queue?
+ (mutex aq-mutex)
+ (condvar aq-condvar)
+ (q aq-q))
+
+(set-record-type-printer!
+ <async-queue>
+ (lambda (aq port)
+ (format port "<async-queue ~a ~a>" (object-address aq)
+ (q-length (aq-q aq)))))
+
+(define* (make-async-queue)
+ (make-aq (make-mutex)
+ (make-condition-variable)
+ (make-q)))
+
+(define* (async-queue-push! aq item)
+ (with-mutex (aq-mutex aq)
+ (enq! (aq-q aq) item)
+ (signal-condition-variable (aq-condvar aq))))
+
+(define* (async-queue->list aq)
+ (with-mutex (aq-mutex aq)
+ (list-copy (car (aq-q aq)))))
+
+(define* (async-queue-pop! aq)
+ (with-mutex (aq-mutex aq)
+ (let lp ()
+ (cond
+ ((q-empty? (aq-q aq))
+ (wait-condition-variable (aq-condvar aq) (aq-mutex aq))
+ (lp))
+ (else
+ (q-pop! (aq-q aq)))))))
+
+
+;;;
+;;; backend
+;;;
+
+(define (bytes-free-on-fs filename)
+ (let* ((p (open-pipe* "r" "df" "-B1" "--output=avail" filename))
+ (l1 (read-line p))
+ (l2 (read-line p))
+ (l3 (read-line p)))
+ (close-pipe p)
+ (cond
+ ((and (string? l1) (string? l2) (eof-object? l3)
+ (equal? (string-trim-both l1) "Avail"))
+ (string->number l2))
+ (else
+ (error "could not get free space for file system containing"
filename)))))
+
+(define (delete-directory-contents-recursively working-dir)
+ (for-each (lambda (file)
+ (delete-file-recursively (in-vicinity working-dir file)))
+ (scandir working-dir
+ (lambda (file)
+ (and (string<> "." file)
+ (string<> ".." file))))))
+
+;; 1GB minimum free space.
+(define *mininum-free-space* #e1e9)
+
+(define (scm-files-in-dir dir)
+ (map (lambda (file)
+ (in-vicinity dir file))
+ (scandir dir
+ (lambda (file)
+ (and (not (file-is-directory? (in-vicinity dir file)))
+ (string-suffix? ".scm" file))))))
+
+(define (copy-header-comments port file)
+ (call-with-input-file file
+ (lambda (in)
+ (let lp ()
+ (let ((line (read-line in)))
+ (unless (eof-object? line)
+ (let ((trimmed (string-trim line)))
+ (when (or (string-null? trimmed) (string-prefix? ";" trimmed))
+ (display trimmed port)
+ (newline port)
+ (lp)))))))))
+
+(define (process-update log host working-dir source-checkout target-checkout
+ remote-git-url branch)
+ (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+ (delete-directory-contents-recursively working-dir)
+ (when (< (bytes-free-on-fs working-dir) *mininum-free-space*)
+ (error "not enough free space")))
+ (chdir working-dir)
+ (let* ((repo-dir (uri-encode remote-git-url))
+ (repo+branch-dir (in-vicinity repo-dir (uri-encode branch))))
+ (cond
+ ((file-exists? repo-dir)
+ (chdir repo-dir)
+ (git-fetch))
+ (else
+ (git-clone remote-git-url repo-dir)
+ (chdir repo-dir)))
+ (git-reset #:ref (string-append "origin/" branch) #:mode 'hard)
+ (unless (file-is-directory? "guix-potluck")
+ (error "repo+branch has no guix-potluck dir" remote-git-url branch))
+ (let* ((files (scm-files-in-dir "guix-potluck"))
+ ;; This step safely loads and validates the potluck package
+ ;; definitions.
+ (packages (map load-potluck-package files))
+ (source-dir (in-vicinity source-checkout repo+branch-dir))
+ (target-dir (in-vicinity target-checkout
+ (in-vicinity "gnu/packages/potluck"
+ repo+branch-dir))))
+ ;; Clear source and target repo entries.
+ (define (ensure-empty-dir filename)
+ (when (file-exists? filename)
+ (delete-file-recursively filename))
+ (mkdir-p filename))
+ (define (commit-dir dir)
+ (with-directory-excursion dir
+ (git-add ".")
+ (git-commit #:message
+ (format #f "Update ~a branch ~a."
+ remote-git-url branch)
+ #:author-name "Guix potluck host"
+ #:author-email (string-append "host@" host))
+ (git-push)))
+ (ensure-empty-dir source-dir)
+ (ensure-empty-dir target-dir)
+ ;; Add potluck files to source repo.
+ (for-each (lambda (file)
+ (copy-file file (in-vicinity source-dir (basename file))))
+ files)
+ (commit-dir source-dir)
+ ;; Add transformed files to target repo.
+ (for-each (lambda (file package)
+ (call-with-output-file
+ (in-vicinity target-dir (basename file))
+ (lambda (port)
+ (define module-name
+ `(gnu packages potluck
+ ,repo-dir
+ ,(uri-encode branch)
+ ,(substring (basename file) 0
+ (- (string-length (basename file))
+ (string-length ".scm")))))
+ ;; Preserve copyright notices if possible.
+ (copy-header-comments port file)
+ (lower-potluck-package-to-module port module-name
+ package))))
+ files packages)
+ (commit-dir target-dir)
+ packages)))
+
+(define (service-queue host working-dir source-checkout target-checkout
+ queue package-log debug-log)
+ (let lp ()
+ (match (async-queue-pop! queue)
+ ((remote-git-url . branch)
+ (sxml-log debug-log "Processing update request of "
+ `(tt ,remote-git-url) " branch " `(tt ,branch) ".")
+ (catch #t
+ (lambda ()
+ (let ((packages (process-update debug-log host working-dir
+ source-checkout target-checkout
+ remote-git-url branch)))
+ (for-each
+ (lambda (package)
+ (sxml-log package-log
+ "Added package "
+ `(tt ,(potluck-package-name package))
+ " version "
+ `(tt ,(potluck-package-version package))
+ " from package definition at "
+ `(tt ,remote-git-url) " branch " `(tt ,branch) "."))
+ packages)
+ (sxml-log debug-log "Success.")))
+ (lambda (k . args)
+ (sxml-log debug-log "Failure updating " `(tt ,remote-git-url)
+ " branch " `(tt ,branch) ": "
+ (call-with-output-string
+ (lambda (port)
+ (print-exception port #f k args))))))
+ (lp)))))
+
+
+;;;
+;;; frontend
+;;;
+
+(define* (validate-public-uri str #:key (schemes '(http https)))
+ (define (public-host? host)
+ ;; There are other ways to spell "localhost" using raw IPv4 or IPv6
+ ;; addresses; this is just a sanity check.
+ (not (member host '("localhost" "127.0.0.1" "[::1]"))))
+ (let ((uri (and (string? str) (string->uri str))))
+ (unless (and uri
+ (memq (uri-scheme uri) schemes)
+ (not (uri-fragment uri))
+ (public-host? (uri-host uri)))
+ (error "expected a public URI" str))))
+
+(define (validate-branch-name str)
+ (unless (git-check-ref-format str #:allow-onelevel? #t)
+ (error "expected a valid git branch name" str)))
+
+(define (enqueue-update params queue log)
+ (let ((remote-git-url (hash-ref params "git-url"))
+ (branch-name (hash-ref params "branch")))
+ (validate-public-uri remote-git-url)
+ (validate-branch-name branch-name)
+ (sxml-log log "Enqueuing update request of "
+ `(tt ,remote-git-url) " branch " `(tt ,branch-name) ".")
+ (async-queue-push! queue (cons remote-git-url branch-name))))
+
+(define (request-body-json request body)
+ (cond
+ ((string? body) (json-string->scm body))
+ ((bytevector? body)
+ (let* ((content-type (request-content-type request))
+ (charset (or (assoc-ref (cdr content-type) "charset")
+ "utf-8")))
+ (json-string->scm (bytevector->string body charset))))
+ ((port? body) (json->scm body))
+ (else (error "unexpected body" body))))
+
+(define (queue-status queue)
+ (match (async-queue->list queue)
+ (() '(p "Queue empty."))
+ (entries
+ `(dl
+ ,@(append-map (match-lambda
+ ((url . branch)
+ `((dt ,(basename url))
+ (dd "Repository " ,url ", " ,branch " branch."))))
+ entries)))))
+
+(define (log-status log)
+ (match (read-log-entries log)
+ (()
+ '(p "No log entries."))
+ (entries
+ `(dl
+ ,@(append-map (match-lambda
+ (((secs . usecs) . sxml)
+ `((dt ,(strftime "%c" (gmtime secs)))
+ (dd ,sxml))))
+ entries)))))
+
+;; FIXME: plumb host, etc through to here.
+(define* (main-page queue package-log debug-log
+ #:key (host "guix-potluck.org")
+ (path-prefix "/git/")
+ (target-repo "/srv/git/target.git"))
+ `(html
+ (head
+ (title "Guix Potluck -- A Decentralized Package Registry for Guix")
+ (meta (@ (name "viewport")
+ (content "width=device-width, initial-scale=1")))
+ (style "
+body {
+ max-width: 600px;
+ margin-left: auto;
+ margin-right: auto;
+ margin-top: 2em;
+ margin-bottom: 3em;
+ padding: 1em;
+ line-height: 1.4;
+ background: #ddd;
+}
+"))
+ (body
+ (h1 "Guix Potluck")
+ (h2 "About")
+ (p "This server hosts a registry of packages for
+the " (a (@ (href "https://gnu.org/software/guix/";)) "Guix package
+manager") ".")
+ (p "The name \"potluck\" refers to a kind of meal in which every
+guest brings a dish. The resulting assembly of plates is only very
+loosely planned, if at all, and the dishes are of varying quality and
+sometimes even duplicate each other. Still, there is something lovely
+about sharing home-cooked food with friends that makes these meals
+very special.")
+ (p "In the same way, the assembly of packages offered by this
+potluck server is unplanned and completely up to what users choose to
+provide. Bring your dish to the feast by using the " (tt "guix
+potluck") " command-line tool to create and upload your package.")
+ (p "To use packages from this repository, clone the repo via:")
+ (pre
+ "git clone https://"; ,host "/" ,(string-trim-both path-prefix #\/)
+ "/" ,(basename target-repo))
+ (p "That will give you a directory of packages that you can add
+to the available set of packages Guix knows about by
+adding " (tt "GUIX_PACKAGE_PATH=" (var "dir")) " to your environment,
+or by passing " (tt "-L " (var "dir")) " to your " (tt "guix
+package") " invocations.")
+ (p "This will get easier in the future when Guix adds a
+\"channel\" facility. In any case, see \"Invoking guix potluck\" in
+the Guix manual for full details.")
+ (h2 "Recently Updated Packages")
+ ,(log-status package-log)
+ (h2 "Recent Log Entries")
+ ,(log-status debug-log)
+ (h2 "Queue Status")
+ ,(queue-status queue))))
+
+(define (handler request body queue package-log debug-log)
+ (match (cons (request-method request)
+ (split-and-decode-uri-path (uri-path (request-uri request))))
+ (('GET)
+ (values (build-response
+ #:code 200
+ #:headers `((content-type . (text/html (charset . "utf-8")))
+ (date . ,(current-date))))
+ (lambda (port)
+ (sxml->xml (main-page queue package-log debug-log) port))))
+ (('POST "api" "enqueue-update")
+ ;; An exception will cause error 500.
+ (enqueue-update (request-body-json request body) queue debug-log)
+ (values (build-response #:code 200)
+ "ok"))
+ (_
+ (values (build-response #:code 404)
+ ""))))
+
+(define (host-potluck host local-port working-dir source-checkout
+ target-checkout)
+ (let ((worker-thread #f)
+ (queue (make-async-queue))
+ (package-log (make-log))
+ (debug-log (make-log)))
+ (sxml-log debug-log "Potluck host started.")
+ (dynamic-wind (lambda ()
+ (set! worker-thread
+ (make-thread
+ (service-queue host working-dir
+ source-checkout target-checkout
+ queue package-log debug-log))))
+ (lambda ()
+ (run-server
+ (lambda (request body)
+ (handler request body queue package-log debug-log))
+ ;; Always listen on localhost.
+ 'http `(#:port ,local-port)))
+ (lambda ()
+ (cancel-thread worker-thread)))))
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
index f9cd40b..ec306ca 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -25,6 +25,7 @@
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix potluck build-systems)
+ #:use-module (guix potluck host)
#:use-module (guix potluck licenses)
#:use-module (guix potluck packages)
#:use-module (guix scripts)
@@ -47,12 +48,12 @@
;;; guix potluck init
;;;
-(define* (init-potluck remote-git-url #:key
+(define* (init-potluck host 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"))
+ (potluck-dir (in-vicinity cwd "guix-potluck"))
(package-name (basename cwd)))
(unless (and (file-exists? dot-git)
(file-is-directory? dot-git))
@@ -74,17 +75,17 @@
;; FIXME: Race condition if HEAD changes between git-rev-parse and
;; here.
(pkg-sha256 (guix-hash-git-checkout cwd)))
- (format #t (_ "Creating potluck/~%"))
+ (format #t (_ "Creating guix-potluck/~%"))
(mkdir potluck-dir)
- (format #t (_ "Creating potluck/README.md~%"))
+ (format #t (_ "Creating guix-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.
+define one package. See https://guix-potluck.org/ for more information.
")))
- (format #t (_ "Creating potluck/~a.scm~%") package-name)
+ (format #t (_ "Creating guix-potluck/~a.scm~%") package-name)
(call-with-output-file (in-vicinity potluck-dir
(string-append package-name ".scm"))
(lambda (port)
@@ -133,16 +134,39 @@ define one package. See https://potluck.guixsd.org/ for
more information.
" 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
+Done. Now open guix-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
+ guix build --file=guix-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))))
+
+Once you push them out, add your dish to the communal potluck by running:
+
+ guix potluck update ~a
+") pkg-name pkg-name remote-git-url))))
+
+;;;
+;;; guix potluck update
+;;;
+
+(define (request-potluck-update host git-url branch)
+ (call-with-values (lambda ()
+ (http-post (build-uri 'https
+ #:host host
+ #:path "/api/enqueue-update")
+ #:body (scm->json-string
+ `((git-url . ,git-url)
+ (branch . ,branch)))))
+ (lambda (response body)
+ (unless (eqv? (response-code response) 200)
+ (error "request failed"
+ (response-code response)
+ (response-reason-phrase response)
+ body)))))
;;;
@@ -159,10 +183,33 @@ ARGS.\n"))
(newline)
(display (_ "\
init create potluck recipe for current working directory\n"))
+ (display (_ "\
+ update ask potluck host to add or update a potluck package\n"))
+ (display (_ "\
+ host-channel run web service providing potluck packages as Guix
channel\n"))
(newline)
(display (_ "The available OPTION flags are:\n"))
(display (_ "
+ --host=HOST for 'update' and 'host-channel', the name of the
+ channel host
+ (default: guix-potluck.org)"))
+ (display (_ "
+ --port=PORT for 'host-channel', the local TCP port on which to
+ listen for HTTP connections
+ (default: 8080)"))
+ (display (_ "
+ --scratch=DIR for 'host-channel', the path to a local directory
+ that will be used as a scratch space to check out
+ remote git repositories"))
+ (display (_ "
+ --source=DIR for 'host-channel', the path to a local checkout
+ of guix potluck source packages to be managed by
+ host-channel"))
+ (display (_ "
+ --target=DIR for 'host-channel', the path to a local checkout
+ of a guix channel to be managed by host-channel"))
+ (display (_ "
--build-system=SYS for 'init', specify the build system. Use
--build-system=help for all available options."))
(display (_ "
@@ -201,19 +248,56 @@ ARGS.\n"))
(option '("license") #t #f
(lambda (opt name arg result)
(alist-cons 'license arg result)))
+ (option '("host") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'host arg result)))
+ (option '("port") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'port arg result)))
+ (option '("scratch") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'scratch arg result)))
+ (option '("source") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'source arg result)))
+ (option '("target") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'target 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)))
+ `((host . "guix-potluck.org")
+ (port . "8080")
+ (verbosity . 0)))
+
+(define (parse-host host-str)
+ ;; Will throw if the host is invalid somehow.
+ (build-uri 'https #:host host-str)
+ host-str)
(define (parse-url url-str)
(unless (string->uri url-str)
(leave (_ "invalid url: ~a~%") url-str))
url-str)
+(define (parse-port port-str)
+ (let ((port (string->number port-str)))
+ (cond
+ ((and port (exact-integer? port) (<= 0 port #xffff))
+ port)
+ (else
+ (leave (_ "invalid port: ~a~%") port-str)))))
+
+(define (parse-absolute-directory-name str)
+ (unless (and (absolute-file-name? str)
+ (file-exists? str)
+ (file-is-directory? str))
+ (leave (_ "invalid absolute directory name: ~a~%") str))
+ str)
+
(define (parse-build-system sys-str)
(unless sys-str
(leave (_ "\
@@ -297,7 +381,8 @@ If your package's license is not in this list, add it to
Guix first.~%")
('init
(match args
((remote-git-url)
- (init-potluck (parse-url remote-git-url)
+ (init-potluck (parse-host (assoc-ref opts 'host))
+ (parse-url remote-git-url)
#:build-system (parse-build-system
(assoc-ref opts 'build-system))
#:autoreconf? (assoc-ref opts 'autoreconf?)
@@ -306,5 +391,33 @@ If your package's license is not in this list, add it to
Guix first.~%")
(args
(wrong-number-of-args
(_ "usage: guix potluck init [OPT...] REMOTE-GIT-URL")))))
+ ('update
+ (match args
+ ((remote-git-url branch)
+ (request-potluck-update (parse-host (assoc-ref opts 'host))
+ (parse-url remote-git-url)
+ branch))
+ (args
+ (wrong-number-of-args
+ (_ "usage: guix potluck update REMOTE-GIT-URL BRANCH-NAME")))))
+ ('host-channel
+ (match args
+ (()
+ (host-potluck (parse-host (assoc-ref opts 'host))
+ (parse-port (assoc-ref opts 'port))
+ (parse-absolute-directory-name
+ (or (assoc-ref opts 'scratch)
+ (leave (_ "missing --scratch argument~%"))))
+ (parse-absolute-directory-name
+ (or (assoc-ref opts 'source)
+ (leave (_ "missing --source argument~%"))))
+ (parse-absolute-directory-name
+ (or (assoc-ref opts 'target)
+ (leave (_ "missing --target argument~%"))))))
+ (args
+ (wrong-number-of-args
+ (_ "usage: guix potluck host-channel --scratch=DIR \
+--source=DIR --target=DIR"))
+ (exit 1))))
(action
(leave (_ "~a: unknown action~%") action))))))
