10/10: gnu: Add potluck host-channel service.

[Andy Wingo]

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

commit eb81966f4a6380446ea98f91e5cccb6746c5e242
Author: Andy Wingo <address@hidden>
Date:   Thu Apr 27 10:48:28 2017 +0200

    gnu: Add potluck host-channel service.
    
    * gnu/services/potluck.scm: New file.
    * gnu/local.mk (GNU_SYSTEM_MODULES): Add new service.
    * doc/guix.texi (Potluck Services): New subsubsection.
    
    potluck fixie
---
 doc/guix.texi            |  54 ++++++++++++++++++
 gnu/local.mk             |   1 +
 gnu/services/potluck.scm | 141 +++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 196 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index bc2a4d0..8e53327 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -222,6 +222,7 @@ Services
 * VPN Services::                VPN daemons.
 * Network File System::         NFS related services.
 * Continuous Integration::      The Cuirass service.
+* Potluck Services::            Guix's decoupled package registry.
 * Power management Services::   The TLP tool.
 * Version Control Services::    Providing remote access to Git repositories.
 * Miscellaneous Services::      Other services.
@@ -8859,6 +8860,7 @@ declaration.
 * VPN Services::                VPN daemons.
 * Network File System::         NFS related services.
 * Continuous Integration::      The Cuirass service.
+* Potluck Services::            Guix's decoupled package registry.
 * Power management Services::   The TLP tool.
 * Version Control Services::    Providing remote access to Git repositories.
 * Miscellaneous Services::      Other services.
@@ -14385,6 +14387,58 @@ The Cuirass package to use.
 @end table
 @end deftp
 
address@hidden Potluck Services
address@hidden Potluck Services
+
address@hidden potluck service
+Guix includes a potluck....
+
address@hidden {Scheme Variable} potluck-service-type
+A service type for the @code{guix-potluck} FastCGI proxy.
address@hidden defvr
+
address@hidden {Data Type} potluck-configuration
+Data type representing the configuration of the @code{guix-potluck} serice.
+This type has the following parameters:
address@hidden @asis
address@hidden @code{package} (default: @code{guix-potluck})
+The guix-potluck package to use.
+
address@hidden @code{scratch} (default: @code{/var/cache/guix-potluck/scratch})
+The scratch directory that @code{guix potluck host-channel} will use.
+The potluck service will ensure that this directory exists and is owned
+by the potluck service user.
+
address@hidden @code{source} (default: @code{/srv/git/source.git})
+A local path to a git repository in which to save Guix potluck packages.
+The potluck service will create this repository if needed.
+
address@hidden @code{source-repo} (default: 
@code{/var/cache/guix-potluck/source})
+A directory that @code{guix potluck host-channel} will use to check out
+the potluck source git repository.  The potluck service will create this
+checkout if needed.
+
address@hidden @code{target} (default: @code{/srv/git/target.git})
address@hidden @code{target-repo} (default: 
@code{/var/cache/guix-potluck/target})
+Like @code{source} and @code{source-repo}, but for compiled Guix
+packages corresponding to the incoming potluck packages.  The idea is
+that the source repository contains the incoming potluck packages
+verbatim, as the users provided them and after the potluck host has
+validated them.  The target repository contains corresponding Guix
+packages, in a form that can just be added to the
address@hidden
+
address@hidden @code{user} (default: @code{guix-potluck})
address@hidden @code{group} (default: @code{guix-potluck})
+The user and group names, as strings, under which to run the @code{guix}
+process, and which should own the corresponding checkouts and scratch
+directories.  The potluck service will ensure that if the user asks for
+the specific user or group names @code{guix-potluck} that the
+corresponding user and/or group is present on the system.
address@hidden table
address@hidden deftp
+
+
 @node Power management Services
 @subsubsection Power management Services
 
diff --git a/gnu/local.mk b/gnu/local.mk
index ac0c9d5..2e0468f 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -429,6 +429,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/services/messaging.scm                   \
   %D%/services/networking.scm                  \
   %D%/services/nfs.scm                 \
+  %D%/services/potluck.scm                     \
   %D%/services/shepherd.scm                    \
   %D%/services/herd.scm                                \
   %D%/services/pm.scm                          \
