Merge branch 'master' into core-updates

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)