guix/scripts/publish.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   3 ;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
   4 ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   5 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
   6 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (guix scripts publish)
  24   #:use-module ((system repl server) #:prefix repl:)
  25   #:use-module (ice-9 binary-ports)
  26   #:use-module (ice-9 format)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 poll)
  29   #:use-module (ice-9 regex)
  30   #:use-module (ice-9 rdelim)
  31   #:use-module (ice-9 threads)
  32   #:use-module (rnrs bytevectors)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-2)
  35   #:use-module (srfi srfi-9)
  36   #:use-module (srfi srfi-9 gnu)
  37   #:use-module (srfi srfi-11)
  38   #:use-module (srfi srfi-19)
  39   #:use-module (srfi srfi-26)
  40   #:use-module (srfi srfi-34)
  41   #:use-module (srfi srfi-37)
  42   #:use-module (web http)
  43   #:use-module (web request)
  44   #:use-module (web response)
  45   #:use-module (web server)
  46   #:use-module (web uri)
  47   #:autoload   (sxml simple) (sxml->xml)
  48   #:autoload   (guix avahi) (avahi-publish-service-thread)
  49   #:use-module (guix base32)
  50   #:use-module (guix base64)
  51   #:use-module (guix config)
  52   #:use-module (guix derivations)
  53   #:use-module (gcrypt hash)
  54   #:use-module (guix pki)
  55   #:use-module (gcrypt pk-crypto)
  56   #:use-module (guix workers)
  57   #:use-module (guix store)
  58   #:use-module ((guix serialization) #:select (write-file))
  59   #:use-module (zlib)
  60   #:autoload   (lzlib) (call-with-lzip-output-port
  61                         make-lzip-output-port)
  62   #:autoload   (zstd)  (call-with-zstd-output-port
  63                         make-zstd-output-port)
  64   #:use-module (guix cache)
  65   #:use-module (guix ui)
  66   #:use-module (guix scripts)
  67   #:use-module ((guix utils)
  68                 #:select (with-atomic-file-output compressed-file?))
  69   #:use-module ((guix build utils)
  70                 #:select (dump-port mkdir-p find-files))
  71   #:use-module ((guix build syscalls) #:select (set-thread-name))
  72   #:export (%default-gzip-compression
  73
  74             %public-key
  75             %private-key
  76             signed-string
  77
  78             open-server-socket
  79             publish-service-type
  80             run-publish-server
  81             guix-publish))
  82
  83 (define (show-help)
  84   (format #t (G_ "Usage: guix publish [OPTION]...
  85 Publish ~a over HTTP.\n") %store-directory)
  86   (display (G_ "
  87   -p, --port=PORT        listen on PORT"))
  88   (display (G_ "
  89       --listen=HOST      listen on the network interface for HOST"))
  90   (display (G_ "
  91   -u, --user=USER        change privileges to USER as soon as possible"))
  92   (display (G_ "
  93   -a, --advertise        advertise on the local network"))
  94   (display (G_ "
  95   -C, --compression[=METHOD:LEVEL]
  96                          compress archives with METHOD at LEVEL"))
  97   (display (G_ "
  98   -c, --cache=DIRECTORY  cache published items to DIRECTORY"))
  99   (display (G_ "
 100       --cache-bypass-threshold=SIZE
 101                          serve store items below SIZE even when not cached"))
 102   (display (G_ "
 103       --workers=N        use N workers to bake items"))
 104   (display (G_ "
 105       --ttl=TTL          announce narinfos can be cached for TTL seconds"))
 106   (display (G_ "
 107       --negative-ttl=TTL announce missing narinfos can be cached for TTL seconds"))
 108   (display (G_ "
 109       --nar-path=PATH    use PATH as the prefix for nar URLs"))
 110   (display (G_ "
 111       --public-key=FILE  use FILE as the public key for signatures"))
 112   (display (G_ "
 113       --private-key=FILE use FILE as the private key for signatures"))
 114   (display (G_ "
 115   -r, --repl[=PORT]      spawn REPL server on PORT"))
 116   (newline)
 117   (display (G_ "
 118   -h, --help             display this help and exit"))
 119   (display (G_ "
 120   -V, --version          display version information and exit"))
 121   (newline)
 122   (show-bug-report-information))
 123
 124 (define (getaddrinfo* host)
 125   "Like 'getaddrinfo', but properly report errors."
 126   (catch 'getaddrinfo-error
 127     (lambda ()
 128       (getaddrinfo host))
 129     (lambda (key error)
 130       (leave (G_ "lookup of host '~a' failed: ~a~%")
 131              host (gai-strerror error)))))
 132
 133 ;; Nar compression parameters.
 134 (define-record-type <compression>
 135   (compression type level)
 136   compression?
 137   (type   compression-type)
 138   (level  compression-level))
 139
 140 (define %no-compression
 141   (compression 'none 0))
 142
 143 (define %default-gzip-compression
 144   ;; Since we compress on the fly, default to fast compression.
 145   (compression 'gzip 3))
 146
 147 (define (default-compression type)
 148   (compression type 3))
 149
 150 (define (actual-compressions item requested)
 151   "Return the actual compressions used for ITEM, which may be %NO-COMPRESSION
 152 if ITEM is already compressed."
 153   (if (compressed-file? item)
 154       (list %no-compression)
 155       requested))
 156
 157 (define (low-compression c)
 158   "Return <compression> of the same type as C, but optimized for low CPU
 159 usage."
 160   (compression (compression-type c)
 161                (min (compression-level c) 2)))
 162
 163 (define %options
 164   (list (option '(#\h "help") #f #f
 165                 (lambda _
 166                   (show-help)
 167                   (exit 0)))
 168         (option '(#\V "version") #f #f
 169                 (lambda _
 170                   (show-version-and-exit "guix publish")))
 171         (option '(#\a "advertise") #f #f
 172                 (lambda (opt name arg result)
 173                   (alist-cons 'advertise? #t result)))
 174         (option '(#\u "user") #t #f
 175                 (lambda (opt name arg result)
 176                   (alist-cons 'user arg result)))
 177         (option '(#\p "port") #t #f
 178                 (lambda (opt name arg result)
 179                   (alist-cons 'port (string->number* arg) result)))
 180         (option '("listen") #t #f
 181                 (lambda (opt name arg result)
 182                   (match (getaddrinfo* arg)
 183                     ((info _ ...)
 184                      (alist-cons 'address (addrinfo:addr info)
 185                                  result))
 186                     (()
 187                      (leave (G_ "lookup of host '~a' returned nothing")
 188                             name)))))
 189         (option '(#\C "compression") #f #t
 190                 (lambda (opt name arg result)
 191                   (let* ((colon (string-index arg #\:))
 192                          (type  (cond
 193                                  (colon (string-take arg colon))
 194                                  ((string->number arg) "gzip")
 195                                  (else arg)))
 196                          (level (if colon
 197                                     (string->number*
 198                                      (string-drop arg (+ 1 colon)))
 199                                     (or (string->number arg) 3))))
 200                     (match level
 201                       (0
 202                        (alist-cons 'compression %no-compression result))
 203                       (level
 204                        (match (string->compression-type type)
 205                          ((? symbol? type)
 206                           (alist-cons 'compression
 207                                       (compression type level)
 208                                       result))
 209                          (_
 210                           (warning (G_ "~a: unsupported compression type~%")
 211                                    type)
 212                           result)))))))
 213         (option '(#\c "cache") #t #f
 214                 (lambda (opt name arg result)
 215                   (alist-cons 'cache arg result)))
 216         (option '("cache-bypass-threshold") #t #f
 217                 (lambda (opt name arg result)
 218                   (alist-cons 'cache-bypass-threshold (size->number arg)
 219                               result)))
 220         (option '("workers") #t #f
 221                 (lambda (opt name arg result)
 222                   (alist-cons 'workers (string->number* arg)
 223                               result)))
 224         (option '("ttl") #t #f
 225                 (lambda (opt name arg result)
 226                   (let ((duration (string->duration arg)))
 227                     (unless duration
 228                       (leave (G_ "~a: invalid duration~%") arg))
 229                     (alist-cons 'narinfo-ttl (time-second duration)
 230                                 result))))
 231         (option '("negative-ttl") #t #f
 232                 (lambda (opt name arg result)
 233                   (let ((duration (string->duration arg)))
 234                     (unless duration
 235                       (leave (G_ "~a: invalid duration~%") arg))
 236                     (alist-cons 'narinfo-negative-ttl (time-second duration)
 237                                 result))))
 238         (option '("nar-path") #t #f
 239                 (lambda (opt name arg result)
 240                   (alist-cons 'nar-path arg result)))
 241         (option '("public-key") #t #f
 242                 (lambda (opt name arg result)
 243                   (alist-cons 'public-key-file arg result)))
 244         (option '("private-key" "secret-key") #t #f
 245                 (lambda (opt name arg result)
 246                   (alist-cons 'private-key-file arg result)))
 247         (option '(#\r "repl") #f #t
 248                 (lambda (opt name arg result)
 249                   ;; If port unspecified, use default Guile REPL port.
 250                   (let ((port (and arg (string->number* arg))))
 251                     (alist-cons 'repl (or port 37146) result))))))
 252
 253 (define %default-options
 254   `((port . 8080)
 255
 256     ;; By default, serve nars under "/nar".
 257     (nar-path . "nar")
 258
 259     (public-key-file . ,%public-key-file)
 260     (private-key-file . ,%private-key-file)
 261
 262     ;; Default number of workers when caching is enabled.
 263     (workers . ,(current-processor-count))
 264
 265     (address . ,(make-socket-address AF_INET INADDR_ANY 0))
 266     (repl . #f)))
 267
 268 ;; The key pair used to sign narinfos.
 269 (define %private-key
 270   (make-parameter #f))
 271 (define %public-key
 272   (make-parameter #f))
 273
 274 (define %nix-cache-info
 275   `(("StoreDir" . ,%store-directory)
 276     ("WantMassQuery" . 0)
 277     ("Priority" . 100)))
 278
 279 ;;; A common buffer size value used for the TCP socket SO_SNDBUF option and
 280 ;;; the gzip compressor buffer size.
 281 (define %default-buffer-size
 282   (* 208 1024))
 283
 284 (define %default-socket-options
 285   ;; List of options passed to 'setsockopt' when transmitting files.
 286   (list (list SO_SNDBUF %default-buffer-size)))
 287
 288 (define* (configure-socket socket #:key (level SOL_SOCKET)
 289                            (options %default-socket-options))
 290   "Apply multiple option tuples in OPTIONS to SOCKET, using LEVEL."
 291   (for-each (cut apply setsockopt socket level <>)
 292             options))
 293
 294 (define (signed-string s)
 295   "Sign the hash of the string S with the daemon's key.  Return a canonical
 296 sexp for the signature."
 297   (let* ((public-key (%public-key))
 298          (hash (bytevector->hash-data (sha256 (string->utf8 s))
 299                                       #:key-type (key-type public-key))))
 300     (signature-sexp hash (%private-key) public-key)))
 301
 302 (define base64-encode-string
 303   (compose base64-encode string->utf8))
 304
 305 (define* (store-item->recutils store-item
 306                                #:key
 307                                (nar-path "nar")
 308                                (compression %no-compression)
 309                                file-size)
 310   "Return the 'Compression' and 'URL' fields of the narinfo for STORE-ITEM,
 311 with COMPRESSION, starting at NAR-PATH."
 312   (let ((url (encode-and-join-uri-path
 313               `(,@(split-and-decode-uri-path nar-path)
 314                 ,@(match compression
 315                     (($ <compression> 'none)
 316                      '())
 317                     (($ <compression> type)
 318                      (list (symbol->string type))))
 319                 ,(basename store-item)))))
 320     (format #f "URL: ~a~%Compression: ~a~%~@[FileSize: ~a~%~]"
 321             url (compression-type compression) file-size)))
 322
 323 (define* (narinfo-string store store-path key
 324                          #:key (compressions (list %no-compression))
 325                          (nar-path "nar") (file-sizes '()))
 326   "Generate a narinfo key/value string for STORE-PATH; an exception is raised
 327 if STORE-PATH is invalid.  Produce a URL that corresponds to COMPRESSION.  The
 328 narinfo is signed with KEY.  NAR-PATH specifies the prefix for nar URLs.
 329
 330 Optionally, FILE-SIZES is a list of compression/integer pairs, where the
 331 integer is size in bytes of the compressed NAR; it informs the client of how
 332 much needs to be downloaded."
 333   (let* ((path-info  (query-path-info store store-path))
 334          (compressions (actual-compressions store-path compressions))
 335          (hash       (bytevector->nix-base32-string
 336                       (path-info-hash path-info)))
 337          (size       (path-info-nar-size path-info))
 338          (file-sizes `((,%no-compression . ,size) ,@file-sizes))
 339          (references (string-join
 340                       (map basename (path-info-references path-info))
 341                       " "))
 342          (deriver    (path-info-deriver path-info))
 343          (base-info  (format #f
 344                              "\
 345 StorePath: ~a
 346 ~{~a~}\
 347 NarHash: sha256:~a
 348 NarSize: ~d
 349 References: ~a~%"
 350                              store-path
 351                              (map (lambda (compression)
 352                                     (let ((size (assoc-ref file-sizes
 353                                                            compression)))
 354                                       (store-item->recutils store-path
 355                                                             #:file-size size
 356                                                             #:nar-path nar-path
 357                                                             #:compression
 358                                                             compression)))
 359                                   compressions)
 360                              hash size references))
 361          ;; Do not render a "Deriver" or "System" line if we are rendering
 362          ;; info for a derivation.
 363          (info       (if (not deriver)
 364                          base-info
 365                          (catch 'system-error
 366                            (lambda ()
 367                              (let ((drv (read-derivation-from-file deriver)))
 368                                (format #f "~aSystem: ~a~%Deriver: ~a~%"
 369                                        base-info (derivation-system drv)
 370                                        (basename deriver))))
 371                            (lambda args
 372                              ;; DERIVER might be missing, but that's fine:
 373                              ;; it's only used for <substitutable> where it's
 374                              ;; optional.  'System' is currently unused.
 375                              (if (= ENOENT (system-error-errno args))
 376                                  base-info
 377                                  (apply throw args))))))
 378          (signature  (base64-encode-string
 379                       (canonical-sexp->string (signed-string info)))))
 380     (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
 381
 382 (define* (not-found request
 383                     #:key (phrase "Resource not found")
 384                     ttl)
 385   "Render 404 response for REQUEST."
 386   (values (build-response #:code 404
 387                           #:headers (if ttl
 388                                         `((cache-control (max-age . ,ttl)))
 389                                         '()))
 390           (string-append phrase ": "
 391                          (uri-path (request-uri request)))))
 392
 393 (define (render-nix-cache-info)
 394   "Render server information."
 395   (values '((content-type . (text/plain)))
 396           (lambda (port)
 397             (for-each (match-lambda
 398                        ((key . value)
 399                         (format port "~a: ~a~%" key value)))
 400                       %nix-cache-info))))
 401
 402 (define* (render-narinfo store request hash
 403                          #:key ttl (compressions (list %no-compression))
 404                          (nar-path "nar") negative-ttl)
 405   "Render metadata for the store path corresponding to HASH.  If TTL is true,
 406 advertise it as the maximum validity period (in seconds) via the
 407 'Cache-Control' header.  This allows 'guix substitute' to cache it for an
 408 appropriate duration.  NAR-PATH specifies the prefix for nar URLs."
 409   (let ((store-path (hash-part->path store hash)))
 410     (if (string-null? store-path)
 411         (not-found request #:phrase "" #:ttl negative-ttl)
 412         (values `((content-type . (application/x-nix-narinfo))
 413                   ,@(if ttl
 414                         `((cache-control (max-age . ,ttl)))
 415                         '()))
 416                 (cut display
 417                   (narinfo-string store store-path (%private-key)
 418                                   #:nar-path nar-path
 419                                   #:compressions compressions)
 420                   <>)))))
 421
 422 (define* (nar-cache-file directory item
 423                              #:key (compression %no-compression))
 424   (string-append directory "/"
 425                  (symbol->string (compression-type compression))
 426                  "/" (basename item) ".nar"))
 427
 428 (define* (narinfo-cache-file directory item
 429                              #:key (compression %no-compression))
 430   (string-append directory "/"
 431                  (symbol->string (compression-type compression))
 432                  "/" (basename item)
 433                  ".narinfo"))
 434
 435 (define (hash-part-mapping-cache-file directory hash)
 436   (string-append directory "/hashes/" hash))
 437
 438 (define run-single-baker
 439   (let ((baking (make-weak-value-hash-table))
 440         (mutex  (make-mutex)))
 441     (lambda (item thunk)
 442       "Run THUNK, which is supposed to bake ITEM, but make sure only one
 443 thread is baking ITEM at a given time."
 444       (define selected?
 445         (with-mutex mutex
 446           (and (not (hash-ref baking item))
 447                (begin
 448                  (hash-set! baking item (current-thread))
 449                  #t))))
 450
 451       (when selected?
 452         (dynamic-wind
 453           (const #t)
 454           thunk
 455           (lambda ()
 456             (with-mutex mutex
 457               (hash-remove! baking item))))))))
 458
 459 (define-syntax-rule (single-baker item exp ...)
 460   "Bake ITEM by evaluating EXP, but make sure there's only one baker for ITEM
 461 at a time."
 462   (run-single-baker item (lambda () exp ...)))
 463
 464
 465 (define (narinfo-files cache)
 466   "Return the list of .narinfo files under CACHE."
 467   (if (file-is-directory? cache)
 468       (find-files cache
 469                   (lambda (file stat)
 470                     (string-suffix? ".narinfo" file)))
 471       '()))
 472
 473 (define (nar-expiration-time ttl)
 474   "Return the narinfo expiration time (in seconds since the Epoch).  The
 475 expiration time is +inf.0 when passed an item that is still in the store; in
 476 other cases, it is the last-access time of the item plus TTL.
 477
 478 This policy allows us to keep cached nars that correspond to valid store
 479 items.  Failing that, we could eventually have to recompute them and return
 480 404 in the meantime."
 481   (let ((expiration-time (file-expiration-time ttl)))
 482     (lambda (file)
 483       (let ((item (string-append (%store-prefix) "/"
 484                                  (basename file ".narinfo"))))
 485         ;; Note: We don't need to use 'valid-path?' here because FILE would
 486         ;; not exist if ITEM were not valid in the first place.
 487         (if (file-exists? item)
 488             +inf.0
 489             (expiration-time file))))))
 490
 491 (define (hash-part->path* store hash cache)
 492   "Like 'hash-part->path' but cache results under CACHE.  This ensures we can
 493 still map HASH to the corresponding store file name, even if said store item
 494 vanished from the store in the meantime."
 495   (let ((cached (hash-part-mapping-cache-file cache hash)))
 496     (catch 'system-error
 497       (lambda ()
 498         (call-with-input-file cached read-string))
 499       (lambda args
 500         (if (= ENOENT (system-error-errno args))
 501             (match (hash-part->path store hash)
 502               ("" "")
 503               (result
 504                (mkdir-p (dirname cached))
 505                (call-with-output-file (string-append cached ".tmp")
 506                  (lambda (port)
 507                    (display result port)))
 508                (rename-file (string-append cached ".tmp") cached)
 509                result))
 510             (apply throw args))))))
 511
 512 (define cache-bypass-threshold
 513   ;; Maximum size of a store item that may be served by the '/cached' handlers
 514   ;; below even when not in cache.
 515   (make-parameter (* 10 (expt 2 20))))
 516
 517 (define (bypass-cache? store item)
 518   "Return true if we allow ITEM to be downloaded before it is cached.  ITEM is
 519 interpreted as the basename of a store item."
 520   (guard (c ((store-error? c) #f))
 521     (< (path-info-nar-size (query-path-info store item))
 522        (cache-bypass-threshold))))
 523
 524 (define* (render-narinfo/cached store request hash
 525                                 #:key ttl (compressions (list %no-compression))
 526                                 (nar-path "nar") negative-ttl
 527                                 cache pool)
 528   "Respond to the narinfo request for REQUEST.  If the narinfo is available in
 529 CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
 530 requested using POOL."
 531   (define (delete-entry narinfo)
 532     ;; Delete NARINFO and the corresponding nar from CACHE.
 533     (let* ((nar     (string-append (string-drop-right narinfo
 534                                                       (string-length ".narinfo"))
 535                                    ".nar"))
 536            (base    (basename narinfo ".narinfo"))
 537            (hash    (string-take base (string-index base #\-)))
 538            (mapping (hash-part-mapping-cache-file cache hash)))
 539       (delete-file* narinfo)
 540       (delete-file* nar)
 541       (delete-file* mapping)))
 542
 543   (let* ((item         (hash-part->path* store hash cache))
 544          (compressions (actual-compressions item compressions))
 545          (cached       (and (not (string-null? item))
 546                             (narinfo-cache-file cache item
 547                                                 #:compression
 548                                                 (first compressions)))))
 549     (cond ((string-null? item)
 550            (not-found request #:ttl negative-ttl))
 551           ((file-exists? cached)
 552            ;; Narinfo is in cache, send it.
 553            (values `((content-type . (application/x-nix-narinfo))
 554                      ,@(if ttl
 555                            `((cache-control (max-age . ,ttl)))
 556                            '()))
 557                    (lambda (port)
 558                      (display (call-with-input-file cached
 559                                 read-string)
 560                               port))))
 561           ((and (file-exists? item)        ;cheaper than the 'valid-path?' RPC
 562                 (valid-path? store item))
 563            ;; Nothing in cache: bake the narinfo and nar in the background and
 564            ;; return 404.
 565            (eventually pool
 566              (single-baker item
 567                ;; Check whether CACHED has been produced in the meantime.
 568                (unless (file-exists? cached)
 569                  ;; (format #t "baking ~s~%" item)
 570                  (bake-narinfo+nar cache item
 571                                    #:ttl ttl
 572                                    #:compressions compressions
 573                                    #:nar-path nar-path)))
 574
 575              (when ttl
 576                (single-baker 'cache-cleanup
 577                  (maybe-remove-expired-cache-entries cache
 578                                                      narinfo-files
 579                                                      #:entry-expiration
 580                                                      (nar-expiration-time ttl)
 581                                                      #:delete-entry delete-entry
 582                                                      #:cleanup-period ttl))))
 583
 584            ;; If ITEM passes 'bypass-cache?', render a temporary narinfo right
 585            ;; away, with a short TTL.  The narinfo is temporary because it
 586            ;; lacks 'FileSize', for instance, which the cached narinfo will
 587            ;; have.  Chances are that the nar will be baked by the time the
 588            ;; client asks for it.
 589            (if (bypass-cache? store item)
 590                (render-narinfo store request hash
 591                                #:ttl 300          ;temporary
 592                                #:nar-path nar-path
 593                                #:compressions compressions)
 594                (not-found request
 595                           #:phrase "We're baking it"
 596                           #:ttl 300)))          ;should be available within 5m
 597           (else
 598            (not-found request #:phrase "" #:ttl negative-ttl)))))
 599
 600 (define (compress-nar cache item compression)
 601   "Save in directory CACHE the nar for ITEM compressed with COMPRESSION."
 602   (define nar
 603     (nar-cache-file cache item #:compression compression))
 604
 605   (define (write-compressed-file call-with-compressed-output-port)
 606     ;; Note: the file port gets closed along with the compressed port.
 607     (call-with-compressed-output-port (open-output-file (string-append nar ".tmp"))
 608       (lambda (port)
 609         (write-file item port))
 610       #:level (compression-level compression))
 611     (rename-file (string-append nar ".tmp") nar))
 612
 613   (mkdir-p (dirname nar))
 614   (match (compression-type compression)
 615     ('gzip
 616      (write-compressed-file call-with-gzip-output-port))
 617     ('lzip
 618      (write-compressed-file call-with-lzip-output-port))
 619     ('zstd
 620      (write-compressed-file call-with-zstd-output-port))
 621     ('none
 622      ;; Cache nars even when compression is disabled so that we can
 623      ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
 624      (with-atomic-file-output nar
 625        (lambda (port)
 626          (write-file item port)
 627          ;; Make the file world-readable, contrary to what
 628          ;; 'with-atomic-file-output' does.
 629          (chmod port (logand #o644 (lognot (umask)))))))))
 630
 631 (define* (bake-narinfo+nar cache item
 632                            #:key ttl (compressions (list %no-compression))
 633                            (nar-path "/nar"))
 634   "Write the narinfo and nar for ITEM to CACHE."
 635   (define (compressed-nar-size compression)
 636     (let* ((nar  (nar-cache-file cache item #:compression compression))
 637            (stat (stat nar #f)))
 638       (and stat
 639            (cons compression (stat:size stat)))))
 640
 641   (let ((compression (actual-compressions item compressions)))
 642
 643     (for-each (cut compress-nar cache item <>) compressions)
 644
 645     (match compressions
 646       ((main others ...)
 647        (let ((narinfo (narinfo-cache-file cache item
 648                                           #:compression main)))
 649          (with-atomic-file-output narinfo
 650            (lambda (port)
 651              ;; Open a new connection to the store.  We cannot reuse the main
 652              ;; thread's connection to the store since we would end up sending
 653              ;; stuff concurrently on the same channel.
 654              (with-store store
 655                (let ((sizes (filter-map compressed-nar-size compression)))
 656                  (display (narinfo-string store item
 657                                           (%private-key)
 658                                           #:nar-path nar-path
 659                                           #:compressions compressions
 660                                           #:file-sizes sizes)
 661                           port)))
 662
 663              ;; Make the cached narinfo world-readable, contrary to what
 664              ;; 'with-atomic-file-output' does, so that other users can rsync
 665              ;; the whole cache.
 666              (chmod port (logand #o644 (lognot (umask))))))
 667
 668          ;; Make narinfo files for OTHERS hard links to NARINFO such that the
 669          ;; atime-based cache eviction considers either all the nars or none
 670          ;; of them as candidates.
 671          (for-each (lambda (other)
 672                      (let ((other (narinfo-cache-file cache item
 673                                                       #:compression other)))
 674                        (link narinfo other)))
 675                    others))))))
 676
 677 ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for
 678 ;; internal consumption: it allows us to pass the compression info to
 679 ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
 680 (declare-header! "X-Nar-Compression"
 681                  (lambda (str)
 682                    (match (call-with-input-string str read)
 683                      (('compression type level)
 684                       (compression type level))))
 685                  compression?
 686                  (lambda (compression port)
 687                    (match compression
 688                      (($ <compression> type level)
 689                       (write `(compression ,type ,level) port)))))
 690
 691 (define* (render-nar store request store-item
 692                      #:key (compression %no-compression))
 693   "Render archive of the store path corresponding to STORE-ITEM."
 694   (let ((store-path (string-append %store-directory "/" store-item)))
 695     ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
 696     ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
 697     ;; sequences.
 698     (if (valid-path? store store-path)
 699         (values `((content-type . (application/x-nix-archive
 700                                    (charset . "ISO-8859-1")))
 701                   (x-nar-compression . ,compression))
 702                 ;; XXX: We're not returning the actual contents, deferring
 703                 ;; instead to 'http-write'.  This is a hack to work around
 704                 ;; <http://bugs.gnu.org/21093>.
 705                 store-path)
 706         (not-found request))))
 707
 708 (define* (render-nar/cached store cache request store-item
 709                             #:key ttl (compression %no-compression))
 710   "Respond to REQUEST with a nar for STORE-ITEM.  If the nar is in CACHE,
 711 return it; otherwise, return 404.  When TTL is true, use it as the
 712 'Cache-Control' expiration time."
 713   (let ((cached (nar-cache-file cache store-item
 714                                 #:compression compression)))
 715     (cond ((file-exists? cached)
 716            (values `((content-type . (application/octet-stream
 717                                       (charset . "ISO-8859-1")))
 718                      ,@(if ttl
 719                            `((cache-control (max-age . ,ttl)))
 720                            '())
 721
 722                      ;; XXX: We're not returning the actual contents, deferring
 723                      ;; instead to 'http-write'.  This is a hack to work around
 724                      ;; <http://bugs.gnu.org/21093>.
 725                      (x-raw-file . ,cached))
 726                    #f))
 727           ((let* ((hash (and=> (string-index store-item #\-)
 728                                (cut string-take store-item <>)))
 729                   (item (and hash
 730                              (guard (c ((store-error? c) #f))
 731                                (hash-part->path store hash)))))
 732              (and item (not (string-null? item))
 733                   (bypass-cache? store item)))
 734            ;; Render STORE-ITEM live.  We reach this because STORE-ITEM is
 735            ;; being baked but clients are already asking for it.  Thus, we're
 736            ;; duplicating work, but doing so allows us to reduce delays.
 737            (render-nar store request store-item
 738                        #:compression (low-compression compression)))
 739           (else
 740            (not-found request)))))
 741
 742 (define (render-content-addressed-file store request
 743                                        name algo hash)
 744   "Return the content of the result of the fixed-output derivation NAME that
 745 has the given HASH of type ALGO."
 746   ;; TODO: Support other hash algorithms.
 747   (if (and (eq? algo 'sha256) (= 32 (bytevector-length hash)))
 748       (let ((item (fixed-output-path name hash
 749                                      #:hash-algo algo
 750                                      #:recursive? #f)))
 751         (if (valid-path? store item)
 752             (values `((content-type . (application/octet-stream
 753                                        (charset . "ISO-8859-1")))
 754                       ;; XXX: We're not returning the actual contents,
 755                       ;; deferring instead to 'http-write'.  This is a hack to
 756                       ;; work around <http://bugs.gnu.org/21093>.
 757                       (x-raw-file . ,item))
 758                     #f)
 759             (not-found request)))
 760       (not-found request)))
 761
 762 (define (render-log-file store request name)
 763   "Render the log file for NAME, the base name of a store item.  Don't attempt
 764 to compress or decompress the log file; just return it as-is."
 765   (define (response-headers file)
 766     ;; XXX: We're not returning the actual contents, deferring instead to
 767     ;; 'http-write'.  This is a hack to work around
 768     ;; <http://bugs.gnu.org/21093>.
 769     (cond ((string-suffix? ".gz" file)
 770            `((content-type . (text/plain (charset . "UTF-8")))
 771              (content-encoding . (gzip))
 772              (x-raw-file . ,file)))
 773           ((string-suffix? ".bz2" file)
 774            `((content-type . (application/x-bzip2
 775                               (charset . "ISO-8859-1")))
 776              (x-raw-file . ,file)))
 777           (else                                   ;uncompressed
 778            `((content-type . (text/plain (charset . "UTF-8")))
 779              (x-raw-file . ,file)))))
 780
 781   (let ((log (log-file store
 782                        (string-append (%store-prefix) "/" name))))
 783     (if log
 784         (values (response-headers log) log)
 785         (not-found request))))
 786
 787 (define (render-signing-key)
 788   "Render signing key."
 789   (let ((file %public-key-file))
 790     (values `((content-type . (text/plain (charset . "UTF-8")))
 791               (x-raw-file . ,file))
 792             file)))
 793
 794 (define (render-home-page request)
 795   "Render the home page."
 796   (values `((content-type . (text/html (charset . "UTF-8"))))
 797           (call-with-output-string
 798             (lambda (port)
 799               (sxml->xml '(html
 800                            (head (title "GNU Guix Substitute Server"))
 801                            (body
 802                             (h1 "GNU Guix Substitute Server")
 803                             (p "Hi, "
 804                                (a (@ (href
 805                                       "https://guix.gnu.org/manual/en/html_node/Invoking-guix-publish.html"))
 806                                   (tt "guix publish"))
 807                                " speaking.  Welcome!")
 808                             (p "Here is the "
 809                                (a (@ (href
 810                                       "signing-key.pub"))
 811                                   (tt "signing key"))
 812                                " for this server. Knock yourselves out!")))
 813                          port)))))
 814
 815 (define (extract-narinfo-hash str)
 816   "Return the hash within the narinfo resource string STR, or false if STR
 817 is invalid."
 818   (and (string-suffix? ".narinfo" str)
 819        (let ((base (string-drop-right str 8)))
 820          (and (string-every %nix-base32-charset base)
 821               base))))
 822
 823 (define (get-request? request)
 824   "Return #t if REQUEST uses the GET method."
 825   (eq? (request-method request) 'GET))
 826
 827 (define (request-path-components request)
 828   "Split the URI path of REQUEST into a list of component strings.  For
 829 example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
 830   (split-and-decode-uri-path (uri-path (request-uri request))))
 831
 832 \f
 833 ;;;
 834 ;;; Server.
 835 ;;;
 836
 837 (define %http-write
 838   (@@ (web server http) http-write))
 839
 840 (define (strip-headers response)
 841   "Return RESPONSE's headers minus 'Content-Length' and our internal headers."
 842   (fold alist-delete
 843         (response-headers response)
 844         '(content-length x-raw-file x-nar-compression)))
 845
 846 (define (sans-content-length response)
 847   "Return RESPONSE without its 'content-length' header."
 848   (set-field response (response-headers)
 849              (strip-headers response)))
 850
 851 (define (with-content-length response length)
 852   "Return RESPONSE with a 'content-length' header set to LENGTH."
 853   (set-field response (response-headers)
 854              (alist-cons 'content-length length
 855                          (strip-headers response))))
 856
 857 (define-syntax-rule (swallow-EPIPE exp ...)
 858   "Swallow EPIPE errors raised by EXP..."
 859   (catch 'system-error
 860     (lambda ()
 861       exp ...)
 862     (lambda args
 863       (if (= EPIPE (system-error-errno args))
 864           (values)
 865           (apply throw args)))))
 866
 867 (define-syntax-rule (swallow-zlib-error exp ...)
 868   "Swallow 'zlib-error' exceptions raised by EXP..."
 869   (catch 'zlib-error
 870     (lambda ()
 871       exp ...)
 872     (const #f)))
 873
 874 (define (nar-compressed-port port compression)
 875   "Return a port on which to write the body of the response of a /nar request,
 876 according to COMPRESSION."
 877   (match compression
 878     (($ <compression> 'gzip level)
 879      ;; Note: We cannot used chunked encoding here because
 880      ;; 'make-gzip-output-port' wants a file port.
 881      (make-gzip-output-port port
 882                             #:level level
 883                             #:buffer-size %default-buffer-size))
 884     (($ <compression> 'lzip level)
 885      (make-lzip-output-port port
 886                             #:level level))
 887     (($ <compression> 'zstd level)
 888      (make-zstd-output-port port
 889                             #:level level))
 890     (($ <compression> 'none)
 891      port)
 892     (#f
 893      port)))
 894
 895 (define (http-write server client response body)
 896   "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid
 897 blocking."
 898   ;; XXX: The default Guile web server implementation supports the keep-alive
 899   ;; mechanism.  However, as we run our own modified version of the http-write
 900   ;; procedure, we need to access a few server implementation details to keep
 901   ;; it functional.
 902   (define *error-events*
 903     (logior POLLHUP POLLERR))
 904
 905   (define *read-events*
 906     POLLIN)
 907
 908   (define *events*
 909     (logior *error-events* *read-events*))
 910
 911   ;; Access the server poll set variable.
 912   (define http-poll-set
 913     (@@ (web server http) http-poll-set))
 914
 915   ;; Copied from (web server http).
 916   (define (keep-alive? response)
 917     (let ((v (response-version response)))
 918       (and (or (< (response-code response) 400)
 919                (= (response-code response) 404))
 920            (case (car v)
 921              ((1)
 922               (case (cdr v)
 923                 ((1) (not (memq 'close (response-connection response))))
 924                 ((0) (memq 'keep-alive (response-connection response)))))
 925              (else #f)))))
 926
 927   (define (keep-alive port)
 928     "Add the given PORT the server poll set."
 929     (force-output port)
 930     (poll-set-add! (http-poll-set server) port *events*))
 931
 932   (define compression
 933     (assoc-ref (response-headers response) 'x-nar-compression))
 934
 935   (match (response-content-type response)
 936     (('application/x-nix-archive . _)
 937      ;; When compressing the NAR on the go, we cannot announce its size
 938      ;; beforehand to the client. Hence, the keep-alive mechanism cannot work
 939      ;; here.
 940      (let ((keep-alive? (and (eq? (compression-type compression) 'none)
 941                              (keep-alive? response))))
 942        ;; Add the client to the server poll set, so that we can receive
 943        ;; further requests without closing the connection.
 944        (when keep-alive?
 945          (keep-alive client))
 946        ;; Sending the the whole archive can take time so do it in a separate
 947        ;; thread so that the main thread can keep working in the meantime.
 948        (call-with-new-thread
 949         (lambda ()
 950           (set-thread-name "publish nar")
 951           (let* ((response    (write-response (sans-content-length response)
 952                                               client))
 953                  (port        (begin
 954                                 (force-output client)
 955                                 (configure-socket client)
 956                                 ;; Duplicate the response port, so that it is
 957                                 ;; not automatically closed when closing the
 958                                 ;; returned port.  This is needed for the
 959                                 ;; keep-alive mechanism.
 960                                 (nar-compressed-port
 961                                  (duplicate-port
 962                                   (response-port response) "w+0b")
 963                                  compression))))
 964             ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093>
 965             ;; in 'render-nar', BODY here is just the file name of the store
 966             ;; item.  We call 'write-file' from here because we know that's
 967             ;; the only way to avoid building the whole nar in memory, which
 968             ;; could quickly become a real problem.  As a bonus, we even do
 969             ;; sendfile(2) directly from the store files to the socket.
 970             (swallow-zlib-error
 971              (swallow-EPIPE
 972               (write-file (utf8->string body) port)))
 973             (swallow-zlib-error
 974              (close-port port)
 975              (unless keep-alive?
 976                (close-port client)))
 977             (values))))))
 978     (_
 979      (match (assoc-ref (response-headers response) 'x-raw-file)
 980        ((? string? file)
 981         (when (keep-alive? response)
 982           (keep-alive client))
 983         ;; Send a raw file in a separate thread.
 984         (call-with-new-thread
 985          (lambda ()
 986            (set-thread-name "publish file")
 987            (catch 'system-error
 988              (lambda ()
 989                (call-with-input-file file
 990                  (lambda (input)
 991                    (let* ((size     (stat:size (stat input)))
 992                           (response (write-response
 993                                      (with-content-length response size)
 994                                      client))
 995                           (output   (response-port response)))
 996                      (configure-socket client)
 997                      (if (file-port? output)
 998                          (sendfile output input size)
 999                          (dump-port input output))
1000                      (unless (keep-alive? response)
1001                        (close-port output))
1002                      (values)))))
1003              (lambda args
1004                ;; If the file was GC'd behind our back, that's fine.  Likewise
1005                ;; if the client closes the connection.
1006                (unless (memv (system-error-errno args)
1007                              (list ENOENT EPIPE ECONNRESET))
1008                  (apply throw args))
1009                (values))))))
1010        (#f
1011         ;; Handle other responses sequentially.
1012         (%http-write server client response body))))))
1013
1014 (define-server-impl concurrent-http-server
1015   ;; A variant of Guile's built-in HTTP server that offloads possibly long
1016   ;; responses to a different thread.
1017   (@@ (web server http) http-open)
1018   (@@ (web server http) http-read)
1019   http-write
1020   (@@ (web server http) http-close))
1021
1022 (define (string->compression-type string)
1023   "Return a symbol denoting the compression method expressed by STRING; return
1024 #f if STRING doesn't match any supported method."
1025   (match string
1026     ("gzip" 'gzip)
1027     ("lzip" 'lzip)
1028     ("zstd" 'zstd)
1029     (_      #f)))
1030
1031 (define (effective-compression requested-type compressions)
1032   "Given the REQUESTED-TYPE for compression and the set of chosen COMPRESSION
1033 methods, return the applicable compression."
1034   (or (find (match-lambda
1035               (($ <compression> type)
1036                (and (eq? type requested-type)
1037                     compression)))
1038             compressions)
1039       (default-compression requested-type)))
1040
1041 (define (preserve-connection-headers request response)
1042   "Add REQUEST's 'connection' header, if any, to HEADERS, a list of response
1043 headers."
1044   (if (pair? response)
1045       (let ((connection
1046              (assq 'connection (request-headers request))))
1047         (append response
1048                 (if connection
1049                     (list connection)
1050                     '())))
1051       response))
1052
1053 (define* (make-request-handler store
1054                                #:key
1055                                cache pool
1056                                narinfo-ttl narinfo-negative-ttl
1057                                (nar-path "nar")
1058                                (compressions (list %no-compression)))
1059   (define compression-type?
1060     string->compression-type)
1061
1062   (define nar-path?
1063     (let ((expected (split-and-decode-uri-path nar-path)))
1064       (cut equal? expected <>)))
1065
1066   (define (handle request body)
1067     (format #t "~a ~a~%"
1068             (request-method request)
1069             (uri-path (request-uri request)))
1070     (if (get-request? request)                    ;reject POST, PUT, etc.
1071         (match (request-path-components request)
1072           ;; /nix-cache-info
1073           (("nix-cache-info")
1074            (render-nix-cache-info))
1075           ;; /
1076           ((or () ("index.html"))
1077            (render-home-page request))
1078           ;; guix signing-key
1079           (("signing-key.pub")
1080            (render-signing-key))
1081           ;; /<hash>.narinfo
1082           (((= extract-narinfo-hash (? string? hash)))
1083            (if cache
1084                (render-narinfo/cached store request hash
1085                                       #:cache cache
1086                                       #:pool pool
1087                                       #:ttl narinfo-ttl
1088                                       #:negative-ttl narinfo-negative-ttl
1089                                       #:nar-path nar-path
1090                                       #:compressions compressions)
1091                (render-narinfo store request hash
1092                                #:ttl narinfo-ttl
1093                                #:negative-ttl narinfo-negative-ttl
1094                                #:nar-path nar-path
1095                                #:compressions compressions)))
1096           ;; /nar/file/NAME/sha256/HASH
1097           (("file" name "sha256" hash)
1098            (guard (c ((invalid-base32-character? c)
1099                       (not-found request)))
1100              (let ((hash (nix-base32-string->bytevector hash)))
1101                (render-content-addressed-file store request
1102                                               name 'sha256 hash))))
1103
1104           ;; /log/OUTPUT
1105           (("log" name)
1106            (render-log-file store request name))
1107
1108           ;; Use different URLs depending on the compression type.  This
1109           ;; guarantees that /nar URLs remain valid even when 'guix publish'
1110           ;; is restarted with different compression parameters.
1111
1112           ;; /nar/gzip/<store-item>
1113           ((components ... (? compression-type? type) store-item)
1114            (if (nar-path? components)
1115                (let* ((compression-type (string->compression-type type))
1116                       (compression (effective-compression compression-type
1117                                                           compressions)))
1118                  (if cache
1119                      (render-nar/cached store cache request store-item
1120                                         #:ttl narinfo-ttl
1121                                         #:compression compression)
1122                      (render-nar store request store-item
1123                                  #:compression compression)))
1124                (not-found request)))
1125
1126           ;; /nar/<store-item>
1127           ((components ... store-item)
1128            (if (nar-path? components)
1129                (if cache
1130                    (render-nar/cached store cache request store-item
1131                                       #:ttl narinfo-ttl
1132                                       #:compression %no-compression)
1133                    (render-nar store request store-item
1134                                #:compression %no-compression))
1135                (not-found request)))
1136
1137           (x (not-found request)))
1138         (not-found request)))
1139
1140   ;; Preserve the request's 'connection' header in the response, so that the
1141   ;; server can close the connection if this is requested by the client.
1142   (lambda (request body)
1143     (let-values (((response response-body)
1144                   (handle request body)))
1145       (values (preserve-connection-headers request response)
1146               response-body))))
1147
1148 (define (service-name)
1149   "Return the Avahi service name of the server."
1150   (string-append "guix-publish-" (gethostname)))
1151
1152 (define publish-service-type
1153   ;; Return the Avahi service type of the server.
1154   "_guix_publish._tcp")
1155
1156 (define* (run-publish-server socket store
1157                              #:key
1158                              advertise? port
1159                              (compressions (list %no-compression))
1160                              (nar-path "nar") narinfo-ttl narinfo-negative-ttl
1161                              cache pool)
1162   (when advertise?
1163     (let ((name (service-name)))
1164       ;; XXX: Use a callback from Guile-Avahi here, as Avahi can pick a
1165       ;; different name to avoid name clashes.
1166       (info (G_ "Advertising ~a~%.") name)
1167       (avahi-publish-service-thread name
1168                                     #:type publish-service-type
1169                                     #:port port)))
1170
1171   (run-server (make-request-handler store
1172                                     #:cache cache
1173                                     #:pool pool
1174                                     #:nar-path nar-path
1175                                     #:narinfo-ttl narinfo-ttl
1176                                     #:narinfo-negative-ttl narinfo-negative-ttl
1177                                     #:compressions compressions)
1178               concurrent-http-server
1179               `(#:socket ,socket)))
1180
1181 (define (open-server-socket address)
1182   "Return a TCP socket bound to ADDRESS, a socket address."
1183   (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
1184     (configure-socket sock #:options (cons (list SO_REUSEADDR 1)
1185                                            %default-socket-options))
1186     (bind sock address)
1187     sock))
1188
1189 (define (gather-user-privileges user)
1190   "Switch to the identity of USER, a user name."
1191   (catch 'misc-error
1192     (lambda ()
1193       (let ((user (getpw user)))
1194         (setgroups #())
1195         (setgid (passwd:gid user))
1196         (setuid (passwd:uid user))))
1197     (lambda (key proc message args . rest)
1198       (leave (G_ "user '~a' not found: ~a~%")
1199              user (apply format #f message args)))))
1200
1201 \f
1202 ;;;
1203 ;;; Entry point.
1204 ;;;
1205
1206 (define-command (guix-publish . args)
1207   (category packaging)
1208   (synopsis "publish build results over HTTP")
1209
1210   (with-error-handling
1211     (let* ((opts    (parse-command-line args %options (list %default-options)
1212                                         #:build-options? #f
1213                                         #:argument-handler
1214                                         (lambda (arg result)
1215                                           (leave (G_ "~A: extraneous argument~%") arg))))
1216            (advertise?  (assoc-ref opts 'advertise?))
1217            (user        (assoc-ref opts 'user))
1218            (port        (assoc-ref opts 'port))
1219            (ttl         (assoc-ref opts 'narinfo-ttl))
1220            (negative-ttl (assoc-ref opts 'narinfo-negative-ttl))
1221            (compressions (match (filter-map (match-lambda
1222                                               (('compression . compression)
1223                                                compression)
1224                                               (_ #f))
1225                                             opts)
1226                            (()
1227                             ;; Default to fast & low compression.
1228                             (list %default-gzip-compression))
1229                            (lst (reverse lst))))
1230            (address (let ((addr (assoc-ref opts 'address)))
1231                       (make-socket-address (sockaddr:fam addr)
1232                                            (sockaddr:addr addr)
1233                                            port)))
1234            (socket  (open-server-socket address))
1235            (nar-path  (assoc-ref opts 'nar-path))
1236            (repl-port (assoc-ref opts 'repl))
1237            (cache     (assoc-ref opts 'cache))
1238            (workers   (assoc-ref opts 'workers))
1239
1240            ;; Read the key right away so that (1) we fail early on if we can't
1241            ;; access them, and (2) we can then drop privileges.
1242            (public-key  (read-file-sexp (assoc-ref opts 'public-key-file)))
1243            (private-key (read-file-sexp (assoc-ref opts 'private-key-file))))
1244
1245       (when user
1246         ;; Now that we've read the key material and opened the socket, we can
1247         ;; drop privileges.
1248         (gather-user-privileges user))
1249
1250       (when (zero? (getuid))
1251         (warning (G_ "server running as root; \
1252 consider using the '--user' option!~%")))
1253
1254       (parameterize ((%public-key public-key)
1255                      (%private-key private-key)
1256                      (cache-bypass-threshold
1257                       (or (assoc-ref opts 'cache-bypass-threshold)
1258                           (cache-bypass-threshold))))
1259         (info (G_ "publishing ~a on ~a, port ~d~%")
1260               %store-directory
1261               (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
1262               (sockaddr:port address))
1263
1264         (for-each (lambda (compression)
1265                     (info (G_ "using '~a' compression method, level ~a~%")
1266                           (compression-type compression)
1267                           (compression-level compression)))
1268                   compressions)
1269
1270         (when repl-port
1271           (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
1272
1273         ;; Set the name of the main thread.
1274         (set-thread-name "guix publish")
1275
1276         (with-store store
1277           (run-publish-server socket store
1278                               #:advertise? advertise?
1279                               #:port port
1280                               #:cache cache
1281                               #:pool (and cache (make-pool workers
1282                                                            #:thread-name
1283                                                            "publish worker"))
1284                               #:nar-path nar-path
1285                               #:compressions compressions
1286                               #:narinfo-negative-ttl negative-ttl
1287                               #:narinfo-ttl ttl))))))
1288
1289 ;;; Local Variables:
1290 ;;; eval: (put 'single-baker 'scheme-indent-function 1)
1291 ;;; End: