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

[Christopher Baines]

---
 gnu/services/version-control.scm | 158 ++++++++++++++++++++++++++++++++++++++-
 gnu/tests/version-control.scm    | 103 ++++++++++++++++++++++++-
 2 files changed, 259 insertions(+), 2 deletions(-)

diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm
index afead87ec..60c3f8b81 100644
--- a/gnu/services/version-control.scm
+++ b/gnu/services/version-control.scm
@@ -40,7 +40,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 +213,143 @@ access to exported repositories under @file{/srv/git}."
             "")
         (list "fastcgi_param GIT_PROJECT_ROOT " git-root ";")
         "fastcgi_param PATH_INFO $1;"))))))
+
+
+;;;
+;;; 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"))
+  (rc-file      gitolite-configuration-rc-file
+                (default (gitolite-rc-file)))
+  (admin-pubkey gitolite-configuration-admin-pubkey
+                (default #f)))
+
+(define (gitolite-accounts config)
+  (let ((user (gitolite-configuration-user config)))
+    ;; User group and account to run Gitolite.
+    (list (user-group (name user) (system? #t))
+          (user-account
+           (name user)
+           (group user)
+           (system? #t)
+           (comment "Gitolite daemon user")
+           (home-directory "/var/lib/gitolite")))))
+
+(define gitolite-setup
+  (match-lambda
+    (($ <gitolite-configuration> package user rc-file admin-pubkey)
+     #~(begin
+         (use-modules (ice-9 match)
+                      (guix build utils))
+         (if (not (file-exists? "/var/lib/gitolite/.gitolite"))
+             (let ((user-info (getpwnam #$user)))
+               (simple-format #t "guix: gitolite: installing ~A\n"
+                              #$rc-file)
+               (symlink #$rc-file "/var/lib/gitolite/.gitolite.rc")
+
+               ;; The key must be writable, so copy it from the store
+               (copy-file #$admin-pubkey "/var/lib/gitolite/id_rsa.pub")
+
+               (chmod "/var/lib/gitolite/id_rsa.pub" #o500)
+               (chown "/var/lib/gitolite/id_rsa.pub"
+                      (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 "/var/lib/gitolite/.gitconfig"
+                 (lambda ()
+                   (display "[user]
+        name = GNU Guix
+        email = address@hidden
+")))
+
+               (match (primitive-fork)
+                 (0
+                  ;; 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
+                       (system* #$(file-append package "/bin/gitolite")
+                                "setup"
+                                "-pk" "/var/lib/gitolite/id_rsa.pub")))
+                    (lambda ()
+                      (primitive-exit 1))))
+                 (pid (waitpid pid)))
+
+               (delete-file "/var/lib/gitolite/id_rsa.pub")))))))
+
+(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)))
+   (default-value (gitolite-configuration))
+   (description
+    "")))
diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm
index 802473973..c6dc0457c 100644
--- a/gnu/tests/version-control.scm
+++ b/gnu/tests/version-control.scm
@@ -27,14 +27,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.")
@@ -306,3 +309,101 @@ HTTP-PORT."
    (name "git-http")
    (description "Connect to a running Git HTTP server.")
    (value (run-git-http-test))))
+
+
+;;;
+;;; 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-eq "service running"
+            'running!
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'ssh-daemon)
+                'running!)
+             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")))
+
+          ;; Make sure we can clone the repo from the host.
+          (test-eq "clone"
+            #t
+            (invoke #$(file-append git "/bin/git")
+                    "clone" "-v"
+                    "ssh://address@hidden:2222/gitolite-admin"
+                    "/tmp/clone"))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "gitolite" test))
+
+(define %test-gitolite
+  (system-test
+   (name "gitolite")
+   (description "Connect to a running Git HTTP server.")
+   (value (run-gitolite-test))))
-- 
2.16.2