02/02: potluck: Implement more host-channel functionality

[Andy Wingo]

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

commit 7449ab4f2be04894671da1872cd36cd85c052cca
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 12 16:42:30 2017 +0200

    potluck: Implement more host-channel functionality
    
    * guix/scripts/potluck.scm: Rework host-channel command to have required
      --scratch, --source, and --target command-line arguments.
    * guix/potluck/host.scm: Implement more functionality.
---
 guix/potluck/host.scm    | 172 ++++++++++++++++++++++++++++++++++++++++++-----
 guix/scripts/potluck.scm |  44 ++++++++++--
 2 files changed, 196 insertions(+), 20 deletions(-)

diff --git a/guix/potluck/host.scm b/guix/potluck/host.scm
index 712d7bd..e4aeb97 100644
--- a/guix/potluck/host.scm
+++ b/guix/potluck/host.scm
@@ -20,6 +20,10 @@
   #: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 utils)
   #:use-module (guix potluck packages)
   #:use-module (guix potluck build-systems)
@@ -27,10 +31,12 @@
   #:use-module (guix scripts)
   #:use-module (guix scripts hash)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 ftw)
   #: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)
@@ -108,6 +114,11 @@
 (define (git . args)
   (git* args))
 
+(define (git-check-ref-format str)
+  (when (string-prefix? "-" str)
+    (error "bad ref" str))
+  (git "check-ref-format" str))
+
 (define (git-rev-parse rev)
   (string-trim-both (git "rev-parse" rev)))
 
@@ -117,6 +128,38 @@
 (define* (git-describe #:optional (ref "HEAD"))
   (string-trim-both (git "describe")))
 
+(define (git-fetch)
+  (git "fetch"))
+
+(define (git-push)
+  (git "push"))
+
+(define (git-clone repo dir)
+  (git "clone" "--" repo dir))
+
+(define (git-clone repo dir)
+  (git "clone" "--" repo dir))
+
+(define* (git-reset #:key (ref "HEAD") (mode 'hard))
+  ;; Can't let the ref be mistaken for a command-line argument.
+  (when (string-prefix? "-" ref)
+    (error "bad ref" ref))
+  (git "reset"
+       (case mode
+         ((hard) "--hard")
+         ((mixed) "--mixed")
+         ((soft) "--soft")
+         (else (error "unknown mode" mode)))
+       ref))
+
+(define (git-add file)
+  (git "add" "--" file))
+
+(define* (git-commit #:key message author-name author-email)
+  (git "commit"
+       (string-append "--message=" message)
+       (string-append "--author=" author-name "<" author-email ">")))
+
 
 ;;;
 ;;; async queues
@@ -160,10 +203,102 @@
 ;;; backend
 ;;;
 
-(define (process-update git-checkout remote-git-url branch)
-  (pk 'hey git-checkout remote-git-url branch))
+(define (bytes-free-on-fs filename)
+  (let* ((p (open-pipe* "r" "df" "--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 (service-queue git-checkout queue)
+(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? file))
+                       (string-suffix? ".scm" file))))))
+
+(define (copy-header-comments port file)
+  #f)
+
+(define (emit-guix-package-module port pkg)
+  #f)
+
+(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 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 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
+          (lambda ()
+            (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 source-dir)) files)
+      (commit-dir source-dir)
+      ;; Add transformed files to target repo.
+      (for-each (lambda (file package)
+                  (call-with-output-file (in-vicinity target-dir file)
+                    (lambda (port)
+                      ;; Preserve copyright notices if possible.
+                      (copy-header-comments port file)
+                      (emit-guix-package-module port 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)
@@ -171,7 +306,9 @@
                remote-git-url branch)
        (catch #t
          (lambda ()
-           (process-update git-checkout remote-git-url branch)
+           (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)
@@ -197,16 +334,15 @@
                  (public-host? (uri-host uri)))
       (error "expected a public URI" str))))
 
-(define (validate-non-empty-string str)
-  (unless (and (string? str)
-               (not (string-null? str)))
-    (error "expected a non-empty string" str)))
+(define (validate-branch-name str)
+  (unless (git-check-ref-format str)
+    (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-non-empty-string branch-name)
+    (validate-branch-name branch-name)
     (async-queue-push! queue (cons remote-git-url branch-name))))
 
 (define (handler request body queue)
@@ -224,17 +360,21 @@
      (values (build-response #:code 404)
              ""))))
 
-(define (host-potluck host local-port local-git-checkout-dir)
+(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 local-git-checkout-dir queue))))
-                  (lambda () (run-server
-                              (lambda (request body)
-                                (handler request body queue))
-                              ;; Always listen on localhost.
-                              'http `(#:port ,local-port)))
+                       (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 bc7393a..2c5d123 100644
--- a/guix/scripts/potluck.scm
+++ b/guix/scripts/potluck.scm
@@ -258,7 +258,7 @@ ARGS.\n"))
   (newline)
   (display (_ "The available OPTION flags are:\n"))
   (display (_ "
-      --host=URL         for 'update' and 'host-channel', the name of the
+      --host=HOST        for 'update' and 'host-channel', the name of the
                          channel host
                          (default: guix-potluck.org)"))
   (display (_ "
@@ -266,6 +266,17 @@ ARGS.\n"))
                          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 (_ "
@@ -310,6 +321,15 @@ ARGS.\n"))
         (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)))))
@@ -338,6 +358,13 @@ ARGS.\n"))
      (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 (_ "\
@@ -439,13 +466,22 @@ If your package's license is not in this list, add it to 
Guix first.~%")
              (_ "usage: guix potluck update REMOTE-GIT-URL BRANCH-NAME")))))
         ('host-channel
          (match args
-           ((local-git-checkout)
+           (()
             (host-potluck (parse-host (assoc-ref opts 'host))
                           (parse-port (assoc-ref opts 'port))
-                          local-git-checkout))
+                          (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 CHANNEL-DIRECTORY"))
+             (_ "usage: guix potluck host-channel --scratch=DIR \
+--source=DIR --target=DIR"))
             (exit 1))))
         (action
          (leave (_ "~a: unknown action~%") action))))))