guix/scripts/publish.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   3 ;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix scripts publish)
  21   #:use-module ((system repl server) #:prefix repl:)
  22   #:use-module (ice-9 binary-ports)
  23   #:use-module (ice-9 format)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 regex)
  26   #:use-module (ice-9 rdelim)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-2)
  30   #:use-module (srfi srfi-9)
  31   #:use-module (srfi srfi-9 gnu)
  32   #:use-module (srfi srfi-19)
  33   #:use-module (srfi srfi-26)
  34   #:use-module (srfi srfi-34)
  35   #:use-module (srfi srfi-37)
  36   #:use-module (web http)
  37   #:use-module (web request)
  38   #:use-module (web response)
  39   #:use-module (web server)
  40   #:use-module (web uri)
  41   #:use-module (guix base32)
  42   #:use-module (guix base64)
  43   #:use-module (guix config)
  44   #:use-module (guix derivations)
  45   #:use-module (guix hash)
  46   #:use-module (guix pki)
  47   #:use-module (guix pk-crypto)
  48   #:use-module (guix store)
  49   #:use-module ((guix serialization) #:select (write-file))
  50   #:use-module (guix zlib)
  51   #:use-module (guix ui)
  52   #:use-module (guix scripts)
  53   #:use-module ((guix utils) #:select (compressed-file?))
  54   #:use-module ((guix build utils) #:select (dump-port))
  55   #:export (guix-publish))
  56
  57 (define (show-help)
  58   (format #t (_ "Usage: guix publish [OPTION]...
  59 Publish ~a over HTTP.\n") %store-directory)
  60   (display (_ "
  61   -p, --port=PORT        listen on PORT"))
  62   (display (_ "
  63       --listen=HOST      listen on the network interface for HOST"))
  64   (display (_ "
  65   -u, --user=USER        change privileges to USER as soon as possible"))
  66   (display (_ "
  67   -C, --compression[=LEVEL]
  68                          compress archives at LEVEL"))
  69   (display (_ "
  70       --ttl=TTL          announce narinfos can be cached for TTL seconds"))
  71   (display (_ "
  72   -r, --repl[=PORT]      spawn REPL server on PORT"))
  73   (newline)
  74   (display (_ "
  75   -h, --help             display this help and exit"))
  76   (display (_ "
  77   -V, --version          display version information and exit"))
  78   (newline)
  79   (show-bug-report-information))
  80
  81 (define (getaddrinfo* host)
  82   "Like 'getaddrinfo', but properly report errors."
  83   (catch 'getaddrinfo-error
  84     (lambda ()
  85       (getaddrinfo host))
  86     (lambda (key error)
  87       (leave (_ "lookup of host '~a' failed: ~a~%")
  88              host (gai-strerror error)))))
  89
  90 ;; Nar compression parameters.
  91 (define-record-type <compression>
  92   (compression type level)
  93   compression?
  94   (type   compression-type)
  95   (level  compression-level))
  96
  97 (define %no-compression
  98   (compression 'none 0))
  99
 100 (define %default-gzip-compression
 101   ;; Since we compress on the fly, default to fast compression.
 102   (compression 'gzip 3))
 103
 104 (define %options
 105   (list (option '(#\h "help") #f #f
 106                 (lambda _
 107                   (show-help)
 108                   (exit 0)))
 109         (option '(#\V "version") #f #f
 110                 (lambda _
 111                   (show-version-and-exit "guix publish")))
 112         (option '(#\u "user") #t #f
 113                 (lambda (opt name arg result)
 114                   (alist-cons 'user arg result)))
 115         (option '(#\p "port") #t #f
 116                 (lambda (opt name arg result)
 117                   (alist-cons 'port (string->number* arg) result)))
 118         (option '("listen") #t #f
 119                 (lambda (opt name arg result)
 120                   (match (getaddrinfo* arg)
 121                     ((info _ ...)
 122                      (alist-cons 'address (addrinfo:addr info)
 123                                  result))
 124                     (()
 125                      (leave (_ "lookup of host '~a' returned nothing")
 126                             name)))))
 127         (option '(#\C "compression") #f #t
 128                 (lambda (opt name arg result)
 129                   (match (if arg (string->number* arg) 3)
 130                     (0
 131                      (alist-cons 'compression %no-compression result))
 132                     (level
 133                      (if (zlib-available?)
 134                          (alist-cons 'compression
 135                                      (compression 'gzip level)
 136                                      result)
 137                          (begin
 138                            (warning (_ "zlib support is missing; \
 139 compression disabled~%"))
 140                            result))))))
 141         (option '("ttl") #t #f
 142                 (lambda (opt name arg result)
 143                   (let ((duration (string->duration arg)))
 144                     (unless duration
 145                       (leave (_ "~a: invalid duration~%") arg))
 146                     (alist-cons 'narinfo-ttl (time-second duration)
 147                                 result))))
 148         (option '(#\r "repl") #f #t
 149                 (lambda (opt name arg result)
 150                   ;; If port unspecified, use default Guile REPL port.
 151                   (let ((port (and arg (string->number* arg))))
 152                     (alist-cons 'repl (or port 37146) result))))))
 153
 154 (define %default-options
 155   `((port . 8080)
 156
 157     ;; Default to fast & low compression.
 158     (compression . ,(if (zlib-available?)
 159                         %default-gzip-compression
 160                         %no-compression))
 161
 162     (address . ,(make-socket-address AF_INET INADDR_ANY 0))
 163     (repl . #f)))
 164
 165 (define (lazy-read-file-sexp file)
 166   "Return a promise to read the canonical sexp from FILE."
 167   (delay
 168     (call-with-input-file file
 169       (compose string->canonical-sexp
 170                read-string))))
 171
 172 (define %private-key
 173   (lazy-read-file-sexp %private-key-file))
 174
 175 (define %public-key
 176   (lazy-read-file-sexp %public-key-file))
 177
 178 (define %nix-cache-info
 179   `(("StoreDir" . ,%store-directory)
 180     ("WantMassQuery" . 0)
 181     ("Priority" . 100)))
 182
 183 (define (load-derivation file)
 184   "Read the derivation from FILE."
 185   (call-with-input-file file read-derivation))
 186
 187 (define (signed-string s)
 188   "Sign the hash of the string S with the daemon's key."
 189   (let* ((public-key (force %public-key))
 190          (hash (bytevector->hash-data (sha256 (string->utf8 s))
 191                                       #:key-type (key-type public-key))))
 192     (signature-sexp hash (force %private-key) public-key)))
 193
 194 (define base64-encode-string
 195   (compose base64-encode string->utf8))
 196
 197 (define* (narinfo-string store store-path key
 198                          #:key (compression %no-compression))
 199   "Generate a narinfo key/value string for STORE-PATH; an exception is raised
 200 if STORE-PATH is invalid.  Produce a URL that corresponds to COMPRESSION.  The
 201 narinfo is signed with KEY."
 202   (let* ((path-info  (query-path-info store store-path))
 203          (compression (if (compressed-file? store-path)
 204                           %no-compression
 205                           compression))
 206          (url        (encode-and-join-uri-path
 207                       `("nar"
 208                         ,@(match compression
 209                             (($ <compression> 'none)
 210                              '())
 211                             (($ <compression> type)
 212                              (list (symbol->string type))))
 213                         ,(basename store-path))))
 214          (hash       (bytevector->nix-base32-string
 215                       (path-info-hash path-info)))
 216          (size       (path-info-nar-size path-info))
 217          (references (string-join
 218                       (map basename (path-info-references path-info))
 219                       " "))
 220          (deriver    (path-info-deriver path-info))
 221          (base-info  (format #f
 222                              "\
 223 StorePath: ~a
 224 URL: ~a
 225 Compression: ~a
 226 NarHash: sha256:~a
 227 NarSize: ~d
 228 References: ~a~%"
 229                              store-path url
 230                              (compression-type compression)
 231                              hash size references))
 232          ;; Do not render a "Deriver" or "System" line if we are rendering
 233          ;; info for a derivation.
 234          (info       (if (not deriver)
 235                          base-info
 236                          (catch 'system-error
 237                            (lambda ()
 238                              (let ((drv (load-derivation deriver)))
 239                                (format #f "~aSystem: ~a~%Deriver: ~a~%"
 240                                        base-info (derivation-system drv)
 241                                        (basename deriver))))
 242                            (lambda args
 243                              ;; DERIVER might be missing, but that's fine:
 244                              ;; it's only used for <substitutable> where it's
 245                              ;; optional.  'System' is currently unused.
 246                              (if (= ENOENT (system-error-errno args))
 247                                  base-info
 248                                  (apply throw args))))))
 249          (signature  (base64-encode-string
 250                       (canonical-sexp->string (signed-string info)))))
 251     (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
 252
 253 (define (not-found request)
 254   "Render 404 response for REQUEST."
 255   (values (build-response #:code 404)
 256           (string-append "Resource not found: "
 257                          (uri-path (request-uri request)))))
 258
 259 (define (render-nix-cache-info)
 260   "Render server information."
 261   (values '((content-type . (text/plain)))
 262           (lambda (port)
 263             (for-each (match-lambda
 264                        ((key . value)
 265                         (format port "~a: ~a~%" key value)))
 266                       %nix-cache-info))))
 267
 268 (define* (render-narinfo store request hash
 269                          #:key ttl (compression %no-compression))
 270   "Render metadata for the store path corresponding to HASH.  If TTL is true,
 271 advertise it as the maximum validity period (in seconds) via the
 272 'Cache-Control' header.  This allows 'guix substitute' to cache it for an
 273 appropriate duration."
 274   (let ((store-path (hash-part->path store hash)))
 275     (if (string-null? store-path)
 276         (not-found request)
 277         (values `((content-type . (application/x-nix-narinfo))
 278                   ,@(if ttl
 279                         `((cache-control (max-age . ,ttl)))
 280                         '()))
 281                 (cut display
 282                   (narinfo-string store store-path (force %private-key)
 283                                   #:compression compression)
 284                   <>)))))
 285
 286 ;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for
 287 ;; internal consumption: it allows us to pass the compression info to
 288 ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
 289 (declare-header! "Guix-Nar-Compression"
 290                  (lambda (str)
 291                    (match (call-with-input-string str read)
 292                      (('compression type level)
 293                       (compression type level))))
 294                  compression?
 295                  (lambda (compression port)
 296                    (match compression
 297                      (($ <compression> type level)
 298                       (write `(compression ,type ,level) port)))))
 299
 300 (define* (render-nar store request store-item
 301                      #:key (compression %no-compression))
 302   "Render archive of the store path corresponding to STORE-ITEM."
 303   (let ((store-path (string-append %store-directory "/" store-item)))
 304     ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
 305     ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
 306     ;; sequences.
 307     (if (valid-path? store store-path)
 308         (values `((content-type . (application/x-nix-archive
 309                                    (charset . "ISO-8859-1")))
 310                   (guix-nar-compression . ,compression))
 311                 ;; XXX: We're not returning the actual contents, deferring
 312                 ;; instead to 'http-write'.  This is a hack to work around
 313                 ;; <http://bugs.gnu.org/21093>.
 314                 store-path)
 315         (not-found request))))
 316
 317 (define (render-content-addressed-file store request
 318                                        name algo hash)
 319   "Return the content of the result of the fixed-output derivation NAME that
 320 has the given HASH of type ALGO."
 321   ;; TODO: Support other hash algorithms.
 322   (if (and (eq? algo 'sha256) (= 32 (bytevector-length hash)))
 323       (let ((item (fixed-output-path name hash
 324                                      #:hash-algo algo
 325                                      #:recursive? #f)))
 326         (if (valid-path? store item)
 327             (values `((content-type . (application/octet-stream
 328                                        (charset . "ISO-8859-1"))))
 329                     ;; XXX: We're not returning the actual contents, deferring
 330                     ;; instead to 'http-write'.  This is a hack to work around
 331                     ;; <http://bugs.gnu.org/21093>.
 332                     item)
 333             (not-found request)))
 334       (not-found request)))
 335
 336 (define extract-narinfo-hash
 337   (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
 338     (lambda (str)
 339       "Return the hash within the narinfo resource string STR, or false if STR
 340 is invalid."
 341       (and=> (regexp-exec regexp str)
 342              (cut match:substring <> 1)))))
 343
 344 (define (get-request? request)
 345   "Return #t if REQUEST uses the GET method."
 346   (eq? (request-method request) 'GET))
 347
 348 (define (request-path-components request)
 349   "Split the URI path of REQUEST into a list of component strings.  For
 350 example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
 351   (split-and-decode-uri-path (uri-path (request-uri request))))
 352
 353 \f
 354 ;;;
 355 ;;; Server.
 356 ;;;
 357
 358 (define %http-write
 359   (@@ (web server http) http-write))
 360
 361 (define (sans-content-length response)
 362   "Return RESPONSE without its 'content-length' header."
 363   (set-field response (response-headers)
 364              (alist-delete 'content-length
 365                            (response-headers response)
 366                            eq?)))
 367
 368 (define-syntax-rule (swallow-EPIPE exp ...)
 369   "Swallow EPIPE errors raised by EXP..."
 370   (catch 'system-error
 371     (lambda ()
 372       exp ...)
 373     (lambda args
 374       (if (= EPIPE (system-error-errno args))
 375           (values)
 376           (apply throw args)))))
 377
 378 (define-syntax-rule (swallow-zlib-error exp ...)
 379   "Swallow 'zlib-error' exceptions raised by EXP..."
 380   (catch 'zlib-error
 381     (lambda ()
 382       exp ...)
 383     (const #f)))
 384
 385 (define (nar-response-port response)
 386   "Return a port on which to write the body of RESPONSE, the response of a
 387 /nar request, according to COMPRESSION."
 388   (match (assoc-ref (response-headers response) 'guix-nar-compression)
 389     (($ <compression> 'gzip level)
 390      ;; Note: We cannot used chunked encoding here because
 391      ;; 'make-gzip-output-port' wants a file port.
 392      (make-gzip-output-port (response-port response)
 393                             #:level level
 394                             #:buffer-size (* 64 1024)))
 395     (($ <compression> 'none)
 396      (response-port response))
 397     (#f
 398      (response-port response))))
 399
 400 (define (http-write server client response body)
 401   "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid
 402 blocking."
 403   (match (response-content-type response)
 404     (('application/x-nix-archive . _)
 405      ;; Sending the the whole archive can take time so do it in a separate
 406      ;; thread so that the main thread can keep working in the meantime.
 407      (call-with-new-thread
 408       (lambda ()
 409         (let* ((response (write-response (sans-content-length response)
 410                                          client))
 411                (port     (begin
 412                            (force-output client)
 413                            (nar-response-port response))))
 414           ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in
 415           ;; 'render-nar', BODY here is just the file name of the store item.
 416           ;; We call 'write-file' from here because we know that's the only
 417           ;; way to avoid building the whole nar in memory, which could
 418           ;; quickly become a real problem.  As a bonus, we even do
 419           ;; sendfile(2) directly from the store files to the socket.
 420           (swallow-zlib-error
 421            (swallow-EPIPE
 422             (write-file (utf8->string body) port)))
 423           (swallow-zlib-error
 424            (close-port port))
 425           (values)))))
 426     (('application/octet-stream . _)
 427      ;; Send a raw file in a separate thread.
 428      (call-with-new-thread
 429       (lambda ()
 430         (catch 'system-error
 431           (lambda ()
 432             (call-with-input-file (utf8->string body)
 433               (lambda (input)
 434                 (let* ((size     (stat:size (stat input)))
 435                        (headers  (alist-cons 'content-length size
 436                                              (alist-delete 'content-length
 437                                                            (response-headers response)
 438                                                            eq?)))
 439                        (response (write-response (set-field response
 440                                                             (response-headers)
 441                                                             headers)
 442                                                  client))
 443                        (output   (response-port response)))
 444                   (dump-port input output)
 445                   (close-port output)
 446                   (values)))))
 447           (lambda args
 448             ;; If the file was GC'd behind our back, that's fine.  Likewise if
 449             ;; the client closes the connection.
 450             (unless (memv (system-error-errno args)
 451                           (list ENOENT EPIPE ECONNRESET))
 452               (apply throw args))
 453             (values))))))
 454     (_
 455      ;; Handle other responses sequentially.
 456      (%http-write server client response body))))
 457
 458 (define-server-impl concurrent-http-server
 459   ;; A variant of Guile's built-in HTTP server that offloads possibly long
 460   ;; responses to a different thread.
 461   (@@ (web server http) http-open)
 462   (@@ (web server http) http-read)
 463   http-write
 464   (@@ (web server http) http-close))
 465
 466 (define* (make-request-handler store
 467                                #:key
 468                                narinfo-ttl
 469                                (compression %no-compression))
 470   (lambda (request body)
 471     (format #t "~a ~a~%"
 472             (request-method request)
 473             (uri-path (request-uri request)))
 474     (if (get-request? request)                    ;reject POST, PUT, etc.
 475         (match (request-path-components request)
 476           ;; /nix-cache-info
 477           (("nix-cache-info")
 478            (render-nix-cache-info))
 479           ;; /<hash>.narinfo
 480           (((= extract-narinfo-hash (? string? hash)))
 481            ;; TODO: Register roots for HASH that will somehow remain for
 482            ;; NARINFO-TTL.
 483            (render-narinfo store request hash
 484                            #:ttl narinfo-ttl
 485                            #:compression compression))
 486
 487           ;; Use different URLs depending on the compression type.  This
 488           ;; guarantees that /nar URLs remain valid even when 'guix publish'
 489           ;; is restarted with different compression parameters.
 490
 491           ;; /nar/<store-item>
 492           (("nar" store-item)
 493            (render-nar store request store-item
 494                        #:compression %no-compression))
 495           ;; /nar/gzip/<store-item>
 496           (("nar" "gzip" store-item)
 497            (if (zlib-available?)
 498                (render-nar store request store-item
 499                            #:compression
 500                            (match compression
 501                              (($ <compression> 'gzip)
 502                               compression)
 503                              (_
 504                               %default-gzip-compression)))
 505                (not-found request)))
 506
 507           ;; /nar/file/NAME/sha256/HASH
 508           (("file" name "sha256" hash)
 509            (guard (c ((invalid-base32-character? c)
 510                       (not-found request)))
 511              (let ((hash (nix-base32-string->bytevector hash)))
 512                (render-content-addressed-file store request
 513                                               name 'sha256 hash))))
 514           (_ (not-found request)))
 515         (not-found request))))
 516
 517 (define* (run-publish-server socket store
 518                              #:key (compression %no-compression) narinfo-ttl)
 519   (run-server (make-request-handler store
 520                                     #:narinfo-ttl narinfo-ttl
 521                                     #:compression compression)
 522               concurrent-http-server
 523               `(#:socket ,socket)))
 524
 525 (define (open-server-socket address)
 526   "Return a TCP socket bound to ADDRESS, a socket address."
 527   (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
 528     (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
 529     (bind sock address)
 530     sock))
 531
 532 (define (gather-user-privileges user)
 533   "Switch to the identity of USER, a user name."
 534   (catch 'misc-error
 535     (lambda ()
 536       (let ((user (getpw user)))
 537         (setgroups #())
 538         (setgid (passwd:gid user))
 539         (setuid (passwd:uid user))))
 540     (lambda (key proc message args . rest)
 541       (leave (_ "user '~a' not found: ~a~%")
 542              user (apply format #f message args)))))
 543
 544 \f
 545 ;;;
 546 ;;; Entry point.
 547 ;;;
 548
 549 (define (guix-publish . args)
 550   (with-error-handling
 551     (let* ((opts    (args-fold* args %options
 552                                 (lambda (opt name arg result)
 553                                   (leave (_ "~A: unrecognized option~%") name))
 554                                 (lambda (arg result)
 555                                   (leave (_ "~A: extraneous argument~%") arg))
 556                                 %default-options))
 557            (user    (assoc-ref opts 'user))
 558            (port    (assoc-ref opts 'port))
 559            (ttl     (assoc-ref opts 'narinfo-ttl))
 560            (compression (assoc-ref opts 'compression))
 561            (address (let ((addr (assoc-ref opts 'address)))
 562                       (make-socket-address (sockaddr:fam addr)
 563                                            (sockaddr:addr addr)
 564                                            port)))
 565            (socket  (open-server-socket address))
 566            (repl-port (assoc-ref opts 'repl)))
 567       ;; Read the key right away so that (1) we fail early on if we can't
 568       ;; access them, and (2) we can then drop privileges.
 569       (force %private-key)
 570       (force %public-key)
 571
 572       (when user
 573         ;; Now that we've read the key material and opened the socket, we can
 574         ;; drop privileges.
 575         (gather-user-privileges user))
 576
 577       (when (zero? (getuid))
 578         (warning (_ "server running as root; \
 579 consider using the '--user' option!~%")))
 580       (format #t (_ "publishing ~a on ~a, port ~d~%")
 581               %store-directory
 582               (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
 583               (sockaddr:port address))
 584       (when repl-port
 585         (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
 586       (with-store store
 587         (run-publish-server socket store
 588                             #:compression compression
 589                             #:narinfo-ttl ttl)))))