diff --git a/gnu/services/potluck.scm b/gnu/services/potluck.scm
new file mode 100644
index 0000000..cbabaa5
--- /dev/null
+++ b/gnu/services/potluck.scm
@@ -0,0 +1,141 @@
+;;; 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 (gnu services potluck)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu packages package-management)
+  #:use-module (gnu packages version-control)
+  #:use-module (guix records)
+  #:use-module (guix gexp)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:export (potluck-configuration
+            potluck-configuration?
+            potluck-service-type))
+
+;;; Commentary:
+;;;
+;;; Guix potluck services.
+;;;
+;;; Code:
+
+;; FIXME: Replace with guix version that has potluck.
+(define guix/potluck guix)
+
+(define-record-type* <potluck-configuration> potluck-configuration
+  make-potluck-configuration
+  potluck-configuration?
+  (package       potluck-configuration-package ;<package>
+                 (default guix/potluck))
+  (scratch       potluck-configuration-scratch
+                 (default "/var/cache/potluck/scratch"))
+  (source        potluck-configuration-source
+                 (default "/var/cache/potluck/source"))
+  (source-repo   potluck-configuration-source-repo
+                 (default "/srv/git/source.git"))
+  (target        potluck-configuration-target
+                 (default "/var/cache/potluck/target"))
+  (target-repo   potluck-configuration-target-repo
+                 (default "/srv/git/target.git"))
+  (user          potluck-configuration-user
+                 (default "potluck"))
+  (group         potluck-configuration-group
+                 (default "potluck")))
+
+(define potluck-accounts
+  (match-lambda
+    (($ <potluck-configuration>
+        package scratch source source-repo target target-repo user group)
+     (filter identity
+             (list
+              (and (equal? group "potluck")
+                   (user-group
+                    (name "potluck")
+                    (system? #t)))
+              (and (equal? user "potluck")
+                   (user-account
+                    (name "potluck")
+                    (group group)
+                    (system? #t)
+                    (comment "Potluck Service")
+                    (home-directory "/var/empty")
+                    (shell (file-append shadow "/sbin/nologin")))))))))
+
+(define potluck-activation-service
+  (match-lambda
+    (($ <potluck-configuration>
+        package scratch source source-repo target target-repo user group)
+     (with-imported-modules '((guix build utils))
+       #~(begin
+          (use-modules (guix build utils) (ice-9 ftw))
+          (define (chown-r dir user group)
+             (let ((uid (passwd:uid (getpwnam user)))
+                  (gid (group:gid (getgrnam group))))
+              (for-each (lambda (f) (chown f uid gid))
+                        (find-files dir #:directories? #t))))
+          (define (ensure-git-repo dir)
+            (unless (file-exists? dir)
+              (mkdir-p dir)
+              (unless (zero? (system* (string-append #$git "/bin/git")
+                                      "init" "--bare" dir))
+                (error "failed to create repository" dir))
+              (chown-r dir #$user #$group)))
+          (define (ensure-checkout repo dir)
+            (unless (file-exists? dir)
+              (mkdir-p (dirname dir))
+              (unless (zero? (system* (string-append #$git "/bin/git")
+                                      "clone" repo dir))
+                (error "failed to check out repository" repo dir))
+              (chown-r dir #$user #$group)))
+          (mkdir-p #$scratch)
+          (chown-r #$scratch #$user #$group)
+          (ensure-git-repo #$source-repo)
+          (ensure-git-repo #$target-repo)
+          (ensure-checkout #$source-repo #$source)
+          (ensure-checkout #$target-repo #$target))))))
+
+(define potluck-shepherd-service
+  (match-lambda
+    (($ <potluck-configuration>
+        package scratch source source-repo target target-repo user group)
+     (list (shepherd-service
+            (provision '(potluck))
+            (documentation "Run the potluck daemon.")
+            (requirement '(networking))
+
+            (start #~(make-forkexec-constructor
+                      '(#$(file-append package "/bin/guix") "host-channel"
+                        #$(format #f "--scratch=~a" scratch)
+                       #$(format #f "--source=~a" source)
+                       #$(format #f "--target=~a" target))
+                     #:user #$user #:group #$group))
+            (stop #~(make-kill-destructor)))))))
+
+(define potluck-service-type
+  (service-type (name 'potluck)
+                (extensions
+                 (list (service-extension activation-service-type
+                                          potluck-activation-service)
+                      (service-extension shepherd-root-service-type
+                                          potluck-shepherd-service)
+                      (service-extension account-service-type
+                                         potluck-accounts)))
+                (default-value (potluck-configuration))))