From ee2691fa33f117bcf51b148b81bb8bc4e7b13a58 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 3 Jun 2019 22:27:25 +0200
Subject: services: guix-publish: Allow for multi-compression.

This is a followup to b8fa86adfc01205f1d942af8cb57515eb3726c52.

* guix/deprecation.scm (warn-about-deprecation): Make public.
* gnu/services/base.scm (<guix-publish-configuration>)[compression]: New
field.
[compression-level]: Default to #f.  Add '%' to getter name.
(guix-publish-configuration-compression-level): Define as deprecated.
(default-compression): New procedure.
(guix-publish-shepherd-service)[config->compression-options]: New
procedure.
Use 'match-record' instead of 'match'.
* doc/guix.texi (Base Services): Remove 'compression-level' and document
'compression'.
---
 gnu/services/base.scm | 109 ++++++++++++++++++++++++++++++++------------------
 1 file changed, 70 insertions(+), 39 deletions(-)

(limited to 'gnu/services/base.scm')

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index f709ca5519..c88a6ddec6 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -142,7 +142,8 @@
             guix-publish-configuration-guix
             guix-publish-configuration-port
             guix-publish-configuration-host
-            guix-publish-configuration-compression-level
+            guix-publish-configuration-compression
+            guix-publish-configuration-compression-level ;deprecated
             guix-publish-configuration-nar-path
             guix-publish-configuration-cache
             guix-publish-configuration-ttl
@@ -1748,8 +1749,12 @@ archive' public keys, with GUIX."
            (default 80))
   (host    guix-publish-configuration-host        ;string
            (default "localhost"))
-  (compression-level guix-publish-configuration-compression-level ;integer
-                     (default 3))
+  (compression       guix-publish-configuration-compression
+                     (thunked)
+                     (default (default-compression this-record
+                                (current-source-location))))
+  (compression-level %guix-publish-configuration-compression-level ;deprecated
+                     (default #f))
   (nar-path    guix-publish-configuration-nar-path ;string
                (default "nar"))
   (cache       guix-publish-configuration-cache   ;#f | string
@@ -1759,42 +1764,68 @@ archive' public keys, with GUIX."
   (ttl         guix-publish-configuration-ttl     ;#f | integer
                (default #f)))
 
-(define guix-publish-shepherd-service
-  (match-lambda
-    (($ <guix-publish-configuration> guix port host compression
-                                     nar-path cache workers ttl)
-     (list (shepherd-service
-            (provision '(guix-publish))
-            (requirement '(guix-daemon))
-            (start #~(make-forkexec-constructor
-                      (list #$(file-append guix "/bin/guix")
-                            "publish" "-u" "guix-publish"
-                            "-p" #$(number->string port)
-                            "-C" #$(number->string compression)
-                            (string-append "--nar-path=" #$nar-path)
-                            (string-append "--listen=" #$host)
-                            #$@(if workers
-                                   #~((string-append "--workers="
-                                                     #$(number->string
-                                                        workers)))
-                                   #~())
-                            #$@(if ttl
-                                   #~((string-append "--ttl="
-                                                     #$(number->string ttl)
-                                                     "s"))
-                                   #~())
-                            #$@(if cache
-                                   #~((string-append "--cache=" #$cache))
-                                   #~()))
-
-                      ;; Make sure we run in a UTF-8 locale so we can produce
-                      ;; nars for packages that contain UTF-8 file names such
-                      ;; as 'nss-certs'.  See <https://bugs.gnu.org/26948>.
-                      #:environment-variables
-                      (list (string-append "GUIX_LOCPATH="
-                                           #$glibc-utf8-locales "/lib/locale")
-                            "LC_ALL=en_US.utf8")))
-            (stop #~(make-kill-destructor)))))))
+(define-deprecated (guix-publish-configuration-compression-level config)
+  "Return a compression level, the old way."
+  (match (guix-publish-configuration-compression config)
+    (((_ level) _ ...) level)))
+
+(define (default-compression config properties)
+  "Return the default 'guix publish' compression according to CONFIG, and
+raise a deprecation warning if the 'compression-level' field was used."
+  (match (%guix-publish-configuration-compression-level config)
+    (#f
+     '(("gzip" 3)))
+    (level
+     (warn-about-deprecation 'compression-level properties
+                             #:replacement 'compression)
+     `(("gzip" ,level)))))
+
+(define (guix-publish-shepherd-service config)
+  (define (config->compression-options config)
+    (match (guix-publish-configuration-compression config)
+      (()                                   ;empty list means "no compression"
+       '("-C0"))
+      (lst
+       (append-map (match-lambda
+                     ((type level)
+                      `("-C" ,(string-append type ":"
+                                             (number->string level)))))
+                   lst))))
+
+  (match-record config <guix-publish-configuration>
+    (guix port host nar-path cache workers ttl)
+    (list (shepherd-service
+           (provision '(guix-publish))
+           (requirement '(guix-daemon))
+           (start #~(make-forkexec-constructor
+                     (list #$(file-append guix "/bin/guix")
+                           "publish" "-u" "guix-publish"
+                           "-p" #$(number->string port)
+                           #$@(config->compression-options config)
+                           (string-append "--nar-path=" #$nar-path)
+                           (string-append "--listen=" #$host)
+                           #$@(if workers
+                                  #~((string-append "--workers="
+                                                    #$(number->string
+                                                       workers)))
+                                  #~())
+                           #$@(if ttl
+                                  #~((string-append "--ttl="
+                                                    #$(number->string ttl)
+                                                    "s"))
+                                  #~())
+                           #$@(if cache
+                                  #~((string-append "--cache=" #$cache))
+                                  #~()))
+
+                     ;; Make sure we run in a UTF-8 locale so we can produce
+                     ;; nars for packages that contain UTF-8 file names such
+                     ;; as 'nss-certs'.  See <https://bugs.gnu.org/26948>.
+                     #:environment-variables
+                     (list (string-append "GUIX_LOCPATH="
+                                          #$glibc-utf8-locales "/lib/locale")
+                           "LC_ALL=en_US.utf8")))
+           (stop #~(make-kill-destructor))))))
 
 (define %guix-publish-accounts
   (list (user-group (name "guix-publish") (system? #t))
-- 
cgit v1.2.3