guix/scripts/publish.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix scripts publish)
  20   #:use-module ((system repl server) #:prefix repl:)
  21   #:use-module (ice-9 binary-ports)
  22   #:use-module (ice-9 format)
  23   #:use-module (ice-9 match)
  24   #:use-module (ice-9 regex)
  25   #:use-module (rnrs io ports)
  26   #:use-module (rnrs bytevectors)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-2)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (srfi srfi-37)
  31   #:use-module (web http)
  32   #:use-module (web request)
  33   #:use-module (web response)
  34   #:use-module (web server)
  35   #:use-module (web uri)
  36   #:use-module (guix base32)
  37   #:use-module (guix base64)
  38   #:use-module (guix config)
  39   #:use-module (guix derivations)
  40   #:use-module (guix hash)
  41   #:use-module (guix pki)
  42   #:use-module (guix pk-crypto)
  43   #:use-module (guix store)
  44   #:use-module (guix serialization)
  45   #:use-module (guix ui)
  46   #:export (guix-publish))
  47
  48 (define (show-help)
  49   (format #t (_ "Usage: guix publish [OPTION]...
  50 Publish ~a over HTTP.\n") %store-directory)
  51   (display (_ "
  52   -p, --port=PORT        listen on PORT"))
  53   (display (_ "
  54       --listen=HOST      listen on the network interface for HOST"))
  55   (display (_ "
  56   -u, --user=USER        change privileges to USER as soon as possible"))
  57   (display (_ "
  58   -r, --repl[=PORT]      spawn REPL server on PORT"))
  59   (newline)
  60   (display (_ "
  61   -h, --help             display this help and exit"))
  62   (display (_ "
  63   -V, --version          display version information and exit"))
  64   (newline)
  65   (show-bug-report-information))
  66
  67 (define (getaddrinfo* host)
  68   "Like 'getaddrinfo', but properly report errors."
  69   (catch 'getaddrinfo-error
  70     (lambda ()
  71       (getaddrinfo host))
  72     (lambda (key error)
  73       (leave (_ "lookup of host '~a' failed: ~a~%")
  74              host (gai-strerror error)))))
  75
  76 (define %options
  77   (list (option '(#\h "help") #f #f
  78                 (lambda _
  79                   (show-help)
  80                   (exit 0)))
  81         (option '(#\V "version") #f #f
  82                 (lambda _
  83                   (show-version-and-exit "guix publish")))
  84         (option '(#\u "user") #t #f
  85                 (lambda (opt name arg result)
  86                   (alist-cons 'user arg result)))
  87         (option '(#\p "port") #t #f
  88                 (lambda (opt name arg result)
  89                   (alist-cons 'port (string->number* arg) result)))
  90         (option '("listen") #t #f
  91                 (lambda (opt name arg result)
  92                   (match (getaddrinfo* arg)
  93                     ((info _ ...)
  94                      (alist-cons 'address (addrinfo:addr info)
  95                                  result))
  96                     (()
  97                      (leave (_ "lookup of host '~a' returned nothing")
  98                             name)))))
  99         (option '(#\r "repl") #f #t
 100                 (lambda (opt name arg result)
 101                   ;; If port unspecified, use default Guile REPL port.
 102                   (let ((port (and arg (string->number* arg))))
 103                     (alist-cons 'repl (or port 37146) result))))))
 104
 105 (define %default-options
 106   `((port . 8080)
 107     (address . ,(make-socket-address AF_INET INADDR_ANY 0))
 108     (repl . #f)))
 109
 110 (define (lazy-read-file-sexp file)
 111   "Return a promise to read the canonical sexp from FILE."
 112   (delay
 113     (call-with-input-file file
 114       (compose string->canonical-sexp
 115                get-string-all))))
 116
 117 (define %private-key
 118   (lazy-read-file-sexp %private-key-file))
 119
 120 (define %public-key
 121   (lazy-read-file-sexp %public-key-file))
 122
 123 (define %nix-cache-info
 124   `(("StoreDir" . ,%store-directory)
 125     ("WantMassQuery" . 0)
 126     ("Priority" . 100)))
 127
 128 (define (load-derivation file)
 129   "Read the derivation from FILE."
 130   (call-with-input-file file read-derivation))
 131
 132 (define (signed-string s)
 133   "Sign the hash of the string S with the daemon's key."
 134   (let* ((public-key (force %public-key))
 135          (hash (bytevector->hash-data (sha256 (string->utf8 s))
 136                                       #:key-type (key-type public-key))))
 137     (signature-sexp hash (force %private-key) public-key)))
 138
 139 (define base64-encode-string
 140   (compose base64-encode string->utf8))
 141
 142 (define (narinfo-string store-path path-info key)
 143   "Generate a narinfo key/value string for STORE-PATH using the details in
 144 PATH-INFO.  The narinfo is signed with KEY."
 145   (let* ((url        (string-append "nar/" (basename store-path)))
 146          (hash       (bytevector->base32-string
 147                       (path-info-hash path-info)))
 148          (size       (path-info-nar-size path-info))
 149          (references (string-join
 150                       (map basename (path-info-references path-info))
 151                       " "))
 152          (deriver (path-info-deriver path-info))
 153          (base-info  (format #f
 154                              "StorePath: ~a
 155 URL: ~a
 156 Compression: none
 157 NarHash: sha256:~a
 158 NarSize: ~d
 159 References: ~a~%"
 160                              store-path url hash size references))
 161          ;; Do not render a "Deriver" or "System" line if we are rendering
 162          ;; info for a derivation.
 163          (info (if (string-null? deriver)
 164                    base-info
 165                    (let ((drv (load-derivation deriver)))
 166                      (format #f "~aSystem: ~a~%Deriver: ~a~%"
 167                              base-info (derivation-system drv)
 168                              (basename deriver)))))
 169          (signature  (base64-encode-string
 170                       (canonical-sexp->string (signed-string info)))))
 171     (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
 172
 173 (define (not-found request)
 174   "Render 404 response for REQUEST."
 175   (values (build-response #:code 404)
 176           (string-append "Resource not found: "
 177                          (uri-path (request-uri request)))))
 178
 179 (define (render-nix-cache-info)
 180   "Render server information."
 181   (values '((content-type . (text/plain)))
 182           (lambda (port)
 183             (for-each (match-lambda
 184                        ((key . value)
 185                         (format port "~a: ~a~%" key value)))
 186                       %nix-cache-info))))
 187
 188 (define (render-narinfo store request hash)
 189   "Render metadata for the store path corresponding to HASH."
 190   (let* ((store-path (hash-part->path store hash))
 191          (path-info (and (not (string-null? store-path))
 192                          (query-path-info store store-path))))
 193     (if path-info
 194         (values '((content-type . (application/x-nix-narinfo)))
 195                 (cut display
 196                      (narinfo-string store-path path-info (force %private-key))
 197                      <>))
 198         (not-found request))))
 199
 200 (define (render-nar request store-item)
 201   "Render archive of the store path corresponding to STORE-ITEM."
 202   (let ((store-path (string-append %store-directory "/" store-item)))
 203     ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
 204     ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
 205     ;; sequences.
 206     (if (file-exists? store-path)
 207         (values '((content-type . (application/x-nix-archive
 208                                    (charset . "ISO-8859-1"))))
 209                 (lambda (port)
 210                   (write-file store-path port)))
 211         (not-found request))))
 212
 213 (define extract-narinfo-hash
 214   (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
 215     (lambda (str)
 216       "Return the hash within the narinfo resource string STR, or false if STR
 217 is invalid."
 218       (and=> (regexp-exec regexp str)
 219              (cut match:substring <> 1)))))
 220
 221 (define (get-request? request)
 222   "Return #t if REQUEST uses the GET method."
 223   (eq? (request-method request) 'GET))
 224
 225 (define (request-path-components request)
 226   "Split the URI path of REQUEST into a list of component strings.  For
 227 example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
 228   (split-and-decode-uri-path (uri-path (request-uri request))))
 229
 230 (define (make-request-handler store)
 231   (lambda (request body)
 232     (format #t "~a ~a~%"
 233             (request-method request)
 234             (uri-path (request-uri request)))
 235     (if (get-request? request) ; reject POST, PUT, etc.
 236         (match (request-path-components request)
 237           ;; /nix-cache-info
 238           (("nix-cache-info")
 239            (render-nix-cache-info))
 240           ;; /<hash>.narinfo
 241           (((= extract-narinfo-hash (? string? hash)))
 242            (render-narinfo store request hash))
 243           ;; /nar/<store-item>
 244           (("nar" store-item)
 245            (render-nar request store-item))
 246           (_ (not-found request)))
 247         (not-found request))))
 248
 249 (define (run-publish-server socket store)
 250   (run-server (make-request-handler store)
 251               'http
 252               `(#:socket ,socket)))
 253
 254 (define (open-server-socket address)
 255   "Return a TCP socket bound to ADDRESS, a socket address."
 256   (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
 257     (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
 258     (bind sock address)
 259     sock))
 260
 261 (define (gather-user-privileges user)
 262   "Switch to the identity of USER, a user name."
 263   (catch 'misc-error
 264     (lambda ()
 265       (let ((user (getpw user)))
 266         (setgroups #())
 267         (setgid (passwd:gid user))
 268         (setuid (passwd:uid user))))
 269     (lambda (key proc message args . rest)
 270       (leave (_ "user '~a' not found: ~a~%")
 271              user (apply format #f message args)))))
 272
 273 \f
 274 ;;;
 275 ;;; Entry point.
 276 ;;;
 277
 278 (define (guix-publish . args)
 279   (with-error-handling
 280     (let* ((opts    (args-fold* args %options
 281                                 (lambda (opt name arg result)
 282                                   (leave (_ "~A: unrecognized option~%") name))
 283                                 (lambda (arg result)
 284                                   (leave (_ "~A: extraneuous argument~%") arg))
 285                                 %default-options))
 286            (user    (assoc-ref opts 'user))
 287            (port    (assoc-ref opts 'port))
 288            (address (let ((addr (assoc-ref opts 'address)))
 289                       (make-socket-address (sockaddr:fam addr)
 290                                            (sockaddr:addr addr)
 291                                            port)))
 292            (socket  (open-server-socket address))
 293            (repl-port (assoc-ref opts 'repl)))
 294       ;; Read the key right away so that (1) we fail early on if we can't
 295       ;; access them, and (2) we can then drop privileges.
 296       (force %private-key)
 297       (force %public-key)
 298
 299       (when user
 300         ;; Now that we've read the key material and opened the socket, we can
 301         ;; drop privileges.
 302         (gather-user-privileges user))
 303
 304       (when (zero? (getuid))
 305         (warning (_ "server running as root; \
 306 consider using the '--user' option!~%")))
 307       (format #t (_ "publishing ~a on ~a, port ~d~%")
 308               %store-directory
 309               (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
 310               (sockaddr:port address))
 311       (when repl-port
 312         (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
 313       (with-store store
 314         (run-publish-server socket store)))))