diff options
| -rw-r--r-- | doc/forge.skb | 6 | ||||
| -rw-r--r-- | guix/forge/forge.scm | 62 |
2 files changed, 52 insertions, 16 deletions
diff --git a/doc/forge.skb b/doc/forge.skb index 27a430e..e2a7cc3 100644 --- a/doc/forge.skb +++ b/doc/forge.skb @@ -557,10 +557,12 @@ gunicorn is run in])))))) [Its value])) (record-documentation "guix/forge/forge.scm" '<forge-configuration> (record-field "web-domain" - [Optional domain name on which to serve the guix-forge web -interface]) + [Domain name on which to serve the guix-forge web interface]) (record-field "tissue-web-domain" [Optional domain name on which to server tissue]) + (record-field "web-root" + [File-like object representing directory to serve as the +document root of the guix-forge web interface]) (record-field "projects" [List of ,(record-ref "<forge-project>") objects describing projects managed by guix-forge])) diff --git a/guix/forge/forge.scm b/guix/forge/forge.scm index cec5cf7..6a0ec6c 100644 --- a/guix/forge/forge.scm +++ b/guix/forge/forge.scm @@ -25,6 +25,7 @@ #: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 nss) #:select (nss-certs)) #:use-module ((gnu packages package-management) #:select (guix)) #:use-module ((gnu packages version-control) #:select (git-minimal)) @@ -50,6 +51,7 @@ forge-configuration? forge-configuration-web-domain forge-configuration-tissue-web-domain + forge-configuration-web-root forge-configuration-projects forge-project forge-project? @@ -107,13 +109,43 @@ (define-record-type* <forge-configuration> forge-configuration make-forge-configuration forge-configuration? - (web-domain forge-configuration-web-domain - (default #f)) + this-forge-configuration + (web-domain forge-configuration-web-domain) (tissue-web-domain forge-configuration-tissue-web-domain (default #f)) + (web-root forge-configuration-web-root + (default (computed-file "forge-web-root" + (forge-web-root-gexp 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)) + + (mkdir #$output) + (let ((html + (sxml->html + `(html + (body + ,@(map (match-lambda + ((name description) + `((h2 ,name) + ,@(if description + `((p ,description)) + '())))) + '#$(map (lambda (project) + (list (forge-project-name project) + (forge-project-description project))) + (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." @@ -456,16 +488,19 @@ that were built." (define (forge-nginx-server-blocks config) "Return list of @code{<nginx-server-configuration>} extensions for forge configuration @var{config}." - ;; Configure nginx server blocks for projects that have a web domain and a - ;; website directory. - (filter-map (match-record-lambda <forge-project> - (web-domain website-directory) - (and web-domain - website-directory - (nginx-server-configuration - (server-name (list web-domain)) - (root website-directory)))) - (forge-configuration-projects config))) + (cons (nginx-server-configuration + (server-name (list (forge-configuration-web-domain config))) + (root (forge-configuration-web-root config))) + ;; Configure nginx server blocks for projects that have a web domain and + ;; a website directory. + (filter-map (match-record-lambda <forge-project> + (web-domain website-directory) + (and web-domain + website-directory + (nginx-server-configuration + (server-name (list web-domain)) + (root website-directory)))) + (forge-configuration-projects config)))) (define (forge-tissue-hosts config) "Return list of @code{<tissue-host>} objects for forge configuration @@ -596,5 +631,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))))))) |