Set %file-port-name-canonicalization to avoid readlink syscalls

As Guix does.

2 files changed, 116 insertions, 114 deletions

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 3bc52a9..5b0a2aa 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -455,108 +455,109 @@
    #:pid-file pid-file
    #:parallel-hooks parallel-hooks)
 
-  ;; Create some worker thread channels, which need to be created prior
-  ;; to run-fibers being called.
-  (let ((chunked-request-channel
-         ;; There are fibers issues when trying to read the chunked
-         ;; requests, so do this in dedicated threads.
-         (make-worker-thread-channel
-          (const '())
-          #:name "chunked request"
-          #:parallelism 16
-          #:log-exception?
-          (lambda (exn)
-            (not
-             (chunked-input-ended-prematurely-error?
-              exn)))
-          #:delay-logger
-          (lambda (seconds-delayed)
-            (log-delay "chunked request channel"
-                       seconds-delayed)
-            (when (> seconds-delayed 0.1)
-              (format
-               (current-error-port)
-               "warning: chunked request channel delayed by ~1,2f seconds~%"
-               seconds-delayed)))))
-
-        (output-hash-channel
-         (make-output-hash-channel
-          build-coordinator)))
-
-    (let ((finished? (make-condition)))
-      (call-with-sigint
-       (lambda ()
-         (run-fibers
-          (lambda ()
-            (let* ((current (current-scheduler))
-                   (schedulers
-                    (cons current (scheduler-remote-peers current))))
-              (for-each
-               (lambda (i sched)
-                 (spawn-fiber
-                  (lambda ()
-                    (catch 'system-error
-                      (lambda ()
-                        (set-thread-name
-                         (string-append "fibers " (number->string i))))
-                      (const #t)))
-                  sched))
-               (iota (length schedulers))
-               schedulers))
-
-            (log-msg (build-coordinator-logger build-coordinator)
-                     'INFO
-                     "initialising metrics")
-            (with-time-logging
-                "datastore initialise metrics"
-              (datastore-initialise-metrics! (build-coordinator-datastore
-                                              build-coordinator)))
-
-            (datastore-spawn-fibers
-             (build-coordinator-datastore build-coordinator))
-
-            (spawn-fiber-to-watch-for-deferred-builds build-coordinator)
-
-            (set-build-coordinator-scheduler! build-coordinator
-                                              (current-scheduler))
-
-            (let ((events-channel
-                   get-state-id
-                   (make-events-channel
-                    (build-coordinator-datastore build-coordinator))))
-
-              (set-build-coordinator-events-channel!
-               build-coordinator
-               events-channel)
-              (set-build-coordinator-get-state-id-proc!
-               build-coordinator
-               get-state-id))
-
-            ;; Start the agent messaging server
-            (match (uri-scheme agent-communication-uri)
-              ('http
-               (let ((host (uri-host agent-communication-uri))
-                     (port (uri-port agent-communication-uri)))
-                 (http-agent-messaging-start-server
-                  port
-                  host
-                  secret-key-base
-                  build-coordinator
-                  chunked-request-channel
-                  output-hash-channel)
-                 (log-msg 'INFO "listening on " host ":" port))))
-
-            ;; Start the client messaging server
-            (start-client-request-server
-             secret-key-base
-             (uri-host client-communication-uri)
-             (uri-port client-communication-uri)
-             build-coordinator)
-
-            (wait finished?))
-          #:hz 10
-          #:parallelism 2))
-       finished?))))
+  (with-fluids ((%file-port-name-canonicalization 'none))
+    ;; Create some worker thread channels, which need to be created prior
+    ;; to run-fibers being called.
+    (let ((chunked-request-channel
+           ;; There are fibers issues when trying to read the chunked
+           ;; requests, so do this in dedicated threads.
+           (make-worker-thread-channel
+            (const '())
+            #:name "chunked request"
+            #:parallelism 16
+            #:log-exception?
+            (lambda (exn)
+              (not
+               (chunked-input-ended-prematurely-error?
+                exn)))
+            #:delay-logger
+            (lambda (seconds-delayed)
+              (log-delay "chunked request channel"
+                         seconds-delayed)
+              (when (> seconds-delayed 0.1)
+                (format
+                 (current-error-port)
+                 "warning: chunked request channel delayed by ~1,2f seconds~%"
+                 seconds-delayed)))))
+
+          (output-hash-channel
+           (make-output-hash-channel
+            build-coordinator)))
+
+      (let ((finished? (make-condition)))
+        (call-with-sigint
+         (lambda ()
+           (run-fibers
+            (lambda ()
+              (let* ((current (current-scheduler))
+                     (schedulers
+                      (cons current (scheduler-remote-peers current))))
+                (for-each
+                 (lambda (i sched)
+                   (spawn-fiber
+                    (lambda ()
+                      (catch 'system-error
+                        (lambda ()
+                          (set-thread-name
+                           (string-append "fibers " (number->string i))))
+                        (const #t)))
+                    sched))
+                 (iota (length schedulers))
+                 schedulers))
+
+              (log-msg (build-coordinator-logger build-coordinator)
+                       'INFO
+                       "initialising metrics")
+              (with-time-logging
+                  "datastore initialise metrics"
+                (datastore-initialise-metrics! (build-coordinator-datastore
+                                                build-coordinator)))
+
+              (datastore-spawn-fibers
+               (build-coordinator-datastore build-coordinator))
+
+              (spawn-fiber-to-watch-for-deferred-builds build-coordinator)
+
+              (set-build-coordinator-scheduler! build-coordinator
+                                                (current-scheduler))
+
+              (let ((events-channel
+                     get-state-id
+                     (make-events-channel
+                      (build-coordinator-datastore build-coordinator))))
+
+                (set-build-coordinator-events-channel!
+                 build-coordinator
+                 events-channel)
+                (set-build-coordinator-get-state-id-proc!
+                 build-coordinator
+                 get-state-id))
+
+              ;; Start the agent messaging server
+              (match (uri-scheme agent-communication-uri)
+                ('http
+                 (let ((host (uri-host agent-communication-uri))
+                       (port (uri-port agent-communication-uri)))
+                   (http-agent-messaging-start-server
+                    port
+                    host
+                    secret-key-base
+                    build-coordinator
+                    chunked-request-channel
+                    output-hash-channel)
+                   (log-msg 'INFO "listening on " host ":" port))))
+
+              ;; Start the client messaging server
+              (start-client-request-server
+               secret-key-base
+               (uri-host client-communication-uri)
+               (uri-port client-communication-uri)
+               build-coordinator)
+
+              (wait finished?))
+            #:hz 10
+            #:parallelism 2))
+         finished?)))))
 
 (define* (submit-build build-coordinator derivation-file
                        #:key
diff --git a/scripts/guix-build-coordinator-agent.in b/scripts/guix-build-coordinator-agent.in
index 006e1f8..6d94302 100644
--- a/scripts/guix-build-coordinator-agent.in
+++ b/scripts/guix-build-coordinator-agent.in
@@ -193,15 +193,16 @@
          (else
           (error "unknown coordinator interface")))))
 
-    (run-agent uuid
-               coordinator-interface
-               (delete-duplicates (assq-ref opts 'systems))
-               (assq-ref opts 'max-parallel-builds)
-               (assq-ref opts 'max-allocated-builds)
-               (assq-ref opts 'max-parallel-uploads)
-               (or (assq-ref opts 'derivation-substitute-urls)
-                   (assq-ref opts 'substitute-urls))
-               (or (assq-ref opts 'non-derivation-substitute-urls)
-                   (assq-ref opts 'substitute-urls))
-               (assq-ref opts 'metrics-file)
-               (assq-ref opts 'max-1min-load-average))))
+    (with-fluids ((%file-port-name-canonicalization 'none))
+      (run-agent uuid
+                 coordinator-interface
+                 (delete-duplicates (assq-ref opts 'systems))
+                 (assq-ref opts 'max-parallel-builds)
+                 (assq-ref opts 'max-allocated-builds)
+                 (assq-ref opts 'max-parallel-uploads)
+                 (or (assq-ref opts 'derivation-substitute-urls)
+                     (assq-ref opts 'substitute-urls))
+                 (or (assq-ref opts 'non-derivation-substitute-urls)
+                     (assq-ref opts 'substitute-urls))
+                 (assq-ref opts 'metrics-file)
+                 (assq-ref opts 'max-1min-load-average)))))