me/guix
Archived
1
0
Fork 0
Code Activity

services: cgit: Add support for file-like objects.

Browse source 
* doc/guix.texi (Version Control Services): Update accordingly.
* gnu/services/cgit.scm (serialize-field, serialize-string, serialize-boolean,
serialize-integer, serialize-repository-cgit-configuration-list,
serialize-nginx-server-configuration-list, serialize-repo-field,
serialize-repo-boolean, serialize-repo-integer, serialize-module-link-path,
serialize-repository-directory, serialize-mimetype-alist): Return strings or
string-valued gexps and stop printing.
(repository-cgit-configuration)[source-filter, about-filter, commit-filter,
logo, owner-filter], (cgit-configuration)[auth-filter, commit-filter, css,
email-filter, favicon, include, logo, owner-filter, mimetype-file, readme,
source-filter]: Replace STRING with FILE-OBJECT.
(file-object?, serialize-file-object, repo-file-object?,
serialize-repo-file-object): New procedures.
(cgit-activation): Use SERIALIZE-CONFIGURATION's return value with
MIXED-TEXT-FILE instead of using its output with PLAIN-FILE.
This commit is contained in:
Clément Lassieur 2018-03-20 20:33:38 +01:00
parent 36027f05e9
commit ad05e96e14
No known key found for this signature in database
GPG key ID: 89F96D4808F359C7
2 changed files with 70 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
doc/guix.texi
View file

