diff options
Diffstat (limited to 'guix/forge')
| -rw-r--r-- | guix/forge/acme.scm | 17 | ||||
| -rw-r--r-- | guix/forge/anubis.scm | 142 | ||||
| -rw-r--r-- | guix/forge/cgit.scm | 162 | ||||
| -rw-r--r-- | guix/forge/fcgiwrap.scm | 13 | ||||
| -rw-r--r-- | guix/forge/forge.scm | 303 | ||||
| -rw-r--r-- | guix/forge/git.scm | 43 | ||||
| -rw-r--r-- | guix/forge/guile-git.scm | 14 | ||||
| -rw-r--r-- | guix/forge/gunicorn.scm | 17 | ||||
| -rw-r--r-- | guix/forge/klaus.scm | 204 | ||||
| -rw-r--r-- | guix/forge/laminar.scm | 20 | ||||
| -rw-r--r-- | guix/forge/nginx.scm | 223 | ||||
| -rw-r--r-- | guix/forge/tissue.scm | 122 | ||||
| -rw-r--r-- | guix/forge/utils.scm | 10 | ||||
| -rw-r--r-- | guix/forge/webhook.scm | 65 |
14 files changed, 991 insertions, 364 deletions
diff --git a/guix/forge/acme.scm b/guix/forge/acme.scm index 5ec27bb..f78eedc 100644 --- a/guix/forge/acme.scm +++ b/guix/forge/acme.scm @@ -1,5 +1,7 @@ ;;; 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> +;;; Copyright © 2025 Frederick M. Muriithi <fredmanglis@protonmail.com> ;;; ;;; This file is part of guix-forge. ;;; @@ -20,9 +22,9 @@ (define-module (forge acme) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module ((gnu packages autotools) #:select (autoconf automake)) - #:use-module ((gnu packages certs) #:select (nss-certs)) #:use-module ((gnu packages curl) #:select (curl)) #:use-module ((gnu packages documentation) #:select (asciidoc)) + #:use-module ((gnu packages nss) #:select (nss-certs)) #:use-module ((gnu packages pkg-config) #:select (pkg-config)) #:use-module ((gnu packages tls) #:select (gnutls)) #:use-module (gnu services) @@ -73,7 +75,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 +85,7 @@ (file-name (git-file-name name version)) (sha256 (base32 - "1jhjyjnrfq07qgslmz1qpka1ahnmpya2garbxldkh2fr0bmsn26b")))) + "1br374d0lnn422rvg2g4m69vhdck8aihdsjydr064hif0lscr8ri")))) (build-system gnu-build-system) (arguments (list #:phases @@ -332,9 +334,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/anubis.scm b/guix/forge/anubis.scm new file mode 100644 index 0000000..63f7a54 --- /dev/null +++ b/guix/forge/anubis.scm @@ -0,0 +1,142 @@ +;;; guix-forge --- Guix software forge meta-service +;;; Copyright © 2026 Ashish Shukla <ashish.is@lostca.se> +;;; Copyright © 2026 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 anubis) + #:use-module ((gnu packages golang) #:select (go-1.26)) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu system file-systems) + #:use-module (guix build-system gnu) + #:use-module (guix download) + #:use-module (guix gexp) + #:use-module (guix least-authority) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix packages) + #:use-module (guix records) + #:use-module (ice-9 match) + #:export (anubis-configuration + anubis-configuration? + anubis-configuration-package + anubis-service-type + %anubis-unix-socket)) + +;; TODO: Unbundle vendored node and go dependencies. See work in progress at +;; https://codeberg.org/guix/guix/pulls/2572 +;; This package is based on https://codeberg.org/group/guix-modules/src/commit/137fe9d6dcdad1582c64a70c6f8a052c9251a590/guix/abbe/packages/golang.scm#L902 +(define-public anubis-ai-firewall + (package + (name "anubis-ai-firewall") + (version "1.26.2") + (source + (origin + (method url-fetch) + (uri (string-append "https://github.com/TecharoHQ/anubis/releases/download/v" + version "/anubis-src-vendor-npm-" version ".tar.gz")) + (sha256 + (base32 "1yab3z58vgi16313wmx7g32xk6nv158lqic54qds43l63y6lmf92")))) + (build-system gnu-build-system) + (arguments + (list #:phases + #~(modify-phases %standard-phases + (delete 'configure) + (add-after 'unpack 'patch-Makefile + (lambda _ + (substitute* "Makefile" + (("\\(GO\\) build" all) + (string-append all " -trimpath"))))) + (replace 'build + (lambda _ + (let ((tmpdir "/tmp")) + (setenv "TMPDIR" tmpdir) + (setenv "GOPATH" (string-append tmpdir "/go")) + (setenv "GOCACHE" (string-append tmpdir "/go-cache")) + (invoke "make" "prebaked-build")))) + (replace 'check + (lambda* (#:key tests? #:allow-other-keys) + (when tests? + (invoke "go" "test" "./..." + ;; This test requires network access. + "-skip" "TestLookup")))) + (replace 'install + (lambda _ + (install-file "var/anubis" + (string-append #$output "/bin"))))))) + (native-inputs + (list go-1.26)) + (home-page "https://anubis.techaro.lol/") + (synopsis "Identify and block HTTP requests from AI bots") + (description + "Anubis is a web AI firewall utility that uses a combination of heuristics +and challenges to identify and block bots before they take your website down. +Anubis is as lightweight as possible and is designed to help protect the small +internet from the endless storm of requests that flood in from AI companies.") + (license license:expat))) + +(define-record-type* <anubis-configuration> + anubis-configuration make-anubis-configuration + anubis-configuration? + (package anubis-configuration-package + (default anubis-ai-firewall))) + +;; TODO: Do not hard-code. +(define %anubis-unix-socket + "/var/run/anubis/socket") + +(define (anubis-activation config) + #~(begin + (let ((user (getpw "nginx"))) + (mkdir-p (dirname #$%anubis-unix-socket)) + (chown (dirname #$%anubis-unix-socket) + (passwd:uid user) + (passwd:gid user))))) + +(define anubis-shepherd-service + (match-lambda + (($ <anubis-configuration> package) + (shepherd-service + (documentation "Run the Anubis AI firewall.") + (provision '(anubis)) + (requirement '(networking)) + (start #~(make-forkexec-constructor + (list #$(least-authority-wrapper + (file-append package "/bin/anubis") + #:name "anubis-pola-wrapper" + #:mappings (list (file-system-mapping + (source (dirname %anubis-unix-socket)) + (target source) + (writable? #t)))) + "-bind" #$%anubis-unix-socket + "-bind-network" "unix" + "-target" " ") + #:user "nginx" + #:group "nginx" + #:log-file "/var/log/anubis.log")) + (stop #~(make-kill-destructor)))))) + +(define anubis-service-type + (service-type + (name 'anubis) + (description "Run the Anubis AI firewall.") + (extensions + (list (service-extension activation-service-type + anubis-activation) + (service-extension shepherd-root-service-type + (compose list anubis-shepherd-service)))) + (default-value (anubis-configuration)))) diff --git a/guix/forge/cgit.scm b/guix/forge/cgit.scm index 805f47f..a607f5f 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–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -20,17 +20,23 @@ (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)) #:use-module ((gnu packages mail) #:select (mailcap)) + #:use-module ((gnu packages golang-apps) #:select (go-chroma)) #:use-module ((gnu packages version-control) - #:select (cgit git-minimal)) + #:select (cgit-pink git-minimal)) #:use-module (gnu services) #:use-module ((gnu services web) #:select (nginx-server-configuration - nginx-location-configuration)) + nginx-location-configuration + nginx-named-location-configuration + nginx-named-location-configuration-body)) #:use-module (gnu system file-systems) + #:use-module (guix diagnostics) #:use-module (guix gexp) + #:use-module (guix i18n) #:use-module (guix records) #:use-module (ice-9 match) #:use-module (srfi srfi-26) @@ -53,6 +59,7 @@ cgit-configuration-repository-sort cgit-configuration-plain-email? cgit-configuration-extra-options + cgit-configuration-fcgiwrap-processes cgit-service-type)) (define %cgit-readme @@ -66,14 +73,29 @@ "README.txt" "README"))) +(define %cgit-chroma-syntax-highlight-gexp + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (match (command-line) + ((_ file) + (invoke #$(file-append go-chroma "/bin/chroma") + "--style" "pastie" + "--html" + "--html-only" + "--html-inline-styles" + "--filename" file)))))) + (define-record-type* <cgit-configuration> cgit-configuration make-cgit-configuration cgit-configuration? this-cgit-configuration (cgit cgit-configuration-cgit - (default cgit)) + (default cgit-pink)) (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")) @@ -89,15 +111,18 @@ (about-filter cgit-configuration-about-filter (default (program-file "about-filter" (about-filter-gexp this-cgit-configuration))) + ;; thunked so that value can reference the cgit package in + ;; configuration (thunked)) (commit-filter cgit-configuration-commit-filter (default #f)) (email-filter cgit-configuration-email-filter (default #f)) (source-filter cgit-configuration-source-filter - (default (file-append (cgit-configuration-cgit - this-cgit-configuration) - "/lib/cgit/filters/syntax-highlighting.py")) + (default (program-file "cgit-chroma-syntax-highlight" + %cgit-chroma-syntax-highlight-gexp)) + ;; thunked so that value can reference the cgit package in + ;; configuration (thunked)) (mimetype-file cgit-configuration-mimetype-file (default (file-append mailcap "/etc/mime.types"))) @@ -107,16 +132,18 @@ (plain-email? cgit-configuration-noplainemail? (default #false)) (extra-options cgit-configuration-extra-options - (default '()))) + (default '())) + (fcgiwrap-processes cgit-configuration-fcgiwrap-processes + (default #~(* 2 (total-processor-count))))) (define (sanitize-cgit-snapshots snapshots) (let ((valid-snapshots (list "tar" "tar.gz" "tar.bz2" "tar.lz" "tar.xz" "tar.zst" "zip"))) (for-each (lambda (snapshot) (unless (member snapshot valid-snapshots) - (leave (G_ "Snapshot ~a is not one of ~s.~%" - snapshot - valid-snapshots)))) + (leave (G_ "Snapshot ~a is not one of ~s.~%") + snapshot + valid-snapshots))) snapshots) snapshots)) @@ -221,73 +248,88 @@ configured in @var{config}." (define (cgit-fcgiwrap-instance config) (match-record config <cgit-configuration> - (cgit git repository-directory) + (cgit git repository-directory fcgiwrap-processes) (let ((cgitrc (computed-file "cgitrc" (cgitrc-gexp config)))) (fcgiwrap-instance (name "cgit") (user "nginx") (group "nginx") + (processes fcgiwrap-processes) (environment-variables (list (environment-variable (name "CGIT_CONFIG") (value cgitrc)))) (mappings (list (file-system-mapping - (source repository-directory) - (target source)) + (source repository-directory) + (target source)) (file-system-mapping - (source cgit) - (target source)) + (source cgit) + (target source)) (file-system-mapping - (source cgitrc) - (target source)) + (source cgitrc) + (target source)) (file-system-mapping - (source (file-append git "/libexec/git-core/git-http-backend")) - (target source)))))))) + (source (file-append git "/libexec/git-core/git-http-backend")) + (target source)))))))) (define cgit-nginx-server-block (match-record-lambda <cgit-configuration> - (cgit git server-name socket repository-directory) - (nginx-server-configuration + (cgit git server-name socket repository-directory) + (forge-nginx-server-configuration (server-name (list server-name)) ;; cgit static files (root (file-append cgit "/share/cgit")) - (try-files (list "$uri" "@cgit")) + (anubis? #t) (locations - (list - ;; git-http-backend for the smart HTTP protocol - (nginx-location-configuration - (uri "~ ^/.*/(HEAD|info/refs|git-receive-pack|git-upload-pack).*$") - (body (list "fastcgi_param SCRIPT_FILENAME " - (file-append git "/libexec/git-core/git-http-backend;") - (string-append "fastcgi_param GIT_PROJECT_ROOT " - repository-directory - ";") - "fastcgi_param GIT_HTTP_EXPORT_ALL yes;" - "fastcgi_param PATH_INFO $uri;" - "fastcgi_param QUERY_STRING $query_string;" - "fastcgi_param REQUEST_METHOD $request_method;" - "fastcgi_param CONTENT_TYPE $content_type;" - (string-append "fastcgi_pass " - (nginx-socket->string socket) - ";")))) - ;; cgit web interface - (nginx-location-configuration - (uri "@cgit") - (body (list - #~(string-append "fastcgi_param SCRIPT_FILENAME " - #$(file-append cgit "/lib/cgit/cgit.cgi") - ";") - "fastcgi_param PATH_INFO $uri;" - "fastcgi_param QUERY_STRING $query_string;" - "fastcgi_param HTTP_HOST $server_name;" - (string-append "fastcgi_pass " - (nginx-socket->string socket) - ";"))))))))) + (let ((cgit-location + (nginx-named-location-configuration + (name "cgit") + (body (list + #~(string-append "fastcgi_param SCRIPT_FILENAME " + #$(file-append cgit "/lib/cgit/cgit.cgi") + ";") + "fastcgi_param PATH_INFO $uri;" + "fastcgi_param QUERY_STRING $query_string;" + "fastcgi_param HTTP_HOST $server_name;" + (string-append "fastcgi_pass " + (nginx-socket->string socket) + ";")))))) + (list + ;; git-http-backend for the smart HTTP protocol + (nginx-location-configuration + (uri "~ ^/.*/(HEAD|info/refs|git-receive-pack|git-upload-pack).*$") + (body (list "fastcgi_param SCRIPT_FILENAME " + (file-append git "/libexec/git-core/git-http-backend;") + (string-append "fastcgi_param GIT_PROJECT_ROOT " + repository-directory + ";") + "fastcgi_param GIT_HTTP_EXPORT_ALL yes;" + "fastcgi_param PATH_INFO $uri;" + "fastcgi_param QUERY_STRING $query_string;" + "fastcgi_param REQUEST_METHOD $request_method;" + "fastcgi_param CONTENT_TYPE $content_type;" + (string-append "fastcgi_pass " + (nginx-socket->string socket) + ";")))) + ;; cgit web interface + cgit-location + ;; Protect the commit, diff and tree URIs behind Anubis. + (nginx-location-configuration + (uri "~ ^/.*/(diff|tree)/") + (body (cons* "auth_request /.within.website/x/cmd/anubis/api/check;" + "error_page 401 = @redirectToAnubis;" + (nginx-named-location-configuration-body cgit-location)))) + ;; On other URIs, try a file before falling back to @cgit. This + ;; try_files cannot be in the server context because it would then + ;; apply to git-http-backend, etc. + (nginx-location-configuration + (uri "/") + (body (list "try_files $uri @cgit;"))))))))) (define cgit-service-type (service-type - (name 'cgit) - (description "Run cgit.") - (extensions (list (service-extension fcgiwrap-service-type - (compose list cgit-fcgiwrap-instance)) - (service-extension forge-nginx-service-type - (compose list cgit-nginx-server-block)))))) + (name 'cgit) + (description "Run cgit.") + (extensions (list (service-extension fcgiwrap-service-type + (compose list cgit-fcgiwrap-instance)) + (service-extension forge-nginx-service-type + (compose list cgit-nginx-server-block)))))) diff --git a/guix/forge/fcgiwrap.scm b/guix/forge/fcgiwrap.scm index f699480..8915f66 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–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -65,7 +65,7 @@ (user fcgiwrap-instance-user) (group fcgiwrap-instance-group) (processes fcgiwrap-instance-processes - (default 1)) + (default #~(* 2 (total-processor-count)))) (environment-variables fcgiwrap-instance-environment-variables (default '())) (mappings fcgiwrap-instance-mappings @@ -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 @@ -112,7 +113,8 @@ (documentation (string-append "Run fcgiwrap for " name " script.")) (provision '(fcgiwrap)) (requirement '(networking)) - (modules '((ice-9 match))) + (modules '((ice-9 match) + (ice-9 threads))) ; for total-processor-count and others (start #~(make-forkexec-constructor (list #$(least-authority-wrapper @@ -137,7 +139,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..bdadb2b 100644 --- a/guix/forge/forge.scm +++ b/guix/forge/forge.scm @@ -1,5 +1,6 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2021–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2025 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2025 Frederick M. Muriithi <fredmanglis@protonmail.com> ;;; ;;; This file is part of guix-forge. ;;; @@ -21,15 +22,19 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:use-module ((gnu packages certs) #:select (nss-certs)) #:use-module ((gnu packages ci) #:select (laminar)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) #:use-module ((gnu packages guile) #:select (guile-3.0 guile-bytestructures guile-zlib)) + #:use-module ((gnu packages guile-xyz) #:select (guile-lib)) + #:use-module ((gnu packages mail) #:select (msmtp)) + #:use-module ((gnu packages nss) #:select (nss-certs)) #:use-module ((gnu packages package-management) #:select (guix)) #: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 +43,21 @@ #: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? + this-forge-configuration + forge-configuration-web-domain + forge-configuration-cgit-domain + forge-configuration-laminar-domain + forge-configuration-tissue-web-domain + forge-configuration-websites-directory + forge-configuration-web-root + forge-configuration-mailer-address forge-configuration-projects forge-project forge-project? @@ -52,9 +66,13 @@ forge-project-user forge-project-repository forge-project-repository-branch - forge-project-website-directory + forge-project-web-domain + forge-project-tissue? + forge-project-website-ci-job forge-project-ci-jobs forge-project-ci-jobs-trigger + forge-project-ci-notify-addresses + forge-project-parallel-ci-job-runs derivation-job-gexp variable-specification variable-specification? @@ -76,8 +94,13 @@ (default "main")) (description forge-project-description (default #f)) - (website-directory forge-project-website-directory - (default #f)) + (web-domain forge-project-web-domain + (default #f)) + (tissue? forge-project-tissue? + (default #f)) + (website-ci-job forge-project-website-ci-job + (default #f) + (thunked)) (ci-jobs forge-project-ci-jobs (default '()) (thunked)) (ci-jobs-trigger forge-project-ci-jobs-trigger ; one of 'post-receive-hook, 'cron, 'webhook @@ -88,15 +111,94 @@ ;; 'cron for remote repositories (else 'cron))) (thunked)) + (ci-notify-addresses forge-project-ci-notify-addresses + (default '())) (parallel-ci-job-runs forge-project-parallel-ci-job-runs (default 1))) (define-record-type* <forge-configuration> forge-configuration make-forge-configuration forge-configuration? + this-forge-configuration + (web-domain forge-configuration-web-domain) + (cgit-domain forge-configuration-cgit-domain + (default #f)) + (laminar-domain forge-configuration-laminar-domain + (default #f)) + (tissue-web-domain forge-configuration-tissue-web-domain + (default #f)) + (websites-directory forge-configuration-websites-directory + (default "/srv/http/forge")) + (web-root forge-configuration-web-root + (default (computed-file "forge-web-root" + (forge-web-root-gexp this-forge-configuration))) + (thunked)) + (mailer-address forge-configuration-mailer-address + (default (string-append "mail@" + (forge-configuration-web-domain this-forge-configuration))) + (thunked)) (projects forge-configuration-projects (default '()))) +(define (forge-web-root-gexp config) + (with-extensions (list guile-lib) + #~(begin + (use-modules (rnrs io ports) + (srfi srfi-26) + (ice-9 match) + (htmlprag)) + + (define (laminar-badge job-name) + `(li (a (@ (href ,(string-append "https://" + #$(forge-configuration-laminar-domain config) + "/jobs/" + job-name))) + (img (@ (src ,(string-append "https://" + #$(forge-configuration-laminar-domain config) + "/badge/" + job-name + ".svg"))))))) + + (mkdir #$output) + (let ((html + (sxml->html + `(html + (body + ,@(map (match-lambda + ((name description website-link jobs) + `((h2 ,(if website-link + `(a (@ (href ,website-link)) + ,name) + name)) + ,@(match jobs + (() '()) + (_ + (if #$(forge-configuration-laminar-domain config) + `((ul ,@(map laminar-badge jobs))) + '()))) + ,@(if description + `((p ,description)) + '()) + (ul + ,@(if #$(forge-configuration-cgit-domain config) + `((li (a (@ (href ,(string-append "https://" + #$(forge-configuration-cgit-domain config) + "/" name "/"))) + "cgit"))) + '()))))) + '#$(map (lambda (project) + (list (forge-project-name project) + (forge-project-description project) + (and (forge-project-website-ci-job project) + (if (forge-project-web-domain project) + (string-append "https://" (forge-project-web-domain project)) + (string-append "/" (forge-project-name project) "/"))) + (map forge-laminar-job-name + (forge-project-all-ci-jobs project config)))) + (forge-configuration-projects config)))))))) + (call-with-output-file (string-append #$output "/index.html") + (cut put-string <> html)))))) + (define* (ci-jobs-trigger-gexp ci-jobs #:key reason) "Return a G-expression that triggers CI-JOBS. CI-JOBS is a list of <forge-laminar-job> objects." @@ -136,12 +238,11 @@ (list (forge-project-user project) (forge-project-repository project) (forge-project-description project) - (forge-project-website-directory project) (program-file (string-append (forge-project-name project) "-post-receive-hook") (ci-jobs-trigger-gexp - (forge-project-ci-jobs project) + (forge-project-all-ci-jobs project config) #:reason "post-receive hook")) (forge-project-ci-jobs-trigger project))) (forge-configuration-projects config)))) @@ -156,8 +257,14 @@ '(regular directory))) #:directories? #t)) + ;; Set ownership of forge websites directory. + (let ((user (getpw "laminar"))) + (chown #$(forge-configuration-websites-directory config) + (passwd:uid user) + (passwd:gid user))) + (for-each (match-lambda - ((username repository description website-directory ci-jobs-trigger ci-jobs-trigger-type) + ((username repository description ci-jobs-trigger ci-jobs-trigger-type) ;; For local repositories only (when (string-prefix? "/" repository) ;; Set description. @@ -179,12 +286,7 @@ (let ((hook-link (string-append repository "/hooks/post-receive"))) (when (file-exists? hook-link) (delete-file hook-link)) - (symlink ci-jobs-trigger hook-link))) - ;; Set ownership of website directory. - (when website-directory - (let ((user (getpw "laminar"))) - (chown (dirname website-directory) - (passwd:uid user) (passwd:gid user)))))) + (symlink ci-jobs-trigger hook-link))))) '#$projects)))) (define (import-module? name) @@ -193,8 +295,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,17 +538,150 @@ that were built." (package-channels pkg)))))))) inferior)))))))) +(define (switch-symlinks-gexp link target) + "Return a G-expression that links @var{link} to @var{target}. @var{target} is a +singleton list of targets as returned by @code{guix-channel-job-gexp}." + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (switch-symlinks #$link + (match #$target + ((target) target)))))) + +(define (forge-nginx-server-blocks config) + "Return list of @code{<nginx-server-configuration>} extensions for +forge configuration @var{config}." + (cons (nginx-server-configuration + (server-name (list (forge-configuration-web-domain config))) + (root (forge-configuration-web-root config)) + ;; Serve HTML files without extension. + (try-files (list "$uri" "$uri.html" "$uri/index.html" "=404")) + (locations + ;; Configure location blocks for projects that have no web domain. + (filter-map (lambda (project) + (match-record project <forge-project> + (name web-domain) + (and (not web-domain) + (nginx-location-configuration + (uri (string-append "/" name "/")) + (body + (list (string-append "root " + (forge-configuration-websites-directory config) + ";"))))))) + (forge-configuration-projects config)))) + ;; Configure nginx server blocks for projects that have a web domain. + (filter-map (match-record-lambda <forge-project> + (name web-domain) + (and web-domain + (nginx-server-configuration + (server-name (list web-domain)) + (root (string-append (forge-configuration-websites-directory config) + "/" + name)) + ;; Serve HTML files without extension. + (try-files (list "$uri" "$uri.html" + "$uri/index.html" "=404"))))) + (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> + (tissue-web-domain projects) + ;; Configure tissue host if a tissue web domain is provided. + (if tissue-web-domain + (list (tissue-host + (name tissue-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 (ci-notify-by-email from to) + "Return a G-expression that emails @var{to} addresses from @var{from} address +about the status of a laminar CI job. The returned G-expression is intended to +be used as the @code{after} field of a @code{<forge-laminar-job>} object." + #~(begin + (use-modules (ice-9 popen) + (srfi srfi-26)) + + (define (call-with-output-pipe command proc) + (let ((port #f)) + (dynamic-wind + (cut set! port (apply open-pipe* OPEN_WRITE command)) + (cut proc port) + (lambda () + (unless (zero? (status:exit-val (close-pipe port))) + (error "Command invocation failed" command)))))) + + (let ((job (getenv "JOB")) + (run (getenv "RUN")) + (result (getenv "RESULT")) + (last-result (getenv "LAST_RESULT"))) + (unless (string=? result last-result) + (call-with-output-pipe (list #$(file-append msmtp "/bin/msmtp") + "--host=localhost" + "--port=587" + "--read-envelope-from" + "--read-recipients") + (cut format + <> + "From: ~a +To: ~a +Subject: Laminar ~a #~a: ~a + +See https://ci.systemreboot.net/jobs/~a/~a for details. +" + #$from + #$(string-join to ",") + job run result job run)))))) + +(define (forge-project-all-ci-jobs project config) + "Return list of all CI jobs for @var{project} in forge configuration +@var{config}." + (map (lambda (job) + (forge-laminar-job + (inherit job) + ;; Add project context to job. + (contexts (cons (forge-project-name project) + (forge-laminar-job-contexts job))) + ;; Add CI email notification to job. + (after #~(begin + #$@(cond + ((forge-laminar-job-after job) => list) + (else (list))) + #$(match (forge-project-ci-notify-addresses project) + (() #f) + (addresses + (ci-notify-by-email (forge-configuration-mailer-address config) + addresses))))))) + ;; Prepend website CI job to the other CI jobs. + (if (forge-project-website-ci-job project) + (cons (forge-laminar-job + (inherit (forge-project-website-ci-job project)) + (run (switch-symlinks-gexp + (string-append (forge-configuration-websites-directory config) + "/" + (forge-project-name project)) + (forge-laminar-job-run (forge-project-website-ci-job project))))) + (forge-project-ci-jobs project)) + (forge-project-ci-jobs project)))) + (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. - (map (lambda (job) - (forge-laminar-job - (inherit job) - (contexts (cons (forge-project-name project) - (forge-laminar-job-contexts job))))) - (forge-project-ci-jobs project))) + (append-map (cut forge-project-all-ci-jobs <> config) (forge-configuration-projects config))) (define (forge-ci-job-contexts config) @@ -463,7 +699,7 @@ value of the returned list is a @code{<forge-laminar-job>} object." @var{config}. Each element of the returned list is a @code{<forge-laminar-group>} object." (filter-map (lambda (project) - (match (forge-project-ci-jobs project) + (match (forge-project-all-ci-jobs project config) (() #f) ((job) #f) (jobs @@ -492,13 +728,13 @@ mcron job specification." (and (eq? (forge-project-ci-jobs-trigger project) 'cron) (any forge-laminar-job-trigger? - (forge-project-ci-jobs project)) + (forge-project-all-ci-jobs project config)) #~(job '(next-day) #$(program-file (string-append (forge-project-name project) "-cron-job") (ci-jobs-trigger-gexp - (forge-project-ci-jobs project) + (forge-project-all-ci-jobs project config) #:reason "Cron job")) #:user "laminar"))) (forge-configuration-projects config))) @@ -510,11 +746,11 @@ value is a list of @code{<webhook-hook>} objects." (and (eq? (forge-project-ci-jobs-trigger project) 'webhook) (any forge-laminar-job-trigger? - (forge-project-ci-jobs project)) + (forge-project-all-ci-jobs project config)) (webhook-hook (id (forge-project-name project)) (run (ci-jobs-trigger-gexp - (forge-project-ci-jobs project) + (forge-project-all-ci-jobs project config) #:reason "Webhook"))))) (forge-configuration-projects config))) @@ -524,6 +760,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 @@ -537,5 +777,4 @@ value is a list of @code{<webhook-hook>} objects." (forge-configuration (inherit config) (projects (append (forge-configuration-projects config) - projects))))) - (default-value (forge-configuration)))) + projects))))))) 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..1650a4d 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–2026 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)) @@ -76,7 +78,9 @@ "/socket"))))) (thunked)) (workers gunicorn-app-workers - (default 1)) + (default #~(* 2 (total-processor-count)))) + (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 @@ -146,7 +151,8 @@ (provision (list (string->symbol name))) (requirement '(networking)) (modules '((guix search-paths) - (ice-9 match))) + (ice-9 match) + (ice-9 threads))) ; for total-processor-count and others (start (let* ((app-manifest (packages->manifest ;; Using python-minimal in the @@ -185,7 +191,7 @@ ;; network namespace. We can't do this yet due to ;; https://yhetil.org/guix/m1ilknoi5r.fsf@fastmail.net/ #:namespaces (delq 'net %namespaces)) - "--workers" #$(number->string (gunicorn-app-workers app)) + "--workers" (number->string #$(gunicorn-app-workers app)) "--timeout" #$(number->string (gunicorn-app-timeout app)) (list #$@(append (append-map (lambda (socket) (list "--bind" @@ -197,6 +203,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..157a974 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–2026 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024 jgart <jgart@dismail.de> ;;; ;;; This file is part of guix-forge. ;;; @@ -19,116 +20,123 @@ (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 nginx) #:use-module (forge socket) - #:use-module ((gnu packages check) #:select (python-nose python-pytest)) - #: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)) + #:select (python-docutils python-markdown)) + #:use-module ((gnu packages version-control) + #:select (python-klaus) + #:prefix guix:) + #:use-module (gnu services) + #:use-module ((gnu services web) #:select (nginx-server-configuration + nginx-location-configuration)) #:use-module (gnu system file-systems) - #:use-module (guix build-system pyproject) - #:use-module (guix build-system python) - #:use-module (guix download) + #:use-module (guix deprecation) #: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") - (source (origin - (method url-fetch) - (uri (pypi-uri "httpauth" version)) - (sha256 - (base32 - "0qas7876igyz978pgldp5r7n7pis8n4vf0v87gxr9l7p7if5lr3l")))) - (build-system pyproject-build-system) - (native-inputs (list python-nose)) - (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"))))))))) + #:use-module (guix records) + #:export (<klaus-configuration> + klaus-configuration + klaus-configuration? + klaus-configuration-python-klaus + klaus-configuration-server-name + klaus-configuration-socket + klaus-configuration-repository-directory + klaus-configuration-site-name + klaus-configuration-gunicorn-workers + klaus-service-type + klaus-gunicorn-app)) (define-public python-klaus (package - (name "python-klaus") - (version "2.0.3") - (source (origin - (method url-fetch) - (uri (pypi-uri "klaus" version)) - (sha256 - (base32 - "1y06xnynfah5d4zif2fc0n83zdr0d1vkh0rwcinsi6wjxalvnhjw")))) - (build-system pyproject-build-system) - (arguments - (list #:tests? #f ; tests fail - #:phases - #~(modify-phases %standard-phases - (add-after 'unpack 'configure-git - (lambda* (#:key inputs #:allow-other-keys) - (for-each (lambda (file) - (substitute* file - (("\"git\"") - (string-append "\"" (search-input-file inputs "/bin/git") "\"")))) - (list "klaus/ctagsutils.py" - "klaus/repo.py" - "klaus/utils.py" - "tests/test_contrib.py" - "tests/test_make_app.py"))))))) + (inherit guix:python-klaus) (inputs - (list git-without-safe-directory-check)) - (native-inputs - (list python-pytest)) + ;; 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 + (modify-inputs (package-inputs guix:python-klaus) + (replace "git-minimal" git-without-safe-directory-check))) (propagated-inputs - (list python-dulwich python-flask python-httpauth - python-humanize python-pygments python-werkzeug)) - (home-page "https://github.com/jonashaag/klaus") - (synopsis "Simple git web viewer") - (description "klaus is a simple, easy-to-set-up git web viewer. It features + (modify-inputs (package-propagated-inputs guix:python-klaus) + ;; Add optional dependencies for markup rendering. + (prepend python-docutils python-markdown))))) + +(define-record-type* <klaus-configuration> + klaus-configuration make-klaus-configuration + klaus-configuration? + (python-klaus klaus-configuration-python-klaus + (default python-klaus)) + (server-name klaus-configuration-server-name) + (socket klaus-configuration-socket + (default (forge-unix-socket + (path "/var/run/gunicorn/klaus/socket")))) + (repository-directory klaus-configuration-repository-directory + (default "/srv/git")) + (site-name klaus-configuration-site-name + (default #f)) + (gunicorn-workers klaus-configuration-gunicorn-workers + (default #~(* 2 (total-processor-count))))) + +(define klaus-gunicorn-apps + (match-record-lambda <klaus-configuration> + (python-klaus socket repository-directory site-name gunicorn-workers) + (list (gunicorn-app + (name "klaus") + (package python-klaus) + (wsgi-app-module "klaus.contrib.wsgi_autoreload") + (sockets (list socket)) + (workers gunicorn-workers) + (environment-variables (cons* (environment-variable + (name "KLAUS_REPOS_ROOT") + (value repository-directory)) + (environment-variable + (name "KLAUS_USE_SMARTHTTP") + (value "1")) + (if site-name + (list (environment-variable + (name "KLAUS_SITE_NAME") + (value site-name))) + (list)))) + (mappings (list (file-system-mapping + (source repository-directory) + (target source)))))))) + +(define klaus-nginx-server-blocks + (match-record-lambda <klaus-configuration> + (server-name socket) + (list (nginx-server-configuration + (server-name (list server-name)) + (locations + ;; Based on + ;; https://github.com/jonashaag/klaus/wiki/Klaus-behind-a-reverse-proxy#nginx-example + (list (nginx-location-configuration + (uri "/") + (body (list (socket->nginx-proxy-pass socket) + ;; Pass in the host, scheme and header fields of + ;; the original request. + "proxy_pass_request_headers on;" + "proxy_set_header X-Forwarded-Proto $scheme;" + "proxy_set_header Host $host;"))))))))) -@itemize -@item Super easy to set up -- no configuration required -@item Syntax highlighting -@item Markdown + RestructuredText rendering support -@item Pull + push support (Git Smart HTTP) -@item Code navigation using Exuberant ctags -@end itemize") - (license license:isc))) +(define klaus-service-type + (service-type + (name 'klaus) + (description "Run klaus.") + (extensions (list (service-extension gunicorn-service-type + klaus-gunicorn-apps) + (service-extension forge-nginx-service-type + klaus-nginx-server-blocks))))) -(define* (klaus-gunicorn-app repository-directory - #:key - (klaus python-klaus) - (sockets (list (forge-unix-socket - (path "/var/run/gunicorn/klaus/socket")))) - site-name) +(define-deprecated (klaus-gunicorn-app repository-directory + #:key + (klaus python-klaus) + (sockets (list (forge-unix-socket + (path "/var/run/gunicorn/klaus/socket")))) + site-name) + klaus-service-type "Return a @code{<gunicorn-app>} object to deploy klaus. @var{repository-directory} is the path to the directory containing git diff --git a/guix/forge/laminar.scm b/guix/forge/laminar.scm index 16f5de7..74789be 100644 --- a/guix/forge/laminar.scm +++ b/guix/forge/laminar.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2021–2022, 2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2022, 2024–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -21,6 +21,7 @@ #:use-module (gnu) #:use-module (srfi srfi-1) #:use-module (gnu packages ci) + #:use-module ((gnu packages guile) #:select (guile-3.0-latest)) #:use-module (gnu services ci) #:use-module (guix records) #:use-module (ice-9 match) @@ -119,11 +120,14 @@ of @var{<forge-laminar-job>} objects." (let ((name (forge-laminar-job-name job))) `(,(let ((run-name (string-append name ".run"))) `(,run-name ,(program-file run-name - (forge-laminar-job-run job)))) + (forge-laminar-job-run job) + #:guile guile-3.0-latest))) ,@(let ((after (forge-laminar-job-after job)) (after-name (string-append name ".after"))) (if after - `((,after-name ,(program-file after-name after))) + `((,after-name ,(program-file after-name + after + #:guile guile-3.0-latest))) '())) ,@(match (forge-laminar-job-contexts job) (() '()) @@ -164,7 +168,15 @@ of @var{<forge-laminar-job>} objects." (lambda (file stat) (memq (stat:type stat) '(regular directory))) - #:directories? #t)))))) + #:directories? #t)) + ;; Ensure the state directory has the right permissions so + ;; that the nginx user can get in and serve files from the + ;; archive directory. The state directory is the home of the + ;; laminar user and is created with more restrictive + ;; permissions. So, the permissions need to be overridden. + ;; The archive directory, however, is always created with + ;; the right permissions. + (chmod #$state-directory #o755))))) (define forge-laminar-service-type (service-type diff --git a/guix/forge/nginx.scm b/guix/forge/nginx.scm index a1f99c2..87ad222 100644 --- a/guix/forge/nginx.scm +++ b/guix/forge/nginx.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2023, 2025–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -19,12 +19,16 @@ (define-module (forge nginx) #:use-module (forge acme) + #:use-module (forge anubis) #:use-module (forge socket) #:use-module ((gnu packages admin) #:select (shepherd)) + #:use-module ((gnu packages web) #:select (nginx)) #:use-module (gnu services) #:use-module (gnu services web) + #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix records) + #:use-module (guix utils) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (<forge-nginx-configuration> @@ -32,12 +36,35 @@ forge-nginx-configuration? forge-nginx-configuration-http-listen forge-nginx-configuration-https-listen + forge-nginx-configuration-proxy-protocol-listen forge-nginx-configuration-acme-state-directory forge-nginx-configuration-acme-challenge-directory forge-nginx-configuration-server-blocks + + <forge-nginx-server-configuration> + forge-nginx-server-configuration + forge-nginx-server-configuration? + forge-nginx-server-configuration-server-name + forge-nginx-server-configuration-root + forge-nginx-server-configuration-locations + forge-nginx-server-configuration-index + forge-nginx-server-configuration-try-files + forge-nginx-server-configuration-anubis? + forge-nginx-server-configuration-raw-content + nginx-socket->string + socket->nginx-proxy-pass forge-nginx-service-type)) +(define-public nginx-with-auth-request + (package + (inherit nginx) + (arguments + (substitute-keyword-arguments (package-arguments nginx) + ((#:configure-flags flags '()) + #~(cons "--with-http_auth_request_module" + #$flags)))))) + (define-record-type* <forge-nginx-configuration> forge-nginx-configuration make-forge-nginx-configuration forge-nginx-configuration? @@ -49,6 +76,8 @@ (default (forge-ip-socket (ip "0.0.0.0") (port 443)))) + (proxy-protocol-listen forge-nginx-configuration-proxy-protocol-listen + (default #f)) (acme-state-directory forge-nginx-configuration-acme-state-directory (default "/var/lib/acme")) (acme-challenge-directory forge-nginx-configuration-acme-challenge-directory @@ -56,6 +85,24 @@ (server-blocks forge-nginx-configuration-server-blocks (default '()))) +(define-record-type* <forge-nginx-server-configuration> + forge-nginx-server-configuration make-forge-nginx-server-configuration + forge-nginx-server-configuration? + (server-name forge-nginx-server-configuration-server-name + (default (list 'default))) + (root forge-nginx-server-configuration-root + (default "/srv/http")) + (locations forge-nginx-server-configuration-locations + (default '())) + (index forge-nginx-server-configuration-index + (default (list "index.html"))) + (try-files forge-nginx-server-configuration-try-files + (default '())) + (anubis? forge-nginx-server-configuration-anubis? + (default #f)) + (raw-content forge-nginx-server-configuration-raw-content + (default '()))) + (define (nginx-socket->string socket) "Serialize @var{socket} to a string as expected by nginx configuration (for example, in the @code{listen} and @@ -66,50 +113,116 @@ configuration (for example, in the @code{listen} and (($ <forge-ip-socket> (or "0.0.0.0" "::") port) (number->string port)) (($ <forge-ip-socket> (? ipv4-address? ip) port) - (string-append ip ":" port)) + (string-append ip ":" (number->string port))) (($ <forge-ip-socket> (? ipv6-address? ip) port) - (string-append "[" ip "]" ":" port)) + (string-append "[" ip "]" ":" (number->string port))) (($ <forge-unix-socket> path) (string-append "unix:" path)))) +(define (socket->nginx-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 (forge-nginx-configuration-coerced-server-blocks config) + "Return server blocks in @code{forge-nginx-configuration} @var{config}, all +coerced into @code{<forge-nginx-server-configuration>} objects." + (map (lambda (server) + (if (nginx-server-configuration? server) + (forge-nginx-server-configuration + (server-name (nginx-server-configuration-server-name server)) + (root (nginx-server-configuration-root server)) + (locations (nginx-server-configuration-locations server)) + (index (nginx-server-configuration-index server)) + (try-files (nginx-server-configuration-try-files server)) + (raw-content (nginx-server-configuration-raw-content server))) + server)) + (forge-nginx-configuration-server-blocks config))) + +(define (anubis-locations anubis-socket) + ;; This configuration is based on + ;; https://anubis.techaro.lol/docs/admin/configuration/subrequest-auth + (list (nginx-location-configuration + ;; Reverse proxy to Anubis for authorization and challenges. This + ;; location cannot be internal because clients need to request + ;; challenge pages. + (uri "/.within.website/") + (body (list (socket->nginx-proxy-pass anubis-socket) + "proxy_set_header X-Real-IP $remote_addr;" + "proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for;" + "proxy_set_header Host $http_host;" + "proxy_pass_request_body off;" + "proxy_set_header Content-Length \"\";"))) + ;; Redirect to Anubis challenge if authorization failed. We may be + ;; listening locally on a non-standard port; do not expose that to the + ;; end user. + (nginx-named-location-configuration + (name "redirectToAnubis") + (body (list "port_in_redirect off;" + "return 307 /.within.website/?redir=$scheme://$host$request_uri;"))))) + (define (forge-nginx-server-blocks config) "Return list of nginx server blocks to provision for forge-web service specified by @var{config}." (match-record config <forge-nginx-configuration> - (http-listen https-listen acme-state-directory acme-challenge-directory server-blocks) + (http-listen https-listen proxy-protocol-listen acme-state-directory acme-challenge-directory) (cons (nginx-server-configuration - (listen (list (nginx-socket->string http-listen))) - (locations - (list (nginx-location-configuration - (uri "/.well-known/acme-challenge/") - ;; Without a trailing slash, a alias of /var/foo - ;; would lookup /bar at /var/foobar, not - ;; /var/foo/bar. So, a trailing slash is - ;; significant. Append it if not already - ;; present. Likewise, the trailing slash in - ;; "/.well-known/acme-challenge/" is also - ;; significant. - (body (list (string-append "alias " - (string-trim-right acme-challenge-directory #\/) - "/;")))) - (nginx-location-configuration - (uri "/") - ;; HTTP Strict Transport Security (HSTS) header as - ;; recommended by https://hstspreload.org - (body (list "add_header Strict-Transport-Security \"max-age=63072000; includeSubdomains; preload\";" - "return 301 https://$host$request_uri;")))))) - (map (lambda (server) - (match (nginx-server-configuration-server-name server) + (listen (list (nginx-socket->string http-listen))) + (locations + (list (nginx-location-configuration + (uri "/.well-known/acme-challenge/") + ;; Without a trailing slash, an alias of /var/foo would + ;; lookup /bar at /var/foobar, not /var/foo/bar. So, a + ;; trailing slash is significant. Append it if not already + ;; present. Likewise, the trailing slash in + ;; "/.well-known/acme-challenge/" is also significant. + (body (list (string-append "alias " + (string-trim-right acme-challenge-directory #\/) + "/;")))) + (nginx-location-configuration + (uri "/") + ;; HTTP Strict Transport Security (HSTS) header as + ;; recommended by https://hstspreload.org + (body (list "add_header Strict-Transport-Security \"max-age=63072000; includeSubdomains; preload\";" + "return 301 https://$host$request_uri;")))))) + (map (match-record-lambda <forge-nginx-server-configuration> + (server-name root locations index try-files anubis? raw-content) + (match server-name ((name _ ...) (nginx-server-configuration - (inherit server) - (listen (list (string-append (nginx-socket->string https-listen) - " ssl"))) - (ssl-certificate (string-append acme-state-directory - "/" name "/cert.pem")) - (ssl-certificate-key (string-append acme-state-directory - "/private/" name "/key.pem")))))) - server-blocks)))) + (listen (cons (string-append (nginx-socket->string https-listen) + " ssl") + (if proxy-protocol-listen + (list (string-append (nginx-socket->string proxy-protocol-listen) + " ssl proxy_protocol")) + (list)))) + (server-name server-name) + (root root) + (locations + (if anubis? + (append (anubis-locations (forge-unix-socket + (path %anubis-unix-socket))) + locations) + locations)) + (index index) + (try-files try-files) + (ssl-certificate (string-append acme-state-directory + "/" name "/cert.pem")) + (ssl-certificate-key (string-append acme-state-directory + "/private/" name "/key.pem")) + (raw-content raw-content))))) + (forge-nginx-configuration-coerced-server-blocks config))))) (define %deploy-hook-gexp (with-imported-modules '((guix build utils)) @@ -127,27 +240,27 @@ specified by @var{config}." (define (forge-nginx-acme-certificates config) "Return list of @code{<acme-certificate>} blocks to provision for forge-nginx service specified by @var{config}." - (match-record config <forge-nginx-configuration> - (server-blocks) - (map (lambda (server) - (acme-certificate - (domains (nginx-server-configuration-server-name server)) - (deploy-hook (program-file "forge-nginx-acme-deploy-hook" - %deploy-hook-gexp)))) - server-blocks))) + (map (lambda (server) + (acme-certificate + (domains (forge-nginx-server-configuration-server-name server)) + (deploy-hook (program-file "forge-nginx-acme-deploy-hook" + %deploy-hook-gexp)))) + (forge-nginx-configuration-coerced-server-blocks config))) (define forge-nginx-service-type (service-type - (name 'forge-nginx) - (description "Run the forge-nginx web server.") - (extensions (list (service-extension nginx-service-type - forge-nginx-server-blocks) - (service-extension acme-service-type - forge-nginx-acme-certificates))) - (compose concatenate) - (extend (lambda (config server-blocks) - (forge-nginx-configuration - (inherit config) - (server-blocks (append (forge-nginx-configuration-server-blocks config) - server-blocks))))) - (default-value (forge-nginx-configuration)))) + (name 'forge-nginx) + (description "Run the forge-nginx web server.") + (extensions (list (service-extension nginx-service-type + forge-nginx-server-blocks) + (service-extension acme-service-type + forge-nginx-acme-certificates) + (service-extension anubis-service-type + (const #t)))) + (compose concatenate) + (extend (lambda (config server-blocks) + (forge-nginx-configuration + (inherit config) + (server-blocks (append (forge-nginx-configuration-server-blocks config) + server-blocks))))) + (default-value (forge-nginx-configuration)))) diff --git a/guix/forge/tissue.scm b/guix/forge/tissue.scm index 4ece204..abf3e39 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,42 @@ #:log-file "/var/log/tissue.log"))) (stop #~(make-kill-destructor))))) +(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->nginx-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 +296,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 diff --git a/guix/forge/utils.scm b/guix/forge/utils.scm index 96d9f51..4b47f3b 100644 --- a/guix/forge/utils.scm +++ b/guix/forge/utils.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2022, 2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -26,9 +26,15 @@ #:use-module (guix profiles) #:use-module (guix search-paths) #:use-module (guix store) - #:export (with-manifest + #:export (file-name-as-directory + with-manifest with-packages)) +(define (file-name-as-directory path) + "Return PATH with a trailing slash." + (string-append (string-trim-right path #\/) + "/")) + (define (with-manifest manifest exp) "Return a gexp executing EXP, another gexp, in a profile defined by MANIFEST." diff --git a/guix/forge/webhook.scm b/guix/forge/webhook.scm index 7915bcb..670adbb 100644 --- a/guix/forge/webhook.scm +++ b/guix/forge/webhook.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2022, 2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -22,19 +22,15 @@ #:use-module (gnu build linux-container) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module ((gnu packages guile) #:select (guile-json-4)) + #:use-module ((gnu packages web) #:select (webhook)) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system accounts) #:use-module (gnu system file-systems) #:use-module (gnu system shadow) #:use-module (guix gexp) - #:use-module (guix modules) #:use-module (guix records) - #:use-module (guix packages) - #:use-module (guix git-download) #:use-module (guix least-authority) - #:use-module (guix build-system go) - #:use-module ((guix licenses) #:prefix license:) #:use-module (forge socket) #:export (webhook-service-type webhook-configuration @@ -48,63 +44,6 @@ webhook-hook-id webhook-hook-run)) -(define-public webhook - (package - (name "webhook") - (version "2.8.0") - (source (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/adnanh/webhook") - (commit version))) - (file-name (git-file-name name version)) - (sha256 - (base32 - "0n03xkgwpzans0cymmzb0iiks8mi2c76xxdak780dk0jbv6qgp5i")))) - (build-system go-build-system) - (arguments - `(#:import-path "github.com/adnanh/webhook" - #:phases - (modify-phases %standard-phases - (add-after 'unpack 'configure - (lambda* (#:key inputs #:allow-other-keys) - (substitute* "src/github.com/adnanh/webhook/webhook_test.go" - (("/bin/echo") - (string-append (assoc-ref inputs "coreutils") - "/bin/echo")))))))) - (home-page "https://github.com/adnanh/webhook") - (synopsis "Lightweight incoming webhook server") - (description "webhook is a lightweight configurable tool written -in Go, that allows you to easily create HTTP endpoints (hooks) on your -server, which you can use to execute configured commands. You can also -pass data from the HTTP request (such as headers, payload or query -variables) to your commands. webhook also allows you to specify rules -which have to be satisfied in order for the hook to be triggered. - -For example, if you're using Github or Bitbucket, you can use webhook -to set up a hook that runs a redeploy script for your project on your -staging server, whenever you push changes to the master branch of your -project. - -If you use Mattermost or Slack, you can set up an \"Outgoing webhook -integration\" or \"Slash command\" to run various commands on your -server, which can then report back directly to you or your channels -using the \"Incoming webhook integrations\", or the appropriate -response body. - -webhook aims to do nothing more than it should do, and that is: - -@itemize -@item receive the request, -@item parse the headers, payload and query variables, -@item check if the specified rules for the hook are satisfied, -@item and finally, pass the specified arguments to the specified -command via command line arguments or via environment variables. -@end itemize - -Everything else is the responsibility of the command's author.") - (license license:expat))) - (define-record-type* <webhook-configuration> webhook-configuration make-webhook-configuration webhook-configuration? |