diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/forge/cgit.scm | 285 |
1 files changed, 285 insertions, 0 deletions
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)))))) |