[bug#30809] [PATCH 2/2] services: Add Gitolite.

[Christopher Baines <mail@cbaines.net>]

* gnu/services/version-control.scm (<gitolite-configuration>,
<gitolite-rc-file>): New record types.
(gitolite-accounts, gitolite-setup, gitolite-activation): New procedures.
(gitolite-service-type): New variables.
* gnu/tests/version-control.scm (%gitolite-test-admin-keypair, %gitolite-os,
%test-gitolite): New variables.
(run-gitolite-test): New procedure.
* doc/guix.texi (Version Control): Document the gitolite service.
---
 doc/guix.texi                    |  90 +++++++++++++++
 gnu/services/version-control.scm | 185 ++++++++++++++++++++++++++++++-
 gnu/tests/version-control.scm    | 112 ++++++++++++++++++-
 3 files changed, 385 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 84347d156..8618f4cdb 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -20217,6 +20217,96 @@ could instantiate a cgit service like this:
           (cgitrc "")))
 @end example
 
+@subsubheading Gitolite Service
+
+@cindex Gitolite service
+@cindex Git, hosting
+@uref{http://gitolite.com/gitolite/, Gitolite} is a tool for hosting Git
+repositories on a central server.
+
+Gitolite can handle multiple repositories and users, and supports flexible
+configuration of the permissions for the users on the repositories.
+
+The following example will configure Gitolite using the default @code{git}
+user, and the provided SSH public key. A public key is necessary to setup
+Gitolite initially, but can be omitted once Gitolite is setup.
+
+@example
+(service gitolite-service-type
+         (gitolite-configuration
+           (admin-pubkey (plain-file
+                           "id_rsa.pub"
+                           "ssh-rsa AAAA... guix@@example.com"))))
+@end example
+
+Gitolite is configured through a special admin repository which you can clone,
+for example, if you setup Gitolite on @code{example.com}, you would run the
+following command to clone the admin repository.
+
+@example
+git clone git@@example.com:gitolite-admin
+@end example
+
+@deftp {Data Type} gitolite-configuration
+Data type representing the configuration for @code{gitolite-service-type}.
+
+@table @asis
+@item @code{package} (default: @var{gitolite})
+Gitolite package to use.
+
+@item @code{user} (default: @var{git})
+User to use for Gitolite.  This will be user that you use when accessing
+Gitolite over SSH.
+
+@item @code{rc-file} (default: @var{(gitolite-rc-file)})
+A ``file-like'' object (@pxref{G-Expressions, file-like objects}),
+representing the configuration for Gitolite.
+
+@item @code{admin-pubkey} (default: @var{#f})
+A ``file-like'' object (@pxref{G-Expressions, file-like objects}) used to
+setup Gitolite.  This can be omitted once Gitolite has successfully been
+setup.
+
+The following G-exp would use the @file{/home/user/.ssh/id_rsa.pub} file.
+
+@example
+(local-file "/home/user/.ssh/id_rsa.pub")
+@end example
+
+To specify the SSH key as a string, use the @code{plain-file} function.
+
+@example
+(plain-file "id_rsa.pub" "ssh-rsa AAAA... guix@@example.com")
+@end example
+
+@end table
+@end deftp
+
+@deftp {Data Type} gitolite-rc-file
+Data type representing the Gitolite RC file.
+
+@table @asis
+@item @code{umask} (default: @code{#o0077})
+This controls the permissions Gitolite sets on the repositories and their
+contents.
+
+A value like @code{#o0027} will give read access to the group used by Gitolite
+(by default: @code{git}). This is necessary when using Gitolite with software
+like cgit or gitweb.
+
+@item @code{git-config-keys} (default: @code{""})
+Gitolite allows you to set git config values using the "config" keyword. This
+setting allows control over the config keys to accept.
+
+@item @code{roles} (default: @code{'(("READERS" . 1) ("WRITERS" . ))})
+Set the role names allowed to be used by users running the perms command.
+
+@item @code{enable} (default: @code{'("help" "desc" "info" "perms" "writable" "ssh-authkeys" "git-config" "daemon" "gitweb")})
+This setting controls the commands and features to enable within Gitolite.
+
+@end table
+@end deftp
+
 
 @node Game Services
 @subsubsection Game Services
diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm
index 58274c8be..367ea3a38 100644
--- a/gnu/services/version-control.scm
+++ b/gnu/services/version-control.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
 ;;; Copyright © 2017 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,7 +41,23 @@
 
             git-http-configuration
             git-http-configuration?
-            git-http-nginx-location-configuration))
+            git-http-nginx-location-configuration
+
+            <gitolite-configuration>
+            gitolite-configuration
+            gitolite-configuration-package
+            gitolite-configuration-user
+            gitolite-configuration-rc-file
+            gitolite-configuration-admin-pubkey
+
+            <gitolite-rc-file>
+            gitolite-rc-file
+            gitolite-rc-file-umask
+            gitolite-rc-file-git-config-keys
+            gitolite-rc-file-roles
+            gitolite-rc-file-enable
+
+            gitolite-service-type))
 
 ;;; Commentary:
 ;;;
@@ -197,3 +214,169 @@ access to exported repositories under @file{/srv/git}."
             "")
         (list "fastcgi_param GIT_PROJECT_ROOT " git-root ";")
         "fastcgi_param PATH_INFO $1;"))))))
