aboutsummaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/base.scm285
-rw-r--r--gnu/services/cgit.scm686
-rw-r--r--gnu/services/configuration.scm17
-rw-r--r--gnu/services/databases.scm104
-rw-r--r--gnu/services/dict.scm3
-rw-r--r--gnu/services/mail.scm147
-rw-r--r--gnu/services/messaging.scm106
-rw-r--r--gnu/services/networking.scm102
-rw-r--r--gnu/services/version-control.scm121
9 files changed, 1153 insertions, 418 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 69e211ffa3..343123a377 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -55,7 +55,6 @@
#:export (fstab-service-type
root-file-system-service
file-system-service-type
- user-unmount-service
swap-service
user-processes-service-type
host-name-service
@@ -464,7 +463,36 @@ FILE-SYSTEM."
(start #~(const #t))
(stop #~(const #f))))
- (cons sink (map file-system-shepherd-service file-systems))))
+ (define known-mount-points
+ (map file-system-mount-point file-systems))
+
+ (define user-unmount
+ (shepherd-service
+ (documentation "Unmount manually-mounted file systems.")
+ (provision '(user-file-systems))
+ (start #~(const #t))
+ (stop #~(lambda args
+ (define (known? mount-point)
+ (member mount-point
+ (cons* "/proc" "/sys" '#$known-mount-points)))
+
+ ;; Make sure we don't keep the user's mount points busy.
+ (chdir "/")
+
+ (for-each (lambda (mount-point)
+ (format #t "unmounting '~a'...~%" mount-point)
+ (catch 'system-error
+ (lambda ()
+ (umount mount-point))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (format #t "failed to unmount '~a': ~a~%"
+ mount-point (strerror errno))))))
+ (filter (negate known?) (mount-points)))
+ #f))))
+
+ (cons* sink user-unmount
+ (map file-system-shepherd-service file-systems))))
(define file-system-service-type
(service-type (name 'file-systems)
@@ -483,38 +511,6 @@ FILE-SYSTEM."
"Provide Shepherd services to mount and unmount the given
file systems, as well as corresponding @file{/etc/fstab} entries.")))
-(define user-unmount-service-type
- (shepherd-service-type
- 'user-file-systems
- (lambda (known-mount-points)
- (shepherd-service
- (documentation "Unmount manually-mounted file systems.")
- (provision '(user-file-systems))
- (start #~(const #t))
- (stop #~(lambda args
- (define (known? mount-point)
- (member mount-point
- (cons* "/proc" "/sys" '#$known-mount-points)))
-
- ;; Make sure we don't keep the user's mount points busy.
- (chdir "/")
-
- (for-each (lambda (mount-point)
- (format #t "unmounting '~a'...~%" mount-point)
- (catch 'system-error
- (lambda ()
- (umount mount-point))
- (lambda args
- (let ((errno (system-error-errno args)))
- (format #t "failed to unmount '~a': ~a~%"
- mount-point (strerror errno))))))
- (filter (negate known?) (mount-points)))
- #f))))))
-
-(define (user-unmount-service known-mount-points)
- "Return a service whose sole purpose is to unmount file systems not listed
-in KNOWN-MOUNT-POINTS when it is stopped."
- (service user-unmount-service-type known-mount-points))
;;;
@@ -941,119 +937,122 @@ to use as the tty. This is primarily useful for headless systems."
;; mingetty-shepherd-service).
(requirement '(user-processes host-name udev))
- (start #~(let ((tty #$(default-serial-port)))
- (if tty
- (make-forkexec-constructor
- (list #$(file-append util-linux "/sbin/agetty")
- #$@extra-options
- #$@(if eight-bits?
- #~("--8bits")
- #~())
- #$@(if no-reset?
- #~("--noreset")
- #~())
- #$@(if remote?
- #~("--remote")
- #~())
- #$@(if flow-control?
- #~("--flow-control")
- #~())
- #$@(if host
- #~("--host" #$host)
- #~())
- #$@(if no-issue?
- #~("--noissue")
- #~())
- #$@(if init-string
- #~("--init-string" #$init-string)
- #~())
- #$@(if no-clear?
- #~("--noclear")
- #~())
+ (start #~(lambda args
+ (let ((defaulted-tty #$(or tty (default-serial-port))))
+ (apply
+ (if defaulted-tty
+ (make-forkexec-constructor
+ (list #$(file-append util-linux "/sbin/agetty")
+ #$@extra-options
+ #$@(if eight-bits?
+ #~("--8bits")
+ #~())
+ #$@(if no-reset?
+ #~("--noreset")
+ #~())
+ #$@(if remote?
+ #~("--remote")
+ #~())
+ #$@(if flow-control?
+ #~("--flow-control")
+ #~())
+ #$@(if host
+ #~("--host" #$host)
+ #~())
+ #$@(if no-issue?
+ #~("--noissue")
+ #~())
+ #$@(if init-string
+ #~("--init-string" #$init-string)
+ #~())
+ #$@(if no-clear?
+ #~("--noclear")
+ #~())
;;; FIXME This doesn't work as expected. According to agetty(8), if this option
;;; is not passed, then the default is 'auto'. However, in my tests, when that
;;; option is selected, agetty never presents the login prompt, and the
;;; term-ttyS0 service respawns every few seconds.
- #$@(if local-line
- #~(#$(match local-line
- ('auto "--local-line=auto")
- ('always "--local-line=always")
- ('never "-local-line=never")))
- #~())
- #$@(if tty
- #~()
- #~("--keep-baud"))
- #$@(if extract-baud?
- #~("--extract-baud")
- #~())
- #$@(if skip-login?
- #~("--skip-login")
- #~())
- #$@(if no-newline?
- #~("--nonewline")
- #~())
- #$@(if login-options
- #~("--login-options" #$login-options)
- #~())
- #$@(if chroot
- #~("--chroot" #$chroot)
- #~())
- #$@(if hangup?
- #~("--hangup")
- #~())
- #$@(if keep-baud?
- #~("--keep-baud")
- #~())
- #$@(if timeout
- #~("--timeout" #$(number->string timeout))
- #~())
- #$@(if detect-case?
- #~("--detect-case")
- #~())
- #$@(if wait-cr?
- #~("--wait-cr")
- #~())
- #$@(if no-hints?
- #~("--nohints?")
- #~())
- #$@(if no-hostname?
- #~("--nohostname")
- #~())
- #$@(if long-hostname?
- #~("--long-hostname")
- #~())
- #$@(if erase-characters
- #~("--erase-chars" #$erase-characters)
- #~())
- #$@(if kill-characters
- #~("--kill-chars" #$kill-characters)
- #~())
- #$@(if chdir
- #~("--chdir" #$chdir)
- #~())
- #$@(if delay
- #~("--delay" #$(number->string delay))
- #~())
- #$@(if nice
- #~("--nice" #$(number->string nice))
- #~())
- #$@(if auto-login
- (list "--autologin" auto-login)
- '())
- #$@(if login-program
- #~("--login-program" #$login-program)
- #~())
- #$@(if login-pause?
- #~("--login-pause")
- #~())
- #$(or tty (default-serial-port))
- #$@(if baud-rate
- #~(#$baud-rate)
- #~())
- #$@(if term
- #~(#$term)
- #~()))))
- (const #f))) ; never start.
+ #$@(if local-line
+ #~(#$(match local-line
+ ('auto "--local-line=auto")
+ ('always "--local-line=always")
+ ('never "-local-line=never")))
+ #~())
+ #$@(if tty
+ #~()
+ #~("--keep-baud"))
+ #$@(if extract-baud?
+ #~("--extract-baud")
+ #~())
+ #$@(if skip-login?
+ #~("--skip-login")
+ #~())
+ #$@(if no-newline?
+ #~("--nonewline")
+ #~())
+ #$@(if login-options
+ #~("--login-options" #$login-options)
+ #~())
+ #$@(if chroot
+ #~("--chroot" #$chroot)
+ #~())
+ #$@(if hangup?
+ #~("--hangup")
+ #~())
+ #$@(if keep-baud?
+ #~("--keep-baud")
+ #~())
+ #$@(if timeout
+ #~("--timeout" #$(number->string timeout))
+ #~())
+ #$@(if detect-case?
+ #~("--detect-case")
+ #~())
+ #$@(if wait-cr?
+ #~("--wait-cr")
+ #~())
+ #$@(if no-hints?
+ #~("--nohints?")
+ #~())
+ #$@(if no-hostname?
+ #~("--nohostname")
+ #~())
+ #$@(if long-hostname?
+ #~("--long-hostname")
+ #~())
+ #$@(if erase-characters
+ #~("--erase-chars" #$erase-characters)
+ #~())
+ #$@(if kill-characters
+ #~("--kill-chars" #$kill-characters)
+ #~())
+ #$@(if chdir
+ #~("--chdir" #$chdir)
+ #~())
+ #$@(if delay
+ #~("--delay" #$(number->string delay))
+ #~())
+ #$@(if nice
+ #~("--nice" #$(number->string nice))
+ #~())
+ #$@(if auto-login
+ (list "--autologin" auto-login)
+ '())
+ #$@(if login-program
+ #~("--login-program" #$login-program)
+ #~())
+ #$@(if login-pause?
+ #~("--login-pause")
+ #~())
+ defaulted-tty
+ #$@(if baud-rate
+ #~(#$baud-rate)
+ #~())
+ #$@(if term
+ #~(#$term)
+ #~())))
+ (const #f)) ; never start.
+ args))))
(stop #~(make-kill-destructor)))))))
(define agetty-service-type
diff --git a/gnu/services/cgit.scm b/gnu/services/cgit.scm
new file mode 100644
index 0000000000..a868d758a4
--- /dev/null
+++ b/gnu/services/cgit.scm
@@ -0,0 +1,686 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
+;;;
+;;; 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 cgit)
+ #:use-module (gnu packages admin)
+ #:use-module (gnu packages version-control)
+ #:use-module (gnu services base)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu services web)
+ #:use-module (gnu services)
+ #:use-module (gnu system shadow)
+ #:use-module (guix gexp)
+ #:use-module (guix packages)
+ #:use-module (guix records)
+ #:use-module (guix store)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (repository-cgit-configuration
+ cgit-configuration
+ %cgit-configuration-nginx
+ cgit-configuration-nginx-config
+ opaque-cgit-configuration
+ cgit-service-type))
+
+;;; Commentary:
+;;;
+;;; This module provides a service definition for the Cgit a web frontend for
+;;; Git repositories written in C.
+;;;
+;;; Note: fields of <cgit-configuration> and <repository-cgit-configuration>
+;;; should be specified in the specific order.
+;;;
+;;; Code:
+
+(define %cgit-configuration-nginx
+ (nginx-server-configuration
+ (root cgit)
+ (locations
+ (list
+ (nginx-location-configuration
+ (uri "@cgit")
+ (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;"
+ "fastcgi_param PATH_INFO $uri;"
+ "fastcgi_param QUERY_STRING $args;"
+ "fastcgi_param HTTP_HOST $server_name;"
+ "fastcgi_pass 127.0.0.1:9000;")))))
+ (try-files (list "$uri" "@cgit"))
+ (listen '("80"))
+ (ssl-certificate #f)
+ (ssl-certificate-key #f)))
+
+
+;;;
+;;; Serialize <cgit-configuration>
+;;;
+
+(define (uglify-field-name field-name)
+ (let ((str (symbol->string field-name)))
+ (string-join (string-split (string-delete #\? str) #\-) "-")))
+
+(define (serialize-field field-name val)
+ (format #t "~a=~a\n" (uglify-field-name field-name) val))
+
+(define (serialize-string field-name val)
+ (if (string=? val "") "" (serialize-field field-name val)))
+
+(define (serialize-boolean field-name val)
+ (serialize-field field-name (if val 1 0)))
+
+(define (serialize-list field-name val)
+ (if (null? val) "" (serialize-field field-name (string-join val))))
+
+(define robots-list? list?)
+
+(define (serialize-robots-list field-name val)
+ (if (null? val) "" (serialize-field field-name (string-join val ", "))))
+
+(define (integer? val)
+ (exact-integer? val))
+
+(define (serialize-integer field-name val)
+ (serialize-field field-name val))
+
+(define (serialize-repository-cgit-configuration x)
+ (serialize-configuration x repository-cgit-configuration-fields))
+
+(define (repository-cgit-configuration-list? val)
+ (list? val))
+
+(define (serialize-repository-cgit-configuration-list field-name val)
+ (for-each serialize-repository-cgit-configuration val))
+
+
+;;;
+;;; Serialize <nginx-server-configuration>
+;;;
+
+(define (nginx-server-configuration-list? val)
+ (and (list? val) (and-map nginx-server-configuration? val)))
+
+(define (serialize-nginx-server-configuration-list field-name val)
+ #f)
+
+
+;;;
+;;; Serialize <repository-cgit-configuration>
+;;;
+
+(define (serialize-repo-field field-name val)
+ (format #t "repo.~a=~a\n" (uglify-field-name field-name) val))
+
+(define (serialize-repo-list field-name val)
+ (if (null? val) "" (serialize-repo-field field-name (string-join val))))
+
+(define repo-boolean? boolean?)
+
+(define (serialize-repo-boolean field-name val)
+ (serialize-repo-field field-name (if val 1 0)))
+
+(define (serialize-repo-integer field-name val)
+ (serialize-repo-field field-name val))
+
+(define repo-list? list?)
+
+(define repo-string? string?)
+
+(define (serialize-repo-string field-name val)
+ (if (string=? val "") "" (serialize-repo-field field-name val)))
+
+(define module-link-path? list?)
+
+(define (serialize-module-link-path field-name val)
+ (if (null? val) ""
+ (match val
+ ((path text)
+ (format #t "repo.~a.~a=~a\n"
+ (string-drop-right (uglify-field-name 'module-link-path)
+ (string-length "-path"))
+ path text)))))
+
+(define repository-directory? string?)
+
+(define (serialize-repository-directory _ val)
+ (if (string=? val "") "" (format #t "scan-path=~a\n" val)))
+
+(define mimetype-alist? list?)
+
+(define (serialize-mimetype-alist field-name val)
+ (format #t "# Mimetypes\n~a"
+ (string-join
+ (map (match-lambda
+ ((extension mimetype)
+ (format #f "mimetype.~a=~a"
+ (symbol->string extension) mimetype)))
+ val) "\n")))
+
+(define-configuration repository-cgit-configuration
+ (snapshots
+ (repo-list '())
+ "A mask of snapshot formats for this repo that cgit generates links for,
+restricted by the global @code{snapshots} setting.")
+ (source-filter
+ (repo-string "")
+ "Override the default @code{source-filter}.")
+ (url
+ (repo-string "")
+ "The relative URL used to access the repository.")
+ (about-filter
+ (repo-string "")
+ "Override the default @code{about-filter}.")
+ (branch-sort
+ (repo-string "")
+ "Flag which, when set to @samp{age}, enables date ordering in the branch
+ref list, and when set to @samp{name} enables ordering by branch name.")
+ (clone-url
+ (repo-list '())
+ "A list of URLs which can be used to clone repo.")
+ (commit-filter
+ (repo-string "")
+ "Override the default @code{commit-filter}.")
+ (commit-sort
+ (repo-string "")
+ "Flag which, when set to @samp{date}, enables strict date ordering in the
+commit log, and when set to @samp{topo} enables strict topological ordering.")
+ (defbranch
+ (repo-string "")
+ "The name of the default branch for this repository. If no such branch
+exists in the repository, the first branch name (when sorted) is used as
+default instead. By default branch pointed to by HEAD, or \"master\" if there
+is no suitable HEAD.")
+ (desc
+ (repo-string "")
+ "The value to show as repository description.")
+ (homepage
+ (repo-string "")
+ "The value to show as repository homepage.")
+ (email-filter
+ (repo-string "")
+ "Override the default @code{email-filter}.")
+ (enable-commit-graph?
+ (repo-boolean #f)
+ "A flag which can be used to disable the global setting
+@code{enable-commit-graph?}.")
+ (enable-log-filecount?
+ (repo-boolean #f)
+ "A flag which can be used to disable the global setting
+@code{enable-log-filecount?}.")
+ (enable-log-linecount?
+ (repo-boolean #f)
+ "A flag which can be used to disable the global setting
+@code{enable-log-linecount?}.")
+ (enable-remote-branches?
+ (repo-boolean #f)
+ "Flag which, when set to @code{#t}, will make cgit display remote
+branches in the summary and refs views.")
+ (enable-subject-links?
+ (repo-boolean #f)
+ "A flag which can be used to override the global setting
+@code{enable-subject-links?}.")
+ (enable-html-serving?
+ (repo-boolean #f)
+ "A flag which can be used to override the global setting
+@code{enable-html-serving?}.")
+ (hide?
+ (repo-boolean #f)
+ "Flag which, when set to @code{#t}, hides the repository from the
+repository index.")
+ (ignore?
+ (repo-boolean #f)
+ "Flag which, when set to @samp{#t}, ignores the repository.")
+ (logo
+ (repo-string "")
+ "URL which specifies the source of an image which will be used as a
+logo on this repo’s pages.")
+ (logo-link
+ (repo-string "")
+ "URL loaded when clicking on the cgit logo image.")
+ (owner-filter
+ (repo-string "")
+ "Override the default @code{owner-filter}.")
+ (module-link
+ (repo-string "")
+ "Text which will be used as the formatstring for a hyperlink when a
+submodule is printed in a directory listing. The arguments for the
+formatstring are the path and SHA1 of the submodule commit.")
+ (module-link-path
+ (module-link-path '())
+ "Text which will be used as the formatstring for a hyperlink when a
+submodule with the specified subdirectory path is printed in a directory
+listing.")
+ (max-stats
+ (repo-string "")
+ "Override the default maximum statistics period.")
+ (name
+ (repo-string "")
+ "The value to show as repository name.")
+ (owner
+ (repo-string "")
+ "A value used to identify the owner of the repository.")
+ (path
+ (repo-string "")
+ "An absolute path to the repository directory.")
+ (readme
+ (repo-string "")
+ "A path (relative to repo) which specifies a file to include verbatim
+as the \"About\" page for this repo.")
+ (section
+ (repo-string "")
+ "The name of the current repository section - all repositories defined
+after this option will inherit the current section name.")
+ (extra-options
+ (repo-list '())
+ "Extra options will be appended to cgitrc file."))
+
+;; Generate a <cgit-configuration> record, which may include a list of
+;; <repository-cgit-configuration>, <nginx-server-configuration>, <package>.
+(define-configuration cgit-configuration
+ (package
+ (package cgit)
+ "The CGIT package.")
+ (nginx
+ (nginx-server-configuration-list (list %cgit-configuration-nginx))
+ "NGINX configuration.")
+ (about-filter
+ (string "")
+ "Specifies a command which will be invoked to format the content of about
+pages (both top-level and for each repository).")
+ (agefile
+ (string "")
+ "Specifies a path, relative to each repository path, which can be used to
+specify the date and time of the youngest commit in the repository.")
+ (auth-filter
+ (string "")
+ "Specifies a command that will be invoked for authenticating repository
+access.")
+ (branch-sort
+ (string "name")
+ "Flag which, when set to @samp{age}, enables date ordering in the branch
+ref list, and when set @samp{name} enables ordering by branch name.")
+ (cache-root
+ (string "/var/cache/cgit")
+ "Path used to store the cgit cache entries.")
+ (cache-static-ttl
+ (integer -1)
+ "Number which specifies the time-to-live, in minutes, for the cached
+version of repository pages accessed with a fixed SHA1.")
+ (cache-dynamic-ttl
+ (integer 5)
+ "Number which specifies the time-to-live, in minutes, for the cached
+version of repository pages accessed without a fixed SHA1.")
+ (cache-repo-ttl
+ (integer 5)
+ "Number which specifies the time-to-live, in minutes, for the cached
+version of the repository summary page.")
+ (cache-root-ttl
+ (integer 5)
+ "Number which specifies the time-to-live, in minutes, for the cached
+version of the repository index page.")
+ (cache-scanrc-ttl
+ (integer 15)
+ "Number which specifies the time-to-live, in minutes, for the result of
+scanning a path for Git repositories.")
+ (cache-about-ttl
+ (integer 15)
+ "Number which specifies the time-to-live, in minutes, for the cached
+version of the repository about page.")
+ (cache-snapshot-ttl
+ (integer 5)
+ "Number which specifies the time-to-live, in minutes, for the cached
+version of snapshots.")
+ (cache-size
+ (integer 0)
+ "The maximum number of entries in the cgit cache. When set to
+@samp{0}, caching is disabled.")
+ (case-sensitive-sort?
+ (boolean #t)
+ "Sort items in the repo list case sensitively.")
+ (clone-prefix
+ (list '())
+ "List of common prefixes which, when combined with a repository URL,
+generates valid clone URLs for the repository.")
+ (clone-url
+ (list '())
+ "List of @code{clone-url} templates.")
+ (commit-filter
+ (string "")
+ "Command which will be invoked to format commit messages.")
+ (commit-sort
+ (string "git log")
+ "Flag which, when set to @samp{date}, enables strict date ordering in the
+commit log, and when set to @samp{topo} enables strict topological
+ordering.")
+ (css
+ (string "/share/cgit/cgit.css")
+ "URL which specifies the css document to include in all cgit pages.")
+ (email-filter
+ (string "")
+ "Specifies a command which will be invoked to format names and email
+address of committers, authors, and taggers, as represented in various
+places throughout the cgit interface.")
+ (embedded?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, will make cgit generate a HTML
+fragment suitable for embedding in other HTML pages.")
+ (enable-commit-graph?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, will make cgit print an ASCII-art
+commit history graph to the left of the commit messages in the
+repository log page.")
+ (enable-filter-overrides?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, allows all filter settings to be
+overridden in repository-specific cgitrc files.")
+ (enable-follow-links?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, allows users to follow a file in the
+log view.")
+ (enable-http-clone?
+ (boolean #t)
+ "If set to @samp{#t}, cgit will act as an dumb HTTP endpoint for Git
+clones.")
+ (enable-index-links?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, will make cgit generate extra links
+\"summary\", \"commit\", \"tree\" for each repo in the repository index.")
+ (enable-index-owner?
+ (boolean #t)
+ "Flag which, when set to @samp{#t}, will make cgit display the owner of
+each repo in the repository index.")
+ (enable-log-filecount?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, will make cgit print the number of
+modified files for each commit on the repository log page.")
+ (enable-log-linecount?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, will make cgit print the number of
+added and removed lines for each commit on the repository log page.")
+ (enable-remote-branches?
+ (boolean #f)
+ "Flag which, when set to @code{#t}, will make cgit display remote
+branches in the summary and refs views.")
+ (enable-subject-links?
+ (boolean #f)
+ "Flag which, when set to @code{1}, will make cgit use the subject of
+the parent commit as link text when generating links to parent commits
+in commit view.")
+ (enable-html-serving?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, will make cgit use the subject of the
+parent commit as link text when generating links to parent commits in
+commit view.")
+ (enable-tree-linenumbers?
+ (boolean #t)
+ "Flag which, when set to @samp{#t}, will make cgit generate linenumber
+links for plaintext blobs printed in the tree view.")
+ (enable-git-config?
+ (boolean #f)
+ "Flag which, when set to @samp{#f}, will allow cgit to use Git config to
+set any repo specific settings.")
+ (favicon
+ (string "/favicon.ico")
+ "URL used as link to a shortcut icon for cgit.")
+ (footer
+ (string "")
+ "The content of the file specified with this option will be included
+verbatim at the bottom of all pages (i.e. it replaces the standard
+\"generated by...\" message).")
+ (head-include
+ (string "")
+ "The content of the file specified with this option will be included
+verbatim in the HTML HEAD section on all pages.")
+ (header
+ (string "")
+ "The content of the file specified with this option will be included
+verbatim at the top of all pages.")
+ (include
+ (string "")
+ "Name of a configfile to include before the rest of the current config-
+file is parsed.")
+ (index-header
+ (string "")
+ "The content of the file specified with this option will be included
+verbatim above the repository index.")
+ (index-info
+ (string "")
+ "The content of the file specified with this option will be included
+verbatim below the heading on the repository index page.")
+ (local-time?
+ (boolean #f)
+ "Flag which, if set to @samp{#t}, makes cgit print commit and tag times
+in the servers timezone.")
+ (logo
+ (string "/share/cgit/cgit.png")
+ "URL which specifies the source of an image which will be used as a logo
+on all cgit pages.")
+ (logo-link
+ (string "")
+ "URL loaded when clicking on the cgit logo image.")
+ (owner-filter
+ (string "")
+ "Command which will be invoked to format the Owner column of the main
+page.")
+ (max-atom-items
+ (integer 10)
+ "Number of items to display in atom feeds view.")
+ (max-commit-count
+ (integer 50)
+ "Number of entries to list per page in \"log\" view.")
+ (max-message-length
+ (integer 80)
+ "Number of commit message characters to display in \"log\" view.")
+ (max-repo-count
+ (integer 50)
+ "Specifies the number of entries to list per page on the repository index
+page.")
+ (max-repodesc-length
+ (integer 80)
+ "Specifies the maximum number of repo description characters to display
+on the repository index page.")
+ (max-blob-size
+ (integer 0)
+ "Specifies the maximum size of a blob to display HTML for in KBytes.")
+ (max-stats
+ (string "")
+ "Maximum statistics period. Valid values are @samp{week},@samp{month},
+@samp{quarter} and @samp{year}.")
+ (mimetype
+ (mimetype-alist '((gif "image/gif")
+ (html "text/html")
+ (jpg "image/jpeg")
+ (jpeg "image/jpeg")
+ (pdf "application/pdf")
+ (png "image/png")
+ (svg "image/svg+xml")))
+ "Mimetype for the specified filename extension.")
+ (mimetype-file
+ (string "")
+ "Specifies the file to use for automatic mimetype lookup.")
+ (module-link
+ (string "")
+ "Text which will be used as the formatstring for a hyperlink when a
+submodule is printed in a directory listing.")
+ (nocache?
+ (boolean #f)
+ "If set to the value @samp{#t} caching will be disabled.")
+ (noplainemail?
+ (boolean #f)
+ "If set to @samp{#t} showing full author email addresses will be
+disabled.")
+ (noheader?
+ (boolean #f)
+ "Flag which, when set to @samp{#t}, will make cgit omit the standard
+header on all pages.")
+ ;; TODO: cgit expects a file name
+ ;; that should be created from a list of strings provided by the user.
+ ;;
+ ;; (project-list
+ ;; (string "")
+ ;; "A list of subdirectories inside of @code{repository-directory},
+ ;; relative to it, that should loaded as Git repositories.")
+ (readme
+ (string "")
+ "Text which will be used as default value for @code{cgit-repo-readme}.")
+ (remove-suffix?
+ (boolean #f)
+ "If set to @code{#t} and @code{repository-directory} is enabled, if any
+repositories are found with a suffix of @code{.git}, this suffix will be
+removed for the URL and name.")
+ (renamelimit
+ (integer -1)
+ "Maximum number of files to consider when detecting renames.")
+ (repository-sort
+ (string "")
+ "The way in which repositories in each section are sorted.")
+ (robots
+ (robots-list (list "noindex" "nofollow"))
+ "Text used as content for the @code{robots} meta-tag.")
+ (root-desc
+ (string "a fast webinterface for the git dscm")
+ "Text printed below the heading on the repository index page.")
+ (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.")
+ (root-title
+ (string "")
+ "Text printed as heading on the repository index page.")
+ (scan-hidden-path
+ (boolean #f)
+ "If set to @samp{#t} and repository-directory is enabled,
+repository-directory will recurse into directories whose name starts with a
+period. Otherwise, repository-directory will stay away from such directories,
+considered as \"hidden\". Note that this does not apply to the \".git\"
+directory in non-bare repos.")
+ (snapshots
+ (list '())
+ "Text which specifies the default set of snapshot formats that cgit
+generates links for.")
+ (repository-directory
+ (repository-directory "/srv/git")
+ "Name of the directory to scan for repositories (represents
+@code{scan-path}).")
+ (section
+ (string "")
+ "The name of the current repository section - all repositories defined
+after this option will inherit the current section name.")
+ (section-sort
+ (string "")
+ "Flag which, when set to @samp{1}, will sort the sections on the repository
+listing by name.")
+ (section-from-path
+ (integer 0)
+ "A number which, if defined prior to repository-directory, specifies how
+many path elements from each repo path to use as a default section name.")
+ (side-by-side-diffs?
+ (boolean #f)
+ "If set to @samp{#t} shows side-by-side diffs instead of unidiffs per
+default.")
+ (source-filter
+ (string "")
+ "Specifies a command which will be invoked to format plaintext blobs in the
+tree view.")
+ (summary-branches
+ (integer 10)
+ "Specifies the number of branches to display in the repository \"summary\"
+view.")
+ (summary-log
+ (integer 10)
+ "Specifies the number of log entries to display in the repository
+\"summary\" view.")
+ (summary-tags
+ (integer 10)
+ "Specifies the number of tags to display in the repository \"summary\"
+view.")
+ (strict-export
+ (string "")
+ "Filename which, if specified, needs to be present within the repository
+for cgit to allow access to that repository.")
+ (virtual-root
+ (string "/")
+ "URL which, if specified, will be used as root for all cgit links.")
+ (repositories
+ (repository-cgit-configuration-list '())
+ "A list of @dfn{cgit-repo} records to use with config.")
+ (extra-options
+ (list '())
+ "Extra options will be appended to cgitrc file."))
+
+(define-configuration opaque-cgit-configuration
+ (cgit
+ (package cgit)
+ "The cgit package.")
+ (cgitrc
+ (string (configuration-missing-field 'opaque-cgit-configuration 'cgitrc))
+ "The contents of the @code{cgitrc} to use.")
+ (cache-root
+ (string "/var/cache/cgit")
+ "Path used to store the cgit cache entries.")
+ (nginx
+ (nginx-server-configuration-list (list %cgit-configuration-nginx))
+ "NGINX configuration."))
+
+(define (cgit-activation config)
+ "Return the activation gexp for CONFIG."
+ (let* ((opaque-config? (opaque-cgit-configuration? config))
+ (config-str
+ (if opaque-config?
+ (opaque-cgit-configuration-cgitrc config)
+ (with-output-to-string
+ (lambda ()
+ (serialize-configuration config
+ cgit-configuration-fields))))))
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p #$(if opaque-config?
+ (opaque-cgit-configuration-cache-root config)
+ (cgit-configuration-cache-root config)))
+ (copy-file #$(plain-file "cgitrc" config-str) "/etc/cgitrc"))))
+
+(define (cgit-configuration-nginx-config config)
+ (if (opaque-cgit-configuration? config)
+ (opaque-cgit-configuration-nginx config)
+ (cgit-configuration-nginx config)))
+
+(define cgit-service-type
+ (service-type
+ (name 'cgit)
+ (extensions
+ (list (service-extension activation-service-type
+ cgit-activation)
+ (service-extension nginx-service-type
+ cgit-configuration-nginx-config)
+
+ ;; Make sure fcgiwrap is instantiated.
+ (service-extension fcgiwrap-service-type
+ (const #t))))
+ (default-value (cgit-configuration))
+ (description
+ "Run the cgit web interface, which allows users to browse Git
+repositories.")))
+
+(define (generate-cgit-documentation)
+ (generate-documentation
+ `((cgit-configuration
+ ,cgit-configuration-fields
+ (repositories repository-cgit-configuration))
+ (repository-cgit-configuration
+ ,repository-cgit-configuration-fields))
+ 'cgit-configuration))
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index c45340f02f..707944cbe0 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -74,11 +74,12 @@
(documentation configuration-field-documentation))
(define (serialize-configuration config fields)
- (for-each (lambda (field)
- ((configuration-field-serializer field)
- (configuration-field-name field)
- ((configuration-field-getter field) config)))
- fields))
+ #~(string-append
+ #$@(map (lambda (field)
+ ((configuration-field-serializer field)
+ (configuration-field-name field)
+ ((configuration-field-getter field) config)))
+ fields)))
(define (validate-configuration config fields)
(for-each (lambda (field)
@@ -105,7 +106,7 @@
(define (maybe-stem? val)
(or (eq? val 'disabled) (stem? val)))
(define (serialize-maybe-stem field-name val)
- (when (stem? val) (serialize-stem field-name val)))))))))
+ (if (stem? val) (serialize-stem field-name val) ""))))))))
(define-syntax define-configuration
(lambda (stx)
@@ -147,7 +148,7 @@
conf))))))))
(define (serialize-package field-name val)
- #f)
+ "")
;; A little helper to make it easier to document all those fields.
(define (generate-documentation documentation documentation-name)
diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm
index b34a67aa95..72927c4534 100644
--- a/gnu/services/databases.scm
+++ b/gnu/services/databases.scm
@@ -29,9 +29,25 @@
#:use-module (guix modules)
#:use-module (guix records)
#:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 match)
- #:export (postgresql-configuration
+ #:export (<postgresql-config-file>
+ postgresql-config-file
+ postgresql-config-file?
+ postgresql-config-file-log-destination
+ postgresql-config-file-hba-file
+ postgresql-config-file-ident-file
+ postgresql-config-file-extra-config
+
+ <postgresql-configuration>
+ postgresql-configuration
postgresql-configuration?
+ postgresql-configuration-postgresql
+ postgresql-configuration-port
+ postgresql-configuration-locale
+ postgresql-configuration-file
+ postgresql-configuration-data-directory
+
postgresql-service
postgresql-service-type
@@ -68,18 +84,6 @@
;;;
;;; Code:
-(define-record-type* <postgresql-configuration>
- postgresql-configuration make-postgresql-configuration
- postgresql-configuration?
- (postgresql postgresql-configuration-postgresql ;<package>
- (default postgresql))
- (port postgresql-configuration-port
- (default 5432))
- (locale postgresql-configuration-locale
- (default "en_US.utf8"))
- (config-file postgresql-configuration-file)
- (data-directory postgresql-configuration-data-directory))
-
(define %default-postgres-hba
(plain-file "pg_hba.conf"
"
@@ -89,13 +93,64 @@ host all all ::1/128 trust"))
(define %default-postgres-ident
(plain-file "pg_ident.conf"
- "# MAPNAME SYSTEM-USERNAME PG-USERNAME"))
+ "# MAPNAME SYSTEM-USERNAME PG-USERNAME"))
+
+(define-record-type* <postgresql-config-file>
+ postgresql-config-file make-postgresql-config-file
+ postgresql-config-file?
+ (log-destination postgresql-config-file-log-destination
+ (default "syslog"))
+ (hba-file postgresql-config-file-hba-file
+ (default %default-postgres-hba))
+ (ident-file postgresql-config-file-ident-file
+ (default %default-postgres-ident))
+ (extra-config postgresql-config-file-extra-config
+ (default '())))
+
+(define-gexp-compiler (postgresql-config-file-compiler
+ (file <postgresql-config-file>) system target)
+ (match file
+ (($ <postgresql-config-file> log-destination hba-file
+ ident-file extra-config)
+ (define (quote' string)
+ (if string
+ (list "'" string "'")
+ '()))
+
+ (define contents
+ (append-map
+ (match-lambda
+ ((key) '())
+ ((key . #f) '())
+ ((key values ...) `(,key " = " ,@values "\n")))
+
+ `(("log_destination" ,@(quote' log-destination))
+ ("hba_file" ,@(quote' hba-file))
+ ("ident_file" ,@(quote' ident-file))
+ ,@extra-config)))
+
+ (gexp->derivation
+ "postgresql.conf"
+ #~(call-with-output-file (ungexp output "out")
+ (lambda (port)
+ (display
+ (string-append #$@contents)
+ port)))
+ #:local-build? #t))))
-(define %default-postgres-config
- (mixed-text-file "postgresql.conf"
- "log_destination = 'syslog'\n"
- "hba_file = '" %default-postgres-hba "'\n"
- "ident_file = '" %default-postgres-ident "'\n"))
+(define-record-type* <postgresql-configuration>
+ postgresql-configuration make-postgresql-configuration
+ postgresql-configuration?
+ (postgresql postgresql-configuration-postgresql ;<package>
+ (default postgresql))
+ (port postgresql-configuration-port
+ (default 5432))
+ (locale postgresql-configuration-locale
+ (default "en_US.utf8"))
+ (config-file postgresql-configuration-file
+ (default (postgresql-config-file)))
+ (data-directory postgresql-configuration-data-directory
+ (default "/var/lib/postgresql/data")))
(define %postgresql-accounts
(list (user-group (name "postgres") (system? #t))
@@ -184,12 +239,13 @@ host all all ::1/128 trust"))
(service-extension activation-service-type
postgresql-activation)
(service-extension account-service-type
- (const %postgresql-accounts))))))
+ (const %postgresql-accounts))))
+ (default-value (postgresql-configuration))))
(define* (postgresql-service #:key (postgresql postgresql)
(port 5432)
(locale "en_US.utf8")
- (config-file %default-postgres-config)
+ (config-file (postgresql-config-file))
(data-directory "/var/lib/postgresql/data"))
"Return a service that runs @var{postgresql}, the PostgreSQL database server.
@@ -466,7 +522,8 @@ FLUSH PRIVILEGES;
(service-extension activation-service-type
%mysql-activation)
(service-extension shepherd-root-service-type
- mysql-shepherd-service)))))
+ mysql-shepherd-service)))
+ (default-value (mysql-configuration))))
(define* (mysql-service #:key (config (mysql-configuration)))
"Return a service that runs @command{mysqld}, the MySQL or MariaDB
@@ -548,4 +605,5 @@ The optional @var{config} argument specifies the configuration for
(service-extension activation-service-type
redis-activation)
(service-extension account-service-type
- (const %redis-accounts))))))
+ (const %redis-accounts))))
+ (default-value (redis-configuration))))
diff --git a/gnu/services/dict.scm b/gnu/services/dict.scm
index c8403c0135..70b05e8f80 100644
--- a/gnu/services/dict.scm
+++ b/gnu/services/dict.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Sou Bunnbu <iyzsong@gmail.com>
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -150,6 +150,7 @@ database {
(gnu system file-systems)))
(list (shepherd-service
(provision '(dicod))
+ (requirement '(user-processes))
(documentation "Run the dicod daemon.")
(modules '((gnu build shepherd)
(gnu system file-systems)))
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index ab90942739..573efa0433 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -1435,90 +1435,91 @@ greyed out, instead of only later giving \"not selectable\" popup error.
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
-(define %dovecot-activation
+(define (%dovecot-activation config)
;; Activation gexp.
- #~(begin
- (use-modules (guix build utils))
- (define (mkdir-p/perms directory owner perms)
- (mkdir-p directory)
- (chown "/var/run/dovecot" (passwd:uid owner) (passwd:gid owner))
- (chmod directory perms))
- (define (build-subject parameters)
- (string-concatenate
- (map (lambda (pair)
- (let ((k (car pair)) (v (cdr pair)))
- (define (escape-char str chr)
- (string-join (string-split str chr) (string #\\ chr)))
- (string-append "/" k "="
- (escape-char (escape-char v #\=) #\/))))
- (filter (lambda (pair) (cdr pair)) parameters))))
- (define* (create-self-signed-certificate-if-absent
- #:key private-key public-key (owner (getpwnam "root"))
- (common-name (gethostname))
- (organization-name "GuixSD")
- (organization-unit-name "Default Self-Signed Certificate")
- (subject-parameters `(("CN" . ,common-name)
- ("O" . ,organization-name)
- ("OU" . ,organization-unit-name)))
- (subject (build-subject subject-parameters)))
- ;; Note that by default, OpenSSL outputs keys in PEM format. This
- ;; is what we want.
- (unless (file-exists? private-key)
- (cond
- ((zero? (system* (string-append #$openssl "/bin/openssl")
- "genrsa" "-out" private-key "2048"))
- (chown private-key (passwd:uid owner) (passwd:gid owner))
- (chmod private-key #o400))
- (else
- (format (current-error-port)
- "Failed to create private key at ~a.\n" private-key))))
- (unless (file-exists? public-key)
- (cond
- ((zero? (system* (string-append #$openssl "/bin/openssl")
- "req" "-new" "-x509" "-key" private-key
- "-out" public-key "-days" "3650"
- "-batch" "-subj" subject))
- (chown public-key (passwd:uid owner) (passwd:gid owner))
- (chmod public-key #o444))
- (else
- (format (current-error-port)
- "Failed to create public key at ~a.\n" public-key)))))
- (let ((user (getpwnam "dovecot")))
- (mkdir-p/perms "/var/run/dovecot" user #o755)
- (mkdir-p/perms "/var/lib/dovecot" user #o755)
- (mkdir-p/perms "/etc/dovecot" user #o755)
- (mkdir-p/perms "/etc/dovecot/private" user #o700)
- (create-self-signed-certificate-if-absent
- #:private-key "/etc/dovecot/private/default.pem"
- #:public-key "/etc/dovecot/default.pem"
- #:owner (getpwnam "root")
- #:common-name (format #f "Dovecot service on ~a" (gethostname))))))
+ (let ((config-str
+ (cond
+ ((opaque-dovecot-configuration? config)
+ (opaque-dovecot-configuration-string config))
+ (else
+ (with-output-to-string
+ (lambda ()
+ (serialize-configuration config
+ dovecot-configuration-fields)))))))
+ #~(begin
+ (use-modules (guix build utils))
+ (define (mkdir-p/perms directory owner perms)
+ (mkdir-p directory)
+ (chown "/var/run/dovecot" (passwd:uid owner) (passwd:gid owner))
+ (chmod directory perms))
+ (define (build-subject parameters)
+ (string-concatenate
+ (map (lambda (pair)
+ (let ((k (car pair)) (v (cdr pair)))
+ (define (escape-char str chr)
+ (string-join (string-split str chr) (string #\\ chr)))
+ (string-append "/" k "="
+ (escape-char (escape-char v #\=) #\/))))
+ (filter (lambda (pair) (cdr pair)) parameters))))
+ (define* (create-self-signed-certificate-if-absent
+ #:key private-key public-key (owner (getpwnam "root"))
+ (common-name (gethostname))
+ (organization-name "GuixSD")
+ (organization-unit-name "Default Self-Signed Certificate")
+ (subject-parameters `(("CN" . ,common-name)
+ ("O" . ,organization-name)
+ ("OU" . ,organization-unit-name)))
+ (subject (build-subject subject-parameters)))
+ ;; Note that by default, OpenSSL outputs keys in PEM format. This
+ ;; is what we want.
+ (unless (file-exists? private-key)
+ (cond
+ ((zero? (system* (string-append #$openssl "/bin/openssl")
+ "genrsa" "-out" private-key "2048"))
+ (chown private-key (passwd:uid owner) (passwd:gid owner))
+ (chmod private-key #o400))
+ (else
+ (format (current-error-port)
+ "Failed to create private key at ~a.\n" private-key))))
+ (unless (file-exists? public-key)
+ (cond
+ ((zero? (system* (string-append #$openssl "/bin/openssl")
+ "req" "-new" "-x509" "-key" private-key
+ "-out" public-key "-days" "3650"
+ "-batch" "-subj" subject))
+ (chown public-key (passwd:uid owner) (passwd:gid owner))
+ (chmod public-key #o444))
+ (else
+ (format (current-error-port)
+ "Failed to create public key at ~a.\n" public-key)))))
+ (let ((user (getpwnam "dovecot")))
+ (mkdir-p/perms "/var/run/dovecot" user #o755)
+ (mkdir-p/perms "/var/lib/dovecot" user #o755)
+ (mkdir-p/perms "/etc/dovecot" user #o755)
+ (copy-file #$(plain-file "dovecot.conf" config-str)
+ "/etc/dovecot/dovecot.conf")
+ (mkdir-p/perms "/etc/dovecot/private" user #o700)
+ (create-self-signed-certificate-if-absent
+ #:private-key "/etc/dovecot/private/default.pem"
+ #:public-key "/etc/dovecot/default.pem"
+ #:owner (getpwnam "root")
+ #:common-name (format #f "Dovecot service on ~a" (gethostname)))))))
(define (dovecot-shepherd-service config)
"Return a list of <shepherd-service> for CONFIG."
- (let* ((config-str
- (cond
- ((opaque-dovecot-configuration? config)
- (opaque-dovecot-configuration-string config))
- (else
- (with-output-to-string
- (lambda ()
- (serialize-configuration config
- dovecot-configuration-fields))))))
- (config-file (plain-file "dovecot.conf" config-str))
- (dovecot (if (opaque-dovecot-configuration? config)
- (opaque-dovecot-configuration-dovecot config)
- (dovecot-configuration-dovecot config))))
+ (let ((dovecot (if (opaque-dovecot-configuration? config)
+ (opaque-dovecot-configuration-dovecot config)
+ (dovecot-configuration-dovecot config))))
(list (shepherd-service
(documentation "Run the Dovecot POP3/IMAP mail server.")
(provision '(dovecot))
(requirement '(networking))
(start #~(make-forkexec-constructor
(list (string-append #$dovecot "/sbin/dovecot")
- "-F" "-c" #$config-file)))
+ "-F")))
(stop #~(make-forkexec-constructor
(list (string-append #$dovecot "/sbin/dovecot")
- "-c" #$config-file "stop")))))))
+ "stop")))))))
(define %dovecot-pam-services
(list (unix-pam-service "dovecot")))
@@ -1533,7 +1534,7 @@ greyed out, instead of only later giving \"not selectable\" popup error.
(service-extension pam-root-service-type
(const %dovecot-pam-services))
(service-extension activation-service-type
- (const %dovecot-activation))))))
+ %dovecot-activation)))))
(define* (dovecot-service #:key (config (dovecot-configuration)))
"Return a service that runs @command{dovecot}, a mail server that can run
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
index 427e2121f6..80ffed0f2f 100644
--- a/gnu/services/messaging.scm
+++ b/gnu/services/messaging.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
@@ -115,16 +115,9 @@
"_")))
(define (serialize-field field-name val)
- (format #t "~a = ~a;\n" (uglify-field-name field-name) val))
+ #~(format #f "~a = ~a;\n" #$(uglify-field-name field-name) #$val))
(define (serialize-field-list field-name val)
- (serialize-field field-name
- (with-output-to-string
- (lambda ()
- (format #t "{\n")
- (for-each (lambda (x)
- (format #t "~a;\n" x))
- val)
- (format #t "}")))))
+ (serialize-field field-name #~(format #f "{\n~@{~a;\n~}}" #$@val)))
(define (serialize-boolean field-name val)
(serialize-field field-name (if val "true" "false")))
@@ -140,17 +133,17 @@
(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))
+ (serialize-field field-name (number->string val)))
(define-maybe non-negative-integer)
(define (non-negative-integer-list? val)
(and (list? val) (and-map non-negative-integer? val)))
(define (serialize-non-negative-integer-list field-name val)
- (serialize-field-list field-name val))
+ (serialize-field-list field-name (map number->string val)))
(define-maybe non-negative-integer-list)
(define (enclose-quotes s)
- (format #f "\"~a\"" s))
+ #~(string-append "\"" #$s "\""))
(define (serialize-string field-name val)
(serialize-field field-name (enclose-quotes val)))
(define-maybe string)
@@ -183,10 +176,22 @@
(serialize-string-list field-name val))
(define-maybe file-name)
+(define (file-object? val)
+ (or (file-like? val) (file-name? val)))
+(define (serialize-file-object field-name val)
+ (serialize-string field-name val))
+(define-maybe file-object)
+
+(define (file-object-list? val)
+ (and (list? val) (and-map file-object? val)))
+(define (serialize-file-object-list field-name val)
+ (serialize-string-list field-name val))
+(define-maybe file-object)
+
(define (raw-content? val)
(not (eq? val 'disabled)))
(define (serialize-raw-content field-name val)
- (format #t "~a" val))
+ val)
(define-maybe raw-content)
(define-configuration mod-muc-configuration
@@ -224,12 +229,12 @@ just joined the room."))
"Path to your certificate file.")
(capath
- (file-name "/etc/ssl/certs")
+ (file-object "/etc/ssl/certs")
"Path to directory containing root certificates that you wish Prosody to
trust when verifying the certificates of remote servers.")
(cafile
- (maybe-file-name 'disabled)
+ (maybe-file-object 'disabled)
"Path to a file containing root certificates that you wish Prosody to trust.
Similar to @code{capath} but with all certificates concatenated together.")
@@ -273,9 +278,8 @@ can create such a file with:
(maybe-string 'disabled)
"Password for encrypted private keys."))
(define (serialize-ssl-configuration field-name val)
- (format #t "ssl = {\n")
- (serialize-configuration val ssl-configuration-fields)
- (format #t "};\n"))
+ #~(format #f "ssl = {\n~a};\n"
+ #$(serialize-configuration val ssl-configuration-fields)))
(define-maybe ssl-configuration)
(define %default-modules-enabled
@@ -303,20 +307,23 @@ can create such a file with:
(define (virtualhost-configuration-list? val)
(and (list? val) (and-map virtualhost-configuration? val)))
(define (serialize-virtualhost-configuration-list l)
- (for-each
- (lambda (val) (serialize-virtualhost-configuration val)) l))
+ #~(string-append
+ #$@(map (lambda (val)
+ (serialize-virtualhost-configuration val)) l)))
(define (int-component-configuration-list? val)
(and (list? val) (and-map int-component-configuration? val)))
(define (serialize-int-component-configuration-list l)
- (for-each
- (lambda (val) (serialize-int-component-configuration val)) l))
+ #~(string-append
+ #$@(map (lambda (val)
+ (serialize-int-component-configuration val)) l)))
(define (ext-component-configuration-list? val)
(and (list? val) (and-map ext-component-configuration? val)))
(define (serialize-ext-component-configuration-list l)
- (for-each
- (lambda (val) (serialize-ext-component-configuration val)) l))
+ #~(string-append
+ #$@(map (lambda (val)
+ (serialize-ext-component-configuration val)) l)))
(define-all-configurations prosody-configuration
(prosody
@@ -331,7 +338,7 @@ can create such a file with:
global)
(plugin-paths
- (file-name-list '())
+ (file-object-list '())
"Additional plugin directories. They are searched in all the specified
paths in order. See @url{https://prosody.im/doc/plugins_directory}."
global)
@@ -372,7 +379,7 @@ should you want to disable them then add them to this list."
common)
(groups-file
- (file-name "/var/lib/prosody/sharedgroups.txt")
+ (file-object "/var/lib/prosody/sharedgroups.txt")
"Path to a text file where the shared groups are defined. If this path is
empty then @samp{mod_groups} does nothing. See
@url{https://prosody.im/doc/modules/mod_groups}."
@@ -566,8 +573,9 @@ See also @url{https://prosody.im/doc/modules/mod_muc}."
'(domain))))
(let ((domain (virtualhost-configuration-domain config))
(rest (filter rest? virtualhost-configuration-fields)))
- (format #t "VirtualHost \"~a\"\n" domain)
- (serialize-configuration config rest)))
+ #~(string-append
+ #$(format #f "VirtualHost \"~a\"\n" domain)
+ #$(serialize-configuration config rest))))
;; Serialize Component line first.
(define (serialize-int-component-configuration config)
@@ -577,8 +585,9 @@ See also @url{https://prosody.im/doc/modules/mod_muc}."
(let ((hostname (int-component-configuration-hostname config))
(plugin (int-component-configuration-plugin config))
(rest (filter rest? int-component-configuration-fields)))
- (format #t "Component \"~a\" \"~a\"\n" hostname plugin)
- (serialize-configuration config rest)))
+ #~(string-append
+ #$(format #f "Component \"~a\" \"~a\"\n" hostname plugin)
+ #$(serialize-configuration config rest))))
;; Serialize Component line first.
(define (serialize-ext-component-configuration config)
@@ -587,22 +596,24 @@ See also @url{https://prosody.im/doc/modules/mod_muc}."
'(hostname))))
(let ((hostname (ext-component-configuration-hostname config))
(rest (filter rest? ext-component-configuration-fields)))
- (format #t "Component \"~a\"\n" hostname)
- (serialize-configuration config rest)))
+ #~(string-append
+ #$(format #f "Component \"~a\"\n" hostname)
+ #$(serialize-configuration config rest))))
;; Serialize virtualhosts and components last.
(define (serialize-prosody-configuration config)
(define (rest? field)
(not (memq (configuration-field-name field)
'(virtualhosts int-components ext-components))))
- (let ((rest (filter rest? prosody-configuration-fields)))
- (serialize-configuration config rest))
- (serialize-virtualhost-configuration-list
- (prosody-configuration-virtualhosts config))
- (serialize-int-component-configuration-list
- (prosody-configuration-int-components config))
- (serialize-ext-component-configuration-list
- (prosody-configuration-ext-components config)))
+ #~(string-append
+ #$(let ((rest (filter rest? prosody-configuration-fields)))
+ (serialize-configuration config rest))
+ #$(serialize-virtualhost-configuration-list
+ (prosody-configuration-virtualhosts config))
+ #$(serialize-int-component-configuration-list
+ (prosody-configuration-int-components config))
+ #$(serialize-ext-component-configuration-list
+ (prosody-configuration-ext-components config))))
(define-configuration opaque-prosody-configuration
(prosody
@@ -646,13 +657,12 @@ See also @url{https://prosody.im/doc/modules/mod_muc}."
(default-certs-dir "/etc/prosody/certs")
(data-path (prosody-configuration-data-path config))
(pidfile-dir (dirname (prosody-configuration-pidfile config)))
- (config-str
- (if (opaque-prosody-configuration? config)
- (opaque-prosody-configuration-prosody.cfg.lua config)
- (with-output-to-string
- (lambda ()
- (serialize-prosody-configuration config)))))
- (config-file (plain-file "prosody.cfg.lua" config-str)))
+ (config-str (if (opaque-prosody-configuration? config)
+ (opaque-prosody-configuration-prosody.cfg.lua config)
+ #~(begin
+ (use-modules (ice-9 format))
+ #$(serialize-prosody-configuration config))))
+ (config-file (mixed-text-file "prosody.cfg.lua" config-str)))
#~(begin
(use-modules (guix build utils))
(define %user (getpw "prosody"))
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 5ba3c5eed6..6ac440fd26 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2016, 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Thomas Danckaert <post@thomasdanckaert.be>
@@ -64,6 +64,10 @@
ntp-service
ntp-service-type
+ openntpd-configuration
+ openntpd-configuration?
+ openntpd-service-type
+
inetd-configuration
inetd-entry
inetd-service-type
@@ -448,6 +452,102 @@ make an initial adjustment of more than 1,000 seconds."
;;;
+;;; OpenNTPD.
+;;;
+
+(define-record-type* <openntpd-configuration>
+ openntpd-configuration make-openntpd-configuration
+ openntpd-configuration?
+ (openntpd openntpd-configuration-openntpd
+ (default openntpd))
+ (listen-on openntpd-listen-on
+ (default '("127.0.0.1"
+ "::1")))
+ (query-from openntpd-query-from
+ (default '()))
+ (sensor openntpd-sensor
+ (default '()))
+ (server openntpd-server
+ (default %ntp-servers))
+ (servers openntpd-servers
+ (default '()))
+ (constraint-from openntpd-constraint-from
+ (default '()))
+ (constraints-from openntpd-constraints-from
+ (default '()))
+ (allow-large-adjustment? openntpd-allow-large-adjustment?
+ (default #f))) ; upstream default
+
+(define (openntpd-shepherd-service config)
+ (match-record config <openntpd-configuration>
+ (openntpd listen-on query-from sensor server servers constraint-from
+ constraints-from allow-large-adjustment?)
+ (let ()
+ (define config
+ (string-join
+ (filter-map
+ (lambda (field value)
+ (string-join
+ (map (cut string-append field <> "\n")
+ value)))
+ '("listen on " "query from " "sensor " "server " "servers "
+ "constraint from ")
+ (list listen-on query-from sensor server servers constraint-from))
+ ;; The 'constraints from' field needs to be enclosed in double quotes.
+ (string-join
+ (map (cut string-append "constraints from \"" <> "\"\n")
+ constraints-from))))
+
+ (define ntpd.conf
+ (plain-file "ntpd.conf" config))
+
+ (list (shepherd-service
+ (provision '(ntpd))
+ (documentation "Run the Network Time Protocol (NTP) daemon.")
+ (requirement '(user-processes networking))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$openntpd "/sbin/ntpd")
+ "-f" #$ntpd.conf
+ "-d" ;; don't daemonize
+ #$@(if allow-large-adjustment?
+ '("-s")
+ '()))
+ ;; When ntpd is daemonized it repeatedly tries to respawn
+ ;; while running, leading shepherd to disable it. To
+ ;; prevent spamming stderr, redirect output to logfile.
+ #:log-file "/var/log/ntpd"))
+ (stop #~(make-kill-destructor)))))))
+
+(define (openntpd-service-activation config)
+ "Return the activation gexp for CONFIG."
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (mkdir-p "/var/db")
+ (mkdir-p "/var/run")
+ (unless (file-exists? "/var/db/ntpd.drift")
+ (with-output-to-file "/var/db/ntpd.drift"
+ (lambda _
+ (format #t "0.0")))))))
+
+(define openntpd-service-type
+ (service-type (name 'openntpd)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ openntpd-shepherd-service)
+ (service-extension account-service-type
+ (const %ntp-accounts))
+ (service-extension activation-service-type
+ openntpd-service-activation)))
+ (default-value (openntpd-configuration))
+ (description
+ "Run the @command{ntpd}, the Network Time Protocol (NTP)
+daemon, as implemented by @uref{http://www.openntpd.org, OpenNTPD}. The
+daemon will keep the system clock synchronized with that of the given servers.")))
+
+
+;;;
;;; Inetd.
;;;
diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm
index 7166ed3d4f..afead87ec7 100644
--- a/gnu/services/version-control.scm
+++ b/gnu/services/version-control.scm
@@ -38,26 +38,6 @@
git-daemon-configuration
git-daemon-configuration?
- <cgit-configuration-file>
- cgit-configuration-file
- cgit-configuration-file?
- cgit-configuration-file-css
- cgit-configuration-file-logo
- cgit-configuration-file-robots
- cgit-configuration-file-virtual-root
- cgit-configuration-file-repository-directory
-
- <cgit-configuration>
- cgit-configuration
- cgit-configuration?
- cgit-configuration-config-file
- cgit-configuration-package
-
- %cgit-configuration-nginx
- cgit-configuration-nginx-config
-
- cgit-service-type
-
git-http-configuration
git-http-configuration?
git-http-nginx-location-configuration))
@@ -174,107 +154,6 @@ access to exported repositories under @file{/srv/git}."
;;;
-;;; Cgit
-;;;
-
-(define-record-type* <cgit-configuration-file>
- cgit-configuration-file
- make-cgit-configuration-file
- cgit-configuration-file?
- (css cgit-configuration-file-css ; string
- (default "/share/cgit/cgit.css"))
- (logo cgit-configuration-file-logo ; string
- (default "/share/cgit/cgit.png"))
- (robots cgit-configuration-file-robots ; list
- (default '("noindex" "nofollow")))
- (virtual-root cgit-configuration-file-virtual-root ; string
- (default "/"))
- (repository-directory cgit-configuration-file-repository-directory ; string
- (default "/srv/git")))
-
-(define (cgit-configuration-robots-string robots)
- (string-join robots ", "))
-
-(define-gexp-compiler (cgit-configuration-file-compiler
- (file <cgit-configuration-file>) system target)
- (match file
- (($ <cgit-configuration-file> css logo
- robots virtual-root repository-directory)
- (apply text-file* "cgitrc"
- (letrec-syntax ((option (syntax-rules ()
- ((_ key value)
- (if value
- `(,key "=" ,value "\n")
- '()))))
- (key/value (syntax-rules ()
- ((_ (key value) rest ...)
- (append (option key value)
- (key/value rest ...)))
- ((_)
- '()))))
- (key/value ("css" css)
- ("logo" logo)
- ("robots" (cgit-configuration-robots-string robots))
- ("virtual-root" virtual-root)
- ("scan-path" repository-directory)))))))
-
-(define %cgit-configuration-nginx
- (list
- (nginx-server-configuration
- (root cgit)
- (locations
- (list
- (nginx-location-configuration
- (uri "@cgit")
- (body '("fastcgi_param SCRIPT_FILENAME $document_root/lib/cgit/cgit.cgi;"
- "fastcgi_param PATH_INFO $uri;"
- "fastcgi_param QUERY_STRING $args;"
- "fastcgi_param HTTP_HOST $server_name;"
- "fastcgi_pass 127.0.0.1:9000;")))))
- (try-files (list "$uri" "@cgit"))
- (listen '("80"))
- (ssl-certificate #f)
- (ssl-certificate-key #f))))
-
-(define-record-type* <cgit-configuration>
- cgit-configuration make-cgit-configuration
- cgit-configuration?
- (config-file cgit-configuration-config-file
- (default (cgit-configuration-file)))
- (package cgit-configuration-package
- (default cgit))
- (nginx cgit-configuration-nginx
- (default %cgit-configuration-nginx)))
-
-(define (cgit-activation config)
- ;; Cgit compiled with default configuration path
- #~(begin
- (use-modules (guix build utils))
- (mkdir-p "/var/cache/cgit")
- (copy-file #$(cgit-configuration-config-file config) "/etc/cgitrc")))
-
-(define (cgit-configuration-nginx-config config)
- (cgit-configuration-nginx config))
-
-(define cgit-service-type
- (service-type
- (name 'cgit)
- (extensions
- (list (service-extension activation-service-type
- cgit-activation)
- (service-extension nginx-service-type
- cgit-configuration-nginx-config)
-
- ;; Make sure fcgiwrap is instantiated.
- (service-extension fcgiwrap-service-type
- (const #t))))
- (default-value (cgit-configuration))
- (description
- "Run the Cgit web interface, which allows users to browse Git
-repositories.")))
-
-
-;;;
;;; HTTP access. Add the result of calling
;;; git-http-nginx-location-configuration to an nginx-server-configuration's
;;; "locations" field.
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-16 17:35:55 +0000