02/02: potluck: Build with Guile 2.0; further bugfixes.

[Andy Wingo]

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

commit 18dad7e25af51d7a902dacbccb8a691bc080bf0c
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 12 18:55:37 2017 +0200

    potluck: Build with Guile 2.0; further bugfixes.
    
    * guix/potluck/environment.scm:
    * guix/potluck/host.scm:
    * guix/scripts/potluck.scm: Allow building with Guile 2.0.  Fix some errors
      between "guix potluck update" and "guix potluck host-channel".
---
 guix/potluck/environment.scm |  4 ----
 guix/potluck/host.scm        | 28 +++++++++++++++++++++-------
 guix/scripts/potluck.scm     | 22 +++++++++++-----------
 3 files changed, 32 insertions(+), 22 deletions(-)

diff --git a/guix/potluck/environment.scm b/guix/potluck/environment.scm
index e362776..279320e 100644
--- a/guix/potluck/environment.scm
+++ b/guix/potluck/environment.scm
@@ -90,10 +90,6 @@
   const
   noop)
 
-;; Nil bindings.
-(define-bindings (guile)
-  nil?)
-
 ;; Unspecified bindings.
 (define-bindings (guile)
   unspecified?
diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
index e4aeb97..1e31695 100644
--- a/guix/potluck/host.scm
+++ b/guix/potluck/host.scm
@@ -32,14 +32,15 @@
   #: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 textual-ports)
   #: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)
@@ -93,7 +94,7 @@
         args))
   (let* ((real-args (redirect-input (prepend-env args)))
          (pipe (apply open-pipe* OPEN_READ real-args))
-         (output (get-string-all pipe))
+         (output (read-string pipe))
          (ret (close-pipe pipe)))
     (case (status:exit-val ret)
       ((0) output)
@@ -114,10 +115,12 @@
 (define (git . args)
   (git* args))
 
-(define (git-check-ref-format str)
+(define* (git-check-ref-format str #:key allow-onelevel?)
   (when (string-prefix? "-" str)
     (error "bad ref" str))
-  (git "check-ref-format" str))
+  (git "check-ref-format"
+       (if allow-onelevel? "--allow-onelevel" "--no-allow-onelevel")
+       str))
 
 (define (git-rev-parse rev)
   (string-trim-both (git "rev-parse" rev)))
@@ -204,7 +207,7 @@
 ;;;
 
 (define (bytes-free-on-fs filename)
-  (let* ((p (open-pipe* "r" "df" "--output=avail" filename))
+  (let* ((p (open-pipe* "r" "df" "-B1" "--output=avail" filename))
          (l1 (read-line p))
          (l2 (read-line p))
          (l3 (read-line p)))
@@ -335,7 +338,7 @@
       (error "expected a public URI" str))))
 
 (define (validate-branch-name str)
-  (unless (git-check-ref-format str)
+  (unless (git-check-ref-format str #:allow-onelevel? #t)
     (error "expected a valid git branch name" str)))
 
 (define (enqueue-update params queue)
@@ -345,6 +348,17 @@
     (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))))
@@ -353,7 +367,7 @@
              "todo: show work queue"))
     (('POST "api" "enqueue-update")
      ;; An exception will cause error 500.
-     (enqueue-update (json->scm body) queue)
+     (enqueue-update (request-body-json request body) queue)
      (values (build-response #:code 200)
              ""))
     (_
diff --git a/guix/scripts/potluck.scm b/guix/scripts/potluck.scm
index 2c5d123..fdc52d9 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -37,7 +37,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 pretty-print)
-  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 rdelim)
   #:use-module (json)
   #:use-module (web client)
   #:use-module (web response)
@@ -84,7 +84,7 @@
         args))
   (let* ((real-args (redirect-input (prepend-env args)))
          (pipe (apply open-pipe* OPEN_READ real-args))
-         (output (get-string-all pipe))
+         (output (read-string pipe))
          (ret (close-pipe pipe)))
     (case (status:exit-val ret)
       ((0) output)
@@ -124,7 +124,7 @@
                        (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))
@@ -146,17 +146,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)
@@ -205,15 +205,15 @@ 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 potluck && git commit -m 'Add initial Guix potluck files.'
+  git add guix-potluck && git commit -m 'Add initial Guix potluck files.'
 ") pkg-name pkg-name))))
 
 ;;;