+
+\f
+;;;
+;;; Gitolite
+;;;
+
+(define-record-type* <gitolite-rc-file>
+  gitolite-rc-file make-gitolite-rc-file
+  gitolite-rc-file?
+  (umask           gitolite-rc-file-umask
+                   (default #o0077))
+  (git-config-keys gitolite-rc-file-git-config-keys
+                   (default ""))
+  (roles           gitolite-rc-file-roles
+                   (default '(("READERS" . 1)
+                              ("WRITERS" . 1))))
+  (enable          gitolite-rc-file-enable
+                   (default '("help"
+                              "desc"
+                              "info"
+                              "perms"
+                              "writable"
+                              "ssh-authkeys"
+                              "git-config"
+                              "daemon"
+                              "gitweb"))))
+
+(define-gexp-compiler (gitolite-rc-file-compiler
+                       (file <gitolite-rc-file>) system target)
+  (match file
+    (($ <gitolite-rc-file> umask git-config-keys roles enable)
+     (apply text-file* "gitolite.rc"
+      `("%RC = (\n"
+        "    UMASK => " ,(format #f "~4,'0o" umask) ",\n"
+        "    GIT_CONFIG_KEYS => '" ,git-config-keys "',\n"
+        "    ROLES => {\n"
+        ,@(map (match-lambda
+                 ((role . value)
+                  (simple-format #f "        ~A => ~A,\n" role value)))
+               roles)
+        "    },\n"
+        "\n"
+        "    ENABLE => [\n"
+        ,@(map (lambda (value)
+                 (simple-format #f "        '~A',\n" value))
+               enable)
+        "    ],\n"
+        ");\n"
+        "\n"
+        "1;\n")))))
+
+(define-record-type* <gitolite-configuration>
+  gitolite-configuration make-gitolite-configuration
+  gitolite-configuration?
+  (package        gitolite-configuration-package
+                  (default gitolite))
+  (user           gitolite-configuration-user
+                  (default "git"))
+  (group          gitolite-configuration-group
+                  (default "git"))
+  (home-directory gitolite-configuration-home-directory
+                  (default "/var/lib/gitolite"))
+  (rc-file        gitolite-configuration-rc-file
+                  (default (gitolite-rc-file)))
+  (admin-pubkey   gitolite-configuration-admin-pubkey
+                  (default #f)))
+
+(define gitolite-accounts
+  (match-lambda
+    (($ <gitolite-configuration> package user group home-directory
+                                 rc-file admin-pubkey)
+     ;; User group and account to run Gitolite.
+     (list (user-group (name user) (system? #t))
+           (user-account
+            (name user)
+            (group group)
+            (system? #t)
+            (comment "Gitolite user")
+            (home-directory home-directory))))))
+
+(define gitolite-setup
+  (match-lambda
+    (($ <gitolite-configuration> package user group home
+                                 rc-file admin-pubkey)
+     #~(let ((user-info (getpwnam #$user)))
+         (use-modules (guix build utils))
+
+         (simple-format #t "guix: gitolite: installing ~A\n" #$rc-file)
+         (copy-file #$rc-file #$(string-append home "/.gitolite.rc"))
+
+         (let ((admin-pubkey #$admin-pubkey)
+               (pubkey-file #$(string-append home "/id_rsa.pub")))
+           (when admin-pubkey
+             ;; The key must be writable, so copy it from the store
+             (copy-file #$admin-pubkey pubkey-file)
+
+             (chmod pubkey-file #o500)
+             (chown pubkey-file
+                    (passwd:uid user-info)
+                    (passwd:gid user-info))
+
+             ;; Set the git configuration, to avoid gitolite trying to use
+             ;; the hostname command, as the network might not be up yet
+             (with-output-to-file #$(string-append home "/.gitconfig")
+               (lambda ()
+                 (display "[user]
+        name = GNU Guix
+        email = guix@localhost
+"))))
+           ;; Run Gitolite setup, as this updates the hooks and include the
+           ;; admin pubkey if specified. The admin pubkey is required for
+           ;; initial setup, and will replace the previous key if run after
+           ;; initial setup
+           (let ((pid (primitive-fork)))
+             (if (eq? pid 0)
+                 (begin
+                   ;; Exit with a non-zero status code if an exception is thrown.
+                   (dynamic-wind
+                     (const #t)
+                     (lambda ()
+                       (setenv "HOME" (passwd:dir user-info))
+                       (setenv "USER" #$user)
+                       (setgid (passwd:gid user-info))
+                       (setuid (passwd:uid user-info))
+                       (primitive-exit
+                        (apply system*
+                               #$(file-append package "/bin/gitolite")
+                               "setup"
+                               (if admin-pubkey
+                                   `("-pk" ,pubkey-file)
+                                   '()))))
+                     (lambda ()
+                       (primitive-exit 1))))
+                 (waitpid pid)))
+
+           (when (file-exists? pubkey-file)
+             (delete-file pubkey-file)))))))
+
+(define (gitolite-activation config)
+  (if (gitolite-configuration-admin-pubkey config)
+      (gitolite-setup config)
+      #~(display
+         "guix: Skipping gitolite setup as the admin-pubkey has not been provided\n")))
+
+(define gitolite-service-type
+  (service-type
+   (name 'gitolite)
+   (extensions
+    (list (service-extension activation-service-type
+                             gitolite-activation)
+          (service-extension account-service-type
+                             gitolite-accounts)
+          (service-extension profile-service-type
+                             ;; The Gitolite package in Guix uses
+                             ;; gitolite-shell in the authorized_keys file, so
+                             ;; gitolite-shell needs to be on the PATH for
+                             ;; gitolite to work.
+                             (lambda (config)
+                               (list
+                                (gitolite-configuration-package config))))))
+   (default-value (gitolite-configuration))
+   (description
+    "Setup @command{gitolite}, a Git hosting tool providing access over SSH..
+By default, the @code{git} user is used, but this is configurable.
+Additionally, Gitolite can integrate with with tools like gitweb or cgit to
+provide a web interface to view selected repositories.")))
diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm
index 3b935a1b4..f2935b166 100644
--- a/gnu/tests/version-control.scm
+++ b/gnu/tests/version-control.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017, 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,14 +28,17 @@
   #:use-module (gnu services)
   #:use-module (gnu services version-control)
   #:use-module (gnu services cgit)
+  #:use-module (gnu services ssh)
   #:use-module (gnu services web)
   #:use-module (gnu services networking)
   #:use-module (gnu packages version-control)
+  #:use-module (gnu packages ssh)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix modules)
   #:export (%test-cgit
-            %test-git-http))
+            %test-git-http
+            %test-gitolite))
 
 (define README-contents
   "Hello!  This is what goes inside the 'README' file.")
