diff options
Diffstat (limited to 'guix/forge')
| -rw-r--r-- | guix/forge/acme.scm | 14 | ||||
| -rw-r--r-- | guix/forge/cgit.scm | 5 | ||||
| -rw-r--r-- | guix/forge/fcgiwrap.scm | 8 | ||||
| -rw-r--r-- | guix/forge/forge.scm | 63 | ||||
| -rw-r--r-- | guix/forge/git.scm | 43 | ||||
| -rw-r--r-- | guix/forge/guile-git.scm | 14 | ||||
| -rw-r--r-- | guix/forge/gunicorn.scm | 10 | ||||
| -rw-r--r-- | guix/forge/klaus.scm | 52 | ||||
| -rw-r--r-- | guix/forge/tissue.scm | 138 |
9 files changed, 266 insertions, 81 deletions
diff --git a/guix/forge/acme.scm b/guix/forge/acme.scm index 5ec27bb..231608e 100644 --- a/guix/forge/acme.scm +++ b/guix/forge/acme.scm @@ -1,5 +1,6 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023, 2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024 jgart <jgart@dismail.de> ;;; ;;; This file is part of guix-forge. ;;; @@ -73,7 +74,7 @@ (define-public uacme (package (name "uacme") - (version "1.7.4") + (version "1.7.5") (source (origin ;; TODO: Unbundle libev. (method git-fetch) @@ -83,7 +84,7 @@ (file-name (git-file-name name version)) (sha256 (base32 - "1jhjyjnrfq07qgslmz1qpka1ahnmpya2garbxldkh2fr0bmsn26b")))) + "1br374d0lnn422rvg2g4m69vhdck8aihdsjydr064hif0lscr8ri")))) (build-system gnu-build-system) (arguments (list #:phases @@ -332,9 +333,10 @@ tls_www_server ;; exists. (unless (file-exists? #$(string-append state-directory "/private/key.pem")) (display " -If this is the first time you are using the acme service, please -register by running `/usr/bin/acme register' and initialize your -certificates by running `/usr/bin/acme renew' +This seems to be the first time you are using the acme service. The +acme service starts out with self-signed certificates. Please run +`/usr/bin/acme renew' to get CA-issued certificates. Thereafter, +certificates will auto-renew via a cron job. ")))))) diff --git a/guix/forge/cgit.scm b/guix/forge/cgit.scm index 805f47f..0f3aaf2 100644 --- a/guix/forge/cgit.scm +++ b/guix/forge/cgit.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023, 2024 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -20,6 +20,7 @@ (define-module (forge cgit) #:use-module (forge environment) #:use-module (forge fcgiwrap) + #:use-module ((forge git) #:select (git-without-safe-directory-check)) #:use-module (forge nginx) #:use-module (forge socket) #:use-module ((gnu packages emacs) #:select (emacs-minimal)) @@ -73,7 +74,7 @@ (cgit cgit-configuration-cgit (default cgit)) (git cgit-configuration-git - (default git-minimal)) + (default git-without-safe-directory-check)) (server-name cgit-configuration-server-name) (repository-directory cgit-configuration-repository-directory (default "/srv/git")) diff --git a/guix/forge/fcgiwrap.scm b/guix/forge/fcgiwrap.scm index f699480..f75fa5f 100644 --- a/guix/forge/fcgiwrap.scm +++ b/guix/forge/fcgiwrap.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023–2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -74,7 +74,8 @@ (define (fcgiwrap-activation config) (with-imported-modules '((guix build utils)) #~(begin - (use-modules (guix build utils)) + (use-modules (guix build utils) + (ice-9 match)) ;; Create socket directories and set ownership. (for-each (match-lambda @@ -137,7 +138,8 @@ ;; https://yhetil.org/guix/m1ilknoi5r.fsf@fastmail.net/ #:namespaces (delq 'net %namespaces)) "-s" #$(socket->fcgiwrap-socket-url socket) - "-c" #$(number->string processes)) + "-c" #$(number->string processes) + "-f") #:user #$user #:group #$group #:environment-variables diff --git a/guix/forge/forge.scm b/guix/forge/forge.scm index 1871a12..cfe8337 100644 --- a/guix/forge/forge.scm +++ b/guix/forge/forge.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2021–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -29,7 +29,9 @@ #:use-module ((gnu packages version-control) #:select (git-minimal)) #:use-module (gnu services) #:use-module (gnu services mcron) + #:use-module (gnu services web) #:use-module (guix channels) + #:use-module (guix deprecation) #:use-module (guix gexp) #:use-module (guix modules) #:use-module (guix packages) @@ -38,12 +40,14 @@ #:use-module (guix store) #:use-module ((forge guile-git) #:select (guile-git)) #:use-module (forge laminar) + #:use-module (forge nginx) #:use-module (forge tissue) #:use-module (forge utils) #:use-module (forge webhook) #:export (forge-service-type forge-configuration forge-configuration? + forge-configuration-web-domain forge-configuration-projects forge-project forge-project? @@ -52,9 +56,12 @@ forge-project-user forge-project-repository forge-project-repository-branch + forge-project-web-domain forge-project-website-directory + forge-project-tissue? forge-project-ci-jobs forge-project-ci-jobs-trigger + forge-project-parallel-ci-job-runs derivation-job-gexp variable-specification variable-specification? @@ -76,8 +83,12 @@ (default "main")) (description forge-project-description (default #f)) + (web-domain forge-project-web-domain + (default #f)) (website-directory forge-project-website-directory (default #f)) + (tissue? forge-project-tissue? + (default #f)) (ci-jobs forge-project-ci-jobs (default '()) (thunked)) (ci-jobs-trigger forge-project-ci-jobs-trigger ; one of 'post-receive-hook, 'cron, 'webhook @@ -94,6 +105,8 @@ (define-record-type* <forge-configuration> forge-configuration make-forge-configuration forge-configuration? + (web-domain forge-configuration-web-domain + (default #f)) (projects forge-configuration-projects (default '()))) @@ -193,8 +206,9 @@ (('forge _ ...) #t) (name (guix-module-name? name)))) -(define* (derivation-job-gexp project job gexp-producer - #:key (guix-daemon-uri (%daemon-socket-uri)) deep-clone?) +(define-deprecated (derivation-job-gexp project job gexp-producer + #:key (guix-daemon-uri (%daemon-socket-uri)) deep-clone?) + guix-channel-job-gexp "Return a G-expression that builds another G-expression as a derivation and returns its output path. GEXP-PRODUCER is a G-expression that expands to a lambda function. The lambda function @@ -435,8 +449,45 @@ that were built." (package-channels pkg)))))))) inferior)))))))) +(define (forge-nginx-server-blocks config) + "Return list of @code{<nginx-server-configuration>} extensions for +forge configuration @var{config}." + ;; Configure nginx server blocks for projects that have a web domain + ;; and a website directory, but do not have tissue enabled. + (filter-map (match-record-lambda <forge-project> + (web-domain website-directory tissue?) + (and web-domain + website-directory + (not tissue?) + (nginx-server-configuration + (server-name (list web-domain)) + (root website-directory)))) + (forge-configuration-projects config))) + +(define (forge-tissue-hosts config) + "Return list of @code{<tissue-host>} objects for forge configuration +@var{config}." + (match-record config <forge-configuration> + (web-domain projects) + (if web-domain + (list (tissue-host + (name web-domain) + (projects + (filter-map (lambda (project) + (and (forge-project-tissue? project) + (tissue-project + (name (forge-project-name project)) + ;; The laminar user must own the + ;; host state so that it can run + ;; tissue pull. + (user "laminar") + (upstream-repository + (forge-project-repository project))))) + projects)))) + (list)))) + (define (forge-ci-jobs config) - "Return list of CI jobs for forge configuraion @var{config}. Each + "Return list of CI jobs for forge configuration @var{config}. Each value of the returned list is a @code{<forge-laminar-job>} object." (append-map (lambda (project) ;; Add project context to CI jobs. @@ -524,6 +575,10 @@ value is a list of @code{<webhook-hook>} objects." (description "Run guix-forge.") (extensions (list (service-extension activation-service-type forge-activation) + (service-extension forge-nginx-service-type + forge-nginx-server-blocks) + (service-extension tissue-service-type + forge-tissue-hosts) (service-extension forge-laminar-service-type forge-ci-jobs+contexts+groups) ;; TODO: Run CI job only if there are new commits diff --git a/guix/forge/git.scm b/guix/forge/git.scm new file mode 100644 index 0000000..cd6fedc --- /dev/null +++ b/guix/forge/git.scm @@ -0,0 +1,43 @@ +;;; guix-forge --- Guix software forge meta-service +;;; Copyright © 2024 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of guix-forge. +;;; +;;; guix-forge 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. +;;; +;;; guix-forge 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 guix-forge. If not, see +;;; <https://www.gnu.org/licenses/>. + +(define-module (forge git) + #:use-module ((gnu packages version-control) #:select (git-minimal)) + #:use-module (guix gexp) + #:use-module (guix packages) + #:use-module (guix utils)) + +;; We serve shared repositories. But, git's safe directory check does +;; not permit us to use shared repositories. Disable it. +(define-public git-without-safe-directory-check + (package + (inherit git-minimal) + (name "git-without-safe-directory-check") + (arguments + (substitute-keyword-arguments (package-arguments git-minimal) + ((#:phases phases #~%standard-phases) + #~(modify-phases #$phases + (add-after 'unpack 'disable-safe-directory-check + (lambda _ + ;; Disable the safe directory check. + (substitute* "setup.c" + (("return data\\.is_safe;") + "return 1;")) + ;; Disable tests broken by this change. + (setenv "GIT_SKIP_TESTS" "t0033 t0411 t9700"))))))))) diff --git a/guix/forge/guile-git.scm b/guix/forge/guile-git.scm index f582b7d..9315524 100644 --- a/guix/forge/guile-git.scm +++ b/guix/forge/guile-git.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023, 2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -19,7 +19,7 @@ (define-module (forge guile-git) #:use-module ((gnu packages guile) #:select (guile-git) #:prefix guix:) - #:use-module ((gnu packages version-control) #:select (libgit2-1.3) #:prefix guix:) + #:use-module ((gnu packages version-control) #:select (libgit2-1.9) #:prefix guix:) #:use-module (guix gexp) #:use-module (guix packages) #:use-module (guix utils)) @@ -27,17 +27,17 @@ ;; Use a patched libgit2 until there is a way to disable repository ;; ownership validation using the API. See ;; https://issues.guix.gnu.org/55399 -(define libgit2-1.3 +(define libgit2-1.9 (package - (inherit guix:libgit2-1.3) + (inherit guix:libgit2-1.9) (name "libgit2") (arguments - (substitute-keyword-arguments (package-arguments guix:libgit2-1.3) + (substitute-keyword-arguments (package-arguments guix:libgit2-1.9) ((#:phases phases #~%standard-phases) #~(modify-phases #$phases (add-after 'unpack 'disable-ownership-validation (lambda _ - (substitute* "src/repository.c" + (substitute* "src/libgit2/repository.c" (("git_repository__validate_ownership = true") "git_repository__validate_ownership = false")))))))))) @@ -46,4 +46,4 @@ (inherit guix:guile-git) (inputs (modify-inputs (package-inputs guix:guile-git) - (replace "libgit2" libgit2-1.3))))) + (replace "libgit2" libgit2-1.9))))) diff --git a/guix/forge/gunicorn.scm b/guix/forge/gunicorn.scm index 148bd53..6fcbd72 100644 --- a/guix/forge/gunicorn.scm +++ b/guix/forge/gunicorn.scm @@ -1,5 +1,6 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2023–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023–2025 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024 Frederick M. Muriithi <fredmanglis@protonmail.com> ;;; ;;; This file is part of guix-forge. ;;; @@ -51,6 +52,7 @@ gunicorn-app-sockets gunicorn-app-workers gunicorn-app-timeout + gunicorn-app-extra-cli-arguments gunicorn-app-environment-variables gunicorn-app-mappings)) @@ -77,6 +79,8 @@ (thunked)) (workers gunicorn-app-workers (default 1)) + (extra-cli-arguments gunicorn-app-extra-cli-arguments + (default '())) (environment-variables gunicorn-app-environment-variables (default '())) (timeout gunicorn-app-timeout @@ -107,7 +111,8 @@ (define (gunicorn-activation config) (with-imported-modules '((guix build utils)) #~(begin - (use-modules (guix build utils)) + (use-modules (guix build utils) + (ice-9 match)) ;; Create socket directories and set ownership. (for-each (match-lambda @@ -197,6 +202,7 @@ "=" #$(environment-variable-value variable)))) (gunicorn-app-environment-variables app)) + (gunicorn-app-extra-cli-arguments app) (list (gunicorn-app-wsgi-app-module app))))) #:user #$name #:group #$name diff --git a/guix/forge/klaus.scm b/guix/forge/klaus.scm index b6222c3..6ffb23c 100644 --- a/guix/forge/klaus.scm +++ b/guix/forge/klaus.scm @@ -1,5 +1,6 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023, 2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024 jgart <jgart@dismail.de> ;;; ;;; This file is part of guix-forge. ;;; @@ -19,14 +20,16 @@ (define-module (forge klaus) #:use-module (forge environment) + #:use-module ((forge git) #:select (git-without-safe-directory-check)) #:use-module (forge gunicorn) #:use-module (forge socket) #:use-module ((gnu packages check) #:select (python-nose python-pytest)) + #:use-module ((gnu packages python-build) + #:select (python-setuptools python-wheel)) #:use-module ((gnu packages python-web) #:select (python-flask python-werkzeug)) #:use-module ((gnu packages python-xyz) #:select (python-dulwich python-humanize python-pygments)) - #:use-module ((gnu packages version-control) #:select (git-minimal)) #:use-module (gnu system file-systems) #:use-module (guix build-system pyproject) #:use-module (guix build-system python) @@ -34,59 +37,39 @@ #:use-module (guix gexp) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix packages) - #:use-module (guix utils) #:export (klaus-gunicorn-app)) (define-public python-httpauth (package (name "python-httpauth") - (version "0.3") + (version "0.4.1") (source (origin (method url-fetch) (uri (pypi-uri "httpauth" version)) (sha256 (base32 - "0qas7876igyz978pgldp5r7n7pis8n4vf0v87gxr9l7p7if5lr3l")))) + "1m6rwvivg61l3h34hf6p6gkqmr69sb1c4k5ha379nxq0p8bfgahb")))) (build-system pyproject-build-system) - (native-inputs (list python-nose)) + (native-inputs + (list python-pytest + python-setuptools + python-wheel)) (home-page "https://github.com/jonashaag/httpauth") (synopsis "WSGI HTTP Digest Authentication middleware") (description "@code{python-httpauth} is WSGI middleware that secures some/all routes using HTTP Digest Authentication.") (license license:bsd-2))) -;; We use klaus to serve shared repositories. But, git's safe -;; directory check does not permit us to use shared -;; repositories. Disable it. The more long term solution is to rewrite -;; klaus to not use the git CLI at all. See -;; https://github.com/jonashaag/klaus/issues/322 -(define-public git-without-safe-directory-check - (package - (inherit git-minimal) - (name "git-without-safe-directory-check") - (arguments - (substitute-keyword-arguments (package-arguments git-minimal) - ((#:phases phases #~%standard-phases) - #~(modify-phases #$phases - (add-after 'unpack 'disable-safe-directory-check - (lambda _ - ;; Disable the safe directory check. - (substitute* "setup.c" - (("return data\\.is_safe;") - "return 1;")) - ;; Disable tests broken by this change. - (setenv "GIT_SKIP_TESTS" "t0033 t9700"))))))))) - (define-public python-klaus (package (name "python-klaus") - (version "2.0.3") + (version "3.0.1") (source (origin (method url-fetch) (uri (pypi-uri "klaus" version)) (sha256 (base32 - "1y06xnynfah5d4zif2fc0n83zdr0d1vkh0rwcinsi6wjxalvnhjw")))) + "1w6sl15llnkcg7kmnpn64awdiis061q2gijnhdx0ng7z4p1glapl")))) (build-system pyproject-build-system) (arguments (list #:tests? #f ; tests fail @@ -104,9 +87,16 @@ routes using HTTP Digest Authentication.") "tests/test_contrib.py" "tests/test_make_app.py"))))))) (inputs + ;; We use klaus to serve shared repositories. But, git's safe + ;; directory check does not permit us to use shared + ;; repositories. Disable it. The more long term solution is to rewrite + ;; klaus to not use the git CLI at all. See + ;; https://github.com/jonashaag/klaus/issues/322 (list git-without-safe-directory-check)) (native-inputs - (list python-pytest)) + (list python-pytest + python-setuptools + python-wheel)) (propagated-inputs (list python-dulwich python-flask python-httpauth python-humanize python-pygments python-werkzeug)) diff --git a/guix/forge/tissue.scm b/guix/forge/tissue.scm index 4ece204..1608728 100644 --- a/guix/forge/tissue.scm +++ b/guix/forge/tissue.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2022, 2023, 2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -19,13 +19,16 @@ (define-module (forge tissue) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module ((forge guile-git) #:select (guile-git)) + #:use-module (forge nginx) #:use-module (forge socket) #:use-module (gnu build linux-container) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module ((gnu packages web) #:select (tissue) #:prefix guix:) #:use-module (gnu services) #:use-module (gnu services shepherd) + #:use-module (gnu services web) #:use-module (gnu system file-systems) #:use-module (gnu system shadow) #:use-module (guix gexp) @@ -34,6 +37,7 @@ #:use-module (guix modules) #:use-module (guix packages) #:use-module (guix records) + #:use-module (ice-9 match) #:export (tissue-service-type <tissue-configuration> tissue-configuration @@ -46,14 +50,19 @@ tissue-host tissue-host? tissue-host-name - tissue-host-user - tissue-host-upstream-repository)) + tissue-host-projects + <tissue-project> + tissue-project + tissue-project-name + tissue-project-user + tissue-project-base-path + tissue-project-upstream-repository)) ;; Run an updated version of tissue until the the 0.1.1 release is ;; out. (define-public tissue - (let ((commit "0c3d6cb7d781fbc0c12eba1563cc7b7ebb370ba9") - (revision "1")) + (let ((commit "a9187595cccca4954c7d4920b93b922ea190e179") + (revision "2")) (package (inherit guix:tissue) (name "tissue") @@ -66,7 +75,7 @@ (file-name (git-file-name name version)) (sha256 (base32 - "0hdqa5n8dm2nc4ccx39xclgajv3ivwpb1hbz9kpbbv25iizqhnv2")))) + "0pgdznck8vwmbccmpcqd3xnikbgzb2phxik7bcm80dls6g4n3py2")))) (inputs (modify-inputs (package-inputs guix:tissue) (replace "guile-git" guile-git)))))) @@ -88,9 +97,22 @@ tissue-host make-tissue-host tissue-host? (name tissue-host-name) - (user tissue-host-user + (projects tissue-host-projects + (default '()))) + +(define-record-type* <tissue-project> + tissue-project make-tissue-project + tissue-project? + this-tissue-project + (name tissue-project-name) + (user tissue-project-user (default "tissue")) - (upstream-repository tissue-host-upstream-repository)) + (base-path tissue-project-base-path + (default (string-append "/" + (tissue-project-name this-tissue-project) + "/")) + (thunked)) + (upstream-repository tissue-project-upstream-repository)) (define %tissue-accounts (list (user-account @@ -105,6 +127,19 @@ (system? #t)))) (define (tissue-conf-gexp config) + (define project->alist + (match-record-lambda <tissue-project> + (name base-path upstream-repository) + `(,name + (base-path . ,base-path) + (upstream-repository . ,upstream-repository)))) + + (define host->alist + (match-record-lambda <tissue-host> + (name projects) + `(,name + (projects . ,(map project->alist projects))))) + (match-record config <tissue-configuration> (socket state-directory hosts) #~(begin @@ -129,11 +164,7 @@ "Socket must be a <forge-ip-socket> or <forge-unix-socket> record") (make-irritants-condition socket)))))) (state-directory . #$state-directory) - (hosts . #$(map (lambda (host) - (match-record host <tissue-host> - (name upstream-repository) - `(,name (upstream-repository . ,upstream-repository)))) - hosts))) + (hosts . #$(map host->alist hosts))) port)))))) ;; We cannot just pass the configuration file on the command-line @@ -162,22 +193,23 @@ ;; the tissue user. (mkdir-p #$state-directory) (chown #$state-directory (passwd:uid user) (passwd:gid user))) - ;; Create host directories if they don't exist, and set - ;; permissions. Each host directory may be owned by its own - ;; user. + ;; Create project directories if they don't exist, and set + ;; permissions. Each project directory may be owned by its + ;; own user. (for-each (match-lambda - ((hostname username) - (let ((host-directory (string-append #$state-directory "/" hostname)) + ((project-name username) + (let ((project-directory (string-append #$state-directory "/" project-name)) (user (getpw username))) - (mkdir-p host-directory) + (mkdir-p project-directory) (for-each (lambda (file) (chown file (passwd:uid user) (passwd:gid user))) - (find-files host-directory #:directories? #t))))) - '#$(map (lambda (host) - (match-record host <tissue-host> - (name user) - (list name user))) - hosts)))))) + (find-files project-directory #:directories? #t))))) + '#$(append-map (lambda (host) + (map (match-record-lambda <tissue-project> + (name user) + (list name user)) + (tissue-host-projects host))) + hosts)))))) (define (tissue-shepherd-service config) (match-record config <tissue-configuration> @@ -216,6 +248,58 @@ #:log-file "/var/log/tissue.log"))) (stop #~(make-kill-destructor))))) +(define (socket->proxy-pass socket) + "Serialize @var{socket}, a forge socket, to an nginx @code{proxy_pass} +directive." + (string-append + "proxy_pass " + (match socket + (($ <forge-host-socket> hostname port) + (string-append "http://" hostname ":" (number->string port))) + (($ <forge-ip-socket> (? ipv4-address? ip) port) + (string-append "http://" ip ":" (number->string port))) + (($ <forge-ip-socket> (? ipv6-address? ip) port) + (string-append "http://[" ip "]:" (number->string port))) + (($ <forge-unix-socket> path) + (string-append "http://unix:" path ":"))) + ";")) + +(define (tissue-nginx-server-blocks config) + "Return list of @code{<nginx-server-configuration>} extensions for +tissue configuration @var{config}." + (define (project->location state-directory project) + (nginx-location-configuration + (uri (tissue-project-base-path project)) + (body (list (string-append "alias " + state-directory + "/" + (tissue-project-name project) + "/website/;") + "try_files $uri $uri.html $uri/ @tissue-search;")))) + + (match-record config <tissue-configuration> + (socket state-directory hosts) + (map (match-record-lambda <tissue-host> + (name projects) + (nginx-server-configuration + (server-name (list name)) + (locations + (cons (nginx-location-configuration + (uri "@tissue-search") + (body (list (socket->proxy-pass socket) + "proxy_set_header Host $host;"))) + (append (map (cut project->location state-directory <>) + projects) + ;; Reject all other locations, unless there + ;; is a project with / as its base path. + (if (member "/" (map tissue-project-base-path + projects)) + (list) + (list (nginx-location-configuration + (uri "/") + (body (list "return 404;")))))))))) + hosts))) + (define tissue-service-type (service-type (name 'tissue) @@ -228,7 +312,9 @@ (service-extension activation-service-type tissue-activation) (service-extension shepherd-root-service-type - (compose list tissue-shepherd-service)))) + (compose list tissue-shepherd-service)) + (service-extension forge-nginx-service-type + tissue-nginx-server-blocks))) (compose concatenate) (extend (lambda (config host-extensions) (tissue-configuration |