From 760fcf32fc3b78887fbe3f85e7cd5b23b0c47a66 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Tue, 8 Aug 2023 21:39:43 +0100 Subject: cgit: Add cgit service. * guix/forge/cgit.scm: New file. * doc/forge.skb (Services)[Git web viewers]: New section. --- doc/forge.skb | 60 +++++++++++ guix/forge/cgit.scm | 285 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 345 insertions(+) create mode 100644 guix/forge/cgit.scm 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" ' + (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 +;;; +;;; 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 +;;; . + +(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 + 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 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) + (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 + (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 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 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)))))) -- cgit v1.2.3