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.
 
 
 
 
 
 

938 lines
38 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 (gcrypt hash)
  47. #:use-module (guix pki)
  48. #:use-module (gcrypt 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 'X-Nar-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! "X-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. (x-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. (x-raw-file . ,cached))
  511. #f)
  512. (not-found request))))
  513. (define (render-content-addressed-file store request
  514. name algo hash)
  515. "Return the content of the result of the fixed-output derivation NAME that
  516. has the given HASH of type ALGO."
  517. ;; TODO: Support other hash algorithms.
  518. (if (and (eq? algo 'sha256) (= 32 (bytevector-length hash)))
  519. (let ((item (fixed-output-path name hash
  520. #:hash-algo algo
  521. #:recursive? #f)))
  522. (if (valid-path? store item)
  523. (values `((content-type . (application/octet-stream
  524. (charset . "ISO-8859-1")))
  525. ;; XXX: We're not returning the actual contents,
  526. ;; deferring instead to 'http-write'. This is a hack to
  527. ;; work around <http://bugs.gnu.org/21093>.
  528. (x-raw-file . ,item))
  529. #f)
  530. (not-found request)))
  531. (not-found request)))
  532. (define (render-log-file store request name)
  533. "Render the log file for NAME, the base name of a store item. Don't attempt
  534. to compress or decompress the log file; just return it as-is."
  535. (define (response-headers file)
  536. ;; XXX: We're not returning the actual contents, deferring instead to
  537. ;; 'http-write'. This is a hack to work around
  538. ;; <http://bugs.gnu.org/21093>.
  539. (cond ((string-suffix? ".gz" file)
  540. `((content-type . (text/plain (charset . "UTF-8")))
  541. (content-encoding . (gzip))
  542. (x-raw-file . ,file)))
  543. ((string-suffix? ".bz2" file)
  544. `((content-type . (application/x-bzip2
  545. (charset . "ISO-8859-1")))
  546. (x-raw-file . ,file)))
  547. (else ;uncompressed
  548. `((content-type . (text/plain (charset . "UTF-8")))
  549. (x-raw-file . ,file)))))
  550. (let ((log (log-file store
  551. (string-append (%store-prefix) "/" name))))
  552. (if log
  553. (values (response-headers log) log)
  554. (not-found request))))
  555. (define (render-home-page request)
  556. "Render the home page."
  557. (values `((content-type . (text/html (charset . "UTF-8"))))
  558. (call-with-output-string
  559. (lambda (port)
  560. (sxml->xml '(html
  561. (head (title "GNU Guix Substitute Server"))
  562. (body
  563. (h1 "GNU Guix Substitute Server")
  564. (p "Hi, "
  565. (a (@ (href
  566. "https://gnu.org/s/guix/manual/html_node/Invoking-guix-publish.html"))
  567. (tt "guix publish"))
  568. " speaking. Welcome!")))
  569. port)))))
  570. (define (extract-narinfo-hash str)
  571. "Return the hash within the narinfo resource string STR, or false if STR
  572. is invalid."
  573. (and (string-suffix? ".narinfo" str)
  574. (let ((base (string-drop-right str 8)))
  575. (and (string-every %nix-base32-charset base)
  576. base))))
  577. (define (get-request? request)
  578. "Return #t if REQUEST uses the GET method."
  579. (eq? (request-method request) 'GET))
  580. (define (request-path-components request)
  581. "Split the URI path of REQUEST into a list of component strings. For
  582. example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
  583. (split-and-decode-uri-path (uri-path (request-uri request))))
  584. ;;;
  585. ;;; Server.
  586. ;;;
  587. (define %http-write
  588. (@@ (web server http) http-write))
  589. (define (strip-headers response)
  590. "Return RESPONSE's headers minus 'Content-Length' and our internal headers."
  591. (fold alist-delete
  592. (response-headers response)
  593. '(content-length x-raw-file x-nar-compression)))
  594. (define (sans-content-length response)
  595. "Return RESPONSE without its 'content-length' header."
  596. (set-field response (response-headers)
  597. (strip-headers response)))
  598. (define (with-content-length response length)
  599. "Return RESPONSE with a 'content-length' header set to LENGTH."
  600. (set-field response (response-headers)
  601. (alist-cons 'content-length length
  602. (strip-headers response))))
  603. (define-syntax-rule (swallow-EPIPE exp ...)
  604. "Swallow EPIPE errors raised by EXP..."
  605. (catch 'system-error
  606. (lambda ()
  607. exp ...)
  608. (lambda args
  609. (if (= EPIPE (system-error-errno args))
  610. (values)
  611. (apply throw args)))))
  612. (define-syntax-rule (swallow-zlib-error exp ...)
  613. "Swallow 'zlib-error' exceptions raised by EXP..."
  614. (catch 'zlib-error
  615. (lambda ()
  616. exp ...)
  617. (const #f)))
  618. (define (nar-response-port response compression)
  619. "Return a port on which to write the body of RESPONSE, the response of a
  620. /nar request, according to COMPRESSION."
  621. (match compression
  622. (($ <compression> 'gzip level)
  623. ;; Note: We cannot used chunked encoding here because
  624. ;; 'make-gzip-output-port' wants a file port.
  625. (make-gzip-output-port (response-port response)
  626. #:level level
  627. #:buffer-size (* 64 1024)))
  628. (($ <compression> 'none)
  629. (response-port response))
  630. (#f
  631. (response-port response))))
  632. (define (http-write server client response body)
  633. "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid
  634. blocking."
  635. (match (response-content-type response)
  636. (('application/x-nix-archive . _)
  637. ;; Sending the the whole archive can take time so do it in a separate
  638. ;; thread so that the main thread can keep working in the meantime.
  639. (call-with-new-thread
  640. (lambda ()
  641. (set-thread-name "publish nar")
  642. (let* ((compression (assoc-ref (response-headers response)
  643. 'x-nar-compression))
  644. (response (write-response (sans-content-length response)
  645. client))
  646. (port (begin
  647. (force-output client)
  648. (nar-response-port response compression))))
  649. ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in
  650. ;; 'render-nar', BODY here is just the file name of the store item.
  651. ;; We call 'write-file' from here because we know that's the only
  652. ;; way to avoid building the whole nar in memory, which could
  653. ;; quickly become a real problem. As a bonus, we even do
  654. ;; sendfile(2) directly from the store files to the socket.
  655. (swallow-zlib-error
  656. (swallow-EPIPE
  657. (write-file (utf8->string body) port)))
  658. (swallow-zlib-error
  659. (close-port port))
  660. (values)))))
  661. (_
  662. (match (assoc-ref (response-headers response) 'x-raw-file)
  663. ((? string? file)
  664. ;; Send a raw file in a separate thread.
  665. (call-with-new-thread
  666. (lambda ()
  667. (set-thread-name "publish file")
  668. (catch 'system-error
  669. (lambda ()
  670. (call-with-input-file file
  671. (lambda (input)
  672. (let* ((size (stat:size (stat input)))
  673. (response (write-response (with-content-length response
  674. size)
  675. client))
  676. (output (response-port response)))
  677. (if (file-port? output)
  678. (sendfile output input size)
  679. (dump-port input output))
  680. (close-port output)
  681. (values)))))
  682. (lambda args
  683. ;; If the file was GC'd behind our back, that's fine. Likewise if
  684. ;; the client closes the connection.
  685. (unless (memv (system-error-errno args)
  686. (list ENOENT EPIPE ECONNRESET))
  687. (apply throw args))
  688. (values))))))
  689. (#f
  690. ;; Handle other responses sequentially.
  691. (%http-write server client response body))))))
  692. (define-server-impl concurrent-http-server
  693. ;; A variant of Guile's built-in HTTP server that offloads possibly long
  694. ;; responses to a different thread.
  695. (@@ (web server http) http-open)
  696. (@@ (web server http) http-read)
  697. http-write
  698. (@@ (web server http) http-close))
  699. (define* (make-request-handler store
  700. #:key
  701. cache pool
  702. narinfo-ttl
  703. (nar-path "nar")
  704. (compression %no-compression))
  705. (define nar-path?
  706. (let ((expected (split-and-decode-uri-path nar-path)))
  707. (cut equal? expected <>)))
  708. (lambda (request body)
  709. (format #t "~a ~a~%"
  710. (request-method request)
  711. (uri-path (request-uri request)))
  712. (if (get-request? request) ;reject POST, PUT, etc.
  713. (match (request-path-components request)
  714. ;; /nix-cache-info
  715. (("nix-cache-info")
  716. (render-nix-cache-info))
  717. ;; /
  718. ((or () ("index.html"))
  719. (render-home-page request))
  720. ;; /<hash>.narinfo
  721. (((= extract-narinfo-hash (? string? hash)))
  722. ;; TODO: Register roots for HASH that will somehow remain for
  723. ;; NARINFO-TTL.
  724. (if cache
  725. (render-narinfo/cached store request hash
  726. #:cache cache
  727. #:pool pool
  728. #:ttl narinfo-ttl
  729. #:nar-path nar-path
  730. #:compression compression)
  731. (render-narinfo store request hash
  732. #:ttl narinfo-ttl
  733. #:nar-path nar-path
  734. #:compression compression)))
  735. ;; /nar/file/NAME/sha256/HASH
  736. (("file" name "sha256" hash)
  737. (guard (c ((invalid-base32-character? c)
  738. (not-found request)))
  739. (let ((hash (nix-base32-string->bytevector hash)))
  740. (render-content-addressed-file store request
  741. name 'sha256 hash))))
  742. ;; /log/OUTPUT
  743. (("log" name)
  744. (render-log-file store request name))
  745. ;; Use different URLs depending on the compression type. This
  746. ;; guarantees that /nar URLs remain valid even when 'guix publish'
  747. ;; is restarted with different compression parameters.
  748. ;; /nar/gzip/<store-item>
  749. ((components ... "gzip" store-item)
  750. (if (and (nar-path? components) (zlib-available?))
  751. (let ((compression (match compression
  752. (($ <compression> 'gzip)
  753. compression)
  754. (_
  755. %default-gzip-compression))))
  756. (if cache
  757. (render-nar/cached store cache request store-item
  758. #:compression compression)
  759. (render-nar store request store-item
  760. #:compression compression)))
  761. (not-found request)))
  762. ;; /nar/<store-item>
  763. ((components ... store-item)
  764. (if (nar-path? components)
  765. (if cache
  766. (render-nar/cached store cache request store-item
  767. #:compression %no-compression)
  768. (render-nar store request store-item
  769. #:compression %no-compression))
  770. (not-found request)))
  771. (x (not-found request)))
  772. (not-found request))))
  773. (define* (run-publish-server socket store
  774. #:key (compression %no-compression)
  775. (nar-path "nar") narinfo-ttl
  776. cache pool)
  777. (run-server (make-request-handler store
  778. #:cache cache
  779. #:pool pool
  780. #:nar-path nar-path
  781. #:narinfo-ttl narinfo-ttl
  782. #:compression compression)
  783. concurrent-http-server
  784. `(#:socket ,socket)))
  785. (define (open-server-socket address)
  786. "Return a TCP socket bound to ADDRESS, a socket address."
  787. (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
  788. (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  789. (bind sock address)
  790. sock))
  791. (define (gather-user-privileges user)
  792. "Switch to the identity of USER, a user name."
  793. (catch 'misc-error
  794. (lambda ()
  795. (let ((user (getpw user)))
  796. (setgroups #())
  797. (setgid (passwd:gid user))
  798. (setuid (passwd:uid user))))
  799. (lambda (key proc message args . rest)
  800. (leave (G_ "user '~a' not found: ~a~%")
  801. user (apply format #f message args)))))
  802. ;;;
  803. ;;; Entry point.
  804. ;;;
  805. (define (guix-publish . args)
  806. (with-error-handling
  807. (let* ((opts (args-fold* args %options
  808. (lambda (opt name arg result)
  809. (leave (G_ "~A: unrecognized option~%") name))
  810. (lambda (arg result)
  811. (leave (G_ "~A: extraneous argument~%") arg))
  812. %default-options))
  813. (user (assoc-ref opts 'user))
  814. (port (assoc-ref opts 'port))
  815. (ttl (assoc-ref opts 'narinfo-ttl))
  816. (compression (assoc-ref opts 'compression))
  817. (address (let ((addr (assoc-ref opts 'address)))
  818. (make-socket-address (sockaddr:fam addr)
  819. (sockaddr:addr addr)
  820. port)))
  821. (socket (open-server-socket address))
  822. (nar-path (assoc-ref opts 'nar-path))
  823. (repl-port (assoc-ref opts 'repl))
  824. (cache (assoc-ref opts 'cache))
  825. (workers (assoc-ref opts 'workers))
  826. ;; Read the key right away so that (1) we fail early on if we can't
  827. ;; access them, and (2) we can then drop privileges.
  828. (public-key (read-file-sexp (assoc-ref opts 'public-key-file)))
  829. (private-key (read-file-sexp (assoc-ref opts 'private-key-file))))
  830. (when user
  831. ;; Now that we've read the key material and opened the socket, we can
  832. ;; drop privileges.
  833. (gather-user-privileges user))
  834. (when (zero? (getuid))
  835. (warning (G_ "server running as root; \
  836. consider using the '--user' option!~%")))
  837. (parameterize ((%public-key public-key)
  838. (%private-key private-key))
  839. (format #t (G_ "publishing ~a on ~a, port ~d~%")
  840. %store-directory
  841. (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
  842. (sockaddr:port address))
  843. (when repl-port
  844. (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
  845. ;; Set the name of the main thread.
  846. (set-thread-name "guix publish")
  847. (with-store store
  848. (run-publish-server socket store
  849. #:cache cache
  850. #:pool (and cache (make-pool workers
  851. #:thread-name
  852. "publish worker"))
  853. #:nar-path nar-path
  854. #:compression compression
  855. #:narinfo-ttl ttl))))))
  856. ;;; Local Variables:
  857. ;;; eval: (put 'single-baker 'scheme-indent-function 1)
  858. ;;; End: