;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2023–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 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-pink git-minimal))
#:use-module (gnu services)
#:use-module ((gnu services web) #:select (nginx-server-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)
#: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-configuration-fcgiwrap-processes
cgit-service-type))
(define %cgit-readme
(append (list "README.md" "README.markdown" "README.mdown" "README.mkd"
"README.org" "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 %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-pink))
(git cgit-configuration-git
(default git-without-safe-directory-check))
(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 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 (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")))
(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 '()))
(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)))
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? ".org" about-file)
(invoke #$(file-append emacs-minimal "/bin/emacs")
"--script"
#$(local-file "org2html.el")))
((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 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))
(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)
(forge-nginx-server-configuration
(server-name (list server-name))
;; cgit static files
(root (file-append cgit "/share/cgit"))
(anubis? #t)
(locations
(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))))))