@ -18542,6 +18542,9 @@ By default, Cgit can be accessed on port 80 (@code{http://localhost:80}).
(service cgit-service-type) (service cgit-service-type)
@end example @end example
The @code{file-object} type designates either a file-like object
(@pxref{G-Expressions, file-like objects}) or a string.
@c %start of fragment @c %start of fragment
Available @code{cgit-configuration} fields are: Available @code{cgit-configuration} fields are:
@ -18556,7 +18559,7 @@ NGINX configuration.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string about-filter @deftypevr {@code{cgit-configuration} parameter} file-object about-filter
Specifies a command which will be invoked to format the content of about Specifies a command which will be invoked to format the content of about
pages (both top-level and for each repository). pages (both top-level and for each repository).
@ -18572,7 +18575,7 @@ Defaults to @samp{""}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string auth-filter @deftypevr {@code{cgit-configuration} parameter} file-object auth-filter
Specifies a command that will be invoked for authenticating repository Specifies a command that will be invoked for authenticating repository
access. access.
@ -18681,7 +18684,7 @@ Defaults to @samp{()}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string commit-filter @deftypevr {@code{cgit-configuration} parameter} file-object commit-filter
Command which will be invoked to format commit messages. Command which will be invoked to format commit messages.
Defaults to @samp{""}. Defaults to @samp{""}.
@ -18697,14 +18700,14 @@ Defaults to @samp{"git log"}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string css @deftypevr {@code{cgit-configuration} parameter} file-object css
URL which specifies the css document to include in all cgit pages. URL which specifies the css document to include in all cgit pages.
Defaults to @samp{"/share/cgit/cgit.css"}. Defaults to @samp{"/share/cgit/cgit.css"}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string email-filter @deftypevr {@code{cgit-configuration} parameter} file-object email-filter
Specifies a command which will be invoked to format names and email Specifies a command which will be invoked to format names and email
address of committers, authors, and taggers, as represented in various address of committers, authors, and taggers, as represented in various
places throughout the cgit interface. places throughout the cgit interface.
@ -18828,7 +18831,7 @@ Defaults to @samp{#f}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string favicon @deftypevr {@code{cgit-configuration} parameter} file-object favicon
URL used as link to a shortcut icon for cgit. URL used as link to a shortcut icon for cgit.
Defaults to @samp{"/favicon.ico"}. Defaults to @samp{"/favicon.ico"}.
@ -18860,7 +18863,7 @@ Defaults to @samp{""}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string include @deftypevr {@code{cgit-configuration} parameter} file-object include
Name of a configfile to include before the rest of the current config- Name of a configfile to include before the rest of the current config-
file is parsed. file is parsed.
@ -18892,7 +18895,7 @@ Defaults to @samp{#f}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string logo @deftypevr {@code{cgit-configuration} parameter} file-object logo
URL which specifies the source of an image which will be used as a logo URL which specifies the source of an image which will be used as a logo
on all cgit pages. on all cgit pages.
@ -18907,7 +18910,7 @@ Defaults to @samp{""}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string owner-filter @deftypevr {@code{cgit-configuration} parameter} file-object owner-filter
Command which will be invoked to format the Owner column of the main Command which will be invoked to format the Owner column of the main
page. page.
@ -18976,7 +18979,7 @@ Defaults to @samp{((gif "image/gif") (html "text/html") (jpg
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string mimetype-file @deftypevr {@code{cgit-configuration} parameter} file-object mimetype-file
Specifies the file to use for automatic mimetype lookup. Specifies the file to use for automatic mimetype lookup.
Defaults to @samp{""}. Defaults to @samp{""}.
@ -19014,7 +19017,7 @@ Defaults to @samp{#f}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string readme @deftypevr {@code{cgit-configuration} parameter} file-object readme
Text which will be used as default value for @code{cgit-repo-readme}. Text which will be used as default value for @code{cgit-repo-readme}.
Defaults to @samp{""}. Defaults to @samp{""}.
@ -19132,7 +19135,7 @@ Defaults to @samp{#f}.
@end deftypevr @end deftypevr
@deftypevr {@code{cgit-configuration} parameter} string source-filter @deftypevr {@code{cgit-configuration} parameter} file-object source-filter
Specifies a command which will be invoked to format plaintext blobs in Specifies a command which will be invoked to format plaintext blobs in
the tree view. the tree view.
@ -19194,7 +19197,7 @@ Defaults to @samp{()}.
@end deftypevr @end deftypevr
@deftypevr {@code{repository-cgit-configuration} parameter} repo-string source-filter @deftypevr {@code{repository-cgit-configuration} parameter} repo-file-object source-filter
Override the default @code{source-filter}. Override the default @code{source-filter}.
Defaults to @samp{""}. Defaults to @samp{""}.
@ -19208,7 +19211,7 @@ Defaults to @samp{""}.
@end deftypevr @end deftypevr
@deftypevr {@code{repository-cgit-configuration} parameter} repo-string about-filter @deftypevr {@code{repository-cgit-configuration} parameter} repo-file-object about-filter
Override the default @code{about-filter}. Override the default @code{about-filter}.
Defaults to @samp{""}. Defaults to @samp{""}.
@ -19230,7 +19233,7 @@ Defaults to @samp{()}.
@end deftypevr @end deftypevr
@deftypevr {@code{repository-cgit-configuration} parameter} repo-string commit-filter @deftypevr {@code{repository-cgit-configuration} parameter} repo-file-object commit-filter
Override the default @code{commit-filter}. Override the default @code{commit-filter}.
Defaults to @samp{""}. Defaults to @samp{""}.
@ -19270,7 +19273,7 @@ Defaults to @samp{""}.
@end deftypevr @end deftypevr
@deftypevr {@code{repository-cgit-configuration} parameter} repo-string email-filter @deftypevr {@code{repository-cgit-configuration} parameter} repo-file-object email-filter
Override the default @code{email-filter}. Override the default @code{email-filter}.
Defaults to @samp{""}. Defaults to @samp{""}.
@ -19340,7 +19343,7 @@ Defaults to @samp{#f}.
@end deftypevr @end deftypevr
@deftypevr {@code{repository-cgit-configuration} parameter} repo-string logo @deftypevr {@code{repository-cgit-configuration} parameter} repo-file-object logo
URL which specifies the source of an image which will be used as a logo URL which specifies the source of an image which will be used as a logo
on this repo’s pages. on this repo’s pages.
@ -19355,7 +19358,7 @@ Defaults to @samp{""}.
@end deftypevr @end deftypevr
@deftypevr {@code{repository-cgit-configuration} parameter} repo-string owner-filter @deftypevr {@code{repository-cgit-configuration} parameter} repo-file-object owner-filter
Override the default @code{owner-filter}. Override the default @code{owner-filter}.
Defaults to @samp{""}. Defaults to @samp{""}.
@ -19440,6 +19443,7 @@ Defaults to @samp{()}.
@end deftypevr @end deftypevr
@c %end of fragment @c %end of fragment
However, it could be that you just want to get a @code{cgitrc} up and However, it could be that you just want to get a @code{cgitrc} up and

87
gnu/services/cgit.scm
View file

@ -76,13 +76,12 @@
(string-delete #\? (symbol->string field-name))) (string-delete #\? (symbol->string field-name)))
(define (serialize-field field-name val) (define (serialize-field field-name val)
(format #t "~a=~a\n" (uglify-field-name field-name) val)) #~(format #f "~a=~a\n" #$(uglify-field-name field-name) #$val))
(define (serialize-string field-name val) (define (serialize-string field-name val)
(if (string=? val "") "" (serialize-field field-name val))) (if (and (string? val) (string=? val ""))
""
(define (serialize-boolean field-name val) (serialize-field field-name val)))
(serialize-field field-name (if val 1 0)))
(define (serialize-list field-name val) (define (serialize-list field-name val)
(if (null? val) "" (serialize-field field-name (string-join val)))) (if (null? val) "" (serialize-field field-name (string-join val))))
@ -96,7 +95,10 @@
(exact-integer? val)) (exact-integer? val))
(define (serialize-integer field-name val) (define (serialize-integer field-name val)
(serialize-field field-name val)) (serialize-field field-name (number->string val)))
(define (serialize-boolean field-name val)
(serialize-integer field-name (if val 1 0)))
(define (serialize-repository-cgit-configuration x) (define (serialize-repository-cgit-configuration x)
(serialize-configuration x repository-cgit-configuration-fields)) (serialize-configuration x repository-cgit-configuration-fields))
@ -105,7 +107,13 @@
(list? val)) (list? val))
(define (serialize-repository-cgit-configuration-list field-name val) (define (serialize-repository-cgit-configuration-list field-name val)
(for-each serialize-repository-cgit-configuration val)) #~(string-append
#$@(map serialize-repository-cgit-configuration val)))
(define (file-object? val)
(or (file-like? val) (string? val)))
(define (serialize-file-object field-name val)
(serialize-string field-name val))
;;; ;;;
@ -116,7 +124,7 @@
(and (list? val) (and-map nginx-server-configuration? val))) (and (list? val) (and-map nginx-server-configuration? val)))
(define (serialize-nginx-server-configuration-list field-name val) (define (serialize-nginx-server-configuration-list field-name val)
#f) "")
;;; ;;;
@ -124,18 +132,18 @@
;;; ;;;
(define (serialize-repo-field field-name val) (define (serialize-repo-field field-name val)
(format #t "repo.~a=~a\n" (uglify-field-name field-name) val)) #~(format #f "repo.~a=~a\n" #$(uglify-field-name field-name) #$val))
(define (serialize-repo-list field-name val) (define (serialize-repo-list field-name val)
(if (null? val) "" (serialize-repo-field field-name (string-join val)))) (if (null? val) "" (serialize-repo-field field-name (string-join val))))
(define repo-boolean? boolean?) (define repo-boolean? boolean?)
(define (serialize-repo-boolean field-name val)
(serialize-repo-field field-name (if val 1 0)))
(define (serialize-repo-integer field-name val) (define (serialize-repo-integer field-name val)
(serialize-repo-field field-name val)) (serialize-repo-field field-name (number->string val)))
(define (serialize-repo-boolean field-name val)
(serialize-repo-integer field-name (if val 1 0)))
(define repo-list? list?) (define repo-list? list?)
@ -144,23 +152,26 @@
(define (serialize-repo-string field-name val) (define (serialize-repo-string field-name val)
(if (string=? val "") "" (serialize-repo-field field-name val))) (if (string=? val "") "" (serialize-repo-field field-name val)))
(define repo-file-object? file-object?)
(define serialize-repo-file-object serialize-repo-string)
(define module-link-path? list?) (define module-link-path? list?)
(define (serialize-module-link-path field-name val) (define (serialize-module-link-path field-name val)
(if (null? val) "" (if (null? val) ""
(match val (match val
((path text) ((path text)
(format #t "repo.module-link.~a=~a\n" path text))))) (format #f "repo.module-link.~a=~a\n" path text)))))
(define repository-directory? string?) (define repository-directory? string?)
(define (serialize-repository-directory _ val) (define (serialize-repository-directory _ val)
(if (string=? val "") "" (format #t "scan-path=~a\n" val))) (if (string=? val "") "" (format #f "scan-path=~a\n" val)))
(define mimetype-alist? list?) (define mimetype-alist? list?)
(define (serialize-mimetype-alist field-name val) (define (serialize-mimetype-alist field-name val)
(format #t "# Mimetypes\n~a" (format #f "# Mimetypes\n~a"
(string-join (string-join
(map (match-lambda (map (match-lambda
((extension mimetype) ((extension mimetype)
@ -174,13 +185,13 @@
"A mask of snapshot formats for this repo that cgit generates links for, "A mask of snapshot formats for this repo that cgit generates links for,
restricted by the global @code{snapshots} setting.") restricted by the global @code{snapshots} setting.")
(source-filter (source-filter
(repo-string "") (repo-file-object "")
"Override the default @code{source-filter}.") "Override the default @code{source-filter}.")
(url (url
(repo-string "") (repo-string "")
"The relative URL used to access the repository.") "The relative URL used to access the repository.")
(about-filter (about-filter
(repo-string "") (repo-file-object "")
"Override the default @code{about-filter}.") "Override the default @code{about-filter}.")
(branch-sort (branch-sort
(repo-string "") (repo-string "")
@ -190,7 +201,7 @@ ref list, and when set to @samp{name} enables ordering by branch name.")
(repo-list '()) (repo-list '())
"A list of URLs which can be used to clone repo.") "A list of URLs which can be used to clone repo.")
(commit-filter (commit-filter
(repo-string "") (repo-file-object "")
"Override the default @code{commit-filter}.") "Override the default @code{commit-filter}.")
(commit-sort (commit-sort
(repo-string "") (repo-string "")
@ -209,7 +220,7 @@ is no suitable HEAD.")
(repo-string "") (repo-string "")
"The value to show as repository homepage.") "The value to show as repository homepage.")
(email-filter (email-filter
(repo-string "") (repo-file-object "")
"Override the default @code{email-filter}.") "Override the default @code{email-filter}.")
(enable-commit-graph? (enable-commit-graph?
(repo-boolean #f) (repo-boolean #f)
@ -243,14 +254,14 @@ repository index.")
(repo-boolean #f) (repo-boolean #f)
"Flag which, when set to @samp{#t}, ignores the repository.") "Flag which, when set to @samp{#t}, ignores the repository.")
(logo (logo
(repo-string "") (repo-file-object "")
"URL which specifies the source of an image which will be used as a "URL which specifies the source of an image which will be used as a
logo on this repo’s pages.") logo on this repo’s pages.")
(logo-link (logo-link
(repo-string "") (repo-string "")
"URL loaded when clicking on the cgit logo image.") "URL loaded when clicking on the cgit logo image.")
(owner-filter (owner-filter
(repo-string "") (repo-file-object "")
"Override the default @code{owner-filter}.") "Override the default @code{owner-filter}.")
(module-link (module-link
(repo-string "") (repo-string "")
@ -296,7 +307,7 @@ after this option will inherit the current section name.")
(nginx-server-configuration-list (list %cgit-configuration-nginx)) (nginx-server-configuration-list (list %cgit-configuration-nginx))
"NGINX configuration.") "NGINX configuration.")
(about-filter (about-filter
(string "") (file-object "")
"Specifies a command which will be invoked to format the content of about "Specifies a command which will be invoked to format the content of about
pages (both top-level and for each repository).") pages (both top-level and for each repository).")
(agefile (agefile
@ -304,7 +315,7 @@ pages (both top-level and for each repository).")
"Specifies a path, relative to each repository path, which can be used to "Specifies a path, relative to each repository path, which can be used to
specify the date and time of the youngest commit in the repository.") specify the date and time of the youngest commit in the repository.")
(auth-filter (auth-filter
(string "") (file-object "")
"Specifies a command that will be invoked for authenticating repository "Specifies a command that will be invoked for authenticating repository
access.") access.")
(branch-sort (branch-sort
@ -357,7 +368,7 @@ generates valid clone URLs for the repository.")
(list '()) (list '())
"List of @code{clone-url} templates.") "List of @code{clone-url} templates.")
(commit-filter (commit-filter
(string "") (file-object "")
"Command which will be invoked to format commit messages.") "Command which will be invoked to format commit messages.")
(commit-sort (commit-sort
(string "git log") (string "git log")
@ -365,10 +376,10 @@ generates valid clone URLs for the repository.")
commit log, and when set to @samp{topo} enables strict topological commit log, and when set to @samp{topo} enables strict topological
ordering.") ordering.")
(css (css
(string "/share/cgit/cgit.css") (file-object "/share/cgit/cgit.css")
"URL which specifies the css document to include in all cgit pages.") "URL which specifies the css document to include in all cgit pages.")
(email-filter (email-filter
(string "") (file-object "")
"Specifies a command which will be invoked to format names and email "Specifies a command which will be invoked to format names and email
address of committers, authors, and taggers, as represented in various address of committers, authors, and taggers, as represented in various
places throughout the cgit interface.") places throughout the cgit interface.")
@ -432,7 +443,7 @@ links for plaintext blobs printed in the tree view.")
"Flag which, when set to @samp{#f}, will allow cgit to use Git config to "Flag which, when set to @samp{#f}, will allow cgit to use Git config to
set any repo specific settings.") set any repo specific settings.")
(favicon (favicon
(string "/favicon.ico") (file-object "/favicon.ico")
"URL used as link to a shortcut icon for cgit.") "URL used as link to a shortcut icon for cgit.")
(footer (footer
(string "") (string "")
@ -448,7 +459,7 @@ verbatim in the HTML HEAD section on all pages.")
"The content of the file specified with this option will be included "The content of the file specified with this option will be included
verbatim at the top of all pages.") verbatim at the top of all pages.")
(include (include
(string "") (file-object "")
"Name of a configfile to include before the rest of the current config- "Name of a configfile to include before the rest of the current config-
file is parsed.") file is parsed.")
(index-header (index-header
@ -464,14 +475,14 @@ verbatim below the heading on the repository index page.")
"Flag which, if set to @samp{#t}, makes cgit print commit and tag times "Flag which, if set to @samp{#t}, makes cgit print commit and tag times
in the servers timezone.") in the servers timezone.")
(logo (logo
(string "/share/cgit/cgit.png") (file-object "/share/cgit/cgit.png")
"URL which specifies the source of an image which will be used as a logo "URL which specifies the source of an image which will be used as a logo
on all cgit pages.") on all cgit pages.")
(logo-link (logo-link
(string "") (string "")
"URL loaded when clicking on the cgit logo image.") "URL loaded when clicking on the cgit logo image.")
(owner-filter (owner-filter
(string "") (file-object "")
"Command which will be invoked to format the Owner column of the main "Command which will be invoked to format the Owner column of the main
page.") page.")
(max-atom-items (max-atom-items
@ -508,7 +519,7 @@ on the repository index page.")
(svg "image/svg+xml"))) (svg "image/svg+xml")))
"Mimetype for the specified filename extension.") "Mimetype for the specified filename extension.")
(mimetype-file (mimetype-file
(string "") (file-object "")
"Specifies the file to use for automatic mimetype lookup.") "Specifies the file to use for automatic mimetype lookup.")
(module-link (module-link
(string "") (string "")
@ -533,7 +544,7 @@ header on all pages.")
;; "A list of subdirectories inside of @code{repository-directory}, ;; "A list of subdirectories inside of @code{repository-directory},
;; relative to it, that should loaded as Git repositories.") ;; relative to it, that should loaded as Git repositories.")
(readme (readme
(string "") (file-object "")
"Text which will be used as default value for @code{cgit-repo-readme}.") "Text which will be used as default value for @code{cgit-repo-readme}.")
(remove-suffix? (remove-suffix?
(boolean #f) (boolean #f)
@ -591,7 +602,7 @@ many path elements from each repo path to use as a default section name.")
"If set to @samp{#t} shows side-by-side diffs instead of unidiffs per "If set to @samp{#t} shows side-by-side diffs instead of unidiffs per
default.") default.")
(source-filter (source-filter
(string "") (file-object "")
"Specifies a command which will be invoked to format plaintext blobs in the "Specifies a command which will be invoked to format plaintext blobs in the
tree view.") tree view.")
(summary-branches (summary-branches
@ -640,16 +651,14 @@ for cgit to allow access to that repository.")
(config-str (config-str
(if opaque-config? (if opaque-config?
(opaque-cgit-configuration-cgitrc config) (opaque-cgit-configuration-cgitrc config)
(with-output-to-string (serialize-configuration config cgit-configuration-fields))))
(lambda ()
(serialize-configuration config
cgit-configuration-fields))))))
#~(begin #~(begin
(use-modules (guix build utils)) (use-modules (guix build utils))
(mkdir-p #$(if opaque-config? (mkdir-p #$(if opaque-config?
(opaque-cgit-configuration-cache-root config) (opaque-cgit-configuration-cache-root config)
(cgit-configuration-cache-root config))) (cgit-configuration-cache-root config)))
(copy-file #$(plain-file "cgitrc" config-str) "/etc/cgitrc")))) (copy-file #$(mixed-text-file "cgitrc" config-str)
"/etc/cgitrc"))))
(define (cgit-configuration-nginx-config config) (define (cgit-configuration-nginx-config config)
(if (opaque-cgit-configuration? config) (if (opaque-cgit-configuration? config)