You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

901 lines
36 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2015 David Thompson <davet@gnu.org>
  3. ;;; Copyright © 2015, 2016, 2017, 2018 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. (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 (ice-9 rdelim)
  26. #:use-module (ice-9 threads)
  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. #:autoload (sxml simple) (sxml->xml)
  42. #:use-module (guix base32)
  43. #:use-module (guix base64)
  44. #:use-module (guix config)
  45. #:use-module (guix derivations)
  46. #:use-module (guix hash)
  47. #:use-module (guix pki)
  48. #:use-module (guix pk-crypto)
  49. #:use-module (guix workers)
  50. #:use-module (guix store)
  51. #:use-module ((guix serialization) #:select (write-file))
  52. #:use-module (guix zlib)
  53. #:use-module (guix cache)
  54. #:use-module (guix ui)
  55. #:use-module (guix scripts)
  56. #:use-module ((guix utils)
  57. #:select (with-atomic-file-output compressed-file?))
  58. #:use-module ((guix build utils)
  59. #:select (dump-port mkdir-p find-files))
  60. #:use-module ((guix build syscalls) #:select (set-thread-name))
  61. #:export (%public-key
  62. %private-key
  63. guix-publish))
  64. (define (show-help)
  65. (format #t (G_ "Usage: guix publish [OPTION]...
  66. Publish ~a over HTTP.\n") %store-directory)
  67. (display (G_ "
  68. -p, --port=PORT listen on PORT"))
  69. (display (G_ "
  70. --listen=HOST listen on the network interface for HOST"))
  71. (display (G_ "
  72. -u, --user=USER change privileges to USER as soon as possible"))
  73. (display (G_ "
  74. -C, --compression[=LEVEL]
  75. compress archives at LEVEL"))
  76. (display (G_ "
  77. -c, --cache=DIRECTORY cache published items to DIRECTORY"))
  78. (display (G_ "
  79. --workers=N use N workers to bake items"))
  80. (display (G_ "
  81. --ttl=TTL announce narinfos can be cached for TTL seconds"))
  82. (display (G_ "
  83. --nar-path=PATH use PATH as the prefix for nar URLs"))
  84. (display (G_ "
  85. --public-key=FILE use FILE as the public key for signatures"))
  86. (display (G_ "
  87. --private-key=FILE use FILE as the private key for signatures"))
  88. (display (G_ "
  89. -r, --repl[=PORT] spawn REPL server on PORT"))
  90. (newline)
  91. (display (G_ "
  92. -h, --help display this help and exit"))
  93. (display (G_ "
  94. -V, --version display version information and exit"))
  95. (newline)
  96. (show-bug-report-information))
  97. (define (getaddrinfo* host)
  98. "Like 'getaddrinfo', but properly report errors."
  99. (catch 'getaddrinfo-error
  100. (lambda ()
  101. (getaddrinfo host))
  102. (lambda (key error)
  103. (leave (G_ "lookup of host '~a' failed: ~a~%")
  104. host (gai-strerror error)))))
  105. ;; Nar compression parameters.
  106. (define-record-type <compression>
  107. (compression type level)
  108. compression?
  109. (type compression-type)
  110. (level compression-level))
  111. (define %no-compression
  112. (compression 'none 0))
  113. (define %default-gzip-compression
  114. ;; Since we compress on the fly, default to fast compression.
  115. (compression 'gzip 3))
  116. (define (actual-compression item requested)
  117. "Return the actual compression used for ITEM, which may be %NO-COMPRESSION
  118. if ITEM is already compressed."
  119. (if (compressed-file? item)
  120. %no-compression
  121. requested))
  122. (define %options
  123. (list (option '(#\h "help") #f #f
  124. (lambda _
  125. (show-help)
  126. (exit 0)))
  127. (option '(#\V "version") #f #f
  128. (lambda _
  129. (show-version-and-exit "guix publish")))
  130. (option '(#\u "user") #t #f
  131. (lambda (opt name arg result)
  132. (alist-cons 'user arg result)))
  133. (option '(#\p "port") #t #f
  134. (lambda (opt name arg result)
  135. (alist-cons 'port (string->number* arg) result)))
  136. (option '("listen") #t #f
  137. (lambda (opt name arg result)
  138. (match (getaddrinfo* arg)
  139. ((info _ ...)
  140. (alist-cons 'address (addrinfo:addr info)
  141. result))
  142. (()
  143. (leave (G_ "lookup of host '~a' returned nothing")
  144. name)))))
  145. (option '(#\C "compression") #f #t
  146. (lambda (opt name arg result)
  147. (match (if arg (string->number* arg) 3)
  148. (0
  149. (alist-cons 'compression %no-compression result))
  150. (level
  151. (if (zlib-available?)
  152. (alist-cons 'compression
  153. (compression 'gzip level)
  154. result)
  155. (begin
  156. (warning (G_ "zlib support is missing; \
  157. compression disabled~%"))
  158. result))))))
  159. (option '(#\c "cache") #t #f
  160. (lambda (opt name arg result)
  161. (alist-cons 'cache arg result)))
  162. (option '("workers") #t #f
  163. (lambda (opt name arg result)
  164. (alist-cons 'workers (string->number* arg)
  165. result)))
  166. (option '("ttl") #t #f
  167. (lambda (opt name arg result)
  168. (let ((duration (string->duration arg)))
  169. (unless duration
  170. (leave (G_ "~a: invalid duration~%") arg))
  171. (alist-cons 'narinfo-ttl (time-second duration)
  172. result))))
  173. (option '("nar-path") #t #f
  174. (lambda (opt name arg result)
  175. (alist-cons 'nar-path arg result)))
  176. (option '("public-key") #t #f
  177. (lambda (opt name arg result)
  178. (alist-cons 'public-key-file arg result)))
  179. (option '("private-key" "secret-key") #t #f
  180. (lambda (opt name arg result)
  181. (alist-cons 'private-key-file arg result)))
  182. (option '(#\r "repl") #f #t
  183. (lambda (opt name arg result)
  184. ;; If port unspecified, use default Guile REPL port.
  185. (let ((port (and arg (string->number* arg))))
  186. (alist-cons 'repl (or port 37146) result))))))
  187. (define %default-options
  188. `((port . 8080)
  189. ;; By default, serve nars under "/nar".
  190. (nar-path . "nar")
  191. (public-key-file . ,%public-key-file)
  192. (private-key-file . ,%private-key-file)
  193. ;; Default to fast & low compression.
  194. (compression . ,(if (zlib-available?)
  195. %default-gzip-compression
  196. %no-compression))
  197. ;; Default number of workers when caching is enabled.
  198. (workers . ,(current-processor-count))
  199. (address . ,(make-socket-address AF_INET INADDR_ANY 0))
  200. (repl . #f)))
  201. ;; The key pair used to sign narinfos.
  202. (define %private-key
  203. (make-parameter #f))
  204. (define %public-key
  205. (make-parameter #f))
  206. (define %nix-cache-info
  207. `(("StoreDir" . ,%store-directory)
  208. ("WantMassQuery" . 0)
  209. ("Priority" . 100)))
  210. (define (signed-string s)
  211. "Sign the hash of the string S with the daemon's key."
  212. (let* ((public-key (%public-key))
  213. (hash (bytevector->hash-data (sha256 (string->utf8 s))
  214. #:key-type (key-type public-key))))
  215. (signature-sexp hash (%private-key) public-key)))
  216. (define base64-encode-string
  217. (compose base64-encode string->utf8))
  218. (define* (narinfo-string store store-path key
  219. #:key (compression %no-compression)
  220. (nar-path "nar") file-size)
  221. "Generate a narinfo key/value string for STORE-PATH; an exception is raised
  222. if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The
  223. narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs.
  224. Optionally, FILE-SIZE can specify the size in bytes of the compressed NAR; it
  225. informs the client of how much needs to be downloaded."
  226. (let* ((path-info (query-path-info store store-path))
  227. (compression (actual-compression store-path compression))
  228. (url (encode-and-join-uri-path
  229. `(,@(split-and-decode-uri-path nar-path)
  230. ,@(match compression
  231. (($ <compression> 'none)
  232. '())
  233. (($ <compression> type)
  234. (list (symbol->string type))))
  235. ,(basename store-path))))
  236. (hash (bytevector->nix-base32-string
  237. (path-info-hash path-info)))
  238. (size (path-info-nar-size path-info))
  239. (file-size (or file-size
  240. (and (eq? compression %no-compression) size)))
  241. (references (string-join
  242. (map basename (path-info-references path-info))
  243. " "))
  244. (deriver (path-info-deriver path-info))
  245. (base-info (format #f
  246. "\
  247. StorePath: ~a
  248. URL: ~a
  249. Compression: ~a
  250. NarHash: sha256:~a
  251. NarSize: ~d
  252. References: ~a~%~a"
  253. store-path url
  254. (compression-type compression)
  255. hash size references
  256. (if file-size
  257. (format #f "FileSize: ~a~%" file-size)
  258. "")))
  259. ;; Do not render a "Deriver" or "System" line if we are rendering
  260. ;; info for a derivation.
  261. (info (if (not deriver)
  262. base-info
  263. (catch 'system-error
  264. (lambda ()
  265. (let ((drv (read-derivation-from-file deriver)))
  266. (format #f "~aSystem: ~a~%Deriver: ~a~%"
  267. base-info (derivation-system drv)
  268. (basename deriver))))
  269. (lambda args
  270. ;; DERIVER might be missing, but that's fine:
  271. ;; it's only used for <substitutable> where it's
  272. ;; optional. 'System' is currently unused.
  273. (if (= ENOENT (system-error-errno args))
  274. base-info
  275. (apply throw args))))))
  276. (signature (base64-encode-string
  277. (canonical-sexp->string (signed-string info)))))
  278. (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
  279. (define* (not-found request
  280. #:key (phrase "Resource not found")
  281. ttl)
  282. "Render 404 response for REQUEST."
  283. (values (build-response #:code 404
  284. #:headers (if ttl
  285. `((cache-control (max-age . ,ttl)))
  286. '()))
  287. (string-append phrase ": "
  288. (uri-path (request-uri request)))))
  289. (define (render-nix-cache-info)
  290. "Render server information."
  291. (values '((content-type . (text/plain)))
  292. (lambda (port)
  293. (for-each (match-lambda
  294. ((key . value)
  295. (format port "~a: ~a~%" key value)))
  296. %nix-cache-info))))
  297. (define* (render-narinfo store request hash
  298. #:key ttl (compression %no-compression)
  299. (nar-path "nar"))
  300. "Render metadata for the store path corresponding to HASH. If TTL is true,
  301. advertise it as the maximum validity period (in seconds) via the
  302. 'Cache-Control' header. This allows 'guix substitute' to cache it for an
  303. appropriate duration. NAR-PATH specifies the prefix for nar URLs."
  304. (let ((store-path (hash-part->path store hash)))
  305. (if (string-null? store-path)
  306. (not-found request #:phrase "")
  307. (values `((content-type . (application/x-nix-narinfo))
  308. ,@(if ttl
  309. `((cache-control (max-age . ,ttl)))
  310. '()))
  311. (cut display
  312. (narinfo-string store store-path (%private-key)
  313. #:nar-path nar-path
  314. #:compression compression)
  315. <>)))))
  316. (define* (nar-cache-file directory item
  317. #:key (compression %no-compression))
  318. (string-append directory "/"
  319. (symbol->string (compression-type compression))
  320. "/" (basename item) ".nar"))
  321. (define* (narinfo-cache-file directory item
  322. #:key (compression %no-compression))
  323. (string-append directory "/"
  324. (symbol->string (compression-type compression))
  325. "/" (basename item)
  326. ".narinfo"))
  327. (define run-single-baker
  328. (let ((baking (make-weak-value-hash-table))
  329. (mutex (make-mutex)))
  330. (lambda (item thunk)
  331. "Run THUNK, which is supposed to bake ITEM, but make sure only one
  332. thread is baking ITEM at a given time."
  333. (define selected?
  334. (with-mutex mutex
  335. (and (not (hash-ref baking item))
  336. (begin
  337. (hash-set! baking item (current-thread))
  338. #t))))
  339. (when selected?
  340. (dynamic-wind
  341. (const #t)
  342. thunk
  343. (lambda ()
  344. (with-mutex mutex
  345. (hash-remove! baking item))))))))
  346. (define-syntax-rule (single-baker item exp ...)
  347. "Bake ITEM by evaluating EXP, but make sure there's only one baker for ITEM
  348. at a time."
  349. (run-single-baker item (lambda () exp ...)))
  350. (define (narinfo-files cache)
  351. "Return the list of .narinfo files under CACHE."
  352. (if (file-is-directory? cache)
  353. (find-files cache
  354. (lambda (file stat)
  355. (string-suffix? ".narinfo" file)))
  356. '()))
  357. (define (nar-expiration-time ttl)
  358. "Return the narinfo expiration time (in seconds since the Epoch). The
  359. expiration time is +inf.0 when passed an item that is still in the store; in
  360. other cases, it is the last-access time of the item plus TTL.
  361. This policy allows us to keep cached nars that correspond to valid store
  362. items. Failing that, we could eventually have to recompute them and return
  363. 404 in the meantime."
  364. (let ((expiration-time (file-expiration-time ttl)))
  365. (lambda (file)
  366. (let ((item (string-append (%store-prefix) "/"
  367. (basename file ".narinfo"))))
  368. ;; Note: We don't need to use 'valid-path?' here because FILE would
  369. ;; not exist if ITEM were not valid in the first place.
  370. (if (file-exists? item)
  371. +inf.0
  372. (expiration-time file))))))
  373. (define* (render-narinfo/cached store request hash
  374. #:key ttl (compression %no-compression)
  375. (nar-path "nar")
  376. cache pool)
  377. "Respond to the narinfo request for REQUEST. If the narinfo is available in
  378. CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
  379. requested using POOL."
  380. (define (delete-entry narinfo)
  381. ;; Delete NARINFO and the corresponding nar from CACHE.
  382. (let ((nar (string-append (string-drop-right narinfo
  383. (string-length ".narinfo"))
  384. ".nar")))
  385. (delete-file* narinfo)
  386. (delete-file* nar)))
  387. (let* ((item (hash-part->path store hash))
  388. (compression (actual-compression item compression))
  389. (cached (and (not (string-null? item))
  390. (narinfo-cache-file cache item
  391. #:compression compression))))
  392. (cond ((string-null? item)
  393. (not-found request))
  394. ((file-exists? cached)
  395. ;; Narinfo is in cache, send it.
  396. (values `((content-type . (application/x-nix-narinfo))
  397. ,@(if ttl
  398. `((cache-control (max-age . ,ttl)))
  399. '()))
  400. (lambda (port)
  401. (display (call-with-input-file cached
  402. read-string)
  403. port))))
  404. ((and (file-exists? item) ;cheaper than the 'valid-path?' RPC
  405. (valid-path? store item))
  406. ;; Nothing in cache: bake the narinfo and nar in the background and
  407. ;; return 404.
  408. (eventually pool
  409. (single-baker item
  410. ;; Check whether CACHED has been produced in the meantime.
  411. (unless (file-exists? cached)
  412. ;; (format #t "baking ~s~%" item)
  413. (bake-narinfo+nar cache item
  414. #:ttl ttl
  415. #:compression compression
  416. #:nar-path nar-path)))
  417. (when ttl
  418. (single-baker 'cache-cleanup
  419. (maybe-remove-expired-cache-entries cache
  420. narinfo-files
  421. #:entry-expiration
  422. (nar-expiration-time ttl)
  423. #:delete-entry delete-entry
  424. #:cleanup-period ttl))))
  425. (not-found request
  426. #:phrase "We're baking it"
  427. #:ttl 300)) ;should be available within 5m
  428. (else
  429. (not-found request #:phrase "")))))
  430. (define* (bake-narinfo+nar cache item
  431. #:key ttl (compression %no-compression)
  432. (nar-path "/nar"))
  433. "Write the narinfo and nar for ITEM to CACHE."
  434. (let* ((compression (actual-compression item compression))
  435. (nar (nar-cache-file cache item
  436. #:compression compression))
  437. (narinfo (narinfo-cache-file cache item
  438. #:compression compression)))
  439. (mkdir-p (dirname nar))
  440. (match (compression-type compression)
  441. ('gzip
  442. ;; Note: the file port gets closed along with the gzip port.
  443. (call-with-gzip-output-port (open-output-file (string-append nar ".tmp"))
  444. (lambda (port)
  445. (write-file item port))
  446. #:level (compression-level compression)
  447. #:buffer-size (* 128 1024))
  448. (rename-file (string-append nar ".tmp") nar))
  449. ('none
  450. ;; Cache nars even when compression is disabled so that we can
  451. ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
  452. (with-atomic-file-output nar
  453. (lambda (port)
  454. (write-file item port)))))
  455. (mkdir-p (dirname narinfo))
  456. (with-atomic-file-output narinfo
  457. (lambda (port)
  458. ;; Open a new connection to the store. We cannot reuse the main
  459. ;; thread's connection to the store since we would end up sending
  460. ;; stuff concurrently on the same channel.
  461. (with-store store
  462. (display (narinfo-string store item
  463. (%private-key)
  464. #:nar-path nar-path
  465. #:compression compression
  466. #:file-size (and=> (stat nar #f)
  467. stat:size))
  468. port))))))
  469. ;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for
  470. ;; internal consumption: it allows us to pass the compression info to
  471. ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
  472. (declare-header! "Guix-Nar-Compression"
  473. (lambda (str)
  474. (match (call-with-input-string str read)
  475. (('compression type level)
  476. (compression type level))))
  477. compression?
  478. (lambda (compression port)
  479. (match compression
  480. (($ <compression> type level)
  481. (write `(compression ,type ,level) port)))))
  482. (define* (render-nar store request store-item
  483. #:key (compression %no-compression))
  484. "Render archive of the store path corresponding to STORE-ITEM."
  485. (let ((store-path (string-append %store-directory "/" store-item)))
  486. ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
  487. ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
  488. ;; sequences.
  489. (if (valid-path? store store-path)
  490. (values `((content-type . (application/x-nix-archive
  491. (charset . "ISO-8859-1")))
  492. (guix-nar-compression . ,compression))
  493. ;; XXX: We're not returning the actual contents, deferring
  494. ;; instead to 'http-write'. This is a hack to work around
  495. ;; <http://bugs.gnu.org/21093>.
  496. store-path)
  497. (not-found request))))
  498. (define* (render-nar/cached store cache request store-item
  499. #:key (compression %no-compression))
  500. "Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE,
  501. return it; otherwise, return 404."
  502. (let ((cached (nar-cache-file cache store-item
  503. #:compression compression)))
  504. (if (file-exists? cached)
  505. (values `((content-type . (application/octet-stream
  506. (charset . "ISO-8859-1"))))
  507. ;; XXX: We're not returning the actual contents, deferring
  508. ;; instead to 'http-write'. This is a hack to work around
  509. ;; <http://bugs.gnu.org/21093>.
  510. cached)
  511. (not-found request))))
  512. (define (render-content-addressed-file store request
  513. name algo hash)
  514. "Return the content of the result of the fixed-output derivation NAME that
  515. has the given HASH of type ALGO."
  516. ;; TODO: Support other hash algorithms.
  517. (if (and (eq? algo 'sha256) (= 32 (bytevector-length hash)))
  518. (let ((item (fixed-output-path name hash
  519. #:hash-algo algo
  520. #:recursive? #f)))
  521. (if (valid-path? store item)
  522. (values `((content-type . (application/octet-stream
  523. (charset . "ISO-8859-1"))))
  524. ;; XXX: We're not returning the actual contents, deferring
  525. ;; instead to 'http-write'. This is a hack to work around
  526. ;; <http://bugs.gnu.org/21093>.
  527. item)
  528. (not-found request)))
  529. (not-found request)))
  530. (define (render-home-page request)
  531. "Render the home page."
  532. (values `((content-type . (text/html (charset . "UTF-8"))))
  533. (call-with-output-string
  534. (lambda (port)
  535. (sxml->xml '(html
  536. (head (title "GNU Guix Substitute Server"))
  537. (body
  538. (h1 "GNU Guix Substitute Server")
  539. (p "Hi, "
  540. (a (@ (href
  541. "https://gnu.org/s/guix/manual/html_node/Invoking-guix-publish.html"))
  542. (tt "guix publish"))
  543. " speaking. Welcome!")))
  544. port)))))
  545. (define (extract-narinfo-hash str)
  546. "Return the hash within the narinfo resource string STR, or false if STR
  547. is invalid."
  548. (and (string-suffix? ".narinfo" str)
  549. (let ((base (string-drop-right str 8)))
  550. (and (string-every %nix-base32-charset base)
  551. base))))
  552. (define (get-request? request)
  553. "Return #t if REQUEST uses the GET method."
  554. (eq? (request-method request) 'GET))
  555. (define (request-path-components request)
  556. "Split the URI path of REQUEST into a list of component strings. For
  557. example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
  558. (split-and-decode-uri-path (uri-path (request-uri request))))
  559. ;;;
  560. ;;; Server.
  561. ;;;
  562. (define %http-write
  563. (@@ (web server http) http-write))
  564. (define (sans-content-length response)
  565. "Return RESPONSE without its 'content-length' header."
  566. (set-field response (response-headers)
  567. (alist-delete 'content-length
  568. (response-headers response)
  569. eq?)))
  570. (define (with-content-length response length)
  571. "Return RESPONSE with a 'content-length' header set to LENGTH."
  572. (set-field response (response-headers)
  573. (alist-cons 'content-length length
  574. (alist-delete 'content-length
  575. (response-headers response)
  576. eq?))))
  577. (define-syntax-rule (swallow-EPIPE exp ...)
  578. "Swallow EPIPE errors raised by EXP..."
  579. (catch 'system-error
  580. (lambda ()
  581. exp ...)
  582. (lambda args
  583. (if (= EPIPE (system-error-errno args))
  584. (values)
  585. (apply throw args)))))
  586. (define-syntax-rule (swallow-zlib-error exp ...)
  587. "Swallow 'zlib-error' exceptions raised by EXP..."
  588. (catch 'zlib-error
  589. (lambda ()
  590. exp ...)
  591. (const #f)))
  592. (define (nar-response-port response)
  593. "Return a port on which to write the body of RESPONSE, the response of a
  594. /nar request, according to COMPRESSION."
  595. (match (assoc-ref (response-headers response) 'guix-nar-compression)
  596. (($ <compression> 'gzip level)
  597. ;; Note: We cannot used chunked encoding here because
  598. ;; 'make-gzip-output-port' wants a file port.
  599. (make-gzip-output-port (response-port response)
  600. #:level level
  601. #:buffer-size (* 64 1024)))
  602. (($ <compression> 'none)
  603. (response-port response))
  604. (#f
  605. (response-port response))))
  606. (define (http-write server client response body)
  607. "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid
  608. blocking."
  609. (match (response-content-type response)
  610. (('application/x-nix-archive . _)
  611. ;; Sending the the whole archive can take time so do it in a separate
  612. ;; thread so that the main thread can keep working in the meantime.
  613. (call-with-new-thread
  614. (lambda ()
  615. (set-thread-name "publish nar")
  616. (let* ((response (write-response (sans-content-length response)
  617. client))
  618. (port (begin
  619. (force-output client)
  620. (nar-response-port response))))
  621. ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in
  622. ;; 'render-nar', BODY here is just the file name of the store item.
  623. ;; We call 'write-file' from here because we know that's the only
  624. ;; way to avoid building the whole nar in memory, which could
  625. ;; quickly become a real problem. As a bonus, we even do
  626. ;; sendfile(2) directly from the store files to the socket.
  627. (swallow-zlib-error
  628. (swallow-EPIPE
  629. (write-file (utf8->string body) port)))
  630. (swallow-zlib-error
  631. (close-port port))
  632. (values)))))
  633. (('application/octet-stream . _)
  634. ;; Send a raw file in a separate thread.
  635. (call-with-new-thread
  636. (lambda ()
  637. (set-thread-name "publish file")
  638. (catch 'system-error
  639. (lambda ()
  640. (call-with-input-file (utf8->string body)
  641. (lambda (input)
  642. (let* ((size (stat:size (stat input)))
  643. (response (write-response (with-content-length response
  644. size)
  645. client))
  646. (output (response-port response)))
  647. (if (file-port? output)
  648. (sendfile output input size)
  649. (dump-port input output))
  650. (close-port output)
  651. (values)))))
  652. (lambda args
  653. ;; If the file was GC'd behind our back, that's fine. Likewise if
  654. ;; the client closes the connection.
  655. (unless (memv (system-error-errno args)
  656. (list ENOENT EPIPE ECONNRESET))
  657. (apply throw args))
  658. (values))))))
  659. (_
  660. ;; Handle other responses sequentially.
  661. (%http-write server client response body))))
  662. (define-server-impl concurrent-http-server
  663. ;; A variant of Guile's built-in HTTP server that offloads possibly long
  664. ;; responses to a different thread.
  665. (@@ (web server http) http-open)
  666. (@@ (web server http) http-read)
  667. http-write
  668. (@@ (web server http) http-close))
  669. (define* (make-request-handler store
  670. #:key
  671. cache pool
  672. narinfo-ttl
  673. (nar-path "nar")
  674. (compression %no-compression))
  675. (define nar-path?
  676. (let ((expected (split-and-decode-uri-path nar-path)))
  677. (cut equal? expected <>)))
  678. (lambda (request body)
  679. (format #t "~a ~a~%"
  680. (request-method request)
  681. (uri-path (request-uri request)))
  682. (if (get-request? request) ;reject POST, PUT, etc.
  683. (match (request-path-components request)
  684. ;; /nix-cache-info
  685. (("nix-cache-info")
  686. (render-nix-cache-info))
  687. ;; /
  688. ((or () ("index.html"))
  689. (render-home-page request))
  690. ;; /<hash>.narinfo
  691. (((= extract-narinfo-hash (? string? hash)))
  692. ;; TODO: Register roots for HASH that will somehow remain for
  693. ;; NARINFO-TTL.
  694. (if cache
  695. (render-narinfo/cached store request hash
  696. #:cache cache
  697. #:pool pool
  698. #:ttl narinfo-ttl
  699. #:nar-path nar-path
  700. #:compression compression)
  701. (render-narinfo store request hash
  702. #:ttl narinfo-ttl
  703. #:nar-path nar-path
  704. #:compression compression)))
  705. ;; /nar/file/NAME/sha256/HASH
  706. (("file" name "sha256" hash)
  707. (guard (c ((invalid-base32-character? c)
  708. (not-found request)))
  709. (let ((hash (nix-base32-string->bytevector hash)))
  710. (render-content-addressed-file store request
  711. name 'sha256 hash))))
  712. ;; Use different URLs depending on the compression type. This
  713. ;; guarantees that /nar URLs remain valid even when 'guix publish'
  714. ;; is restarted with different compression parameters.
  715. ;; /nar/gzip/<store-item>
  716. ((components ... "gzip" store-item)
  717. (if (and (nar-path? components) (zlib-available?))
  718. (let ((compression (match compression
  719. (($ <compression> 'gzip)
  720. compression)
  721. (_
  722. %default-gzip-compression))))
  723. (if cache
  724. (render-nar/cached store cache request store-item
  725. #:compression compression)
  726. (render-nar store request store-item
  727. #:compression compression)))
  728. (not-found request)))
  729. ;; /nar/<store-item>
  730. ((components ... store-item)
  731. (if (nar-path? components)
  732. (if cache
  733. (render-nar/cached store cache request store-item
  734. #:compression %no-compression)
  735. (render-nar store request store-item
  736. #:compression %no-compression))
  737. (not-found request)))
  738. (x (not-found request)))
  739. (not-found request))))
  740. (define* (run-publish-server socket store
  741. #:key (compression %no-compression)
  742. (nar-path "nar") narinfo-ttl
  743. cache pool)
  744. (run-server (make-request-handler store
  745. #:cache cache
  746. #:pool pool
  747. #:nar-path nar-path
  748. #:narinfo-ttl narinfo-ttl
  749. #:compression compression)
  750. concurrent-http-server
  751. `(#:socket ,socket)))
  752. (define (open-server-socket address)
  753. "Return a TCP socket bound to ADDRESS, a socket address."
  754. (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
  755. (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  756. (bind sock address)
  757. sock))
  758. (define (gather-user-privileges user)
  759. "Switch to the identity of USER, a user name."
  760. (catch 'misc-error
  761. (lambda ()
  762. (let ((user (getpw user)))
  763. (setgroups #())
  764. (setgid (passwd:gid user))
  765. (setuid (passwd:uid user))))
  766. (lambda (key proc message args . rest)
  767. (leave (G_ "user '~a' not found: ~a~%")
  768. user (apply format #f message args)))))
  769. ;;;
  770. ;;; Entry point.
  771. ;;;
  772. (define (guix-publish . args)
  773. (with-error-handling
  774. (let* ((opts (args-fold* args %options
  775. (lambda (opt name arg result)
  776. (leave (G_ "~A: unrecognized option~%") name))
  777. (lambda (arg result)
  778. (leave (G_ "~A: extraneous argument~%") arg))
  779. %default-options))
  780. (user (assoc-ref opts 'user))
  781. (port (assoc-ref opts 'port))
  782. (ttl (assoc-ref opts 'narinfo-ttl))
  783. (compression (assoc-ref opts 'compression))
  784. (address (let ((addr (assoc-ref opts 'address)))
  785. (make-socket-address (sockaddr:fam addr)
  786. (sockaddr:addr addr)
  787. port)))
  788. (socket (open-server-socket address))
  789. (nar-path (assoc-ref opts 'nar-path))
  790. (repl-port (assoc-ref opts 'repl))
  791. (cache (assoc-ref opts 'cache))
  792. (workers (assoc-ref opts 'workers))
  793. ;; Read the key right away so that (1) we fail early on if we can't
  794. ;; access them, and (2) we can then drop privileges.
  795. (public-key (read-file-sexp (assoc-ref opts 'public-key-file)))
  796. (private-key (read-file-sexp (assoc-ref opts 'private-key-file))))
  797. (when user
  798. ;; Now that we've read the key material and opened the socket, we can
  799. ;; drop privileges.
  800. (gather-user-privileges user))
  801. (when (zero? (getuid))
  802. (warning (G_ "server running as root; \
  803. consider using the '--user' option!~%")))
  804. (parameterize ((%public-key public-key)
  805. (%private-key private-key))
  806. (format #t (G_ "publishing ~a on ~a, port ~d~%")
  807. %store-directory
  808. (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
  809. (sockaddr:port address))
  810. (when repl-port
  811. (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
  812. ;; Set the name of the main thread.
  813. (set-thread-name "guix publish")
  814. (with-store store
  815. (run-publish-server socket store
  816. #:cache cache
  817. #:pool (and cache (make-pool workers
  818. #:thread-name
  819. "publish worker"))
  820. #:nar-path nar-path
  821. #:compression compression
  822. #:narinfo-ttl ttl))))))
  823. ;;; Local Variables:
  824. ;;; eval: (put 'single-baker 'scheme-indent-function 1)
  825. ;;; End: