diff options
Diffstat (limited to 'gnu/services/cgit.scm')
| -rw-r--r-- | gnu/services/cgit.scm | 133 |
1 files changed, 82 insertions, 51 deletions
diff --git a/gnu/services/cgit.scm b/gnu/services/cgit.scm index a868d758a4..8ef12cd5a0 100644 --- a/gnu/services/cgit.scm +++ b/gnu/services/cgit.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -72,17 +73,15 @@ ;;; (define (uglify-field-name field-name) - (let ((str (symbol->string field-name))) - (string-join (string-split (string-delete #\? str) #\-) "-"))) + (string-delete #\? (symbol->string field-name))) (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) - (if (string=? val "") "" (serialize-field field-name val))) - -(define (serialize-boolean field-name val) - (serialize-field field-name (if val 1 0))) + (if (and (string? val) (string=? val "")) + "" + (serialize-field field-name val))) (define (serialize-list field-name val) (if (null? val) "" (serialize-field field-name (string-join val)))) @@ -96,7 +95,10 @@ (exact-integer? 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) (serialize-configuration x repository-cgit-configuration-fields)) @@ -105,7 +107,13 @@ (list? 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))) (define (serialize-nginx-server-configuration-list field-name val) - #f) + "") ;;; @@ -124,18 +132,18 @@ ;;; (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) (if (null? val) "" (serialize-repo-field field-name (string-join val)))) (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) - (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?) @@ -144,26 +152,32 @@ (define (serialize-repo-string 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 (serialize-module-link-path field-name val) (if (null? val) "" (match val ((path text) - (format #t "repo.~a.~a=~a\n" - (string-drop-right (uglify-field-name 'module-link-path) - (string-length "-path")) - path text))))) + (format #f "repo.module-link.~a=~a\n" path text))))) + +(define (serialize-project-list _ val) + (if (null? val) "" + (serialize-field + 'project-list + (plain-file "project-list" (string-join val "\n"))))) (define repository-directory? string?) (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 (serialize-mimetype-alist field-name val) - (format #t "# Mimetypes\n~a" + (format #f "# Mimetypes\n~a" (string-join (map (match-lambda ((extension mimetype) @@ -177,13 +191,13 @@ "A mask of snapshot formats for this repo that cgit generates links for, restricted by the global @code{snapshots} setting.") (source-filter - (repo-string "") + (repo-file-object "") "Override the default @code{source-filter}.") (url (repo-string "") "The relative URL used to access the repository.") (about-filter - (repo-string "") + (repo-file-object "") "Override the default @code{about-filter}.") (branch-sort (repo-string "") @@ -193,7 +207,7 @@ ref list, and when set to @samp{name} enables ordering by branch name.") (repo-list '()) "A list of URLs which can be used to clone repo.") (commit-filter - (repo-string "") + (repo-file-object "") "Override the default @code{commit-filter}.") (commit-sort (repo-string "") @@ -212,7 +226,7 @@ is no suitable HEAD.") (repo-string "") "The value to show as repository homepage.") (email-filter - (repo-string "") + (repo-file-object "") "Override the default @code{email-filter}.") (enable-commit-graph? (repo-boolean #f) @@ -246,14 +260,14 @@ repository index.") (repo-boolean #f) "Flag which, when set to @samp{#t}, ignores the repository.") (logo - (repo-string "") + (repo-file-object "") "URL which specifies the source of an image which will be used as a logo on this repo’s pages.") (logo-link (repo-string "") "URL loaded when clicking on the cgit logo image.") (owner-filter - (repo-string "") + (repo-file-object "") "Override the default @code{owner-filter}.") (module-link (repo-string "") @@ -299,7 +313,7 @@ after this option will inherit the current section name.") (nginx-server-configuration-list (list %cgit-configuration-nginx)) "NGINX configuration.") (about-filter - (string "") + (file-object "") "Specifies a command which will be invoked to format the content of about pages (both top-level and for each repository).") (agefile @@ -307,7 +321,7 @@ pages (both top-level and for each repository).") "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.") (auth-filter - (string "") + (file-object "") "Specifies a command that will be invoked for authenticating repository access.") (branch-sort @@ -360,7 +374,7 @@ generates valid clone URLs for the repository.") (list '()) "List of @code{clone-url} templates.") (commit-filter - (string "") + (file-object "") "Command which will be invoked to format commit messages.") (commit-sort (string "git log") @@ -368,10 +382,10 @@ generates valid clone URLs for the repository.") commit log, and when set to @samp{topo} enables strict topological ordering.") (css - (string "/share/cgit/cgit.css") + (file-object "/share/cgit/cgit.css") "URL which specifies the css document to include in all cgit pages.") (email-filter - (string "") + (file-object "") "Specifies a command which will be invoked to format names and email address of committers, authors, and taggers, as represented in various places throughout the cgit interface.") @@ -435,7 +449,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 set any repo specific settings.") (favicon - (string "/favicon.ico") + (file-object "/favicon.ico") "URL used as link to a shortcut icon for cgit.") (footer (string "") @@ -451,7 +465,7 @@ verbatim in the HTML HEAD section on all pages.") "The content of the file specified with this option will be included verbatim at the top of all pages.") (include - (string "") + (file-object "") "Name of a configfile to include before the rest of the current config- file is parsed.") (index-header @@ -467,14 +481,14 @@ verbatim below the heading on the repository index page.") "Flag which, if set to @samp{#t}, makes cgit print commit and tag times in the servers timezone.") (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 on all cgit pages.") (logo-link (string "") "URL loaded when clicking on the cgit logo image.") (owner-filter - (string "") + (file-object "") "Command which will be invoked to format the Owner column of the main page.") (max-atom-items @@ -511,7 +525,7 @@ on the repository index page.") (svg "image/svg+xml"))) "Mimetype for the specified filename extension.") (mimetype-file - (string "") + (file-object "") "Specifies the file to use for automatic mimetype lookup.") (module-link (string "") @@ -528,15 +542,13 @@ disabled.") (boolean #f) "Flag which, when set to @samp{#t}, will make cgit omit the standard header on all pages.") - ;; TODO: cgit expects a file name - ;; that should be created from a list of strings provided by the user. - ;; - ;; (project-list - ;; (string "") - ;; "A list of subdirectories inside of @code{repository-directory}, - ;; relative to it, that should loaded as Git repositories.") + (project-list + (list '()) + "A list of subdirectories inside of @code{repository-directory}, relative +to it, that should loaded as Git repositories. An empty list means that all +subdirectories will be loaded.") (readme - (string "") + (file-object "") "Text which will be used as default value for @code{cgit-repo-readme}.") (remove-suffix? (boolean #f) @@ -594,7 +606,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 default.") (source-filter - (string "") + (file-object "") "Specifies a command which will be invoked to format plaintext blobs in the tree view.") (summary-branches @@ -623,6 +635,27 @@ for cgit to allow access to that repository.") (list '()) "Extra options will be appended to cgitrc file.")) +;; This distinguishes fields whose order matters, and makes sure further +;; changes won't inadvertently change the order. +(define (serialize-cgit-configuration config) + (define (rest? field) + (not (memq (configuration-field-name field) + '(project-list + repository-directory + repositories)))) + #~(string-append + #$(let ((rest (filter rest? cgit-configuration-fields))) + (serialize-configuration config rest)) + #$(serialize-project-list + 'project-list + (cgit-configuration-project-list config)) + #$(serialize-repository-directory + 'repository-directory + (cgit-configuration-repository-directory config)) + #$(serialize-repository-cgit-configuration-list + 'repositories + (cgit-configuration-repositories config)))) + (define-configuration opaque-cgit-configuration (cgit (package cgit) @@ -643,16 +676,14 @@ for cgit to allow access to that repository.") (config-str (if opaque-config? (opaque-cgit-configuration-cgitrc config) - (with-output-to-string - (lambda () - (serialize-configuration config - cgit-configuration-fields)))))) + (serialize-cgit-configuration config)))) #~(begin (use-modules (guix build utils)) (mkdir-p #$(if opaque-config? (opaque-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) (if (opaque-cgit-configuration? config) |