diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/cgit.scm | 3 | ||||
| -rw-r--r-- | gnu/services/getmail.scm | 380 | ||||
| -rw-r--r-- | gnu/services/herd.scm | 4 | ||||
| -rw-r--r-- | gnu/services/sddm.scm | 16 | ||||
| -rw-r--r-- | gnu/services/web.scm | 368 |
5 files changed, 760 insertions, 11 deletions
diff --git a/gnu/services/cgit.scm b/gnu/services/cgit.scm index a84a2dadb2..94ca9e281a 100644 --- a/gnu/services/cgit.scm +++ b/gnu/services/cgit.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -581,7 +582,7 @@ removed for the URL and name.") (root-readme (string "") "The content of the file specified with this option will be included -verbatim below thef \"about\" link on the repository index page.") +verbatim below the \"about\" link on the repository index page.") (root-title (string "") "Text printed as heading on the repository index page.") diff --git a/gnu/services/getmail.scm b/gnu/services/getmail.scm new file mode 100644 index 0000000000..b807bb3a5d --- /dev/null +++ b/gnu/services/getmail.scm @@ -0,0 +1,380 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; 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 getmail) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services configuration) + #:use-module (gnu services shepherd) + #:use-module (gnu system pam) + #:use-module (gnu system shadow) + #:use-module (gnu packages mail) + #:use-module (gnu packages admin) + #:use-module (gnu packages tls) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:export (getmail-retriever-configuration + getmail-retriever-configuration-extra-parameters + getmail-destination-configuration + getmail-options-configuration + getmail-configuration-file + getmail-configuration + getmail-service-type)) + +;;; Commentary: +;;; +;;; Service for the getmail mail retriever. +;;; +;;; Code: + +(define (uglify-field-name field-name) + (let ((str (symbol->string field-name))) + (string-join (string-split (if (string-suffix? "?" str) + (substring str 0 (1- (string-length str))) + str) + #\-) + "_"))) + +(define (serialize-field field-name val) + #~(let ((val '#$val)) + (format #f "~a = ~a\n" + #$(uglify-field-name field-name) + (cond + ((list? val) + (string-append + "(" + (string-concatenate + (map (lambda (list-val) + (format #f "\"~a\", " list-val)) + val)) + ")")) + (else + val))))) + +(define (serialize-string field-name val) + (if (string=? val "") + "" + (serialize-field field-name val))) + +(define (string-or-filelike? val) + (or (string? val) + (file-like? val))) +(define (serialize-string-or-filelike field-name val) + (if (equal? val "") + "" + (serialize-field field-name val))) + +(define (serialize-boolean field-name val) + (serialize-field field-name (if val "true" "false"))) + +(define (non-negative-integer? val) + (and (exact-integer? val) (not (negative? val)))) +(define (serialize-non-negative-integer field-name val) + (serialize-field field-name val)) + +(define serialize-list serialize-field) + +(define parameter-alist? list?) +(define (serialize-parameter-alist field-name val) + #~(string-append + #$@(map (match-lambda + ((key . value) + (serialize-field key value))) + val))) + +(define (serialize-getmail-retriever-configuration field-name val) + (serialize-configuration val getmail-retriever-configuration-fields)) + +(define-configuration getmail-retriever-configuration + (type + (string "SimpleIMAPSSLRetriever") + "The type of mail retriever to use. Valid values include +@samp{passwd} and @samp{static}.") + (server + (string 'unset) + "Space separated list of arguments to the userdb driver.") + (username + (string 'unset) + "Space separated list of arguments to the userdb driver.") + (port + (non-negative-integer #f) + "Space separated list of arguments to the userdb driver.") + (password + (string "") + "Override fields from passwd.") + (password-command + (list '()) + "Override fields from passwd.") + (keyfile + (string "") + "PEM-formatted key file to use for the TLS negotiation") + (certfile + (string "") + "PEM-formatted certificate file to use for the TLS negotiation") + (ca-certs + (string "") + "CA certificates to use") + (extra-parameters + (parameter-alist '()) + "Extra retriever parameters")) + +(define (serialize-getmail-destination-configuration field-name val) + (serialize-configuration val getmail-destination-configuration-fields)) + +(define-configuration getmail-destination-configuration + (type + (string 'unset) + "The type of mail destination. Valid values include @samp{Maildir}, +@samp{Mboxrd} and @samp{MDA_external}.") + (path + (string-or-filelike "") + "The path option for the mail destination. The behaviour depends on the +chosen type.") + (extra-parameters + (parameter-alist '()) + "Extra destination parameters")) + +(define (serialize-getmail-options-configuration field-name val) + (serialize-configuration val getmail-options-configuration-fields)) + +(define-configuration getmail-options-configuration + (verbose + (non-negative-integer 1) + "If set to @samp{0}, getmail will only print warnings and errors. A value +of @samp{1} means that messages will be printed about retrieving and deleting +messages. If set to @samp{2}, getmail will print messages about each of it's +actions.") + (read-all + (boolean #t) + "If true, getmail will retrieve all available messages. Otherwise it will +only retrieve messages it hasn't seen previously.") + (delete + (boolean #f) + "If set to true, messages will be deleted from the server after retrieving +and successfully delivering them. Otherwise, messages will be left on the +server.") + (delete-after + (non-negative-integer 0) + "Getmail will delete messages this number of days after seeing them, if +they have not been delivered. This means messages will be left on the server +this number of days after delivering them. A value of @samp{0} disabled this +feature.") + (delete-bigger-than + (non-negative-integer 0) + "Delete messages larger than this of bytes after retrieving them, even if +the delete and delete-after options are disabled. A value of @samp{0} +disables this feature.") + (max-bytes-per-session + (non-negative-integer 0) + "Retrieve messages totalling up to this number of bytes before closing the +session with the server. A value of @samp{0} disables this feature.") + (max-message-size + (non-negative-integer 0) + "Don't retrieve messages larger than this number of bytes. A value of +@samp{0} disables this feature.") + (delivered-to + (boolean #t) + "If true, getmail will add a Delivered-To header to messages.") + (received + (boolean #t) + "If set, getmail adds a Received header to the messages.") + (message-log + (string "") + "Getmail will record a log of its actions to the named file. A value of +@samp{\"\"} disables this feature.") + (message-log-syslog + (boolean #t) + "If true, getmail will record a log of its actions using the system +logger.") + (message-log-verbose + (boolean #t) + "If true, getmail will log information about messages not retrieved and the +reason for not retrieving them, as well as starting and ending information +lines.") + (extra-parameters + (parameter-alist '()) + "Extra options to include.")) + +(define (serialize-getmail-configuration-file field-name val) + (match val + (($ <getmail-configuration-file> location + retriever destination options) + #~(string-append + "[retriever]\n" + #$(serialize-getmail-retriever-configuration #f retriever) + "\n[destination]\n" + #$(serialize-getmail-destination-configuration #f destination) + "\n[options]\n" + #$(serialize-getmail-options-configuration #f options))))) + +(define-configuration getmail-configuration-file + (retriever + (getmail-retriever-configuration (getmail-retriever-configuration)) + "What mail account to retrieve mail from, and how to access that account.") + (destination + (getmail-destination-configuration (getmail-destination-configuration)) + "What to do with retrieved messages.") + (options + (getmail-options-configuration (getmail-options-configuration)) + "Configure getmail.")) + +(define (serialize-symbol field-name val) "") +(define (serialize-getmail-configuration field-name val) "") + +(define-configuration getmail-configuration + (name + (symbol "unset") + "A symbol to identify the getmail service.") + (package + (package getmail) + "The getmail package to use.") + (user + (string "getmail") + "The user to run getmail as.") + (group + (string "getmail") + "The group to run getmail as.") + (directory + (string "/var/lib/getmail/default") + "The getmail directory to use.") + (rcfile + (getmail-configuration-file (getmail-configuration-file)) + "The getmail configuration file to use.") + (idle + (list '()) + "A list of mailboxes that getmail should wait on the server for new mail +notifications. This depends on the server supporting the IDLE extension.") + (environment-variables + (list '()) + "Environment variables to set for getmail.")) + +(define (generate-getmail-documentation) + (generate-documentation + `((getmail-configuration + ,getmail-configuration-fields + (rcfile getmail-configuration-file)) + (getmail-configuration-file + ,getmail-configuration-file-fields + (retriever getmail-retriever-configuration) + (destination getmail-destination-configuration) + (options getmail-options-configuration)) + (getmail-retriever-configuration ,getmail-retriever-configuration-fields) + (getmail-destination-configuration ,getmail-destination-configuration-fields) + (getmail-options-configuration ,getmail-options-configuration-fields)) + 'getmail-configuration)) + +(define-gexp-compiler (getmail-configuration-file-compiler + (rcfile <getmail-configuration-file>) system target) + (gexp->derivation + "getmailrc" + #~(call-with-output-file #$output + (lambda (port) + (display #$(serialize-getmail-configuration-file #f rcfile) + port))) + #:system system + #:target target)) + +(define (getmail-accounts configs) + (let ((users (delete-duplicates + (map getmail-configuration-user + configs))) + (groups (delete-duplicates + (map getmail-configuration-group + configs)))) + (append + (map (lambda (group) + (user-group + (name group) + (system? #t))) + groups) + (map (lambda (user) + (user-account + (name user) + (group (getmail-configuration-group + (find (lambda (config) + (and + (string=? user (getmail-configuration-user config)) + (getmail-configuration-group config))) + configs))) + (system? #t) + (comment "Getmail user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin")))) + users)))) + +(define (getmail-activation configs) + "Return the activation GEXP for CONFIGS." + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + #$@(map + (lambda (config) + #~(let* ((pw (getpw #$(getmail-configuration-user config))) + (uid (passwd:uid pw)) + (gid (passwd:gid pw)) + (getmaildir #$(getmail-configuration-directory config))) + (mkdir-p getmaildir) + (chown getmaildir uid gid))) + configs)))) + +(define (getmail-shepherd-services configs) + "Return a list of <shepherd-service> for CONFIGS." + (map (match-lambda + (($ <getmail-configuration> location name package + user group directory rcfile idle + environment-variables) + (shepherd-service + (documentation "Run getmail.") + (provision (list (symbol-append 'getmail- name))) + (requirement '(networking)) + (start #~(make-forkexec-constructor + `(#$(file-append package "/bin/getmail") + ,(string-append "--getmaildir=" #$directory) + #$@(map (lambda (idle) + (string-append "--idle=" idle)) + idle) + ,(string-append "--rcfile=" #$rcfile)) + #:user #$user + #:group #$group + #:environment-variables + (list #$@environment-variables) + #:log-file + #$(string-append "/var/log/getmail-" + (symbol->string name))))))) + configs)) + +(define getmail-service-type + (service-type + (name 'getmail) + (extensions + (list (service-extension shepherd-root-service-type + getmail-shepherd-services) + (service-extension activation-service-type + getmail-activation) + (service-extension account-service-type + getmail-accounts))) + (description + "Run @command{getmail}, a mail retriever program.") + (default-value '()) + (compose concatenate) + (extend append))) diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 9fe757fb73..0008746fe9 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -76,7 +76,7 @@ return the socket." (catch 'system-error (lambda () (connect sock address) - (setvbuf sock _IOFBF 1024) + (setvbuf sock 'block 1024) sock) (lambda args (close-port sock) diff --git a/gnu/services/sddm.scm b/gnu/services/sddm.scm index b433c59e12..b0e6d40260 100644 --- a/gnu/services/sddm.scm +++ b/gnu/services/sddm.scm @@ -175,7 +175,7 @@ Relogin=" (if (sddm-configuration-relogin? config) (define (sddm-etc-service config) (list `("sddm.conf" ,(sddm-configuration-file config)))) -(define (sddm-pam-service) +(define (sddm-pam-service config) "Return a PAM service for @command{sddm}." (pam-service (name "sddm") @@ -190,7 +190,9 @@ Relogin=" (if (sddm-configuration-relogin? config) (pam-entry (control "required") (module "pam_succeed_if.so") - (arguments (list "uid >= 1000" "quiet"))) + (arguments (list (string-append "uid >= " + (number->string (sddm-configuration-minimum-uid config))) + "quiet"))) ;; should be factored out into system-auth (pam-entry (control "required") @@ -249,7 +251,7 @@ Relogin=" (if (sddm-configuration-relogin? config) (control "required") (module "pam_unix.so")))))) -(define (sddm-autologin-pam-service) +(define (sddm-autologin-pam-service config) "Return a PAM service for @command{sddm-autologin}" (pam-service (name "sddm-autologin") @@ -261,7 +263,9 @@ Relogin=" (if (sddm-configuration-relogin? config) (pam-entry (control "required") (module "pam_succeed_if.so") - (arguments (list "uid >= 1000" "quiet"))) + (arguments (list (string-append "uid >= " + (number->string (sddm-configuration-minimum-uid config))) + "quiet"))) (pam-entry (control "required") (module "pam_permit.so")))) @@ -282,9 +286,9 @@ Relogin=" (if (sddm-configuration-relogin? config) (module "sddm")))))) (define (sddm-pam-services config) - (list (sddm-pam-service) + (list (sddm-pam-service config) (sddm-greeter-pam-service) - (sddm-autologin-pam-service))) + (sddm-autologin-pam-service config))) (define %sddm-accounts (list (user-group (name "sddm") (system? #t)) diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 84294db53b..35efddb0ae 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2017 nee <nee-git@hidamari.blue> ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr> -;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2017, 2018, 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. @@ -29,14 +29,23 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services admin) + #:use-module (gnu services getmail) + #:use-module (gnu services mail) #: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 gnupg) + #:use-module (gnu packages guile) #:use-module (gnu packages logging) + #:use-module (guix packages) #: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)) @@ -210,7 +219,42 @@ 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-virtualhost + patchwork-service-type)) ;;; Commentary: ;;; @@ -1268,3 +1312,323 @@ 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 "httpd")) + (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-file patchwork-settings-module-secret-key-file + (default "/etc/patchwork/django-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)) + (domain patchwork-configuration-domain) + (settings-module patchwork-configuration-settings-module) + (static-path patchwork-configuration-static-url + (default "/static/")) + (getmail-retriever-config getmail-retriever-config)) + +;; Django uses a Python module for configuration, so this compiler generates a +;; Python module from the configuration record. +(define-gexp-compiler (patchwork-settings-module-compiler + (file <patchwork-settings-module>) system target) + (match file + (($ <patchwork-settings-module> database-configuration secret-key-file + 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 +with open('" #$secret-key-file "') as f: + SECRET_KEY = f.read().strip() + +ALLOWED_HOSTS = [ +" #$(string-concatenate + (map (lambda (allowed-host) + (string-append " '" allowed-host "'\n")) + allowed-hosts)) +"] + +ADMINS = [ +" #$(string-concatenate + (map (match-lambda + ((name email-address) + (string-append + "('" name "','" email-address "'),"))) + admins)) +"] + +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-virtualhost + (match-lambda + (($ <patchwork-configuration> patchwork domain + settings-module static-path + getmail-retriever-config) + (define wsgi.py + (file-append patchwork + (string-append + "/lib/python" + (version-major+minor + (package-version python)) + "/site-packages/patchwork/wsgi.py"))) + + (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 " ,(package-name 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 " ,(package-name patchwork) " +WSGIPassAuthorization On + +<Files " ,wsgi.py "> + Require all granted +</Files> + +" ,@(if static-path + `("Alias " ,static-path " " ,patchwork "/share/patchwork/htdocs/") + '()) +" +<Directory \"/srv/http/" ,domain "/\"> + AllowOverride None + Options MultiViews Indexes SymlinksIfOwnerMatch IncludesNoExec + Require method GET POST OPTIONS +</Directory>"))))) + +(define (patchwork-httpd-configuration patchwork-configuration) + (list "WSGISocketPrefix /var/run/mod_wsgi" + (list "LoadModule wsgi_module " + (file-append mod-wsgi "/modules/mod_wsgi.so")) + (patchwork-virtualhost patchwork-configuration))) + +(define (patchwork-django-admin-gexp patchwork settings-module) + #~(lambda command + (let ((pid (primitive-fork)) + (user (getpwnam "httpd"))) + (if (eq? pid 0) + (dynamic-wind + (const #t) + (lambda () + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + + (setenv "DJANGO_SETTINGS_MODULE" "guix.patchwork.settings") + (setenv "PYTHONPATH" #$settings-module) + (primitive-exit + (if (zero? + (apply system* + #$(file-append patchwork "/bin/patchwork-admin") + command)) + 0 + 1))) + (lambda () + (primitive-exit 1))) + (zero? (cdr (waitpid pid))))))) + +(define (patchwork-django-admin-action patchwork settings-module) + (shepherd-action + (name 'django-admin) + (documentation + "Run a django admin command for patchwork") + (procedure (patchwork-django-admin-gexp patchwork settings-module)))) + +(define patchwork-shepherd-services + (match-lambda + (($ <patchwork-configuration> patchwork domain + settings-module static-path + getmail-retriever-config) + (define secret-key-file-creation-gexp + (if (patchwork-settings-module? settings-module) + (with-extensions (list guile-gcrypt) + #~(let ((secret-key-file + #$(patchwork-settings-module-secret-key-file + settings-module))) + (use-modules (guix build utils) + (gcrypt random)) + + (unless (file-exists? secret-key-file) + (mkdir-p (dirname secret-key-file)) + (call-with-output-file secret-key-file + (lambda (port) + (display (random-token 30 'very-strong) port))) + (let* ((pw (getpwnam "httpd")) + (uid (passwd:uid pw)) + (gid (passwd:gid pw))) + (chown secret-key-file uid gid) + (chmod secret-key-file #o400))))) + #~())) + + (list (shepherd-service + (requirement '(postgres)) + (provision (list (string->symbol + (string-append (package-name patchwork) + "-setup")))) + (start + #~(lambda () + (define run-django-admin-command + #$(patchwork-django-admin-gexp patchwork + settings-module)) + + #$secret-key-file-creation-gexp + + (run-django-admin-command "migrate"))) + (stop #~(const #f)) + (actions + (list (patchwork-django-admin-action patchwork + settings-module))) + (respawn? #f) + (documentation "Setup Patchwork.")))))) + +(define patchwork-getmail-configs + (match-lambda + (($ <patchwork-configuration> patchwork domain + settings-module static-path + getmail-retriever-config) + (list + (getmail-configuration + (name (string->symbol (package-name patchwork))) + (user "httpd") + (directory (string-append + "/var/lib/getmail/" (package-name patchwork))) + (rcfile + (getmail-configuration-file + (retriever getmail-retriever-config) + (destination + (getmail-destination-configuration + (type "MDA_external") + (path (file-append patchwork "/bin/patchwork-admin")) + (extra-parameters + '((arguments . ("parsemail")))))) + (options + (getmail-options-configuration + (read-all #f) + (delivered-to #f) + (received #f))))) + (idle (assq-ref + (getmail-retriever-configuration-extra-parameters + getmail-retriever-config) + 'mailboxes)) + (environment-variables + (list "DJANGO_SETTINGS_MODULE=guix.patchwork.settings" + #~(string-append "PYTHONPATH=" #$settings-module)))))))) + +(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 + patchwork-shepherd-services) + (service-extension getmail-service-type + patchwork-getmail-configs))) + (description + "Patchwork patch tracking system."))) |