@@ -300,3 +304,109 @@ HTTP-PORT."
    (name "git-http")
    (description "Connect to a running Git HTTP server.")
    (value (run-git-http-test))))
+
+\f
+;;;
+;;; Gitolite.
+;;;
+
+(define %gitolite-test-admin-keypair
+  (computed-file
+   "gitolite-test-admin-keypair"
+   (with-imported-modules (source-module-closure
+                           '((guix build utils)))
+     #~(begin
+         (use-modules (ice-9 match) (srfi srfi-26)
+                      (guix build utils))
+
+         (mkdir #$output)
+         (invoke #$(file-append openssh "/bin/ssh-keygen")
+                 "-f" (string-append #$output "/id_rsa")
+                 "-t" "rsa"
+                 "-q"
+                 "-N" "")))))
+
+(define %gitolite-os
+  (simple-operating-system
+   (dhcp-client-service)
+   (service openssh-service-type)
+   (service gitolite-service-type
+            (gitolite-configuration
+             (admin-pubkey
+              (file-append %gitolite-test-admin-keypair "/id_rsa.pub"))))))
+
+(define (run-gitolite-test)
+  (define os
+    (marionette-operating-system
+     %gitolite-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings `((2222 . 22)))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette)
+                             (guix build utils))
+      #~(begin
+          (use-modules (srfi srfi-64)
+                       (rnrs io ports)
+                       (gnu build marionette)
+                       (guix build utils))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "gitolite")
+
+          ;; Wait for sshd to be up and running.
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'ssh-daemon))
+             marionette))
+
+          (display #$%gitolite-test-admin-keypair)
+
+          (setenv "GIT_SSH_VARIANT" "ssh")
+          (setenv "GIT_SSH_COMMAND"
+                  (string-join
+                   '(#$(file-append openssh "/bin/ssh")
+                     "-i" #$(file-append %gitolite-test-admin-keypair "/id_rsa")
+                     "-o" "UserKnownHostsFile=/dev/null"
+                     "-o" "StrictHostKeyChecking=no")))
+
+          (test-eq "cloning the admin repository"
+            #t
+            (invoke #$(file-append git "/bin/git")
+                    "clone" "-v"
+                    "ssh://git@localhost:2222/gitolite-admin"
+                    "/tmp/clone"))
+
+          (with-directory-excursion "/tmp/clone"
+            (invoke #$(file-append git "/bin/git")
+                    "-c" "user.name=Guix" "-c" "user.email=guix"
+                    "commit"
+                    "-m" "Test commit"
+                    "--allow-empty")
+
+            (test-eq "pushing, and the associated hooks"
+              #t
+              (invoke #$(file-append git "/bin/git") "push")))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "gitolite" test))
+
+(define %test-gitolite
+  (system-test
+   (name "gitolite")
+   (description "Clone the Gitolite admin repository.")
+   (value (run-gitolite-test))))
-- 
2.18.0