code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Nikita <nikita@n0.is>
;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Raghav Gururajan <rg@raghavgururajan.name>
;;;
;;; 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 certbot)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services mcron)
  #:use-module (gnu services web)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages tls)
  #:use-module (guix i18n)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (certbot-service-type
            certbot-configuration
            certbot-configuration?
            certificate-configuration))

;;; Commentary:
;;;
;;; Automatically obtaining TLS certificates from Let's Encrypt.
;;;
;;; Code:

(define-record-type* <certificate-configuration>
  certificate-configuration make-certificate-configuration
  certificate-configuration?
  (name                certificate-configuration-name
                       (default #f))
  (domains             certificate-configuration-domains
                       (default '()))
  (challenge           certificate-configuration-challenge
                       (default #f))
  (csr                 certificate-configuration-csr
                       (default #f))
  (authentication-hook certificate-authentication-hook
                       (default #f))
  (cleanup-hook        certificate-cleanup-hook
                       (default #f))
  (deploy-hook         certificate-configuration-deploy-hook
                       (default #f)))

(define-record-type* <certbot-configuration>
  certbot-configuration make-certbot-configuration
  certbot-configuration?
  (package             certbot-configuration-package
                       (default certbot))
  (webroot             certbot-configuration-webroot
                       (default "/var/www"))
  (certificates        certbot-configuration-certificates
                       (default '()))
  (email               certbot-configuration-email
                       (default #f))
  (server              certbot-configuration-server
                       (default #f))
  (rsa-key-size        certbot-configuration-rsa-key-size
                       (default #f))
  (default-location    certbot-configuration-default-location
                       (default
                         (nginx-location-configuration
                          (uri "/")
                          (body
                           (list "return 301 https://$host$request_uri;"))))))

(define certbot-command
  (match-lambda
    (($ <certbot-configuration> package webroot certificates email
                                server rsa-key-size default-location)
     (let* ((certbot (file-append package "/bin/certbot"))
            (rsa-key-size (and rsa-key-size (number->string rsa-key-size)))
            (commands
             (map
              (match-lambda
                (($ <certificate-configuration> custom-name domains challenge
                                                csr authentication-hook
                                                cleanup-hook deploy-hook)
                 (let ((name (or custom-name (car domains))))
                   (if challenge
                     (append
                      (list name certbot "certonly" "-n" "--agree-tos"
                            "--manual"
                            (string-append "--preferred-challenges=" challenge)
                            "--cert-name" name
                            "--manual-public-ip-logging-ok"
                            "-d" (string-join domains ","))
                      (if csr `("--csr" ,csr) '())
                      (if email
                          `("--email" ,email)
                          '("--register-unsafely-without-email"))
                      (if server `("--server" ,server) '())
                      (if rsa-key-size `("--rsa-key-size" ,rsa-key-size) '())
                      (if authentication-hook
                          `("--manual-auth-hook" ,authentication-hook)
                          '())
                      (if cleanup-hook `("--manual-cleanup-hook" ,cleanup-hook) '())
                      (if deploy-hook `("--deploy-hook" ,deploy-hook) '()))
                     (append
                      (list name certbot "certonly" "-n" "--agree-tos"
                            "--webroot" "-w" webroot
                            "--cert-name" name
                            "-d" (string-join domains ","))
                      (if csr `("--csr" ,csr) '())
                      (if email
                          `("--email" ,email)
                          '("--register-unsafely-without-email"))
                      (if server `("--server" ,server) '())
                      (if rsa-key-size `("--rsa-key-size" ,rsa-key-size) '())
                      (if deploy-hook `("--deploy-hook" ,deploy-hook) '()))))))
              certificates)))
       (program-file
        "certbot-command"
        #~(begin
            (use-modules (ice-9 match))
            (let ((code 0))
              (for-each
               (match-lambda
                 ((name . command)
                  (begin
                    (format #t "Acquiring or renewing certificate: ~a~%" name)
                    (set! code (or (apply system* command) code)))))
               '#$commands) code)))))))

(define (certbot-renewal-jobs config)
  (list
   ;; Attempt to renew the certificates twice per day, at a random minute
   ;; within the hour.  See https://certbot.eff.org/all-instructions/.
   #~(job '(next-minute-from (next-hour '(0 12)) (list (random 60)))
          #$(certbot-command config))))

(define (certbot-activation config)
  (let* ((certbot-directory "/var/lib/certbot")
         (script (in-vicinity certbot-directory "renew-certificates"))
         (message (format #f (G_ "~a may need to be run~%") script)))
    (match config
      (($ <certbot-configuration> package webroot certificates email
                                  server rsa-key-size default-location)
       (with-imported-modules '((guix build utils))
         #~(begin
             (use-modules (guix build utils))
             (mkdir-p #$webroot)
             (mkdir-p #$certbot-directory)
             (copy-file #$(certbot-command config) #$script)
             (display #$message)))))))

(define certbot-nginx-server-configurations
  (match-lambda
    (($ <certbot-configuration> package webroot certificates email
                                server rsa-key-size default-location)
     (list
      (nginx-server-configuration
       (listen '("80" "[::]:80"))
       (ssl-certificate #f)
       (ssl-certificate-key #f)
       (server-name
        (apply append (map certificate-configuration-domains certificates)))
       (locations
        (filter identity
                (list
                 (nginx-location-configuration
                  (uri "/.well-known")
                  (body (list (list "root " webroot ";"))))
                 default-location))))))))

(define certbot-service-type
  (service-type (name 'certbot)
                (extensions
                 (list (service-extension nginx-service-type
                                          certbot-nginx-server-configurations)
                       (service-extension activation-service-type
                                          certbot-activation)
                       (service-extension mcron-service-type
                                          certbot-renewal-jobs)))
                (compose concatenate)
                (extend (lambda (config additional-certificates)
                          (certbot-configuration
                           (inherit config)
                           (certificates
                            (append
                             (certbot-configuration-certificates config)
                             additional-certificates)))))
                (description
                 "Automatically renew @url{https://letsencrypt.org, Let's
Encrypt} HTTPS certificates by adjusting the nginx web server configuration
and periodically invoking @command{certbot}.")))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; 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.
;;;
;;; 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)
  (string-delete #\? (symbol->string field-name)))

(define (serialize-field field-name val)
  #~(format #f "~a=~a\n" #$(uglify-field-name field-name) #$val))

(define (serialize-string field-name val)
  (if (and (string? val) (string=? val ""))
      ""
      (serialize-field field-name val)))

(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 (number->string val)))

(define (serialize-boolean field-name val)
  (serialize-integer field-name (if val 1 0)))

(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)
  #~(string-append
     #$@(map serialize-repository-cgit-configuration val)))

(define (file-object? val)
  (or (file-like? val) (string? val)))
(define (serialize-file-object field-name val)
  (serialize-string field-name val))

(define (project-list? val)
  (or (list? val)
      (file-object? 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)
  "")

;;;
;;; Serialize <repository-cgit-configuration>
;;;

(define (serialize-repo-field field-name val)
  #~(format #f "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-integer field-name val)
  (serialize-repo-field field-name (number->string val)))

(define (serialize-repo-boolean field-name val)
  (serialize-repo-integer field-name (if val 1 0)))
(define-maybe repo-boolean)

(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 repo-file-object? file-object?)
(define serialize-repo-file-object serialize-repo-string)

(define module-link-path? list?)

(define (serialize-module-link-path field-name val)
  (if (null? val) ""
      (match val
        ((path text)
         (format #f "repo.module-link.~a=~a\n" path text)))))

(define (serialize-project-list _ val)
  (if (null? val) ""
      (serialize-field
       'project-list
       (if (file-object? val)
           val
           (plain-file "project-list" (string-join val "\n"))))))

(define (serialize-extra-options extra-options)
  (string-join extra-options "\n" 'suffix))

(define repository-directory? string?)

(define (serialize-repository-directory _ val)
  (if (string=? val "") "" (format #f "scan-path=~a\n" val)))

(define mimetype-alist? list?)

(define (serialize-mimetype-alist field-name val)
  (format #f "# 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-file-object "")
   "Override the default @code{source-filter}.")
  (url
   (repo-string "")
   "The relative URL used to access the repository.")
  (about-filter
   (repo-file-object "")
   "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-file-object "")
   "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-file-object "")
   "Override the default @code{email-filter}.")
  (enable-commit-graph?
   (maybe-repo-boolean 'disabled)
   "A flag which can be used to disable the global setting
@code{enable-commit-graph?}.")
  (enable-log-filecount?
   (maybe-repo-boolean 'disabled)
   "A flag which can be used to disable the global setting
@code{enable-log-filecount?}.")
  (enable-log-linecount?
   (maybe-repo-boolean 'disabled)
   "A flag which can be used to disable the global setting
@code{enable-log-linecount?}.")
  (enable-remote-branches?
   (maybe-repo-boolean 'disabled)
   "Flag which, when set to @code{#t}, will make cgit display remote
branches in the summary and refs views.")
  (enable-subject-links?
   (maybe-repo-boolean 'disabled)
   "A flag which can be used to override the global setting
@code{enable-subject-links?}.")
  (enable-html-serving?
   (maybe-repo-boolean 'disabled)
   "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-file-object "")
   "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-file-object "")
   "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
   (file-object "")
   "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
   (file-object "")
   "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
   (file-object "")
   "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
   (file-object "/share/cgit/cgit.css")
   "URL which specifies the css document to include in all cgit pages.")
  (email-filter
   (file-object "")
   "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
   (file-object "/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
   (file-object "")
   "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
   (file-object "/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
   (file-object "")
   "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
   (file-object "")
   "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.")
  (project-list
   (project-list '())
   "A list of subdirectories inside of @code{repository-directory}, relative
to it, that should loaded as Git repositories.  An empty list means that all
subdirectories will be loaded.")
  (readme
   (file-object "")
   "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 the \"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
   (file-object "")
   "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."))

;; This distinguishes fields whose order matters, and makes sure further
;; changes won't inadvertently change the order.
(define (serialize-cgit-configuration config)
  (define (rest? field)
    (not (memq (configuration-field-name field)
               '(project-list
                 extra-options
                 repository-directory
                 repositories))))
  #~(string-append
     #$(let ((rest (filter rest? cgit-configuration-fields)))
         (serialize-configuration config rest))
     #$(serialize-project-list
        'project-list
        (cgit-configuration-project-list config))
     #$(serialize-extra-options
        (cgit-configuration-extra-options config))
     #$(serialize-repository-directory
        'repository-directory
        (cgit-configuration-repository-directory config))
     #$(serialize-repository-cgit-configuration-list
        'repositories
        (cgit-configuration-repositories config))))

(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)
              (serialize-cgit-configuration config))))
    #~(begin
        (use-modules (guix build utils))
        (mkdir-p #$(if opaque-config?
                       (opaque-cgit-configuration-cache-root config)
                       (cgit-configuration-cache-root config)))
        (copy-file #$(mixed-text-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))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020, 2021 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.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 ci)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages ci)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services admin)
  #:use-module (gnu system shadow)
  #:use-module (ice-9 match)
  #:export (laminar-configuration
            laminar-configuration?
            laminar-configuration-home-directory
            laminar-configuration-bind-http
            laminar-configuration-bind-rpc
            laminar-configuration-title
            laminar-configuration-keep-rundirs
            laminar-configuration-archive-url
            laminar-configuration-base-url

            laminar-service-type))

;;;; Commentary:
;;;
;;; This module implements a service that to run instances of Laminar, a
;;; continuous integration tool.
;;;
;;;; Code:

(define-record-type* <laminar-configuration>
  laminar-configuration make-laminar-configuration
  laminar-configuration?
  (laminar          laminars-configuration-laminar
                    (default laminar))
  (home-directory   laminar-configuration-home-directory
                    (default "/var/lib/laminar"))
  (bind-http        laminar-configuration-bind-http
                    (default "*:8080"))
  (bind-rpc         laminar-configuration-bind-rpc
                    (default "unix-abstract:laminar"))
  (title            laminar-configuration-title
                    (default "Laminar"))
  (keep-rundirs     laminar-keep-rundirs
                    (default 0))
  (archive-url      laminar-archive-url
                    (default #f))
  (base-url         laminar-base-url
                    (default #f)))

(define laminar-shepherd-service
  (match-lambda
    (($ <laminar-configuration> laminar home-directory
                                bind-http bind-rpc
                                title keep-rundirs archive-url
                                base-url)
     (list (shepherd-service
            (documentation "Run Laminar.")
            (provision '(laminar))
            (requirement '(networking))
            (start #~(make-forkexec-constructor
                      (list #$(file-append laminar "/sbin/laminard"))
                      #:environment-variables
                      `(,(string-append "LAMINAR_HOME="
                                        #$home-directory)
                        ,(string-append "LAMINAR_BIND_HTTP="
                                        #$bind-http)
                        ,(string-append "LAMINAR_TITLE="
                                        #$title)
                        ,(string-append "LAMINAR_KEEP_RUNDIRS="
                                        #$(number->string
                                           keep-rundirs))
                        ,@(if #$archive-url
                              (list
                               (string-append "LAMINAR_ARCHIVE_URL="
                                              #$archive-url))
                              '())
                        ,@(if #$base-url
                              (list
                               (string-append "LAMINAR_BASE_URL="
                                              #$base-url))
                              '()))
                      #:user "laminar"
                      #:group "laminar"))
            (stop #~(make-kill-destructor)))))))

(define (laminar-account config)
  "Return the user accounts and user groups for CONFIG."
  (list (user-group
         (name "laminar")
         (system? #t))
        (user-account
         (name "laminar")
         (group "laminar")
         (system? #t)
         (comment "Laminar privilege separation user")
         (home-directory (laminar-configuration-home-directory config))
         (shell #~(string-append #$shadow "/sbin/nologin")))))

(define (laminar-activation config)
  (let ((bind-http (laminar-configuration-bind-http config)))
    #~(begin
        ;; If listen is a unix socket, create its parent directory.
        (when (string-prefix? "unix:" #$bind-http)
          (let ((run-directory
                 (dirname (substring #$bind-http (string-length "unix:"))))
                (user (getpw "laminar")))
            (mkdir-p run-directory)
            (chown run-directory (passwd:uid user) (passwd:gid user)))))))

(define laminar-service-type
  (service-type
   (name 'laminar)
   (extensions
    (list
     (service-extension shepherd-root-service-type laminar-shepherd-service)
     (service-extension account-service-type laminar-account)
     (service-extension activation-service-type laminar-activation)))
   (default-value (laminar-configuration))
   (description
    "Run the Laminar continuous integration service.")))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@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 configuration)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module ((guix utils) #:select (source-properties->location))
  #:autoload   (texinfo) (texi-fragment->stexi)
  #:autoload   (texinfo serialize) (stexi->texi)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (append-map))
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (configuration-field
            configuration-field-name
            configuration-field-type
            configuration-missing-field
            configuration-field-error
            configuration-field-serializer
            configuration-field-getter
            configuration-field-default-value-thunk
            configuration-field-documentation

            configuration-error?

            define-configuration
            define-configuration/no-serialization
            no-serialization

            serialize-configuration
            define-maybe
            define-maybe/no-serialization
            validate-configuration
            generate-documentation
            configuration->documentation
            empty-serializer
            serialize-package))

;;; Commentary:
;;;
;;; Syntax for creating Scheme bindings to complex configuration files.
;;;
;;; Code:

(define-condition-type &configuration-error &error
  configuration-error?)

(define (configuration-error message)
  (raise (condition (&message (message message))
                    (&configuration-error))))
(define (configuration-field-error field val)
  (configuration-error
   (format #f "Invalid value for field ~a: ~s" field val)))
(define (configuration-missing-field kind field)
  (configuration-error
   (format #f "~a configuration missing required field ~a" kind field)))
(define (configuration-no-default-value kind field)
  (configuration-error
   (format #f "The field `~a' of the `~a' configuration record \
does not have a default value" field kind)))

(define-record-type* <configuration-field>
  configuration-field make-configuration-field configuration-field?
  (name configuration-field-name)
  (type configuration-field-type)
  (getter configuration-field-getter)
  (predicate configuration-field-predicate)
  (serializer configuration-field-serializer)
  (default-value-thunk configuration-field-default-value-thunk)
  (documentation configuration-field-documentation))

(define (serialize-configuration 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)
              (let ((val ((configuration-field-getter field) config)))
                (unless ((configuration-field-predicate field) val)
                  (configuration-field-error
                   (configuration-field-name field) val))))
            fields))

(define-syntax-rule (id ctx parts ...)
  "Assemble PARTS into a raw (unhygienic) identifier."
  (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))

(define (define-maybe-helper serialize? prefix syn)
  (syntax-case syn ()
    ((_ stem)
     (with-syntax
         ((stem?            (id #'stem #'stem #'?))
          (maybe-stem?      (id #'stem #'maybe- #'stem #'?))
          (serialize-stem   (if prefix
                                (id #'stem prefix #'serialize- #'stem)
                                (id #'stem #'serialize- #'stem)))
          (serialize-maybe-stem (if prefix
                                    (id #'stem prefix #'serialize-maybe- #'stem)
                                    (id #'stem #'serialize-maybe- #'stem))))
       #`(begin
           (define (maybe-stem? val)
             (or (eq? val 'disabled) (stem? val)))
           #,@(if serialize?
                  (list #'(define (serialize-maybe-stem field-name val)
                            (if (stem? val)
                                (serialize-stem field-name val)
                                "")))
                  '()))))))

(define-syntax define-maybe
  (lambda (x)
    (syntax-case x (no-serialization prefix)
      ((_ stem (no-serialization))
       (define-maybe-helper #f #f #'(_ stem)))
      ((_ stem (prefix serializer-prefix))
       (define-maybe-helper #t #'serializer-prefix #'(_ stem)))
      ((_ stem)
       (define-maybe-helper #t #f #'(_ stem))))))

(define-syntax-rule (define-maybe/no-serialization stem)
  (define-maybe stem (no-serialization)))

(define (define-configuration-helper serialize? serializer-prefix syn)
  (syntax-case syn ()
    ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
     (with-syntax (((field-getter ...)
                    (map (lambda (field)
                           (id #'stem #'stem #'- field))
    			 #'(field ...)))
                   ((field-predicate ...)
                    (map (lambda (type)
                           (id #'stem type #'?))
    			 #'(field-type ...)))
                   ((field-default ...)
                    (map (match-lambda
    			   ((field-type default-value)
                            default-value)
    			   ((field-type)
                            ;; Quote `undefined' to prevent a possibly
                            ;; unbound warning.
                            (syntax 'undefined)))
    			 #'((field-type def ...) ...)))
                   ((field-serializer ...)
                    (map (lambda (type custom-serializer)
                           (and serialize?
                                (match custom-serializer
                                  ((serializer)
                                   serializer)
                                  (()
                                   (if serializer-prefix
                                       (id #'stem
                                           serializer-prefix
                                           #'serialize- type)
                                       (id #'stem #'serialize- type))))))
                         #'(field-type ...)
                         #'((custom-serializer ...) ...))))
       #`(begin
    	   (define-record-type* #,(id #'stem #'< #'stem #'>)
    	     #,(id #'stem #'% #'stem)
    	     #,(id #'stem #'make- #'stem)
    	     #,(id #'stem #'stem #'?)
    	     (%location #,(id #'stem #'stem #'-location)
    			(default (and=> (current-source-location)
    					source-properties->location))
    			(innate))
    	     #,@(map (lambda (name getter def)
    		       (if (eq? (syntax->datum def) (quote 'undefined))
    			   #`(#,name #,getter)
    			   #`(#,name #,getter (default #,def))))
    		     #'(field ...)
    		     #'(field-getter ...)
    		     #'(field-default ...)))
    	   (define #,(id #'stem #'stem #'-fields)
    	     (list (configuration-field
    		    (name 'field)
    		    (type 'field-type)
    		    (getter field-getter)
    		    (predicate field-predicate)
    		    (serializer field-serializer)
    		    (default-value-thunk
    		      (lambda ()
    			(display '#,(id #'stem #'% #'stem))
    			(if (eq? (syntax->datum field-default)
    				 'undefined)
    			    (configuration-no-default-value
    			     '#,(id #'stem #'% #'stem) 'field)
    			    field-default)))
    		    (documentation doc))
    		   ...))
    	   (define-syntax-rule (stem arg (... ...))
    	     (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
    	       (validate-configuration conf
    				       #,(id #'stem #'stem #'-fields))
    	       conf)))))))

(define no-serialization         ;syntactic keyword for 'define-configuration'
  '(no serialization))

(define-syntax define-configuration
  (lambda (s)
    (syntax-case s (no-serialization prefix)
      ((_ stem (field (field-type def ...) doc custom-serializer ...) ...
          (no-serialization))
       (define-configuration-helper
         #f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
                 ...)))
      ((_ stem  (field (field-type def ...) doc custom-serializer ...) ...
          (prefix serializer-prefix))
       (define-configuration-helper
         #t #'serializer-prefix #'(_ stem (field (field-type def ...)
                                                 doc custom-serializer ...)
                 ...)))
      ((_ stem (field (field-type def ...) doc custom-serializer ...) ...)
       (define-configuration-helper
         #t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...)
                 ...))))))

(define-syntax-rule (define-configuration/no-serialization
                      stem (field (field-type def ...)
                                  doc custom-serializer ...) ...)
  (define-configuration stem (field (field-type def ...)
                                    doc custom-serializer ...) ...
    (no-serialization)))

(define (empty-serializer field-name val) "")
(define serialize-package empty-serializer)

;; A little helper to make it easier to document all those fields.
(define (generate-documentation documentation documentation-name)
  (define (str x) (object->string x))
  (define (generate configuration-name)
    (match (assq-ref documentation configuration-name)
      ((fields . sub-documentation)
       `((para "Available " (code ,(str configuration-name)) " fields are:")
         ,@(map
            (lambda (f)
              (let ((field-name (configuration-field-name f))
                    (field-type (configuration-field-type f))
                    (field-docs (cdr (texi-fragment->stexi
                                      (configuration-field-documentation f))))
                    (default (catch #t
                               (configuration-field-default-value-thunk f)
                               (lambda _ '%invalid))))
                (define (show-default? val)
                  (or (string? val) (number? val) (boolean? val)
                      (and (symbol? val) (not (eq? val '%invalid)))
                      (and (list? val) (and-map show-default? val))))
                `(deftypevr (% (category
                                (code ,(str configuration-name)) " parameter")
                               (data-type ,(str field-type))
                               (name ,(str field-name)))
                   ,@field-docs
                   ,@(if (show-default? default)
                         `((para "Defaults to " (samp ,(str default)) "."))
                         '())
                   ,@(append-map
                      generate
                      (or (assq-ref sub-documentation field-name) '())))))
            fields)))))
  (stexi->texi `(*fragment* . ,(generate documentation-name))))

(define (configuration->documentation configuration-symbol)
  "Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when
defining a configuration record with DEFINE-CONFIGURATION, and output the
Texinfo documentation of its fields."
  ;; This is helper for a simple, straight-forward application of
  ;; GENERATE-DOCUMENTATION.
  (let ((fields-getter (module-ref (current-module)
                                   (symbol-append configuration-symbol
                                                  '-fields))))
    (display (generate-documentation `((,configuration-symbol ,fields-getter))
                                     configuration-symbol))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; 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 cuirass)
  #:use-module (guix channels)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix utils)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages ci)
  #:use-module (gnu packages databases)
  #:use-module (gnu packages version-control)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services databases)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services admin)
  #:use-module (gnu system shadow)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (cuirass-remote-server-configuration
            cuirass-remote-server-configuration?

            cuirass-configuration
            cuirass-configuration?
            cuirass-service-type

            cuirass-remote-worker-configuration
            cuirass-remote-worker-configuration?
            cuirass-remote-worker-service-type))

;;;; Commentary:
;;;
;;; This module implements a service that to run instances of Cuirass, a
;;; continuous integration tool.
;;;
;;;; Code:

(define %cuirass-default-database
  "dbname=cuirass host=/tmp")

(define-record-type* <cuirass-remote-server-configuration>
  cuirass-remote-server-configuration make-cuirass-remote-server-configuration
  cuirass-remote-server-configuration?
  (backend-port     cuirass-remote-server-configuration-backend-port ;int
                    (default 5555))
  (log-port         cuirass-remote-server-configuration-log-port ;int
                    (default 5556))
  (publish-port     cuirass-remote-server-configuration-publish-port ;int
                    (default 5557))
  (log-file         cuirass-remote-server-log-file ;string
                    (default "/var/log/cuirass-remote-server.log"))
  (cache            cuirass-remote-server-configuration-cache ;string
                    (default "/var/cache/cuirass/remote/"))
  (trigger-url      cuirass-remote-server-trigger-url ;string
                    (default #f))
  (public-key       cuirass-remote-server-configuration-public-key ;string
                    (default #f))
  (private-key      cuirass-remote-server-configuration-private-key ;string
                    (default #f)))

(define-record-type* <cuirass-configuration>
  cuirass-configuration make-cuirass-configuration
  cuirass-configuration?
  (cuirass          cuirass-configuration-cuirass ;package
                    (default cuirass))
  (log-file         cuirass-configuration-log-file ;string
                    (default "/var/log/cuirass.log"))
  (web-log-file     cuirass-configuration-web-log-file ;string
                    (default "/var/log/cuirass-web.log"))
  (cache-directory  cuirass-configuration-cache-directory ;string (dir-name)
                    (default "/var/cache/cuirass"))
  (user             cuirass-configuration-user ;string
                    (default "cuirass"))
  (group            cuirass-configuration-group ;string
                    (default "cuirass"))
  (interval         cuirass-configuration-interval ;integer (seconds)
                    (default 60))
  (parameters       cuirass-configuration-parameters ;string
                    (default #f))
  (remote-server    cuirass-configuration-remote-server
                    (default #f))
  (database         cuirass-configuration-database ;string
                    (default %cuirass-default-database))
  (port             cuirass-configuration-port ;integer (port)
                    (default 8081))
  (host             cuirass-configuration-host ;string
                    (default "localhost"))
  (specifications   cuirass-configuration-specifications)
                                  ;gexp that evaluates to specification-alist
  (use-substitutes? cuirass-configuration-use-substitutes? ;boolean
                    (default #f))
  (one-shot?        cuirass-configuration-one-shot? ;boolean
                    (default #f))
  (fallback?        cuirass-configuration-fallback? ;boolean
                    (default #f))
  (extra-options    cuirass-configuration-extra-options
                    (default '())))

(define (cuirass-shepherd-service config)
  "Return a <shepherd-service> for the Cuirass service with CONFIG."
  (let ((cuirass          (cuirass-configuration-cuirass config))
        (cache-directory  (cuirass-configuration-cache-directory config))
        (web-log-file     (cuirass-configuration-web-log-file config))
        (log-file         (cuirass-configuration-log-file config))
        (user             (cuirass-configuration-user config))
        (group            (cuirass-configuration-group config))
        (interval         (cuirass-configuration-interval config))
        (parameters       (cuirass-configuration-parameters config))
        (remote-server    (cuirass-configuration-remote-server config))
        (database         (cuirass-configuration-database config))
        (port             (cuirass-configuration-port config))
        (host             (cuirass-configuration-host config))
        (specs            (cuirass-configuration-specifications config))
        (use-substitutes? (cuirass-configuration-use-substitutes? config))
        (one-shot?        (cuirass-configuration-one-shot? config))
        (fallback?        (cuirass-configuration-fallback? config))
        (extra-options    (cuirass-configuration-extra-options config)))
    `(,(shepherd-service
        (documentation "Run Cuirass.")
        (provision '(cuirass))
        (requirement '(guix-daemon postgres postgres-roles networking))
        (start #~(make-forkexec-constructor
                  (list (string-append #$cuirass "/bin/cuirass")
                        "register"
                        "--cache-directory" #$cache-directory
                        "--specifications"
                        #$(scheme-file "cuirass-specs.scm" specs)
                        "--database" #$database
                        "--interval" #$(number->string interval)
                        #$@(if parameters
                               (list (string-append
                                      "--parameters="
                                      parameters))
                               '())
                        #$@(if remote-server '("--build-remote") '())
                        #$@(if use-substitutes? '("--use-substitutes") '())
                        #$@(if one-shot? '("--one-shot") '())
                        #$@(if fallback? '("--fallback") '())
                        #$@extra-options)

                  #:environment-variables
                  (list "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt"
                        (string-append "GIT_EXEC_PATH=" #$git
                                       "/libexec/git-core"))

                  #:user #$user
                  #:group #$group
                  #:log-file #$log-file))
        (stop #~(make-kill-destructor)))
      ,(shepherd-service
        (documentation "Run Cuirass web interface.")
        (provision '(cuirass-web))
        (requirement '(cuirass))
        (start #~(make-forkexec-constructor
                  (list (string-append #$cuirass "/bin/cuirass")
                        "web"
                        "--database" #$database
                        "--listen" #$host
                        "--port" #$(number->string port)
                        #$@(if parameters
                               (list (string-append
                                      "--parameters="
                                      parameters))
                               '())
                        #$@extra-options)

                  #:user #$user
                  #:group #$group
                  #:log-file #$web-log-file))
        (stop #~(make-kill-destructor)))
      ,@(if remote-server
            (match-record remote-server <cuirass-remote-server-configuration>
              (backend-port publish-port log-file cache trigger-url
                            public-key private-key)
              (list
               (shepherd-service
                (documentation "Run Cuirass remote build server.")
                (provision '(cuirass-remote-server))
                (requirement '(avahi-daemon cuirass))
                (start #~(make-forkexec-constructor
                          (list (string-append #$cuirass "/bin/cuirass")
                                "remote-server"
                                (string-append "--database=" #$database)
                                (string-append "--cache=" #$cache)
                                (string-append "--user=" #$user)
                                #$@(if backend-port
                                       (list (string-append
                                              "--backend-port="
                                              (number->string backend-port)))
                                       '())
                                #$@(if publish-port
                                       (list (string-append
                                              "--publish-port="
                                              (number->string publish-port)))
                                       '())
                                #$@(if parameters
                                       (list (string-append
                                              "--parameters="
                                              parameters))
                                       '())
                                #$@(if trigger-url
                                       (list
                                        (string-append
                                         "--trigger-substitute-url="
                                         trigger-url))
                                       '())
                                #$@(if public-key
                                       (list
                                        (string-append "--public-key="
                                                       public-key))
                                       '())
                                #$@(if private-key
                                       (list
                                        (string-append "--private-key="
                                                       private-key))
                                       '()))
                          #:log-file #$log-file))
                (stop #~(make-kill-destructor)))))
            '()))))

(define (cuirass-account config)
  "Return the user accounts and user groups for CONFIG."
  (let ((cuirass-user  (cuirass-configuration-user config))
        (cuirass-group (cuirass-configuration-group config)))
    (list (user-group
           (name cuirass-group)
           (system? #t))
          (user-account
           (name cuirass-user)
           (group cuirass-group)
           (system? #t)
           (comment "Cuirass privilege separation user")
           (home-directory (string-append "/var/lib/" cuirass-user))
           (shell (file-append shadow "/sbin/nologin"))))))

(define (cuirass-postgresql-role config)
  (let ((user (cuirass-configuration-user config)))
    (list (postgresql-role
           (name user)
           (create-database? #t)))))

(define (cuirass-activation config)
  "Return the activation code for CONFIG."
  (let* ((cache          (cuirass-configuration-cache-directory config))
         (remote-server  (cuirass-configuration-remote-server config))
         (remote-cache   (and remote-server
                              (cuirass-remote-server-configuration-cache
                               remote-server)))
         (user           (cuirass-configuration-user config))
         (log            "/var/log/cuirass")
         (profile        (string-append "/var/guix/profiles/per-user/" user))
         (roots          (string-append profile "/cuirass"))
         (group          (cuirass-configuration-group config)))
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))

          (mkdir-p #$cache)
          (mkdir-p #$log)
          (mkdir-p #$roots)

          (when #$remote-cache
            (mkdir-p #$remote-cache))

          (let ((uid (passwd:uid (getpw #$user)))
                (gid (group:gid (getgr #$group))))
            (chown #$cache uid gid)
            (chown #$log uid gid)
            (chown #$roots uid gid)
            (chown #$profile uid gid)

            (when #$remote-cache
              (chown #$remote-cache uid gid)))))))

(define (cuirass-log-rotations config)
  "Return the list of log rotations that corresponds to CONFIG."
  (list (log-rotation
         (files (list (cuirass-configuration-log-file config)))
         (frequency 'weekly)
         (options '("rotate 40")))))              ;worth keeping

(define cuirass-service-type
  (service-type
   (name 'cuirass)
   (extensions
    (list
     (service-extension profile-service-type      ;for 'info cuirass'
                        (compose list cuirass-configuration-cuirass))
     (service-extension rottlog-service-type cuirass-log-rotations)
     (service-extension activation-service-type cuirass-activation)
     (service-extension shepherd-root-service-type cuirass-shepherd-service)
     (service-extension account-service-type cuirass-account)
     ;; Make sure postgresql and postgresql-role are instantiated.
     (service-extension postgresql-service-type (const #t))
     (service-extension postgresql-role-service-type
                        cuirass-postgresql-role)))
   (description
    "Run the Cuirass continuous integration service.")))

(define-record-type* <cuirass-remote-worker-configuration>
  cuirass-remote-worker-configuration make-cuirass-remote-worker-configuration
  cuirass-remote-worker-configuration?
  (cuirass          cuirass-remote-worker-configuration-cuirass ;package
                    (default cuirass))
  (workers          cuirass-remote-worker-workers ;int
                    (default 1))
  (server           cuirass-remote-worker-server ;string
                    (default #f))
  (systems          cuirass-remote-worker-systems ;list
                    (default (list (%current-system))))
  (log-file         cuirass-remote-worker-log-file ;string
                    (default "/var/log/cuirass-remote-worker.log"))
  (publish-port     cuirass-remote-worker-configuration-publish-port ;int
                    (default 5558))
  (public-key       cuirass-remote-worker-configuration-public-key ;string
                    (default #f))
  (private-key      cuirass-remote-worker-configuration-private-key ;string
                    (default #f)))

(define (cuirass-remote-worker-shepherd-service config)
  "Return a <shepherd-service> for the Cuirass remote worker service with
CONFIG."
  (match-record config <cuirass-remote-worker-configuration>
    (cuirass workers server systems log-file publish-port
             public-key private-key)
    (list (shepherd-service
           (documentation "Run Cuirass remote build worker.")
           (provision '(cuirass-remote-worker))
           (requirement '(avahi-daemon guix-daemon networking))
           (start #~(make-forkexec-constructor
                     (list (string-append #$cuirass "/bin/cuirass")
                           "remote-worker"
                           (string-append "--workers="
                                          #$(number->string workers))
                           #$@(if server
                                  (list (string-append "--server=" server))
                                  '())
                           #$@(if systems
                                  (list (string-append
                                         "--systems="
                                         (string-join systems ",")))
                                  '())
                           #$@(if publish-port
                                  (list (string-append
                                         "--publish-port="
                                         (number->string publish-port)))
                                  '())
                           #$@(if public-key
                                  (list
                                   (string-append "--public-key="
                                                  public-key))
                                  '())
                           #$@(if private-key
                                  (list
                                   (string-append "--private-key="
                                                  private-key))
                                  '()))
                    #:log-file #$log-file))
           (stop #~(make-kill-destructor))))))

(define cuirass-remote-worker-service-type
  (service-type
   (name 'cuirass-remote-worker)
   (extensions
    (list
     (service-extension shepherd-root-service-type
                        cuirass-remote-worker-shepherd-service)))
   (description
    "Run the Cuirass remote build worker service.")))