08/10: potluck: Add host-channel subcommand.

[Andy Wingo]

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

commit 78dab505a3af07f7dd77fcfc81adf9aa405ae452
Author: Andy Wingo <address@hidden>
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    | 304 +++++++++++++++++++++++++++++++++++++++++++++++
 guix/scripts/potluck.scm | 137 +++++++++++++++++++--
 3 files changed, 430 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..5ac8e0f
--- /dev/null
+++ b/guix/potluck/host.scm
@@ -0,0 +1,304 @@
+;;; 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 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))
+
+
+;;;
+;;; 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-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 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)))
+  ;; 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)))))
+
+
+;;;
+;;; 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 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))))))