forge: List projects on forge home page.

1 files changed, 48 insertions, 14 deletions

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)))))))