services: Add patchwork.

2 files changed, 399 insertions, 2 deletions

diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index d71fed20ed..816cbaa3f0 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -32,12 +32,16 @@
   #:use-module (gnu system pam)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages admin)
+  #:use-module (gnu packages databases)
   #:use-module (gnu packages web)
+  #:use-module (gnu packages patchutils)
   #:use-module (gnu packages php)
+  #:use-module (gnu packages python)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages logging)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix utils)
   #:use-module (guix gexp)
   #:use-module ((guix store) #:select (text-file))
   #:use-module ((guix utils) #:select (version-major))
@@ -211,7 +215,41 @@
             varnish-configuration-parameters
             varnish-configuration-extra-options
 
-            varnish-service-type))
+            varnish-service-type
+
+            <patchwork-database-configuration>
+            patchwork-database-configuration
+            patchwork-database-configuration?
+            patchwork-database-configuration-engine
+            patchwork-database-configuration-name
+            patchwork-database-configuration-user
+            patchwork-database-configuration-password
+            patchwork-database-configuration-host
+            patchwork-database-configuration-port
+
+            <patchwork-settings-module>
+            patchwork-settings-module
+            patchwork-settings-module?
+            patchwork-settings-module-database-configuration
+            patchwork-settings-module-secret-key
+            patchwork-settings-module-allowed-hosts
+            patchwork-settings-module-default-from-email
+            patchwork-settings-module-static-url
+            patchwork-settings-module-admins
+            patchwork-settings-module-debug?
+            patchwork-settings-module-enable-rest-api?
+            patchwork-settings-module-enable-xmlrpc?
+            patchwork-settings-module-force-https-links?
+            patchwork-settings-module-extra-settings
+
+            <patchwork-configuration>
+            patchwork-configuration
+            patchwork-configuration?
+            patchwork-configuration-patchwork
+            patchwork-configuration-settings-module
+            patchwork-configuration-domain
+
+            patchwork-service-type))
 
 ;;; Commentary:
 ;;;
@@ -1269,3 +1307,260 @@ files.")
                              varnish-shepherd-service)))
    (default-value
      (varnish-configuration))))
