cgit: Add cgit service.

* guix/forge/cgit.scm: New file.
* doc/forge.skb (Services)[Git web viewers]: New section.

2 files changed, 345 insertions, 0 deletions

diff --git a/doc/forge.skb b/doc/forge.skb
index 91a608d..23d8faf 100644
--- a/doc/forge.skb
+++ b/doc/forge.skb
@@ -189,6 +189,66 @@ repeated below for your reference.])
                   :file "doc/snippets/tutorial.scm")))
   (chapter :title [Services]
            :ident "chapter-services"
+    (section :title [Git web vievers]
+             :ident "section-git-web-viewers"
+      (subsection :title [cgit service]
+                  :ident "subsection-cgit-service"
+        (p [cgit is a web frontend to serve git repositories on the
+web. Our cgit service features]
+           (itemize
+            (item [cloneable URLs via the smart HTTP protocol through
+,(command [git-http-backend])])
+            (item [syntax highlighting for a wide variety of
+programming languages using ,(ref :url "https://pygments.org/" :text
+"Pygments")])
+            (item [rendering markdown, man page, html or plain text
+README files in the ,(emph [About]) page])
+            (item [hiding full email addresses on cgit web pages])))
+        (description
+         (record-documentation "guix/forge/cgit.scm" '<cgit-configuration>
+           (record-field "cgit"
+             [,(code [cgit]) package to use])
+           (record-field "git"
+             [,(code [git]) package to use. ,(code [git]) provides the
+smart HTTP protocol backend.])
+           (record-field "server-name"
+             [Domain name to serve cgit on])
+           (record-field "repository-directory"
+             [Directory containing git repositories to serve])
+           (record-field "socket"
+             [Socket that the internal cgit fcgiwrap instance listens on])
+           (record-field "readme"
+             [README file to serve as the ,(emph [About]) page of the
+repository. This field is a list of candidate README files. cgit will
+serve the first file that is found.])
+           (record-field "snapshots"
+             [List of strings specifying snapshot formats that cgit
+generates links for. Valid strings are ,(code ["tar"]), ,(code
+["tar.gz"]), ,(code ["tar.bz2"]), ,(code ["tar.lz"]), ,(code
+["tar.xz"]), ,(code ["tar.xst"]) and ,(code ["zip"]).])
+           (record-field "about-filter"
+             [Script invoked to format the content of about pages])
+           (record-field "commit-filter"
+             [Script invoked to format commit messages])
+           (record-field "email-filter"
+             [Script invoked to format email addresses])
+           (record-field "source-filter"
+             [Script invoked to format plaintext blobs in the tree
+view])
+           (record-field "mimetype-file"
+             [File to use for automatic mimetype lookup. This is used
+by the plain endpoint when serving blob content])
+           (record-field "repository-sort"
+             [Order in which repositories are sorted on the index
+page. Valid values are ,(code ['name]) (sorting by repository name)
+and ,(code ['age]) (sorting most recently updated repository
+first).])
+           (record-field "plain-email?"
+             [If ,(code [#true]), full email addresses will be
+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])))))
     (section :title [forge nginx service]
              :ident "section-forge-nginx-service"
       (p [The forge nginx service is a wrapper around the nginx web
diff --git a/guix/forge/cgit.scm b/guix/forge/cgit.scm
new file mode 100644
index 0000000..6ac7589
--- /dev/null
+++ b/guix/forge/cgit.scm
@@ -0,0 +1,285 @@
+;;; guix-forge --- Guix software forge meta-service
+;;; Copyright © 2023 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 cgit)
+  #:use-module (forge fcgiwrap)
+  #:use-module (forge nginx)
+  #:use-module (forge socket)
+  #:use-module ((gnu packages mail) #:select (mailcap))
+  #:use-module ((gnu packages version-control)
+                #:select (cgit git-minimal))
+  #: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 gexp)
+  #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:export (%cgit-readme
+            <cgit-configuration>
+            cgit-configuration
+            cgit-configuration?
+            cgit-configuration-cgit
+            cgit-configuration-git
+            cgit-configuration-server-name
+            cgit-configuration-repository-directory
+            cgit-configuration-socket
+            cgit-configuration-readme
+            cgit-configuration-snapshots
+            cgit-configuration-about-filter
+            cgit-configuration-commit-filter
+            cgit-configuration-email-filter
+            cgit-configuration-source-filter
+            cgit-configuration-mimetype-file
+            cgit-configuration-repository-sort
+            cgit-configuration-plain-email?
+            cgit-configuration-extra-options
+            cgit-service-type))
+
+(define %cgit-readme
+  (append (list "README.md" "README.markdown" "README.mdown" "README.mkd"
+                "README.rst")
+          ;; man page READMEs
+          (map (lambda (n)
+                 (string-append "README." (number->string n)))
+               (iota 9 1))
+          (list "README.htm" "README.html"
+                "README.txt"
+                "README")))
+
+(define-record-type* <cgit-configuration>
+  cgit-configuration make-cgit-configuration
+  cgit-configuration?
+  this-cgit-configuration
+  (cgit cgit-configuration-cgit
+        (default cgit))
+  (git cgit-configuration-git
+       (default git-minimal))
+  (server-name cgit-configuration-server-name)
+  (repository-directory cgit-configuration-repository-directory
+                        (default "/srv/git"))
+  (socket cgit-configuration-socket
+          (default (forge-unix-socket
+                    (path "/var/run/fcgiwrap/cgit/socket"))))
+  ;; TODO: Support org mode and gemtext READMEs too.
+  (readme cgit-configuration-readme
+          (default %cgit-readme))
+  (snapshots cgit-configuration-snapshots
+             (default (list "tar.gz"))
+             (sanitize sanitize-cgit-snapshots))
+  (about-filter cgit-configuration-about-filter
+                (default (program-file "about-filter"
+                                       (about-filter-gexp this-cgit-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"))
+                 (thunked))
+  (mimetype-file cgit-configuration-mimetype-file
+                 (default (file-append mailcap "/etc/mime.types")))
+  (repository-sort cgit-configuration-repository-sort
+                   (default 'age)
+                   (sanitize sanitize-cgit-repository-sort))
+  (plain-email? cgit-configuration-noplainemail?
+                (default #false))
+  (extra-options cgit-configuration-extra-options
+                 (default '())))
+
+(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))))
+              snapshots)
+    snapshots))
+
+(define (sanitize-cgit-repository-sort repository-sort)
+  (case repository-sort
+    ((name age) repository-sort)
+    (else
+     (leave (G_ "Invalid cgit repository-sort '~s. It should either be 'age or 'name.~%")
+            repository-sort))))
+
+(define (about-filter-gexp config)
+  "Return G-expression for a cgit about-filter. Use cgit package
+configured in @var{config}."
+  (match-record config <cgit-configuration>
+    (cgit)
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils)
+                       (ice-9 match)
+                       (srfi srfi-1))
+
+          (match (command-line)
+            ((_ about-file)
+             (cond
+              ((or (string-suffix-ci? ".markdown" about-file)
+                   (string-suffix-ci? ".mdown" about-file)
+                   (string-suffix-ci? ".md" about-file)
+                   (string-suffix-ci? ".mkd" about-file))
+               (invoke #$(file-append cgit "/lib/cgit/filters/html-converters/md2html")
+                       about-file))
+              ((string-suffix-ci? ".rst" about-file)
+               (invoke #$(file-append cgit "/lib/cgit/filters/html-converters/rst2html")
+                       about-file))
+              ((any (lambda (n)
+                      (string-suffix-ci? (string-append "." (number->string n))
+                                         about-file))
+                    (iota 9 1))
+               (invoke #$(file-append cgit "/lib/cgit/filters/html-converters/rst2html")
+                       about-file))
+              ((or (string-suffix-ci? ".htm" about-file)
+                   (string-suffix-ci? ".html" about-file))
+               (put-bytevector (current-output-port)
+                               (call-with-input-file about-file
+                                 get-bytevector-all)))
+              (else
+               (invoke #$(file-append cgit "/lib/cgit/filters/html-converters/txt2html")
+                       about-file)))))))))
+
+(define (cgitrc-gexp config)
+  "Return G-expression to serialize @var{config} into cgitrc."
+  (match-record config <cgit-configuration>
+    (repository-directory
+     readme snapshots
+     about-filter commit-filter email-filter source-filter
+     mimetype-file repository-sort plain-email? extra-options)
+    #~(begin
+        (use-modules (ice-9 match))
+        
+        (call-with-output-file #$output
+          (lambda (port)
+            (for-each (match-lambda
+                        ((key #t)
+                         (format port "~a=1~%" key))
+                        ((key #f)
+                         (format port "~a=0~%" key))
+                        ((key value)
+                         (format port "~a=~a~%" key value)))
+                      '#$(append (map (lambda (file)
+                                        (list "readme" (string-append ":" file)))
+                                      readme)
+                                 (if about-filter
+                                     `(("about-filter" ,about-filter))
+                                     (list))
+                                 (if commit-filter
+                                     `(("commit-filter" ,commit-filter))
+                                     (list))
+                                 (if email-filter
+                                     `(("email-filter" ,email-filter))
+                                     (list))
+                                 (if source-filter
+                                     `(("source-filter" ,source-filter))
+                                     (list))
+                                 (if mimetype-file
+                                     `(("mimetype-file" ,mimetype-file))
+                                     (list))
+                                 ;; The order of settings in cgitrc is
+                                 ;; significant.
+                                 `(("snapshots" ,(string-join snapshots))
+                                   ("repository-sort" ,(symbol->string repository-sort))
+                                   ("noplainemail" ,(not plain-email?))
+                                   ("enable-index-owner" #f)
+                                   ("virtual-root" "/")
+                                   ,@(map (match-lambda
+                                            ((key . value)
+                                             (list key value)))
+                                          extra-options)
+                                   ("scan-path" ,repository-directory)))))))))
+
+(define (cgit-fcgiwrap-instance config)
+  (match-record config <cgit-configuration>
+    (cgit git repository-directory)
+    (let ((cgitrc (computed-file "cgitrc" (cgitrc-gexp config))))
+      (fcgiwrap-instance
+       (name "cgit")
+       (user "nginx")
+       (group "nginx")
+       (environment-variables `(("CGIT_CONFIG" . ,cgitrc)))
+       (mappings (list (file-system-mapping
+                        (source repository-directory)
+                        (target source))
+                       (file-system-mapping
+                        (source cgit)
+                        (target source))
+                       (file-system-mapping
+                        (source cgitrc)
+                        (target source))
+                       (file-system-mapping
+                        (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
+     (server-name (list server-name))
+     ;; cgit static files
+     (root (file-append cgit "/share/cgit"))
+     (try-files (list "$uri" "@cgit"))
+     (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)
+                              ";")))))))))
+
+(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))))))