summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/forge/cgit.scm285
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))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-22 23:21:19 +0000