summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/forge.skb60
-rw-r--r--guix/forge/cgit.scm285
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))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-25 19:06:48 +0000