From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:41177) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d2l7X-00043V-5F for guix-patches@gnu.org; Mon, 24 Apr 2017 17:02:12 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d2l7T-0004fG-75 for guix-patches@gnu.org; Mon, 24 Apr 2017 17:02:07 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40333) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d2l7T-0004ew-2N for guix-patches@gnu.org; Mon, 24 Apr 2017 17:02:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d2l7S-0004gP-Ql for guix-patches@gnu.org; Mon, 24 Apr 2017 17:02:02 -0400 Subject: bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand. Resent-Message-ID: From: Andy Wingo Date: Mon, 24 Apr 2017 22:59:22 +0200 Message-Id: <20170424205923.27726-8-wingo@igalia.com> In-Reply-To: <20170424205923.27726-1-wingo@igalia.com> References: <20170424205923.27726-1-wingo@igalia.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26645@debbugs.gnu.org * 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 | 304 +++++++++++++++++++++++++++++++++++++++++= ++++++ guix/scripts/potluck.scm | 137 +++++++++++++++++++-- 3 files changed, 430 insertions(+), 12 deletions(-) create mode 100644 guix/potluck/host.scm diff --git a/Makefile.am b/Makefile.am index 628283b57..94fa05d5b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -129,6 +129,7 @@ MODULES =3D \ 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 000000000..5ac8e0f5f --- /dev/null +++ b/guix/potluck/host.scm @@ -0,0 +1,304 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2017 Andy Wingo +;;; +;;; 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 (a= t +;;; 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 . + +(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 (web uri) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server) + #:export (host-potluck)) + +=0C +;;; +;;; async queues +;;; + +(define-record-type + (make-aq mutex condvar q) + async-queue? + (mutex aq-mutex) + (condvar aq-condvar) + (q aq-q)) + +(set-record-type-printer! + + (lambda (aq port) + (format port "" (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-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))))))) + +=0C +;;; +;;; backend +;;; + +(define (bytes-free-on-fs filename) + (let* ((p (open-pipe* "r" "df" "-B1" "--output=3Davail" 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" filen= ame))))) + +(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? ";" trimm= ed)) + (display trimmed port) + (newline port) + (lp))))))))) + +(define (process-update 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 fi= le)) + (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))) + ;; 8. post success message + (pk 'success target-checkout remote-git-url branch)) + +(define (service-queue host working-dir source-checkout target-checkout = queue) + (let lp () + (match (async-queue-pop! queue) + ((remote-git-url . branch) + (format (current-error-port) "log: handling ~a / ~a\n" + remote-git-url branch) + (catch #t + (lambda () + (process-update host working-dir + source-checkout target-checkout + remote-git-url branch) + (format (current-error-port) "log: success ~a / ~a\n" + remote-git-url branch)) + (lambda (k . args) + (format (current-error-port) "log: failure ~a / ~a\n" + remote-git-url branch) + (print-exception (current-error-port) #f k args))) + (lp))))) + +=0C +;;; +;;; 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) + (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) + (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 (handler request body queue) + (match (cons (request-method request) + (split-and-decode-uri-path (uri-path (request-uri request= )))) + (('GET) + (values (build-response #:code 200) + "todo: show work queue")) + (('POST "api" "enqueue-update") + ;; An exception will cause error 500. + (enqueue-update (request-body-json request body) queue) + (values (build-response #:code 200) + "")) + (_ + (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))) + (dynamic-wind (lambda () + (set! worker-thread + (make-thread + (service-queue host working-dir + source-checkout target-checkout + queue)))) + (lambda () + (run-server + (lambda (request body) + (handler request body queue)) + ;; 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 f9cd40bd0..ec306cae6 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 ;;; =20 -(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-pars= e 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 sh= ould -define one package. See https://potluck.guixsd.org/ for more informatio= n. +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 \"synop= sis\" +and \"description\" fields, add dependencies to the 'inputs' field, and = try to build with =20 - guix build --file=3Dpotluck/~a.scm + guix build --file=3Dguix-potluck/~a.scm =20 When you get that working, commit your results to git via: =20 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))))) =20 =0C ;;; @@ -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 c= hannel\n")) =20 (newline) (display (_ "The available OPTION flags are:\n")) (display (_ " + --host=3DHOST for 'update' and 'host-channel', the name of = the + channel host + (default: guix-potluck.org)")) + (display (_ " + --port=3DPORT for 'host-channel', the local TCP port on whi= ch to + listen for HTTP connections + (default: 8080)")) + (display (_ " + --scratch=3DDIR for 'host-channel', the path to a local direc= tory + that will be used as a scratch space to check o= ut + remote git repositories")) + (display (_ " + --source=3DDIR for 'host-channel', the path to a local check= out + of guix potluck source packages to be managed b= y + host-channel")) + (display (_ " + --target=3DDIR for 'host-channel', the path to a local check= out + of a guix channel to be managed by host-channel= ")) + (display (_ " --build-system=3DSYS for 'init', specify the build system. Use --build-system=3Dhelp 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))))= ) =20 (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) =20 (define (parse-url url-str) (unless (string->uri url-str) (leave (_ "invalid url: ~a~%") url-str)) url-str) =20 +(define (parse-port port-str) + (let ((port (string->number port-str))) + (cond + ((and port (exact-integer? port) (<=3D 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 i= t 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=3DDIR \ +--source=3DDIR --target=3DDIR")) + (exit 1)))) (action (leave (_ "~a: unknown action~%") action)))))) --=20 2.12.2