diff options
| -rw-r--r-- | .guix-channel | 3 | ||||
| -rw-r--r-- | NEWS | 29 | ||||
| -rw-r--r-- | doc/forge.skb | 110 | ||||
| -rw-r--r-- | doc/skribilo.scm | 28 | ||||
| -rw-r--r-- | guix/forge/acme.scm | 17 | ||||
| -rw-r--r-- | guix/forge/cgit.scm | 9 | ||||
| -rw-r--r-- | guix/forge/fcgiwrap.scm | 8 | ||||
| -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 | 10 | ||||
| -rw-r--r-- | guix/forge/klaus.scm | 191 | ||||
| -rw-r--r-- | guix/forge/laminar.scm | 12 | ||||
| -rw-r--r-- | guix/forge/nginx.scm | 25 | ||||
| -rw-r--r-- | guix/forge/tissue.scm | 122 | ||||
| -rw-r--r-- | guix/forge/utils.scm | 10 | ||||
| -rw-r--r-- | guix/forge/webhook.scm | 65 | ||||
| -rw-r--r-- | guix/guix-forge-website.scm | 78 | ||||
| -rw-r--r-- | tissue.scm | 2 | ||||
| -rw-r--r-- | website/index.skb | 6 |
20 files changed, 809 insertions, 276 deletions
diff --git a/.guix-channel b/.guix-channel index 8cec433..e12672e 100644 --- a/.guix-channel +++ b/.guix-channel @@ -1,3 +1,4 @@ (channel (version 0) - (directory "guix")) + (directory "guix") + (news-file "NEWS")) diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..b0660fc --- /dev/null +++ b/NEWS @@ -0,0 +1,29 @@ +;;; -*- lisp-data -*- +;;; guix-forge --- Guix software forge meta-service +;;; Copyright © 2025 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/>. + +(channel-news + (version 0) + (entry (commit "3c8dc85a584c98bc90088ec1c85933d4d10e7383") + (title (en "We now have news!") + (ta "அறிமுகம் செய்திகள்!")) + (body (en "We now have news in this channel. Hopefully, there will be something +to say in the future!") + (ta "இவ்வலைவரிசையில் இப்போது செய்திகள் உள்ளன. வருங்காலத்தில் சொல்வதற்கு ஏதாவது +இருக்கமென நம்புகிறோம்!")))) diff --git a/doc/forge.skb b/doc/forge.skb index 99d1b86..3ea04d3 100644 --- a/doc/forge.skb +++ b/doc/forge.skb @@ -1,5 +1,6 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2022–2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2022–2025 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024 Frederick M. Muriithi <fredmanglis@protonmail.com> ;;; ;;; This file is part of guix-forge. ;;; @@ -290,7 +291,62 @@ first).]) shown. Else, they won't.]) (record-field "extra-options" [Association list of additional key-value option pairs to -include in the generated ,(file [cgitrc]) configuration file]))))) +include in the generated ,(file [cgitrc]) configuration file])))) + (subsection :title [klaus service] + :ident "subsection-klaus-service" + (p [klaus is a web viewer to serve git repositories on the web.]) + (description + (record-documentation "guix/forge/klaus.scm" '<klaus-configuration> + (record-field "python-klaus" + [,(code [python-klaus]) package to use]) + (record-field "server-name" + [Domain name to serve klaus on]) + (record-field "socket" + [Socket that the internal klaus gunicorn app listens on]) + (record-field "repository-directory" + [Directory containing git repositories to serve]) + (record-field "site-name" + [Title on klaus web pages]))))) + (section :title [tissue service] + :ident "section-tissue-service" + (p [tissue is an issue tracker built on plain text files and +git. In addition, it features a static site generator tuned to +building project websites.]) + (description + (record-documentation "guix/forge/tissue.scm" '<tissue-configuration> + (record-field "package" + [,(code [tissue]) package to use]) + (record-field "socket" + [Socket to listen on. Socket may be a ,(record-ref +"<forge-ip-socket>"), or ,(record-ref "<forge-unix-socket>") +object.]) + (record-field "state-directory" + [Directory in which tissue maintains its state]) + (record-field "hosts" + [List of ,(record-ref "<tissue-host>") objects describing +configured hosts. A single tissue instance may serve several +hosts—this is often called ,(ref :url +"https://en.wikipedia.org/wiki/Virtual_hosting" :text "virtual +hosting").])) + (record-documentation "guix/forge/tissue.scm" '<tissue-host> + (record-field "name" + [HTTP host name to listen on]) + (record-field "projects" + [List of ,(record-ref "<tissue-project>") objects +describing configured projects])) + (record-documentation "guix/forge/tissue.scm" '<tissue-project> + (record-field "name" + [Name of the project]) + (record-field "user" + [Name of user who owns the project directory in the tissue +,(record-field-ref "<tissue-configuration>" "state-directory")]) + (record-field "base-path" + [Base web path at which the project is served. Several +projects may be served on the same host at ,(samp "/project1/"), +,(samp "/project2/") and so on.] + :default [,(samp "\"/<name>/\"")]) + (record-field "upstream-repository" + [Path to git repository of project])))) (section :title [forge nginx service] :ident "section-forge-nginx-service" (p [The forge nginx service is a wrapper around the nginx web @@ -467,6 +523,7 @@ environment]) describing additional directories that should be shared with the container fcgiwrap is run in])))) (subsection :title [gunicorn service] + :ident "subsection-gunicorn-service" (p [gunicorn is a specialized web server for Python ,(ref :url "https://en.wikipedia.org/wiki/Web_Server_Gateway_Interface" :text "WSGI") applications. We run separate containerized instances of @@ -494,6 +551,9 @@ describing sockets to listen on]) (record-field "timeout" [Workers silent for more than this many seconds are killed and restarted.]) + (record-field "extra-cli-arguments" + [List of strings to pass as additional command-line +arguments to gunicorn]) (record-field "environment-variables" [List of ,(record-ref "<environment-variable>") objects describing environment variables that should be set in the execution @@ -511,6 +571,26 @@ gunicorn is run in])))))) (record-field "value" [Its value])) (record-documentation "guix/forge/forge.scm" '<forge-configuration> + (record-field "web-domain" + [Domain name on which to serve the guix-forge web interface]) + (record-field "cgit-domain" + [Domain name on which cgit is hosted]) + (record-field "laminar-domain" + [Domain name on which laminar is hosted]) + (record-field "tissue-web-domain" + [Optional domain name on which to serve tissue]) + (record-field "web-root" + [File-like object representing directory to serve as the +document root of the guix-forge web interface]) + (record-field "websites-directory" + [Directory containing websites for each project. Each +project's website is put in a subdirectory with the same name as the +project. Project websites are built by the ,(abbr :short "CI" :long +"continuous integration") job configured in its ,(record-field-ref +"<forge-project>" "website-ci-job").]) + (record-field "mailer-address" + [,(samp "From") address from which to send out notification +emails.]) (record-field "projects" [List of ,(record-ref "<forge-project>") objects describing projects managed by guix-forge])) @@ -528,14 +608,19 @@ disregarded if the repository is remote.]) the ,(file "description") file in the repository and will appear in the cgit web interface. This field is disregarded if the repository is remote.]) - (record-field "website-directory" - [Path to the document root of the project website. The -ownership of its parent directory is granted to the ,(code "laminar") -user. The idea is that the website is built by a Guix derivation as a -store item and a symbolic link to that store item is created in the -parent directory.]) + (record-field "web-domain" + [Domain name to serve project website on]) + (record-field "tissue?" + [Does this project use ,(ref :url +"https://forge.systemreboot.net/tissue/" :text "tissue")? If so, it +will be served at ,(samp "/<name>/") on the ,(record-field-ref +"<forge-configuration>" "web-domain") configured in ,(record-ref +"<forge-configuration>").]) + (record-field "website-ci-job" + [,(record-ref "<forge-laminar-job>") object describing ,(abbr +:short "CI" :long "continuous integration") job to build website]) (record-field "ci-jobs" - [List of ,(record-ref "<forge-laminar-job>") objects + [List of other ,(record-ref "<forge-laminar-job>") objects describing ,(abbr :short "CI" :long "continuous integration") jobs to configure]) (record-field "ci-jobs-trigger" @@ -555,6 +640,10 @@ jobs when a request is received on ,(samp "http://hostname:port/hooks/<name>") \ specified, a cron job triggers the CI jobs once a day.]))] :default [,(code ['post-receive-hook]) for local repositories and ,(code ['cron]) for remote repositories]) + (record-field "ci-notify-addresses" + [List of email addresses to send CI notification emails to. +This requires an SMTP server listening on ,(samp "localhost") port +,(samp "587").]) (record-field "parallel-ci-job-runs" [Number of CI job runs of this project to run simultaneously]) @@ -606,5 +695,4 @@ hooks to configure])) [Identifier of the webhook. This hook is triggered at ,(ref :url [http://host:port/hooks/<id>]).]) (record-field "run" - [G-expression to run when the webhook is triggered])) - (docstring-function-documentation "guix/forge/klaus.scm" 'klaus-gunicorn-app)))) + [G-expression to run when the webhook is triggered]))))) diff --git a/doc/skribilo.scm b/doc/skribilo.scm index 972b626..dc1bc15 100644 --- a/doc/skribilo.scm +++ b/doc/skribilo.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. ;;; @@ -45,6 +45,7 @@ record-documentation record-field record-ref + record-field-ref docstring-function-documentation)) ;; Constants @@ -268,24 +269,27 @@ are a list of <record-field> objects." (code identifier)))) (apply description (map (lambda (documented-field) - (let* ((identifier (record-field-identifier documented-field)) + (let* ((field-identifier (record-field-identifier documented-field)) (record-field (find (lambda (field) (eq? (record-field-identifier field) - (string->symbol identifier))) + (string->symbol field-identifier))) (record-fields record)))) - (item #:key + (item #:ident (string-append identifier + "-" + field-identifier) + #:key (cond ;; No default value ((no-default? (record-field-default record-field)) - (code identifier)) + (code field-identifier)) ;; Default value in documentation ((record-field-default documented-field) => (lambda (default) - (list (append (list (code identifier) " (Default: ") + (list (append (list (code field-identifier) " (Default: ") default (list ")"))))) ;; Default value from the source - (else (list (list (code identifier) " (Default: " + (else (list (list (code field-identifier) " (Default: " (code (expression->string (record-field-default record-field))) ")")))) @@ -293,11 +297,17 @@ are a list of <record-field> objects." fields)))))) (define (record-ref identifier) - "Link to record documentation of record identified by + "Link to documentation of record identified by @var{identifier}." (ref #:ident identifier #:text (code identifier))) +(define (record-field-ref record-identifier field-identifier) + "Link to documentation of field identified by @var{field-identifier} in +record identified by @var{record-identifier}." + (ref #:ident (string-append record-identifier "-" field-identifier) + #:text (code field-identifier))) + (define-record-type <function> (function name arguments docstring) function? @@ -364,7 +374,7 @@ are a list of <record-field> objects." ;; HTML engine customizations (let ((html-engine (find-engine 'html))) - (engine-custom-set! html-engine 'css "/style.css") + (engine-custom-set! html-engine 'css "/guix-forge/style.css") (engine-custom-set! html-engine 'charset "UTF-8") (markup-writer 'abbr html-engine #:options '(#:short #:long) 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/cgit.scm b/guix/forge/cgit.scm index 805f47f..2be21cb 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–2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -20,12 +20,13 @@ (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 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)) @@ -71,9 +72,9 @@ 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")) 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..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..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..23de1db 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–2025 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024 jgart <jgart@dismail.de> ;;; ;;; This file is part of guix-forge. ;;; @@ -19,116 +20,108 @@ (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 gexp) - #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix deprecation) #: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-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))) + +(define klaus-gunicorn-apps + (match-record-lambda <klaus-configuration> + (python-klaus socket repository-directory site-name) + (list (gunicorn-app + (name "klaus") + (package python-klaus) + (wsgi-app-module "klaus.contrib.wsgi_autoreload") + (sockets (list socket)) + (environment-variables (cons (environment-variable + (name "KLAUS_REPOS_ROOT") + (value repository-directory)) + (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 + (list (nginx-location-configuration + (uri "/") + (body (list (socket->nginx-proxy-pass socket)))))))))) -@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..dcbc5bf 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–2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -164,7 +164,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..2e22bd8 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 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -36,6 +36,7 @@ forge-nginx-configuration-acme-challenge-directory forge-nginx-configuration-server-blocks nginx-socket->string + socket->nginx-proxy-pass forge-nginx-service-type)) (define-record-type* <forge-nginx-configuration> @@ -66,12 +67,28 @@ 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-server-blocks config) "Return list of nginx server blocks to provision for forge-web service specified by @var{config}." @@ -82,7 +99,7 @@ specified by @var{config}." (locations (list (nginx-location-configuration (uri "/.well-known/acme-challenge/") - ;; Without a trailing slash, a alias of /var/foo + ;; 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 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? diff --git a/guix/guix-forge-website.scm b/guix/guix-forge-website.scm new file mode 100644 index 0000000..2b0be61 --- /dev/null +++ b/guix/guix-forge-website.scm @@ -0,0 +1,78 @@ +;;; guix-forge --- Guix software forge meta-service +;;; Copyright © 2025 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 (guix-forge-website) + #:use-module ((gnu packages fonts) #:select (font-charter font-fira-code)) + #:use-module ((gnu packages skribilo) #:select (skribilo)) + #:use-module (guix gexp) + #:use-module (guix git-download) + #:use-module (guix utils)) + +(define-public guix-forge-source + (local-file ".." + "guix-forge-checkout" + #:recursive? #t + #:select? (or (git-predicate (dirname (current-source-directory))) + (const #t)))) + +(define guix-forge-website-home-page-gexp + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (invoke #$(file-append skribilo "/bin/skribilo") + (string-append "--preload=" #$(file-append guix-forge-source "/doc/skribilo.scm")) + (string-append "--output=" #$output) + #$(file-append guix-forge-source "/website/index.skb"))))) + +(define guix-forge-website-manual-en-gexp + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (chdir #$guix-forge-source) + (invoke #$(file-append skribilo "/bin/skribilo") + (string-append "--preload=" + #$(file-append guix-forge-source "/doc/skribilo.scm")) + (string-append "--source-path=" #$guix-forge-source) + (string-append "--output=" #$output) + #$(file-append guix-forge-source "/doc/forge.skb"))))) + +(define-public guix-forge-website + (file-union "guix-forge-website" + `(("index.html" + ,(computed-file "guix-forge-website-home-page" + guix-forge-website-home-page-gexp)) + ("manual/dev/en/index.html" + ,(computed-file "guix-forge-website-manual-en" + guix-forge-website-manual-en-gexp)) + ("style.css" + ,(file-append guix-forge-source + "/website/style.css")) + ("fonts/charter_regular.woff2" + ,(file-append font-charter + "/share/fonts/web/charter_regular.woff2")) + ("fonts/FiraCode-Regular.woff2" + ,(file-append font-fira-code + "/share/fonts/web/FiraCode-Regular.woff2")) + ("fonts/FiraCode-SemiBold.woff2" + ,(file-append font-fira-code + "/share/fonts/web/FiraCode-SemiBold.woff2"))))) + +guix-forge-website diff --git a/tissue.scm b/tissue.scm index 3717bea..cef25ef 100644 --- a/tissue.scm +++ b/tissue.scm @@ -27,7 +27,7 @@ #:indexed-documents (append (map (lambda (filename) (slot-set (read-gemtext-issue filename) 'web-uri - (string-append "/" (string-remove-suffix ".gmi" filename)))) + (string-append "/guix-forge/" (string-remove-suffix ".gmi" filename)))) (gemtext-files-in-directory "issues")) (map (lambda (identifier) (slot-set (document-fragment "doc/forge.skb" identifier) diff --git a/website/index.skb b/website/index.skb index e92fa65..b5f91dc 100644 --- a/website/index.skb +++ b/website/index.skb @@ -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. ;;; @@ -26,7 +26,7 @@ (item [,(code "[X]") ,(ref :url "https://git.zx2c4.com/cgit/" :text "cgit") and ,(ref :url "https://github.com/jonashaag/klaus/" :text "klaus") (pick your favourite) to serve project git repositories on the web]) (item [,(code "[X]") ,(ref :url "https://laminar.ohwg.net" :text "laminar") for continuous integration]) (item [,(code "[X]") ,(ref :url "https://github.com/ndilieto/uacme/" :text "uacme") and ,(ref :url "https://gnutls.org/" :text "gnutls") for automatic provision and renewal of TLS certificates via ACME]) - (item [,(code "[ ]") web server to serve static project sites]) + (item [,(code "[X]") web server to serve static project sites]) (item [,(code "[ ]") ,(ref :url "https://public-inbox.org/README.html" :text "public-inbox") for project discussions])) (p [A choice of different software components may be offered provided it does not complicate the interface too much.]) (p [,(emph [guix-forge]) is provided on a best effort basis. Its design is unstable, and open to change. We will try our best to not break your system configuration often, but it might happen.]) @@ -45,7 +45,7 @@ :line #f)) (section :title "Documentation" :number #f - (p [The ,(ref :url "/manual/dev/en/" :text "guix-forge manual") is available online.])) + (p [The ,(ref :url "/guix-forge/manual/dev/en/" :text "guix-forge manual") is available online.])) (section :title "Philosophy" :number #f (p [In order to empower ordinary users, software should not just be free (as in freedom), but also be simple and easy to deploy, especially for small-scale deployments. ,(emph [guix-forge]) is therefore minimalistic, and does not require running large database servers such as MariaDB and PostgreSQL.]) |