+
+
+;;;
+;;; Patchwork
+;;;
+
+(define-record-type* <patchwork-database-configuration>
+  patchwork-database-configuration make-patchwork-database-configuration
+  patchwork-database-configuration?
+  (engine          patchwork-database-configuration-engine
+                   (default "django.db.backends.postgresql_psycopg2"))
+  (name            patchwork-database-configuration-name
+                   (default "patchwork"))
+  (user            patchwork-database-configuration-user
+                   (default ""))
+  (password        patchwork-database-configuration-password
+                   (default ""))
+  (host            patchwork-database-configuration-host
+                   (default ""))
+  (port            patchwork-database-configuration-port
+                   (default "")))
+
+(define-record-type* <patchwork-settings-module>
+  patchwork-settings-module make-patchwork-settings-module
+  patchwork-settings-module?
+  (database-configuration    patchwork-settings-module-database-configuration
+                             (default (patchwork-database-configuration)))
+  (secret-key                patchwork-settings-module-secret-key)
+  (allowed-hosts             patchwork-settings-module-allowed-hosts)
+  (default-from-email        patchwork-settings-module-default-from-email)
+  (static-url                patchwork-settings-module-static-url
+                             (default "/static/"))
+  (admins                    patchwork-settings-module-admins
+                             (default '()))
+  (debug?                    patchwork-settings-module-debug?
+                             (default #f))
+  (enable-rest-api?          patchwork-settings-module-enable-rest-api?
+                             (default #t))
+  (enable-xmlrpc?            patchwork-settings-module-enable-xmlrpc?
+                             (default #t))
+  (force-https-links?        patchwork-settings-module-force-https-links?
+                             (default #t))
+  (extra-settings            patchwork-settings-module-extra-settings
+                             (default "")))
+
+(define-record-type* <patchwork-configuration>
+  patchwork-configuration make-patchwork-configuration
+  patchwork-configuration?
+  (patchwork            patchwork-configuration-patchwork
+                        (default patchwork))
+  (settings-module      patchwork-configuration-settings-module)
+  (domain               patchwork-configuration-domain))
+
+(define-gexp-compiler (patchwork-settings-module-compiler
+                       (file <patchwork-settings-module>) system target)
+  (match file
+    (($ <patchwork-settings-module> database-configuration secret-key
+                                    allowed-hosts default-from-email
+                                    static-url admins debug? enable-rest-api?
+                                    enable-xmlrpc? force-https-links?
+                                    extra-configuration)
+     (gexp->derivation
+      "patchwork-settings"
+      (with-imported-modules '((guix build utils))
+        #~(let ((output #$output))
+            (define (create-__init__.py filename)
+              (call-with-output-file filename
+                (lambda (port) (display "" port))))
+
+            (use-modules (guix build utils)
+                         (srfi srfi-1))
+
+            (mkdir-p (string-append output "/guix/patchwork"))
+            (create-__init__.py
+             (string-append output "/guix/__init__.py"))
+            (create-__init__.py
+             (string-append output "/guix/patchwork/__init__.py"))
+
+            (call-with-output-file
+                (string-append output "/guix/patchwork/settings.py")
+              (lambda (port)
+                (display
+                 (string-append "from patchwork.settings.base import *
+
+# Configuration from Guix
+SECRET_KEY = '" #$secret-key "'
+
+ALLOWED_HOSTS = [
+" #$(string-concatenate
+     (map (lambda (allowed-host)
+            (string-append "  '" allowed-host "'\n"))
+          allowed-hosts))
+"]
+
+DEBUG = " #$(if debug? "True" "False") "
+
+ENABLE_REST_API = " #$(if enable-xmlrpc? "True" "False") "
+ENABLE_XMLRPC = " #$(if enable-xmlrpc? "True" "False") "
+
+FORCE_HTTPS_LINKS = " #$(if force-https-links? "True" "False") "
+
+DATABASES = {
+    'default': {
+" #$(match database-configuration
+      (($ <patchwork-database-configuration>
+          engine name user password host port)
+       (string-append
+        "        'ENGINE': '" engine "',\n"
+        "        'NAME': '" name "',\n"
+        "        'USER': '" user "',\n"
+        "        'PASSWORD': '" password "',\n"
+        "        'HOST': '" host "',\n"
+        "        'PORT': '" port "',\n"))) "
+    },
+}
+
+" #$(if debug?
+        #~(string-append "STATIC_ROOT = '" #$(file-append patchwork "/share/patchwork/htdocs") "'")
+        #~(string-append "STATIC_URL = '" #$static-url "'")) "
+
+STATICFILES_STORAGE = (
+  'django.contrib.staticfiles.storage.StaticFilesStorage'
+)
+
+# Guix Extra Configuration
+" #$extra-configuration "
+") port)))
+            #t))
+      #:local-build? #t))))
+
+(define (patchwork-wsgi-wrapper patchwork)
+  (define patchwork-wsgi.py
+    (file-append patchwork
+                 (string-append
+                  "/lib/python"
+                  (version-major+minor
+                   (package-version python))
+                  "/site-packages/patchwork/wsgi.py")))
+
+  (mixed-text-file
+   "patchwork-wsgi.py"
+   "import os\n"
+   "\n"
+   "exec(open(\"" patchwork-wsgi.py "\").read())\n"))
+
+(define patchwork-httpd-configuration
+  (match-lambda
+    (($ <patchwork-configuration> patchwork settings-module
+                                  domain)
+
+     (define wsgi.py (patchwork-wsgi-wrapper patchwork))
+
+     (list "WSGISocketPrefix /var/run/mod_wsgi"
+           (list "LoadModule wsgi_module "
+                 (file-append mod-wsgi "/modules/mod_wsgi.so"))
+           (httpd-virtualhost
+            "*:8080"
+            `("ServerAdmin admin@example.com
+ServerName " ,domain "
+
+LogFormat \"%v %h %l %u %t \\\"%r\\\" %>s %b \\\"%{Referer}i\\\" \\\"%{User-Agent}i\\\"\" customformat
+LogLevel info
+CustomLog \"/var/log/httpd/" ,domain "-access_log\" customformat
+
+ErrorLog /var/log/httpd/error.log
+
+WSGIScriptAlias / " ,wsgi.py "
+WSGIDaemonProcess patchwork user=httpd group=httpd processes=1 threads=2 display-name=%{GROUP} lang='en_US.UTF-8' locale='en_US.UTF-8' python-path=" ,settings-module "
+WSGIProcessGroup patchwork
+WSGIPassAuthorization On
+
+<Files " ,wsgi.py ">
+  Require all granted
+</Files>
+
+Alias /static " ,patchwork "/share/patchwork/htdocs
+<Directory \"/srv/http/" ,domain "/\">
+    AllowOverride None
+    Options MultiViews Indexes SymlinksIfOwnerMatch IncludesNoExec
+    Require method GET POST OPTIONS
+</Directory>"))))))
+
+(define (patchwork-setup-gexp settings-module)
+  (with-imported-modules (source-module-closure
+                          '((guix build utils)))
+    #~(lambda ()
+        (catch #t
+          (lambda ()
+            (let ((pid (primitive-fork))
+                  (user (getpwnam "postgres")))
+              (if (eq? pid 0)
+                  (dynamic-wind
+                    (const #t)
+                    (lambda ()
+                      (setgid (passwd:gid user))
+                      (setuid (passwd:uid user))
+                      (primitive-exit
+                       (if (and
+                            (zero?
+                             (system* #$(file-append postgresql "/bin/createuser")
+                                      "httpd"))
+                            (zero?
+                             (system* #$(file-append postgresql "/bin/createdb")
+                                      "-O" "httpd" "patchwork")))
+                           0
+                           1)))
+                    (lambda ()
+                      (primitive-exit 1)))
+                  (zero? (cdr (waitpid pid)))))
+            (let ((pid (primitive-fork))
+                  (user (getpwnam "httpd")))
+              (if (eq? pid 0)
+                  (dynamic-wind
+                    (const #t)
+                    (lambda ()
+                      (setgid (passwd:gid user))
+                      (setuid (passwd:uid user))
+                      ;; TODO Extract
+                      (setenv "DJANGO_SECRET_KEY" "testsecretkey")
+                      (setenv "DATABASE_NAME" "patchwork")
+                      (setenv "PYTHONPATH" #$settings-module)
+                      (primitive-exit
+                       (if (and
+                            (zero?
+                             (system* #$(file-append patchwork
+                                                     "/bin/patchwork-admin")
+                                      "migrate")))
+                           0
+                           1)))
+                    (lambda ()
+                      (primitive-exit 1)))
+                  (zero? (cdr (waitpid pid))))))
+          (lambda (key . parameters)
+            (format (current-error-port)
+                    "Uncaught throw to '~a: ~a\n" key parameters)
+            #f)))))
+
+(define patchwork-service-type
+  (service-type
+   (name 'patchwork-setup)
+   (extensions
+    (list (service-extension httpd-service-type
+                             patchwork-httpd-configuration)
+          (service-extension
+           shepherd-root-service-type
+           (match-lambda
+             (($ <patchwork-configuration> patchwork settings-module
+                                           domain)
+              (list (shepherd-service
+                     (requirement '(postgres))
+                     (provision '(patchwork-setup))
+                     (start (patchwork-setup-gexp settings-module))
+                     (stop #~(const #f))
+                     (respawn? #f)
+                     (documentation "Setup patchwork."))))))))
+   (description
+    "patchwork")))
diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm
index 319655396a..fbdf78a036 100644
--- a/gnu/tests/web.scm
+++ b/gnu/tests/web.scm
@@ -28,15 +28,27 @@
   #:use-module (gnu system vm)
   #:use-module (gnu services)
   #:use-module (gnu services web)
+  #:use-module (gnu services databases)
   #:use-module (gnu services networking)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu packages databases)
+  #:use-module (gnu packages patchutils)
+  #:use-module (gnu packages python)
+  #:use-module (gnu packages web)
+  #:use-module (guix packages)
+  #:use-module (guix modules)
+  #:use-module (guix records)
   #:use-module (guix gexp)
   #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
   #:export (%test-httpd
             %test-nginx
             %test-varnish
             %test-php-fpm
             %test-hpcguix-web
-            %test-tailon))
+            %test-tailon
+            %test-patchwork))
 
 (define %index.html-contents
   ;; Contents of the /index.html file.
@@ -498,3 +510,93 @@ HTTP-PORT."
    (name "tailon")
    (description "Connect to a running Tailon server.")
    (value (run-tailon-test))))
+
+
+;;;
+;;; Patchwork
+;;;
+
+(define %patchwork-os
+  (simple-operating-system
+   (service dhcp-client-service-type)
+   (service httpd-service-type
+            (httpd-configuration
+             (config
+              (httpd-config-file
+               (listen '("8080"))))))
+   (service postgresql-service-type)
+   (service patchwork-service-type
+            (patchwork-configuration
+             (settings-module
+              (patchwork-settings-module
+               (secret-key "00000")
+               (allowed-hosts '("*"))
+               (default-from-email "")
+               (debug? #t)))
+             (domain "localhost")))))
+
+(define* (run-patchwork-test)
+  "Run tests in %NGINX-OS, which has nginx running and listening on
+HTTP-PORT."
+  (define os
+    (marionette-operating-system
+     %patchwork-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define forwarded-port 8080)
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings `((8080 . ,forwarded-port)))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette)
+                       (web uri)
+                       (web client)
+                       (web response))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "patchwork")
+
+          (test-assert "httpd service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'httpd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((#t) #t)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          ;; Retrieve the index.html file we put in /srv.
+          (test-equal "http-get"
+            200
+            (let-values
+                (((response text)
+                  (http-get #$(simple-format
+                               #f "http://localhost:~A/" forwarded-port)
+                            #:decode-body? #t)))
+              (response-code response)))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "patchwork-test" test))
+
+(define %test-patchwork
+  (system-test
+   (name "patchwork")
+   (description "")
+   (value (run-patchwork-test))))